john/prosperon
1
0
Fork 0
Code Issues Pull requests Actions Releases Activity
prosperon/source/engine/thirdparty/s7/s7.c
John Alanbrook a7378e1d17 Organized files
2022-01-19 22:43:21 +00:00

114092 lines
3.4 MiB
Raw Blame History

/* s7, a Scheme interpreter
*
* derived from TinyScheme 1.39, but not a single byte of that code remains
* SPDX-License-Identifier: 0BSD
*
* Bill Schottstaedt, bil@ccrma.stanford.edu
*
* Mike Scholz provided the FreeBSD support (complex trig funcs, etc)
* Rick Taube, Andrew Burnson, Donny Ward, and Greg Santucci provided the MS Visual C++ support
* Kjetil Matheussen provided the mingw support
* chai xiaoxiang provided the msys2 support
*
* Documentation is in s7.h and s7.html.
* s7test.scm is a regression test.
* repl.scm is a vt100-based listener.
* nrepl.scm is a notcurses-based listener.
* cload.scm and lib*.scm tie in various C libraries.
* lint.scm checks Scheme code for infelicities.
* r7rs.scm implements some of r7rs (small).
* write.scm currrently has pretty-print.
* mockery.scm has the mock-data definitions.
* reactive.scm has reactive-set and friends.
* stuff.scm has some stuff.
* profile.scm has code to display profile data.
* debug.scm has debugging aids.
* case.scm has case*, an extension of case to pattern matching.
* timing tests are in the s7 tools directory
*
* s7.c is organized as follows:
* structs and type flags
* internal debugging stuff
* constants
* GC
* stacks
* symbols and keywords
* lets
* continuations
* numbers
* characters
* strings
* ports
* format
* lists
* vectors
* hash-tables
* c-objects
* functions
* equal?
* generic length, copy, reverse, fill!, append
* error handlers
* sundry leftovers
* the optimizers
* multiple-values, quasiquote
* eval
* *s7*
* initialization and free
* repl
*
* naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible,
* H_* are documentation strings, Q_* are procedure signatures,
* *_1 are ancillary functions, big_* refer to gmp,
* scheme "?" corresponds to C "is_", scheme "->" to C "_to_".
*
* ---------------- compile time switches ----------------
*/
/*
* 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 might not signal an error).
*
* so the incoming (non-s7-specific) compile-time switches are
* HAVE_COMPLEX_NUMBERS, HAVE_COMPLEX_TRIG, SIZEOF_VOID_P
* if SIZEOF_VOID_P is not defined, we look for __SIZEOF_POINTER__ instead,
* the default is to assume that we're running on a 64-bit machine.
*
* To get multiprecision arithmetic, set WITH_GMP to 1.
* You'll also need libgmp, libmpfr, and libmpc (version 0.8.0 or later)
*
* and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, __clang__, __ANDROID__
*
* if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included.
* 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
* to use nrepl, also define WITH_NOTCURSES
*
* -O3 produces segfaults, and is often slower than -O2 (at least according to callgrind)
* -march=native seems to improve tree-vectorization which is important in Snd
* -ffast-math makes a mess of NaNs, and does not appear to be faster
* for timing tests, I use: -O2 -march=native -fomit-frame-pointer -funroll-loops
* some say -funroll-loops has no effect, but it is consistently faster (according to callgrind) in s7's timing tests
* according to callgrind, clang is normally about 10% slower than gcc, and vectorization either doesn't work or is much worse than gcc's
* also g++ appears to be slightly slower than gcc
*/
#if (defined(__GNUC__) || defined(__clang__)) /* s7 uses PRId64 so (for example) g++ 4.4 is too old */
#define WITH_GCC 1
#else
#define WITH_GCC 0
#endif
/* ---------------- initial sizes ---------------- */
#ifndef INITIAL_HEAP_SIZE
/* #define INITIAL_HEAP_SIZE 128000 */
#define INITIAL_HEAP_SIZE 64000 /* 29-Jul-21 -- seems faster */
#endif
/* the heap grows as needed, this is its initial size. If the initial heap is small, s7 can run in about 2.5 Mbytes of memory.
* There are many cases where a bigger heap is faster (but harware cache size probably matters more).
* The heap size must be a multiple of 32. Each object takes 48 bytes.
*/
#ifndef SYMBOL_TABLE_SIZE
#define SYMBOL_TABLE_SIZE 32749
#endif
/* names are hashed into the symbol table (a vector) and collisions are chained as lists. */
/* 16381: thash +80 [string->symbol] tauto +45[sublet called 4x as often?] tlet +80 [g_symbol] */
#ifndef INITIAL_STACK_SIZE
#define INITIAL_STACK_SIZE 4096 /* was 2048 17-Mar-21 */
#endif
/* the stack grows as needed, each frame takes 4 entries, this is its initial size. (*s7* 'stack-top) divides size by 4 */
#define STACK_RESIZE_TRIGGER (INITIAL_STACK_SIZE / 2)
#ifndef INITIAL_PROTECTED_OBJECTS_SIZE
#define INITIAL_PROTECTED_OBJECTS_SIZE 16
#endif
/* a vector of objects that are (semi-permanently) protected from the GC, grows as needed */
#ifndef GC_TEMPS_SIZE
#define GC_TEMPS_SIZE 256
#endif
/* the number of recent objects that are temporarily gc-protected; 8 works for s7test and snd-test.
* For the FFI, this sets the lag between a call on s7_cons and the first moment when its result
* might be vulnerable to the GC.
*/
/* ---------------- scheme choices ---------------- */
#ifndef WITH_GMP
#define WITH_GMP 0
/* this includes multiprecision arithmetic for all numeric types and functions, using gmp, mpfr, and mpc
* WITH_GMP adds the following functions: bignum and bignum?, and (*s7* 'bignum-precision)
*/
#endif
#ifndef DEFAULT_BIGNUM_PRECISION
#define DEFAULT_BIGNUM_PRECISION 128 /* (*s7* 'bignum-precision) initial value, must be >= 2 */
#endif
#ifndef WITH_PURE_S7
#define WITH_PURE_S7 0
#endif
#if WITH_PURE_S7
#define WITH_EXTRA_EXPONENT_MARKERS 0
#define WITH_IMMUTABLE_UNQUOTE 1
/* also omitted: *-ci* functions, char-ready?, cond-expand, multiple-values-bind|set!, call-with-values
* and a lot more (inexact/exact, integer-length, etc) -- see s7.html.
*/
#endif
#ifndef WITH_EXTRA_EXPONENT_MARKERS
#define WITH_EXTRA_EXPONENT_MARKERS 0
#endif
/* if 1, s7 recognizes "d", "f", "l", and "s" as exponent markers, in addition to "e" (also "D", "F", "L", "S") */
#ifndef WITH_SYSTEM_EXTRAS
#define WITH_SYSTEM_EXTRAS (!_MSC_VER)
/* this adds several functions that access file info, directories, times, etc */
#endif
#ifndef WITH_IMMUTABLE_UNQUOTE
#define WITH_IMMUTABLE_UNQUOTE 0
/* this removes the name "unquote" */
#endif
#ifndef WITH_C_LOADER
#if WITH_GCC && (!__MINGW32__) && (!__CYGWIN__)
#define WITH_C_LOADER 1
/* (load file.so [e]) looks for (e 'init_func) and if found, calls it as the shared object init function.
* If WITH_SYSTEM_EXTRAS is 0, the caller needs to supply system and delete-file so that cload.scm works.
*/
#else
#define WITH_C_LOADER 0
/* I think dlopen et al are available in MS C, but I have no way to test them; see load_shared_object below */
#endif
#endif
#ifndef WITH_HISTORY
#define WITH_HISTORY 0
/* this includes a circular buffer of previous evaluations for debugging, ((owlet) 'error-history) and (*s7* 'history-size) */
#endif
#ifndef DEFAULT_HISTORY_SIZE
#define DEFAULT_HISTORY_SIZE 8
/* this is the default length of the eval history buffer */
#endif
#if WITH_HISTORY
#define MAX_HISTORY_SIZE 1048576
#endif
#ifndef DEFAULT_PRINT_LENGTH
#define DEFAULT_PRINT_LENGTH 12 /* (*s7* 'print-length) initial value, was 32 but Snd uses 12, 23-Jul-21 */
#endif
/* 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 WITH_MULTITHREAD_CHECKS
#define WITH_MULTITHREAD_CHECKS 0
/* debugging aid if using s7 in a multithreaded program -- this code courtesy of Kjetil Matheussen */
#endif
#ifndef WITH_WARNINGS
#define WITH_WARNINGS 0
/* int+int overflows to real, etc: this adds warnings which are expensive even though they are never called (procedure overhead) */
#endif
#ifndef S7_DEBUGGING
#define S7_DEBUGGING 0
#endif
#undef DEBUGGING
#define DEBUGGING typo!
#define HAVE_GMP typo!
#define SHOW_EVAL_OPS 0
#ifndef _GNU_SOURCE
#define _GNU_SOURCE
/* for qsort_r, grumble... */
#endif
#ifndef _MSC_VER
#include <unistd.h>
#include <sys/param.h>
#include <strings.h>
#include <errno.h>
#include <locale.h>
#else
/* in Snd these are in mus-config.h */
#ifndef MUS_CONFIG_H_LOADED
#if _MSC_VER < 1900
#define snprintf _snprintf
#endif
#if _MSC_VER > 1200
#define _CRT_SECURE_NO_DEPRECATE 1
#define _CRT_NONSTDC_NO_DEPRECATE 1
#define _CRT_SECURE_CPP_OVERLOAD_STANDARD_NAMES 1
#endif
#endif
#include <io.h>
#pragma warning(disable: 4244) /* conversion might cause loss of data warning */
#endif
#if WITH_GCC && (!S7_DEBUGGING)
#define Inline inline __attribute__((__always_inline__))
#else
#ifdef _MSC_VER
#define Inline __forceinline
#else
#define Inline inline
#endif
#endif
#ifndef WITH_VECTORIZE
#define WITH_VECTORIZE 1
#endif
#if (WITH_VECTORIZE) && (defined(__GNUC__) && __GNUC__ >= 5)
#define Vectorized __attribute__((optimize("tree-vectorize")))
#else
#define Vectorized
#endif
#if WITH_GCC
#define Sentinel __attribute__((sentinel))
#else
#define Sentinel
#endif
#ifndef S7_ALIGNED
#define S7_ALIGNED 0
#endif
#include <stdio.h>
#include <limits.h>
#include <ctype.h>
#include <string.h>
#include <stdlib.h>
#include <sys/types.h>
#include <time.h>
#include <stdarg.h>
#include <stddef.h>
#include <stdint.h>
#include <inttypes.h>
#include <setjmp.h>
#ifdef _MSC_VER
#define MS_WINDOWS 1
#else
#define MS_WINDOWS 0
#endif
#ifdef __MINGW32__
#define Jmp_Buf jmp_buf
#define SetJmp(A, B) setjmp(A)
#define LongJmp(A, B) longjmp(A, B)
#else
#define Jmp_Buf jmp_buf
#define SetJmp(A, B) setjmp(A) /* Was sigX for all; sigsetjmp(A, B). Changed to compile with musl-libc */
#define LongJmp(A, B) longjmp(A, B)
/* we need sigsetjmp, not setjmp for nrepl's interrupt (something to do with signal masks??)
* unfortunately sigsetjmp is noticeably slower than setjmp, especially when s7_optimize_1 is called a lot.
* In one case, the sigsetjmp version runs in 24 seconds, but the setjmp version takes 10 seconds, and
* yet callgrind says there is almost no difference, so I removed setjmp from s7_optimize.
*/
#endif
#if (!MS_WINDOWS)
#include <pthread.h>
#endif
#if __cplusplus
#include <cmath>
#else
#include <math.h>
#endif
/* there is also apparently __STDC_NO_COMPLEX__ */
#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
#if (!(defined(__cplusplus))) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)) && !defined(__INTEL_COMPILER)
#define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y))
#else
#define CMPLX(r, i) ((r) + ((i) * _Complex_I))
#endif
#endif
#endif
#include "s7.h"
#ifndef M_PI
#define M_PI 3.1415926535897932384626433832795029L
#endif
#ifndef INFINITY
#ifndef HUGE_VAL
#define INFINITY (1.0/0.0) /* -log(0.0) is triggering dumb complaints from cppcheck */
/* there is sometimes a function, infinity(), MSC apparently uses HUGE_VALF, gcc has __builtin_huge_val() */
#else
#define INFINITY HUGE_VAL
#endif
#endif
#ifndef NAN
#define NAN (INFINITY / INFINITY)
#endif
#define BOLD_TEXT "\033[1m"
#define UNBOLD_TEXT "\033[22m"
#if ((!__NetBSD__) && ((_MSC_VER) || (!defined(__STC__)) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 199901L))))
#define __func__ __FUNCTION__
#endif
#define display(Obj) string_value(s7_object_to_string(sc, Obj, false))
#define display_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80))
typedef intptr_t opcode_t;
#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__)))
#define NUMBER_NAME_SIZE 2 /* pointless */
#define POINTER_32 true
#else
#define NUMBER_NAME_SIZE 22 /* leave 1 for uint8_t name len (byte 0), 1 for terminating nul */
#define POINTER_32 false
#endif
#define WRITE_REAL_PRECISION 16
typedef long double long_double;
#define ld64 PRId64
#define p64 PRIdPTR
#define MAX_FLOAT_FORMAT_PRECISION 128
/* types */
enum { T_FREE = 0,
T_PAIR, T_NIL, T_UNUSED, T_UNDEFINED, T_UNSPECIFIED, T_EOF, T_BOOLEAN,
T_CHARACTER, T_SYNTAX, T_SYMBOL,
T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO,
T_BIG_REAL, T_BIG_COMPLEX,
T_STRING, T_C_OBJECT, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR,
T_BYTE_VECTOR,
T_CATCH, T_DYNAMIC_WIND, T_HASH_TABLE, T_LET, T_ITERATOR,
T_STACK, T_COUNTER, T_SLOT, T_C_POINTER, T_OUTPUT_PORT, T_INPUT_PORT,
T_RANDOM_STATE, T_CONTINUATION, T_GOTO,
T_CLOSURE, T_CLOSURE_STAR, T_MACRO, T_MACRO_STAR, T_BACRO,
T_BACRO_STAR, T_C_MACRO,
T_C_FUNCTION_STAR, T_C_FUNCTION, T_C_ANY_ARGS_FUNCTION,
T_C_OPT_ARGS_FUNCTION, T_C_RST_ARGS_FUNCTION,
NUM_TYPES
};
/* T_UNUSED, T_STACK, T_SLOT, T_DYNAMIC_WIND, T_CATCH, and T_COUNTER are internal */
#if S7_DEBUGGING || SHOW_EVAL_OPS
static const char *s7_type_names[] =
{ "free", "pair", "nil", "unused", "undefined", "unspecified",
"eof_object", "boolean", "character", "syntax", "symbol",
"integer", "ratio", "real", "complex", "big_integer", "big_ratio",
"big_real", "big_complex",
"string", "c_object", "vector", "int_vector", "float_vector",
"byte_vector",
"catch", "dynamic_wind", "hash_table", "let", "iterator",
"stack", "counter", "slot", "c_pointer", "output_port", "input_port",
"random_state", "continuation", "goto",
"closure", "closure*", "macro", "macro*", "bacro", "bacro*", "c_macro",
"c_function*", "c_function", "c_any_args_function",
"c_opt_args_function", "c_rst_args_function"
};
#endif
typedef struct block_t {
union {
void *data;
s7_pointer d_ptr;
s7_int *i_ptr;
s7_int pos;
} dx;
int32_t index;
union {
bool needs_free;
uint32_t tag;
} ln;
s7_int size;
union {
struct block_t *next;
char *documentation;
s7_pointer ksym;
s7_int nx_int;
s7_int *ix_ptr;
struct {
uint32_t i1, i2;
} ix;
} nx;
union {
s7_pointer ex_ptr;
void *ex_info;
s7_int ckey;
} ex;
} block_t;
#define NUM_BLOCK_LISTS 18
#define TOP_BLOCK_LIST 17
#define BLOCK_LIST 0
#define block_data(p) p->dx.data
#define block_index(p) p->index
#define block_set_index(p, Index) p->index = Index
#define block_size(p) p->size
#define block_set_size(p, Size) p->size = Size
#define block_next(p) p->nx.next
#define block_info(p) p->ex.ex_info
typedef block_t hash_entry_t;
#define hash_entry_key(p) p->dx.d_ptr
#define hash_entry_value(p) (p)->ex.ex_ptr
#define hash_entry_set_value(p, Val) p->ex.ex_ptr = Val
#define hash_entry_next(p) block_next(p)
#define hash_entry_raw_hash(p) block_size(p)
#define hash_entry_set_raw_hash(p, Hash) block_set_size(p, Hash)
typedef block_t vdims_t;
#define vdims_rank(p) p->size
#define vector_elements_should_be_freed(p) p->ln.needs_free
#define vdims_dims(p) p->dx.i_ptr
#define vdims_offsets(p) p->nx.ix_ptr
#define vdims_original(p) p->ex.ex_ptr
typedef enum { TOKEN_EOF, TOKEN_LEFT_PAREN, TOKEN_RIGHT_PAREN, TOKEN_DOT,
TOKEN_ATOM, TOKEN_QUOTE, TOKEN_DOUBLE_QUOTE, TOKEN_BACK_QUOTE,
TOKEN_COMMA, TOKEN_AT_MARK, TOKEN_SHARP_CONST, TOKEN_VECTOR,
TOKEN_BYTE_VECTOR, TOKEN_INT_VECTOR, TOKEN_FLOAT_VECTOR
} token_t;
typedef enum { NO_ARTICLE, INDEFINITE_ARTICLE } article_t;
typedef enum { DWIND_INIT, DWIND_BODY, DWIND_FINISH } dwind_t;
enum { NO_SAFETY = 0, IMMUTABLE_VECTOR_SAFETY, MORE_SAFETY_WARNINGS }; /* (*s7* 'safety) settings */
/* IO ports */
typedef enum { FILE_PORT, STRING_PORT, FUNCTION_PORT } port_type_t;
typedef struct {
int32_t(*read_character) (s7_scheme * sc, s7_pointer port); /* function to read a character, int32_t for EOF */
void (*write_character)(s7_scheme * sc, uint8_t c, s7_pointer port); /* function to write a character */
void (*write_string)(s7_scheme * sc, const char *str, s7_int len, s7_pointer port); /* function to write a string of known length */
token_t(*read_semicolon) (s7_scheme * sc, s7_pointer port); /* internal skip-to-semicolon reader */
int32_t(*read_white_space) (s7_scheme * sc, s7_pointer port); /* internal skip white space reader */
s7_pointer(*read_name) (s7_scheme * sc, s7_pointer 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); /* function to read a string up to \n */
void (*displayer)(s7_scheme * sc, const char *s, s7_pointer pt);
void (*close_port)(s7_scheme * sc, s7_pointer p); /* close-in|output-port */
} port_functions_t;
typedef struct {
bool needs_free, is_closed;
port_type_t ptype;
FILE *file;
char *filename;
block_t *filename_block;
uint32_t line_number, file_number;
s7_int filename_length;
block_t *block;
s7_pointer orig_str; /* GC protection for string port string */
const port_functions_t *pf;
s7_pointer(*input_function) (s7_scheme * sc, s7_read_t read_choice,
s7_pointer port);
void (*output_function)(s7_scheme * sc, uint8_t c, s7_pointer port);
} port_t;
typedef enum { o_d_v, o_d_vd, o_d_vdd, o_d_vid, o_d_id, o_d_7pi, o_d_7pii,
o_d_7piid, o_d_7piii, o_d_7piiid,
o_d_ip, o_d_pd, o_d_7pid, o_d, o_d_d, o_d_dd, o_d_7dd, o_d_ddd,
o_d_dddd,
o_i_i, o_i_7i, o_i_ii, o_i_7ii, o_i_iii, o_i_7pi, o_i_7pii, o_i_7piii,
o_d_p,
o_b_p, o_b_7p, o_b_pp, o_b_7pp, o_b_pp_unchecked, o_b_pi, o_b_ii,
o_b_7ii, o_b_dd,
o_p, o_p_p, o_p_ii, o_p_d, o_p_dd, o_i_7d, o_i_7p, o_d_7d, o_p_pp,
o_p_ppp, o_p_pi, o_p_pi_unchecked,
o_p_ppi, o_p_i, o_p_pii, o_p_pip, o_p_pip_unchecked, o_p_piip, o_b_i,
o_b_d
} opt_func_t;
typedef struct opt_funcs_t {
opt_func_t typ;
void *func;
struct opt_funcs_t *next;
} opt_funcs_t;
typedef struct {
const char *name;
int32_t name_length;
uint32_t id;
char *doc;
block_t *block;
opt_funcs_t *opt_data; /* vunion-functions (see below) */
s7_pointer generic_ff, setter, signature, pars;
s7_pointer(*chooser) (s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops);
/* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC protection */
union {
s7_pointer *arg_defaults;
s7_pointer bool_setter;
} dam;
union {
s7_pointer *arg_names;
s7_pointer c_sym;
} sam;
union {
s7_pointer call_args;
void (*marker)(s7_pointer p, s7_int len);
} cam;
} c_proc_t;
typedef struct {
s7_int type, outer_type;
s7_pointer scheme_name, getter, setter;
void (*mark)(void *val);
void (*free)(void *value); /* this will go away someday (use gc_free) */
bool (*eql)(void *val1, void *val2); /* this will go away someday (use equal) */
#if (!DISABLE_DEPRECATED)
char *(*print)(s7_scheme * sc, void *value);
#endif
s7_pointer(*equal) (s7_scheme * sc, s7_pointer args);
s7_pointer(*equivalent) (s7_scheme * sc, s7_pointer args);
s7_pointer(*ref) (s7_scheme * sc, s7_pointer args);
s7_pointer(*set) (s7_scheme * sc, s7_pointer args);
s7_pointer(*length) (s7_scheme * sc, s7_pointer args);
s7_pointer(*reverse) (s7_scheme * sc, s7_pointer args);
s7_pointer(*copy) (s7_scheme * sc, s7_pointer args);
s7_pointer(*fill) (s7_scheme * sc, s7_pointer args);
s7_pointer(*to_list) (s7_scheme * sc, s7_pointer args);
s7_pointer(*to_string) (s7_scheme * sc, s7_pointer args);
s7_pointer(*gc_mark) (s7_scheme * sc, s7_pointer args);
s7_pointer(*gc_free) (s7_scheme * sc, s7_pointer args);
} c_object_t;
typedef s7_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[NUM_TYPES];
typedef s7_int(*s7_i_7pi_t) (s7_scheme * sc, s7_pointer p, s7_int i1);
typedef s7_int(*s7_i_7pii_t) (s7_scheme * sc, s7_pointer p, s7_int i1,
s7_int i2);
typedef s7_int(*s7_i_7piii_t) (s7_scheme * sc, s7_pointer p, s7_int i1,
s7_int i2, s7_int i3);
typedef s7_int(*s7_i_iii_t) (s7_int i1, s7_int i2, s7_int i3);
typedef s7_int(*s7_i_7i_t) (s7_scheme * sc, s7_int i1);
typedef s7_int(*s7_i_7ii_t) (s7_scheme * sc, s7_int i1, s7_int i2);
typedef bool (*s7_b_pp_t)(s7_pointer p1, s7_pointer p2);
typedef bool (*s7_b_7pp_t)(s7_scheme * sc, s7_pointer p1, s7_pointer p2);
typedef bool (*s7_b_7p_t)(s7_scheme * sc, s7_pointer p1);
typedef bool (*s7_b_pi_t)(s7_scheme * sc, s7_pointer p1, s7_int i2);
typedef bool (*s7_b_d_t)(s7_double p1);
typedef bool (*s7_b_i_t)(s7_int p1);
typedef bool (*s7_b_ii_t)(s7_int p1, s7_int p2);
typedef bool (*s7_b_7ii_t)(s7_scheme * sc, s7_int p1, s7_int p2);
typedef bool (*s7_b_dd_t)(s7_double p1, s7_double p2);
typedef s7_pointer(*s7_p_p_t) (s7_scheme * sc, s7_pointer p);
typedef s7_pointer(*s7_p_t) (s7_scheme * sc);
typedef s7_pointer(*s7_p_pp_t) (s7_scheme * sc, s7_pointer p1,
s7_pointer p2);
typedef s7_pointer(*s7_p_ppi_t) (s7_scheme * sc, s7_pointer p1,
s7_pointer p2, s7_int i1);
typedef s7_pointer(*s7_p_ppp_t) (s7_scheme * sc, s7_pointer p1,
s7_pointer p2, s7_pointer p3);
typedef s7_pointer(*s7_p_pi_t) (s7_scheme * sc, s7_pointer p1, s7_int i1);
typedef s7_pointer(*s7_p_pii_t) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_int i2);
typedef s7_pointer(*s7_p_pip_t) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_pointer p2);
typedef s7_pointer(*s7_p_piip_t) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_int i2, s7_pointer p3);
typedef s7_pointer(*s7_p_i_t) (s7_scheme * sc, s7_int i);
typedef s7_pointer(*s7_p_ii_t) (s7_scheme * sc, s7_int i1, s7_int i2);
typedef s7_pointer(*s7_p_dd_t) (s7_scheme * sc, s7_double x1,
s7_double x2);
typedef s7_double(*s7_d_7d_t) (s7_scheme * sc, s7_double p1);
typedef s7_double(*s7_d_7dd_t) (s7_scheme * sc, s7_double p1,
s7_double p2);
typedef s7_double(*s7_d_7pii_t) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_int i2);
typedef s7_double(*s7_d_7piid_t) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_int i2, s7_double x1);
typedef s7_double(*s7_d_7piii_t) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_int i2, s7_int i3);
typedef s7_double(*s7_d_7piiid_t) (s7_scheme * sc, s7_pointer p1,
s7_int i1, s7_int i2, s7_int i3,
s7_double x1);
typedef struct opt_info opt_info;
typedef union {
s7_int i;
s7_double x;
s7_pointer p;
void *obj;
opt_info *o1;
s7_function call;
s7_double(*d_f) (void);
s7_double(*d_d_f) (s7_double x);
s7_double(*d_7d_f) (s7_scheme * sc, s7_double x);
s7_double(*d_dd_f) (s7_double x1, s7_double x2);
s7_double(*d_7dd_f) (s7_scheme * sc, s7_double x1, s7_double x2);
s7_double(*d_ddd_f) (s7_double x1, s7_double x2, s7_double x3);
s7_double(*d_dddd_f) (s7_double x1, s7_double x2, s7_double x3,
s7_double x4);
s7_double(*d_v_f) (void *obj);
s7_double(*d_vd_f) (void *obj, s7_double fm);
s7_double(*d_vdd_f) (void *obj, s7_double x1, s7_double x2);
s7_double(*d_vid_f) (void *obj, s7_int i, s7_double fm);
s7_double(*d_id_f) (s7_int i, s7_double fm);
s7_double(*d_7pi_f) (s7_scheme * sc, s7_pointer obj, s7_int i1);
s7_double(*d_7pid_f) (s7_scheme * sc, s7_pointer obj, s7_int i1,
s7_double x);
s7_double(*d_7pii_f) (s7_scheme * sc, s7_pointer obj, s7_int i1,
s7_int i2);
s7_double(*d_7piid_f) (s7_scheme * sc, s7_pointer obj, s7_int i1,
s7_int i2, s7_double x);
s7_double(*d_7piii_f) (s7_scheme * sc, s7_pointer obj, s7_int i1,
s7_int i2, s7_int i3);
s7_double(*d_7piiid_f) (s7_scheme * sc, s7_pointer obj, s7_int i1,
s7_int i2, s7_int i3, s7_double x);
s7_double(*d_ip_f) (s7_int i1, s7_pointer p);
s7_double(*d_pd_f) (s7_pointer obj, s7_double x);
s7_double(*d_p_f) (s7_pointer p);
s7_int(*i_7d_f) (s7_scheme * sc, s7_double i1);
s7_int(*i_7p_f) (s7_scheme * sc, s7_pointer i1);
s7_int(*i_i_f) (s7_int i1);
s7_int(*i_7i_f) (s7_scheme * sc, s7_int i1);
s7_int(*i_ii_f) (s7_int i1, s7_int i2);
s7_int(*i_7ii_f) (s7_scheme * sc, s7_int i1, s7_int i2);
s7_int(*i_iii_f) (s7_int i1, s7_int i2, s7_int i3);
s7_int(*i_7pi_f) (s7_scheme * sc, s7_pointer p, s7_int i1);
s7_int(*i_7pii_f) (s7_scheme * sc, s7_pointer p, s7_int i1,
s7_int i2);
s7_int(*i_7piii_f) (s7_scheme * sc, s7_pointer p, s7_int i1,
s7_int i2, s7_int i3);
bool (*b_i_f)(s7_int p);
bool (*b_d_f)(s7_double p);
bool (*b_p_f)(s7_pointer p);
bool (*b_pp_f)(s7_pointer p1, s7_pointer p2);
bool (*b_7pp_f)(s7_scheme * sc, s7_pointer p1, s7_pointer p2);
bool (*b_7p_f)(s7_scheme * sc, s7_pointer p1);
bool (*b_pi_f)(s7_scheme * sc, s7_pointer p1, s7_int i2);
bool (*b_ii_f)(s7_int i1, s7_int i2);
bool (*b_7ii_f)(s7_scheme * sc, s7_int i1, s7_int i2);
bool (*b_dd_f)(s7_double x1, s7_double x2);
s7_pointer(*p_f) (s7_scheme * sc);
s7_pointer(*p_p_f) (s7_scheme * sc, s7_pointer p);
s7_pointer(*p_pp_f) (s7_scheme * sc, s7_pointer p1, s7_pointer p2);
s7_pointer(*p_ppp_f) (s7_scheme * sc, s7_pointer p, s7_pointer p2,
s7_pointer p3);
s7_pointer(*p_pi_f) (s7_scheme * sc, s7_pointer p1, s7_int i1);
s7_pointer(*p_pii_f) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_int i2);
s7_pointer(*p_ppi_f) (s7_scheme * sc, s7_pointer p1, s7_pointer p2,
s7_int i1);
s7_pointer(*p_pip_f) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_pointer p2);
s7_pointer(*p_piip_f) (s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_int i2, s7_pointer p3);
s7_pointer(*p_i_f) (s7_scheme * sc, s7_int i);
s7_pointer(*p_ii_f) (s7_scheme * sc, s7_int x1, s7_int x2);
s7_pointer(*p_d_f) (s7_scheme * sc, s7_double x);
s7_pointer(*p_dd_f) (s7_scheme * sc, s7_double x1, s7_double x2);
s7_double(*fd) (opt_info * o);
s7_int(*fi) (opt_info * o);
bool (*fb)(opt_info * o);
s7_pointer(*fp) (opt_info * o);
} vunion;
#define NUM_VUNIONS 15
struct opt_info {
vunion v[NUM_VUNIONS];
s7_scheme *sc;
};
#define O_WRAP (NUM_VUNIONS - 1)
#if WITH_GMP
typedef struct bigint {
mpz_t n;
struct bigint *nxt;
} bigint;
typedef struct bigrat {
mpq_t q;
struct bigrat *nxt;
} bigrat;
typedef struct bigflt {
mpfr_t x;
struct bigflt *nxt;
} bigflt;
typedef struct bigcmp {
mpc_t z;
struct bigcmp *nxt;
} bigcmp;
typedef struct {
mpfr_t error, ux, x0, x1;
mpz_t i, i0, i1, n;
mpz_t p0, q0, r, r1, p1, q1, old_p1, old_q1;
mpfr_t val, e0, e1, e0p, e1p, old_e0, old_e1, old_e0p;
mpq_t q;
} rat_locals_t;
#endif
/* -------------------------------- cell structure -------------------------------- */
typedef struct s7_cell {
union {
uint64_t flag; /* type info */
int64_t signed_flag;
uint8_t type_field;
uint16_t sflag;
struct {
uint32_t unused_low_flag;
uint16_t opt_choice;
uint16_t high_flag;
} opts;
} tf;
union {
union { /* integers, floats */
s7_int integer_value;
s7_double real_value;
struct { /* ratios */
s7_int numerator;
s7_int denominator;
} fraction_value;
struct { /* complex numbers */
s7_double rl;
s7_double im;
} complex_value;
#if WITH_GMP
bigint *bgi; /* bignums */
bigrat *bgr;
bigflt *bgf;
bigcmp *bgc;
#endif
} number;
struct {
s7_int unused1, unused2; /* always int64_t so this is 16 bytes */
uint8_t name[24];
} number_name;
struct { /* ports */
port_t *port;
uint8_t *data;
s7_int size, point;
block_t *block;
} prt;
struct { /* characters */
uint8_t c, up_c;
int32_t length;
bool alpha_c, digit_c, space_c, upper_c, lower_c;
char c_name[12];
} chr;
struct { /* c-pointers */
void *c_pointer;
s7_pointer c_type, info, weak1, weak2;
} cptr;
struct { /* vectors */
s7_int length;
union {
s7_pointer *objects;
s7_int *ints;
s7_double *floats;
uint8_t *bytes;
} elements;
block_t *block;
s7_pointer(*vget) (s7_scheme * sc, s7_pointer vec,
s7_int loc);
union {
s7_pointer(*vset) (s7_scheme * sc, s7_pointer vec,
s7_int loc, s7_pointer val);
s7_pointer fset;
} setv;
} vector;
struct { /* stacks (internal) struct must match vector above for length/objects */
s7_int length;
s7_pointer *objects;
block_t *block;
int64_t top, flags;
} stk;
struct { /* hash-tables */
s7_int mask;
hash_entry_t **elements;
hash_check_t hash_func;
hash_map_t *loc;
block_t *block;
} hasher;
struct { /* iterators */
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_int required_args, optional_args, all_args;
} fnc;
struct { /* pairs */
s7_pointer car, cdr, opt1, opt2, opt3;
} cons;
struct { /* pairs */
s7_pointer car, cdr, opt1, opt2;
uint8_t opt_type;
} cons_ext;
struct { /* special purpose pairs (symbol-table etc) */
s7_pointer unused_car, unused_cdr;
uint64_t hash;
const char *fstr;
uint64_t location; /* line/file/position, also used in symbol_table as raw_len */
} sym_cons;
struct { /* scheme functions */
s7_pointer args, body, env, setter; /* args can be a symbol, as well as a list, setter can be #f as well as a procedure/closure */
int32_t arity;
} func;
struct { /* strings */
s7_int length;
char *svalue;
uint64_t hash; /* string hash-index */
block_t *block;
block_t *gensym_block;
} string;
struct { /* symbols */
s7_pointer name, global_slot, local_slot;
int64_t id; /* which let last bound the symbol -- for faster symbol lookup */
uint32_t ctr; /* how many times has symbol been bound */
uint32_t tag; /* symbol as member of a set (tree-set-memq etc), high 32 bits are in symbol_info (the string block) */
} sym;
struct { /* syntax */
s7_pointer symbol;
opcode_t op;
int32_t min_args, max_args;
const char *documentation;
} syn;
struct { /* slots (bindings) */
s7_pointer sym, val, nxt, pending_value, expr;
} slt;
struct { /* lets (environments) */
s7_pointer slots, nxt;
int64_t id; /* id of rootlet is -1 */
union {
struct {
s7_pointer function; /* *function* (code) if this is a funclet */
uint32_t line, file; /* *function* location if it is known */
} efnc;
struct {
s7_pointer dox1, dox2; /* do loop variables */
} dox;
struct { /* (catch #t ...) opts */
uint64_t op_stack_loc, goto_loc;
} ctall;
struct {
s7_int key; /* s7_int is sc->baffle_ctr type */
} bafl;
} edat;
} envr;
struct { /* special stuff like #<unspecified> */
s7_pointer car, cdr; /* unique_car|cdr, for sc->nil these are sc->unspecified for faster assoc etc */
int64_t unused_let_id; /* let_id(sc->nil) is -1, so this needs to align with envr.id above, only used by sc->nil, so free elsewhere */
const char *name;
s7_int len;
} unq;
struct { /* #<...> */
char *name; /* not const because the GC frees it */
s7_int len;
} undef;
struct { /* #<eof> */
const char *name;
s7_int len;
} eof;
struct { /* counter (internal) */
s7_pointer result, list, env, slots; /* env = counter_let (curlet after map/for-each let created) */
uint64_t cap; /* sc->capture_let_counter for let reuse */
} ctr;
struct { /* random-state */
#if WITH_GMP
gmp_randstate_t state;
#else
uint64_t seed, carry;
#endif
} rng;
struct { /* additional object types (C) */
s7_int type;
void *value; /* the value the caller associates with the c_object */
s7_pointer e; /* the method list, if any (openlet) */
s7_scheme *sc;
} c_obj;
struct { /* continuations */
block_t *block;
s7_pointer stack, op_stack;
s7_pointer *stack_start, *stack_end;
} cwcc;
struct { /* call-with-exit */
uint64_t goto_loc, op_stack_loc;
bool active;
s7_pointer name;
} rexit;
struct { /* catch */
uint64_t 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;
dwind_t state;
} winder;
} object;
#if S7_DEBUGGING
int32_t current_alloc_line, previous_alloc_line, uses,
explicit_free_line, gc_line;
int64_t current_alloc_type, previous_alloc_type, debugger_bits;
const char *current_alloc_func, *previous_alloc_func, *gc_func;
#endif
} s7_cell;
typedef struct s7_big_cell {
s7_cell cell;
int64_t big_hloc;
} s7_big_cell;
typedef struct s7_big_cell *s7_big_pointer;
typedef struct heap_block_t {
intptr_t start, end;
int64_t offset;
struct heap_block_t *next;
} heap_block_t;
typedef struct {
s7_pointer *objs;
int32_t size, top, ref, size2;
bool has_hits;
int32_t *refs;
s7_pointer cycle_port, init_port;
s7_int cycle_loc, init_loc;
bool *defined;
} shared_info_t;
typedef struct {
s7_int loc, curly_len, ctr;
char *curly_str;
s7_pointer args, orig_str, curly_arg;
s7_pointer port, strport;
} format_data_t;
typedef struct gc_obj_t {
s7_pointer p;
struct gc_obj_t *nxt;
} gc_obj_t;
typedef struct {
s7_pointer *list;
s7_int size, loc;
} gc_list_t;
typedef struct {
int32_t size, top, excl_size, excl_top;
s7_pointer *funcs;
s7_int *data, *excl;
} profile_data_t;
/* -------------------------------- s7_scheme struct -------------------------------- */
struct s7_scheme {
s7_pointer code;
s7_pointer curlet; /* layout of first 4 entries should match stack frame layout */
s7_pointer args; /* arguments of current function */
opcode_t cur_op;
s7_pointer value;
s7_pointer cur_code;
token_t tok;
s7_pointer stack; /* stack is a vector */
uint32_t stack_size;
s7_pointer *stack_start, *stack_end, *stack_resize_trigger;
s7_pointer *op_stack, *op_stack_now, *op_stack_end;
uint32_t op_stack_size, max_stack_size;
s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger,
**previous_free_heap_top;
int64_t heap_size, gc_freed, gc_total_freed, max_heap_size,
gc_temps_size;
s7_double gc_resize_heap_fraction, gc_resize_heap_by_4_fraction;
s7_int gc_calls, gc_total_time, gc_start, gc_end;
heap_block_t *heap_blocks;
#if WITH_HISTORY
s7_pointer eval_history1, eval_history2, error_history, history_sink,
history_pairs, old_cur_code;
bool using_history1;
#endif
#if WITH_MULTITHREAD_CHECKS
int32_t lock_count;
pthread_mutex_t lock;
#endif
gc_obj_t *permanent_objects, *permanent_lets;
s7_pointer protected_objects, protected_setters, protected_setter_symbols; /* vectors of gc-protected objects */
s7_int *gpofl; /* "gc_protected_objects_free_locations" (so we never have to do a linear search for a place to store something) */
s7_int protected_objects_size, protected_setters_size,
protected_setters_loc;
s7_int gpofl_loc;
s7_pointer nil; /* empty list */
s7_pointer T; /* #t */
s7_pointer F; /* #f */
s7_pointer undefined; /* #<undefined> */
s7_pointer unspecified; /* #<unspecified> */
s7_pointer no_value; /* the (values) value */
s7_pointer unused; /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */
s7_pointer 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) */
uint32_t input_port_stack_size, input_port_stack_loc;
s7_pointer output_port; /* current-output-port */
s7_pointer error_port; /* current-error-port */
s7_pointer owlet; /* owlet */
s7_pointer error_type, error_data, error_code, error_line, error_file, error_position; /* owlet slots */
s7_pointer standard_input, standard_output, standard_error;
s7_pointer sharp_readers; /* the binding pair for the global *#readers* list */
s7_pointer load_hook; /* *load-hook* hook object */
s7_pointer autoload_hook; /* *autoload-hook* hook object */
s7_pointer unbound_variable_hook; /* *unbound-variable-hook* hook object */
s7_pointer missing_close_paren_hook, rootlet_redefinition_hook;
s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */
bool gc_off; /* gc_off: if true, the GC won't run */
uint32_t gc_stats, gensym_counter, f_class, add_class, multiply_class,
subtract_class, num_eq_class;
int32_t format_column;
uint64_t capture_let_counter;
bool short_print, is_autoloading, in_with_let, object_out_locked,
has_openlets, is_expanding, accept_all_keyword_arguments,
muffle_warnings;
bool got_tc, got_rec, not_tc;
s7_int rec_tc_args, continuation_counter;
int64_t let_number;
s7_double default_rationalize_error, equivalent_float_epsilon,
hash_table_float_epsilon;
s7_int default_hash_table_length, initial_string_port_length,
print_length, objstr_max_len, history_size, true_history_size,
output_port_data_size;
s7_int max_vector_length, max_string_length, max_list_length,
max_vector_dimensions, max_format_length, max_port_data_size,
rec_loc, rec_len;
s7_pointer stacktrace_defaults;
s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p,
rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p;
s7_pointer rec_resp, rec_slot1, rec_slot2, rec_slot3, rec_p1, rec_p2;
s7_pointer *rec_els;
s7_function rec_testf, rec_f1f, rec_f2f, rec_f3f, rec_f4f, rec_f5f,
rec_f6f, rec_f7f, rec_f8f, rec_f9f, rec_resf, rec_fn;
s7_int(*rec_fi1) (opt_info * o);
s7_int(*rec_fi2) (opt_info * o);
s7_int(*rec_fi3) (opt_info * o);
s7_int(*rec_fi4) (opt_info * o);
s7_int(*rec_fi5) (opt_info * o);
s7_int(*rec_fi6) (opt_info * o);
bool (*rec_fb1)(opt_info * o);
bool (*rec_fb2)(opt_info * o);
opt_info *rec_test_o, *rec_result_o, *rec_a1_o, *rec_a2_o, *rec_a3_o,
*rec_a4_o, *rec_a5_o, *rec_a6_o;
s7_i_ii_t rec_i_ii_f;
s7_d_dd_t rec_d_dd_f;
s7_pointer rec_val1, rec_val2;
int32_t float_format_precision;
vdims_t *wrap_only;
char *typnam;
int32_t typnam_len, print_width;
s7_pointer *singletons;
block_t *unentry; /* hash-table lookup failure indicator */
#define INITIAL_FILE_NAMES_SIZE 8
s7_pointer *file_names;
int32_t file_names_size, file_names_top;
#define INITIAL_STRBUF_SIZE 1024
s7_int strbuf_size;
char *strbuf;
char *read_line_buf;
s7_int read_line_buf_size;
s7_pointer u, v, w, x, y, z; /* evaluator local vars */
s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8,
temp9, temp_cell_2;
s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, z2_1, z2_2, t4_1, u1_1,
u2_1, u2_2;
Jmp_Buf goto_start;
bool longjmp_ok;
int32_t setjmp_loc;
void (*begin_hook)(s7_scheme * sc, bool *val);
opcode_t begin_op;
bool debug_or_profile, profiling_gensyms;
s7_int current_line, s7_call_line, safety, debug, profile;
profile_data_t *profile_data;
const char *current_file, *s7_call_file, *s7_call_name;
shared_info_t *circle_info;
format_data_t **fdats;
int32_t num_fdats, last_error_line;
s7_pointer elist_1, elist_2, elist_3, elist_4, elist_5, plist_1,
plist_2, plist_2_2, plist_3, qlist_2, qlist_3, clist_1, dlist_1;
gc_list_t *strings, *vectors, *input_ports, *output_ports,
*input_string_ports, *continuations, *c_objects, *hash_tables;
gc_list_t *gensyms, *undefineds, *lambdas, *multivectors, *weak_refs,
*weak_hash_iterators, *opt1_funcs;
#if (WITH_GMP)
gc_list_t *big_integers, *big_ratios, *big_reals, *big_complexes,
*big_random_states;
mpz_t mpz_1, mpz_2, mpz_3, mpz_4;
mpq_t mpq_1, mpq_2, mpq_3;
mpfr_t mpfr_1, mpfr_2, mpfr_3;
mpc_t mpc_1, mpc_2;
rat_locals_t *ratloc;
bigint *bigints;
bigrat *bigrats;
bigflt *bigflts;
bigcmp *bigcmps;
#endif
s7_pointer *setters;
s7_int setters_size, setters_loc;
s7_pointer *tree_pointers;
int32_t tree_pointers_size, tree_pointers_top, permanent_cells,
string_wrapper_pos, num_to_str_size;
s7_pointer format_ports;
uint32_t alloc_pointer_k, alloc_function_k, alloc_symbol_k;
s7_cell *alloc_pointer_cells;
c_proc_t *alloc_function_cells;
uint32_t alloc_big_pointer_k;
s7_big_cell *alloc_big_pointer_cells;
s7_pointer *string_wrappers;
uint8_t *alloc_symbol_cells;
char *num_to_str;
block_t *block_lists[NUM_BLOCK_LISTS];
size_t alloc_string_k;
char *alloc_string_cells;
c_object_t **c_object_types;
int32_t c_object_types_size, num_c_object_types;
s7_pointer type_to_typers[NUM_TYPES];
uint32_t syms_tag, syms_tag2;
int32_t bignum_precision;
s7_int baffle_ctr;
s7_pointer default_rng;
s7_pointer sort_body, sort_begin, sort_v1, sort_v2;
opcode_t sort_op;
s7_int sort_body_len;
s7_b_7pp_t sort_f;
opt_info *sort_o;
bool (*sort_fb)(opt_info * o);
#define INT_TO_STR_SIZE 32
char int_to_str1[INT_TO_STR_SIZE], int_to_str2[INT_TO_STR_SIZE],
int_to_str3[INT_TO_STR_SIZE], int_to_str4[INT_TO_STR_SIZE],
int_to_str5[INT_TO_STR_SIZE];
s7_pointer abs_symbol, acos_symbol, acosh_symbol, add_symbol,
angle_symbol, append_symbol, apply_symbol, apply_values_symbol,
arity_symbol, ash_symbol, asin_symbol, asinh_symbol, assoc_symbol,
assq_symbol, assv_symbol, atan_symbol, atanh_symbol,
autoload_symbol, autoloader_symbol, bacro_symbol,
bacro_star_symbol, bignum_symbol, byte_vector_symbol,
byte_vector_ref_symbol, byte_vector_set_symbol,
byte_vector_to_string_symbol, c_pointer_symbol,
c_pointer_info_symbol, c_pointer_to_list_symbol,
c_pointer_type_symbol, c_pointer_weak1_symbol,
c_pointer_weak2_symbol, c_pointer_with_type, 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, cyclic_sequences_symbol,
denominator_symbol, dilambda_symbol, display_symbol, divide_symbol,
documentation_symbol, dynamic_wind_symbol, dynamic_unwind_symbol,
num_eq_symbol, error_symbol, eval_string_symbol, eval_symbol,
exact_to_inexact_symbol, exit_symbol, exp_symbol, expt_symbol,
features_symbol, file__symbol, fill_symbol,
float_vector_ref_symbol, float_vector_set_symbol,
float_vector_symbol, floor_symbol, flush_output_port_symbol,
for_each_symbol, format_symbol, funclet_symbol, _function__symbol,
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_symbol,
help_symbol, imag_part_symbol, immutable_symbol,
inexact_to_exact_symbol, inlet_symbol, int_vector_ref_symbol,
int_vector_set_symbol, int_vector_symbol,
integer_decode_float_symbol, integer_to_char_symbol,
is_aritable_symbol, is_bignum_symbol, is_boolean_symbol,
is_byte_symbol, is_byte_vector_symbol, is_c_object_symbol,
c_object_type_symbol, is_c_pointer_symbol,
is_char_alphabetic_symbol, is_char_lower_case_symbol,
is_char_numeric_symbol, is_char_symbol, is_char_upper_case_symbol,
is_char_whitespace_symbol, is_complex_symbol, is_constant_symbol,
is_continuation_symbol, is_defined_symbol, is_dilambda_symbol,
is_eof_object_symbol, is_eq_symbol, is_equal_symbol, is_eqv_symbol,
is_even_symbol, is_exact_symbol, is_float_vector_symbol,
is_funclet_symbol, is_gensym_symbol, is_goto_symbol,
is_hash_table_symbol, is_immutable_symbol, is_inexact_symbol,
is_infinite_symbol, is_input_port_symbol, is_int_vector_symbol,
is_integer_symbol, is_iterator_symbol, is_keyword_symbol,
is_let_symbol, is_list_symbol, is_macro_symbol,
is_equivalent_symbol, is_nan_symbol, is_negative_symbol,
is_null_symbol, is_number_symbol, is_odd_symbol, is_openlet_symbol,
is_output_port_symbol, is_pair_symbol, is_port_closed_symbol,
is_positive_symbol, is_procedure_symbol, is_proper_list_symbol,
is_provided_symbol, is_random_state_symbol, is_rational_symbol,
is_real_symbol, is_sequence_symbol, is_string_symbol,
is_subvector_symbol, is_symbol_symbol, is_syntax_symbol,
is_vector_symbol, is_weak_hash_table_symbol, is_zero_symbol,
is_float_symbol, is_integer_or_real_at_end_symbol,
is_integer_or_any_at_end_symbol, is_unspecified_symbol,
is_undefined_symbol, iterate_symbol, iterator_is_at_end_symbol,
iterator_sequence_symbol, keyword_to_symbol_symbol, lcm_symbol,
length_symbol, leq_symbol, let_ref_fallback_symbol, let_ref_symbol,
let_set_fallback_symbol, let_set_symbol, let_temporarily_symbol,
libraries_symbol, list_ref_symbol, list_set_symbol, list_symbol,
list_tail_symbol, list_values_symbol, load_path_symbol,
load_symbol, log_symbol, logand_symbol, logbit_symbol,
logior_symbol, lognot_symbol, logxor_symbol, lt_symbol,
macro_symbol, macro_star_symbol, magnitude_symbol,
make_byte_vector_symbol, make_float_vector_symbol,
make_hash_table_symbol, make_weak_hash_table_symbol,
make_int_vector_symbol, make_iterator_symbol,
string_to_keyword_symbol, make_list_symbol, make_string_symbol,
make_vector_symbol, map_symbol, max_symbol, member_symbol,
memq_symbol, memv_symbol, min_symbol, modulo_symbol,
multiply_symbol, name_symbol, newline_symbol, not_symbol,
number_to_string_symbol, numerator_symbol, object_to_string_symbol,
object_to_let_symbol, open_input_file_symbol,
open_input_function_symbol, open_input_string_symbol,
open_output_file_symbol, open_output_function_symbol,
open_output_string_symbol, openlet_symbol, outlet_symbol,
owlet_symbol, pair_filename_symbol, pair_line_number_symbol,
peek_char_symbol, pi_symbol, port_filename_symbol,
port_line_number_symbol, port_file_symbol, port_position_symbol,
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, setter_symbol,
set_car_symbol, set_cdr_symbol, set_current_error_port_symbol,
set_current_input_port_symbol, set_current_output_port_symbol,
signature_symbol, sin_symbol, sinh_symbol, sort_symbol,
sqrt_symbol, stacktrace_symbol, string_append_symbol,
string_copy_symbol, string_downcase_symbol, string_eq_symbol,
string_fill_symbol, string_geq_symbol, string_gt_symbol,
string_leq_symbol, string_lt_symbol, string_position_symbol,
string_ref_symbol, string_set_symbol, string_symbol,
string_to_number_symbol, string_to_symbol_symbol,
string_upcase_symbol, sublet_symbol, substring_symbol,
subtract_symbol, subvector_symbol, subvector_position_symbol,
subvector_vector_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,
tree_count_symbol, tree_leaves_symbol, tree_memq_symbol,
tree_set_memq_symbol, tree_is_cyclic_symbol, truncate_symbol,
type_of_symbol, unlet_symbol, values_symbol, varlet_symbol,
vector_append_symbol, vector_dimension_symbol,
vector_dimensions_symbol, vector_fill_symbol, vector_rank_symbol,
vector_ref_symbol, vector_set_symbol, vector_symbol,
weak_hash_table_symbol, with_input_from_file_symbol,
with_input_from_string_symbol, with_output_to_file_symbol,
with_output_to_string_symbol, write_byte_symbol, write_char_symbol,
write_string_symbol, write_symbol, local_documentation_symbol,
local_signature_symbol, local_setter_symbol, local_iterator_symbol;
s7_pointer hash_code_symbol, dummy_equal_hash_table;
#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, list_to_string_symbol, list_to_vector_symbol,
vector_length_symbol;
#endif
/* syntax symbols et al */
s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol,
quote_symbol, quasiquote_symbol, unquote_symbol,
macroexpand_symbol, define_expansion_symbol,
define_expansion_star_symbol, with_let_symbol, if_symbol,
autoload_error_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,
key_display_symbol, key_write_symbol, value_symbol, type_symbol,
baffled_symbol, set_symbol, body_symbol, class_name_symbol,
feed_to_symbol, format_error_symbol, immutable_error_symbol,
wrong_number_of_args_symbol, read_error_symbol,
string_read_error_symbol, syntax_error_symbol,
division_by_zero_symbol, bad_result_symbol, no_catch_symbol,
io_error_symbol, invalid_escape_function_symbol,
wrong_type_arg_symbol, out_of_range_symbol, out_of_memory_symbol,
missing_method_symbol, unbound_variable_symbol, key_if_symbol,
symbol_table_symbol, profile_in_symbol, trace_in_symbol;
/* signatures of sequences used as applicable objects: ("hi" 1) */
s7_pointer string_signature, vector_signature, float_vector_signature,
int_vector_signature, byte_vector_signature, c_object_signature,
let_signature, hash_table_signature, pair_signature;
/* common signatures */
s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, pcl_e, pcl_f, pcl_i, pcl_n,
pcl_r, pcl_s, pcl_v, pl_bc, pl_bn, pl_bt, pl_p, pl_sf, pl_tl,
pl_nn;
/* optimizer s7_functions */
s7_pointer add_2, add_3, add_1x, add_x1, subtract_1, subtract_2,
subtract_3, subtract_x1, subtract_2f, subtract_f2, simple_char_eq,
char_equal_2, char_greater_2, char_less_2, char_position_csi,
string_equal_2, substring_uncopied, display_2, display_f,
string_greater_2, string_less_2, symbol_to_string_uncopied,
get_output_string_uncopied, string_equal_2c, string_c1,
string_append_2, vector_ref_2, vector_ref_3, vector_set_3,
vector_set_4, read_char_1, dynamic_wind_unchecked, append_2,
fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_3,
iv_set_3, bv_ref_2, bv_ref_3, bv_set_3, vector_2, vector_3, list_0,
list_1, list_2, list_3, list_4, list_set_i, hash_table_ref_2,
hash_table_2, list_ref_at_0, list_ref_at_1, list_ref_at_2,
format_f, format_no_column, format_just_control_string,
format_as_objstr, values_uncopied, memq_2, memq_3, memq_4,
memq_any, tree_set_memq_syms, simple_inlet, profile_out,
lint_let_ref, lint_let_set, geq_2, add_i_random,
is_defined_in_rootlet;
s7_pointer multiply_2, invert_1, invert_x, divide_2, divide_by_2,
max_2, min_2, max_3, min_3, num_eq_2, num_eq_xi, num_eq_ix,
less_xi, less_xf, less_x0, less_2, greater_xi, greater_xf,
greater_2, leq_xi, leq_2, leq_ixx, geq_xi, geq_xf, random_i,
random_f, random_1, mul_2_ff, mul_2_ii, mul_2_if, mul_2_fi,
mul_2_xi, mul_2_ix, mul_2_fx, mul_2_xf, add_2_ff, add_2_ii,
add_2_if, add_2_fi, add_2_xi, add_2_ix, add_2_fx, add_2_xf;
s7_pointer seed_symbol, carry_symbol;
/* object->let symbols */
s7_pointer active_symbol, goto_symbol, data_symbol, weak_symbol,
dimensions_symbol, info_symbol, c_type_symbol, source_symbol,
c_object_ref_symbol, at_end_symbol, sequence_symbol,
position_symbol, entries_symbol, locked_symbol, function_symbol,
open_symbol, alias_symbol, port_type_symbol, file_symbol,
file_info_symbol, line_symbol, c_object_let_symbol, class_symbol,
c_object_length_symbol, c_object_set_symbol, current_value_symbol,
c_object_copy_symbol, c_object_fill_symbol,
c_object_reverse_symbol, c_object_to_list_symbol,
c_object_to_string_symbol, closed_symbol, mutable_symbol,
size_symbol, original_vector_symbol, pointer_symbol;
#if WITH_SYSTEM_EXTRAS
s7_pointer is_directory_symbol, file_exists_symbol, delete_file_symbol,
getenv_symbol, system_symbol, directory_to_list_symbol,
file_mtime_symbol;
#endif
s7_pointer open_input_function_choices[S7_NUM_READ_CHOICES];
s7_pointer closed_input_function, closed_output_function;
s7_pointer vector_set_function, string_set_function, list_set_function,
hash_table_set_function, let_set_function, c_object_set_function,
last_function;
s7_pointer wrong_type_arg_info, out_of_range_info,
simple_wrong_type_arg_info, simple_out_of_range_info;
s7_pointer integer_wrapper1, integer_wrapper2, integer_wrapper3;
s7_pointer real_wrapper1, real_wrapper2, real_wrapper3, real_wrapper4;
#define NUM_SAFE_PRELISTS 8
#define NUM_SAFE_LISTS 64 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test */
s7_pointer safe_lists[NUM_SAFE_LISTS];
int32_t current_safe_list;
s7_pointer autoload_table, s7_let, s7_let_symbol;
const char ***autoload_names;
s7_int *autoload_names_sizes;
bool **autoloaded_already;
s7_int autoload_names_loc, autoload_names_top;
int32_t format_depth;
bool undefined_identifier_warnings, undefined_constant_warnings,
stop_at_error;
opt_funcs_t *alloc_opt_func_cells;
int32_t alloc_opt_func_k;
int32_t pc;
#define OPTS_SIZE 256 /* pqw-vox needs 178 */
opt_info *opts[OPTS_SIZE + 1]; /* this form is a lot faster than opt_info**! */
#define INITIAL_SAVED_POINTERS_SIZE 256 /* s7test: 838, thash: 55377, trec: 81 */
void **saved_pointers;
s7_int saved_pointers_loc, saved_pointers_size;
s7_pointer prepackaged_type_names[NUM_TYPES];
#if S7_DEBUGGING
int *tc_rec_calls;
int last_gc_line;
#endif
};
#if S7_DEBUGGING
static void gdb_break(void)
{
};
#endif
static s7_scheme *cur_sc = NULL; /* intended for gdb (see gdbinit), but also used if S7_DEBUGGING unfortunately */
#define opt_sc(o) o->sc
#define opt_set_sc(o, sc) o->sc = sc
/* -------------------------------- mallocate -------------------------------- */
static void add_saved_pointer(s7_scheme * sc, void *p)
{
if (sc->saved_pointers_loc == sc->saved_pointers_size) {
sc->saved_pointers_size *= 2;
sc->saved_pointers =
(void **) realloc(sc->saved_pointers,
sc->saved_pointers_size * sizeof(void *));
}
sc->saved_pointers[sc->saved_pointers_loc++] = p;
}
#if POINTER_32
static void *Malloc(size_t bytes)
{
void *p;
p = malloc(bytes);
if (!p)
s7_error(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil);
return (p);
}
static void *Calloc(size_t nmemb, size_t size)
{
void *p;
p = calloc(nmemb, size);
if (!p)
s7_error(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil);
return (p);
}
static void *Realloc(void *ptr, size_t size)
{
void *p;
p = realloc(ptr, size);
if (!p)
s7_error(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil);
return (p);
}
#else
#define Malloc malloc
#define Calloc calloc
#define Realloc realloc
#endif
static const int32_t intlen_bits[256] =
{ 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5,
5, 5, 5, 5, 5, 5, 5, 5, 5,
6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
6, 6, 6, 6, 6, 6, 6, 6,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
8, 8, 8, 8, 8, 8, 8, 8
};
static void memclr(void *s, size_t n)
{
uint8_t *s2;
#if S7_ALIGNED
s2 = (uint8_t *) s;
#else
#if (defined(__x86_64__) || defined(__i386__))
if (n >= 8) {
int64_t *s1 = (int64_t *) s;
size_t n8 = n >> 3;
do {
*s1++ = 0;
} while (--n8 > 0);
n &= 7;
s2 = (uint8_t *) s1;
} else
s2 = (uint8_t *) s;
#else
s2 = (uint8_t *) s;
#endif
#endif
while (n > 0) {
*s2++ = 0;
n--;
}
}
#define LOOP_4(Code) do {Code; Code; Code; Code;} while (0)
#define LOOP_8(Code) do {Code; Code; Code; Code; Code; Code; Code; Code;} while (0)
#define STEP_8(Var) (((Var) & 0x7) == 0)
#define STEP_64(Var) (((Var) & 0x3f) == 0)
#if POINTER_32
#define memclr64 memclr
#else
static Vectorized void memclr64(void *p, size_t bytes)
{
size_t i, n = bytes >> 3;
int64_t *vals = (int64_t *) p;
for (i = 0; i < n;)
LOOP_8(vals[i++] = 0);
}
#endif
static void init_block_lists(s7_scheme * sc)
{
int32_t i;
for (i = 0; i < NUM_BLOCK_LISTS; i++)
sc->block_lists[i] = NULL;
}
static inline void liberate(s7_scheme * sc, block_t * p)
{
if (block_index(p) != TOP_BLOCK_LIST) {
block_next(p) = (struct block_t *) sc->block_lists[block_index(p)];
sc->block_lists[block_index(p)] = p;
} else {
if (block_data(p)) {
free(block_data(p));
block_data(p) = NULL;
}
block_next(p) = (struct block_t *) sc->block_lists[BLOCK_LIST];
sc->block_lists[BLOCK_LIST] = p;
}
}
static inline void liberate_block(s7_scheme * sc, block_t * p)
{
block_next(p) = (struct block_t *) sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST=0 */
sc->block_lists[BLOCK_LIST] = p;
}
static void fill_block_list(s7_scheme * sc)
{
int32_t i;
block_t *b;
#define BLOCK_MALLOC_SIZE 256
b = (block_t *) Malloc(BLOCK_MALLOC_SIZE * sizeof(block_t)); /* batch alloc means blocks in this batch can't be freed, only returned to the list */
add_saved_pointer(sc, b);
sc->block_lists[BLOCK_LIST] = b;
for (i = 0; i < BLOCK_MALLOC_SIZE - 1; b++, i++)
block_next(b) = (block_t *) (b + 1);
block_next(b) = NULL;
}
static inline block_t *mallocate_block(s7_scheme * sc)
{
block_t *p;
if (!sc->block_lists[BLOCK_LIST])
fill_block_list(sc); /* this is much faster than allocating blocks as needed */
p = sc->block_lists[BLOCK_LIST];
sc->block_lists[BLOCK_LIST] = (block_t *) (block_next(p));
block_set_index(p, BLOCK_LIST);
return (p);
}
static inline char *permalloc(s7_scheme * sc, size_t len)
{
#define ALLOC_STRING_SIZE (65536 * 8) /* going up to 16 made no difference in timings */
#define ALLOC_MAX_STRING (512 * 8) /* was 256 -- sets max size of block space lost at the end, but smaller = more direct malloc calls */
char *result;
size_t next_k;
len = (len + 7) & (~7); /* 8-byte aligned -- more than half the time, len is already 8-byte aligned */
next_k = sc->alloc_string_k + len;
if (next_k > ALLOC_STRING_SIZE) {
if (len >= ALLOC_MAX_STRING) {
result = (char *) Malloc(len);
add_saved_pointer(sc, result);
return (result);
}
sc->alloc_string_cells = (char *) Malloc(ALLOC_STRING_SIZE); /* get a new block */
add_saved_pointer(sc, sc->alloc_string_cells);
sc->alloc_string_k = 0;
next_k = len;
}
result = &(sc->alloc_string_cells[sc->alloc_string_k]);
sc->alloc_string_k = next_k;
return (result);
}
static Inline block_t *mallocate(s7_scheme * sc, size_t bytes)
{
block_t *p;
if (bytes > 0) {
int32_t index;
if (bytes <= 8) /* presetting a version of intlen_bits with 3's gave only a small speed-up */
index = 3;
else {
if (bytes <= 256)
index = intlen_bits[bytes - 1];
else
index = (bytes <= 65536) ? (8 + intlen_bits[(bytes - 1) >> 8]) : TOP_BLOCK_LIST; /* expansion to (1 << 17) made no difference */
}
p = sc->block_lists[index];
if (p)
sc->block_lists[index] = (block_t *) block_next(p);
else {
if (index < (TOP_BLOCK_LIST - 1)) {
p = sc->block_lists[index + 1];
if (p) {
/* we are "borrowing" a block from the next larger bin -- this saves space but costs a bit of time.
* in a tauto run repeating every call 1000 times, the old form ends up at 129M and 31.1 secs,
* whereas the borrowing form ends at 116M and 31.5 secs, but most of my tests show a slight
* speed-up, probably because grabbing a block here is faster than making a new one.
* Worst case is tlet: 8 slower in callgrind.
*/
sc->block_lists[index + 1] = (block_t *) block_next(p);
block_set_size(p, bytes);
return (p);
}
}
p = mallocate_block(sc);
block_data(p) =
(index < TOP_BLOCK_LIST) ? (void *) permalloc(sc,
(size_t) (1
<<
index))
: Malloc(bytes);
block_set_index(p, index);
}} else
p = mallocate_block(sc);
block_set_size(p, bytes);
return (p);
}
static block_t *callocate(s7_scheme * sc, size_t bytes)
{
block_t *p;
p = mallocate(sc, bytes);
if ((block_data(p)) && (block_index(p) != BLOCK_LIST)) {
if ((bytes & (~0x3f)) > 0)
memclr64((void *) block_data(p), bytes & (~0x3f));
if ((bytes & 0x3f) > 0)
memclr((void *) ((uint8_t *) block_data(p) +
(bytes & (~0x3f))), bytes & 0x3f);
}
return (p);
}
static block_t *reallocate(s7_scheme * sc, block_t * op, size_t bytes)
{
block_t *np;
np = mallocate(sc, bytes);
if (block_data(op)) /* presumably block_data(np) is not null */
memcpy((uint8_t *) (block_data(np)), (uint8_t *) (block_data(op)),
block_size(op));
liberate(sc, op);
return (np);
}
/* we can't export mallocate et al without also exporting block_t or accessors for it
* that is, the block_t* pointer returned can't be used as if it were the void* pointer returned by malloc
*/
/* -------------------------------------------------------------------------------- */
typedef enum { P_DISPLAY, P_WRITE, P_READABLE, P_KEY } use_write_t;
static s7_pointer too_many_arguments_string, not_enough_arguments_string,
missing_method_string, cant_bind_immutable_string, a_boolean_string,
a_byte_vector_string, a_format_port_string, a_let_string,
a_list_string, a_non_constant_symbol_string,
a_non_negative_integer_string, a_normal_procedure_string,
a_normal_real_string, a_number_string, a_procedure_string,
a_procedure_or_a_macro_string, a_proper_list_string,
a_random_state_object_string, a_rational_string, a_sequence_string,
a_symbol_string, a_thunk_string, a_valid_radix_string,
an_association_list_string, an_eq_func_string,
an_input_file_port_string, an_input_port_string,
an_input_string_port_string, an_open_port_string,
an_output_file_port_string, an_output_port_string,
an_output_string_port_string, an_unsigned_byte_string,
caaar_a_list_string, caadr_a_list_string, caar_a_list_string,
cadar_a_list_string, caddr_a_list_string, cadr_a_list_string,
car_a_list_string, cdaar_a_list_string, cdadr_a_list_string,
cdar_a_list_string, cddar_a_list_string, cdddr_a_list_string,
cddr_a_list_string, cdr_a_list_string, immutable_error_string,
its_infinite_string, its_nan_string, its_negative_string,
its_too_large_string, its_too_small_string, parameter_set_twice_string,
result_is_too_large_string, something_applicable_string,
too_many_indices_string, value_is_missing_string, no_setter_string,
intermediate_too_large_string, format_string_1, format_string_2,
format_string_3, format_string_4;
static bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES],
t_rational_p[NUM_TYPES], t_real_p[NUM_TYPES],
t_big_number_p[NUM_TYPES];
static bool t_simple_p[NUM_TYPES], t_structure_p[NUM_TYPES];
static bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES],
t_has_closure_let[NUM_TYPES];
static bool t_mappable_p[NUM_TYPES], t_sequence_p[NUM_TYPES],
t_vector_p[NUM_TYPES];
static bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES];
#if S7_DEBUGGING
static bool t_freeze_p[NUM_TYPES]; /* free_cell sanity check */
#endif
static void init_types(void)
{
int32_t i;
for (i = 0; i < NUM_TYPES; i++) {
t_number_p[i] = false;
t_small_real_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_mappable_p[i] = false;
t_vector_p[i] = false;
t_applicable_p[i] = false;
t_procedure_p[i] = false;
#if S7_DEBUGGING
t_freeze_p[i] = false;
#endif
}
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_number_p[T_BIG_INTEGER] = true;
t_number_p[T_BIG_RATIO] = true;
t_number_p[T_BIG_REAL] = true;
t_number_p[T_BIG_COMPLEX] = true;
t_rational_p[T_INTEGER] = true;
t_rational_p[T_RATIO] = true;
t_rational_p[T_BIG_INTEGER] = true;
t_rational_p[T_BIG_RATIO] = true;
t_small_real_p[T_INTEGER] = true;
t_small_real_p[T_RATIO] = true;
t_small_real_p[T_REAL] = true;
t_real_p[T_INTEGER] = true;
t_real_p[T_RATIO] = true;
t_real_p[T_REAL] = true;
t_real_p[T_BIG_INTEGER] = true;
t_real_p[T_BIG_RATIO] = true;
t_real_p[T_BIG_REAL] = true;
t_big_number_p[T_BIG_INTEGER] = true;
t_big_number_p[T_BIG_RATIO] = true;
t_big_number_p[T_BIG_REAL] = true;
t_big_number_p[T_BIG_COMPLEX] = true;
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_structure_p[T_C_POINTER] = true;
t_structure_p[T_C_OBJECT] = 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_BYTE_VECTOR] = true;
t_sequence_p[T_HASH_TABLE] = true;
t_sequence_p[T_LET] = true;
t_sequence_p[T_C_OBJECT] = true;
t_mappable_p[T_PAIR] = true;
t_mappable_p[T_STRING] = true;
t_mappable_p[T_VECTOR] = true;
t_mappable_p[T_INT_VECTOR] = true;
t_mappable_p[T_FLOAT_VECTOR] = true;
t_mappable_p[T_BYTE_VECTOR] = true;
t_mappable_p[T_HASH_TABLE] = true;
t_mappable_p[T_LET] = true;
t_mappable_p[T_C_OBJECT] = true;
t_mappable_p[T_ITERATOR] = true;
t_mappable_p[T_C_MACRO] = true;
t_mappable_p[T_MACRO] = true;
t_mappable_p[T_BACRO] = true;
t_mappable_p[T_MACRO_STAR] = true;
t_mappable_p[T_BACRO_STAR] = true;
t_mappable_p[T_CLOSURE] = true;
t_mappable_p[T_CLOSURE_STAR] = true;
t_vector_p[T_VECTOR] = true;
t_vector_p[T_INT_VECTOR] = true;
t_vector_p[T_FLOAT_VECTOR] = true;
t_vector_p[T_BYTE_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_BYTE_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_procedure_p[T_C_OBJECT] = true; */
t_procedure_p[T_C_FUNCTION] = true;
t_procedure_p[T_C_FUNCTION_STAR] = true;
t_procedure_p[T_C_ANY_ARGS_FUNCTION] = true;
t_procedure_p[T_C_OPT_ARGS_FUNCTION] = true;
t_procedure_p[T_C_RST_ARGS_FUNCTION] = true;
t_procedure_p[T_CLOSURE] = true;
t_procedure_p[T_CLOSURE_STAR] = true;
t_procedure_p[T_GOTO] = true;
t_procedure_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_UNDEFINED] = true; *//* only #<undefined> itself will work with eq? */
t_simple_p[T_EOF] = 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 S7_DEBUGGING
t_freeze_p[T_STRING] = true;
t_freeze_p[T_BYTE_VECTOR] = true;
t_freeze_p[T_VECTOR] = true;
t_freeze_p[T_FLOAT_VECTOR] = true;
t_freeze_p[T_INT_VECTOR] = true;
t_freeze_p[T_UNDEFINED] = true;
t_freeze_p[T_C_OBJECT] = true;
t_freeze_p[T_HASH_TABLE] = true;
t_freeze_p[T_C_FUNCTION] = true;
t_freeze_p[T_CONTINUATION] = true;
t_freeze_p[T_INPUT_PORT] = true;
t_freeze_p[T_OUTPUT_PORT] = true;
#endif
}
#if WITH_HISTORY
#define current_code(Sc) car(Sc->cur_code)
#define set_current_code(Sc, Code) do {Sc->cur_code = cdr(Sc->cur_code); set_car(Sc->cur_code, T_Pos(Code));} while (0)
#define replace_current_code(Sc, Code) set_car(Sc->cur_code, T_Pos(Code))
#define mark_current_code(Sc) do {int32_t i; s7_pointer p; for (p = Sc->cur_code, i = 0; i < Sc->history_size; i++, p = cdr(p)) gc_mark(car(p));} while (0)
#else
#define current_code(Sc) Sc->cur_code
#define set_current_code(Sc, Code) Sc->cur_code = T_Pos(Code)
#define replace_current_code(Sc, Code) Sc->cur_code = T_Pos(Code)
#define mark_current_code(Sc) gc_mark(Sc->cur_code)
#endif
#define full_type(p) ((p)->tf.flag)
#define typesflag(p) ((p)->tf.sflag)
#define TYPE_MASK 0xff
#if S7_DEBUGGING
static bool printing_gc_info = false;
static void print_gc_info(s7_scheme * sc, s7_pointer obj, int32_t line);
static s7_pointer check_ref(s7_pointer p, uint8_t expected_type,
const char *func, int32_t line,
const char *func1, const char *func2);
static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line);
static s7_pointer check_ref11(s7_pointer p, const char *func,
int32_t line);
static s7_pointer check_ref16(s7_pointer p, const char *func,
int32_t line);
static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line);
static s7_pointer check_let_ref(s7_pointer p, uint64_t role,
const char *func, int32_t line);
#define unchecked_type(p) ((p)->tf.type_field)
#if WITH_GCC
#define type(p) ({uint8_t _t_; _t_ = (p)->tf.type_field; if ((!printing_gc_info) && ((_t_ == T_FREE) || (_t_ >= NUM_TYPES))) print_gc_info(cur_sc, p, __LINE__); _t_;})
#else
#define type(p) (p)->tf.type_field
#endif
#define set_full_type(p, f) set_type_1(p, f, __func__, __LINE__)
/* these check most s7_cell field references (and many type bits) for consistency */
#define T_Any(P) check_cell(sc, P, __func__, __LINE__) /* any cell */
#define T_App(P) check_ref11(P, __func__, __LINE__) /* applicable or #f */
#define T_Arg(P) check_ref10(P, __func__, __LINE__) /* closure arg (list, symbol) */
#define T_BVc(P) check_ref(P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL)
#define T_Bgf(P) check_ref(P, T_BIG_RATIO, __func__, __LINE__, "sweep", NULL)
#define T_Bgi(P) check_ref(P, T_BIG_INTEGER, __func__, __LINE__, "sweep", NULL)
#define T_Bgr(P) check_ref(P, T_BIG_REAL, __func__, __LINE__, "sweep", NULL)
#define T_Bgz(P) check_ref(P, T_BIG_COMPLEX, __func__, __LINE__, "sweep", NULL)
#define T_CMac(P) check_ref(P, T_C_MACRO, __func__, __LINE__, NULL, NULL)
#define T_Cat(P) check_ref(P, T_CATCH, __func__, __LINE__, NULL, NULL)
#define T_Chr(P) check_ref(P, T_CHARACTER, __func__, __LINE__, NULL, NULL)
#define T_Clo(P) check_ref5(P, __func__, __LINE__) /* has closure let */
#define T_Cmp(P) check_ref(P, T_COMPLEX, __func__, __LINE__, NULL, NULL)
#define T_Con(P) check_ref(P, T_CONTINUATION, __func__, __LINE__, "sweep", "process_continuation")
#define T_Ctr(P) check_ref(P, T_COUNTER, __func__, __LINE__, NULL, NULL)
#define T_Dyn(P) check_ref(P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL)
#define T_Eof(P) check_ref(P, T_EOF, __func__, __LINE__, "sweep", NULL)
#define T_Fnc(P) check_ref6(P, __func__, __LINE__) /* any c_function|c_macro */
#define T_Frc(P) check_ref2(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL)
#define T_Fst(P) check_ref(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL)
#define T_Fvc(P) check_ref(P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL)
#define T_Got(P) check_ref(P, T_GOTO, __func__, __LINE__, NULL, NULL)
#define T_Hsh(P) check_ref(P, T_HASH_TABLE, __func__, __LINE__, "sweep", "free_hash_table")
#define T_Int(P) check_ref(P, T_INTEGER, __func__, __LINE__, NULL, NULL)
#define T_Itr(P) check_ref(P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator")
#define T_Ivc(P) check_ref(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL)
#define T_Let(P) check_ref(P, T_LET, __func__, __LINE__, NULL, NULL)
#define T_Lid(P) check_ref16(P, __func__, __LINE__) /* let/nil */
#define T_Lst(P) check_ref2(P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL)
#define T_Mac(P) check_ref17(P, __func__, __LINE__) /* and non-C macro */
#define T_Met(P) check_ref9(P, __func__, __LINE__) /* anything that might contain a method */
#define T_Nmv(P) check_ref15(P, __func__, __LINE__) /* not multiple-value, not free */
#define T_Num(P) check_ref7(P, __func__, __LINE__) /* any number (not bignums) */
#define T_Nvc(P) check_ref(P, T_VECTOR, __func__, __LINE__, "sweep", NULL)
#define T_Obj(P) check_ref(P, T_C_OBJECT, __func__, __LINE__, "sweep", "s7_c_object_value")
#define T_Pair(P) check_ref(P, T_PAIR, __func__, __LINE__, NULL, NULL)
#define T_Pcs(P) check_ref2(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL)
#define T_Pos(P) check_nref(P, __func__, __LINE__) /* not free */
#define T_Prc(P) check_ref14(P, __func__, __LINE__) /* any procedure or #f (setters) */
#define T_Prt(P) check_ref3(P, __func__, __LINE__) /* input|output_port */
#define T_Ptr(P) check_ref(P, T_C_POINTER, __func__, __LINE__, NULL, NULL)
#define T_Ran(P) check_ref(P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL)
#define T_Rel(P) check_ref(P, T_REAL, __func__, __LINE__, NULL, NULL)
#define T_SVec(P) check_ref13(P, __func__, __LINE__) /* subvector */
#define T_Seq(P) check_ref8(P, __func__, __LINE__) /* any sequence or structure */
#define T_Sld(P) check_ref2(P, T_SLOT, T_UNDEFINED,__func__, __LINE__, NULL, NULL)
#define T_Sln(P) check_ref12(P, __func__, __LINE__) /* slot or nil */
#define T_Slt(P) check_ref(P, T_SLOT, __func__, __LINE__, NULL, NULL)
#define T_Stk(P) check_ref(P, T_STACK, __func__, __LINE__, NULL, NULL)
#define T_Str(P) check_ref(P, T_STRING, __func__, __LINE__, "sweep", NULL)
#define T_Sym(P) check_ref(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table")
#define T_Syn(P) check_ref(P, T_SYNTAX, __func__, __LINE__, NULL, NULL)
#define T_Undf(P) check_ref(P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL)
#define T_Vec(P) check_ref4(P, __func__, __LINE__) /* any vector */
#else
/* if not debugging, all those checks go away */
#define T_Any(P) P
#define T_App(P) P
#define T_Arg(P) P
#define T_BVc(P) P
#define T_Bgf(P) P
#define T_Bgi(P) P
#define T_Bgr(P) P
#define T_Bgz(P) P
#define T_CMac(P) P
#define T_Cat(P) P
#define T_Chr(P) P
#define T_Clo(P) P
#define T_Cmp(P) P
#define T_Con(P) P
#define T_Ctr(P) P
#define T_Dyn(P) P
#define T_Eof(P) P
#define T_Fnc(P) P
#define T_Frc(P) P
#define T_Fst(P) P
#define T_Fvc(P) P
#define T_Got(P) P
#define T_Hsh(P) P
#define T_Int(P) P
#define T_Itr(P) P
#define T_Ivc(P) P
#define T_Let(P) P
#define T_Lid(P) P
#define T_Lst(P) P
#define T_Mac(P) P
#define T_Met(P) P
#define T_Nmv(P) P
#define T_Num(P) P
#define T_Nvc(P) P
#define T_Obj(P) P
#define T_Pair(P) P
#define T_Pcs(P) P
#define T_Pos(P) P
#define T_Prc(P) P
#define T_Prt(P) P
#define T_Ptr(P) P
#define T_Ran(P) P
#define T_Rel(P) P
#define T_SVec(P) P
#define T_Seq(P) P
#define T_Sld(P) P
#define T_Sln(P) P
#define T_Slt(P) P
#define T_Stk(P) P
#define T_Str(P) P
#define T_Sym(P) P
#define T_Syn(P) P
#define T_Undf(P) P
#define T_Vec(P) P
#define unchecked_type(p) ((p)->tf.type_field)
#define type(p) ((p)->tf.type_field)
#define set_full_type(p, f) full_type(p) = f
#endif
#define signed_type(p) (p)->tf.signed_flag
#define is_number(P) t_number_p[type(P)]
#define is_small_real(P) t_small_real_p[type(P)]
#define is_real(P) t_real_p[type(P)]
#define is_rational(P) t_rational_p[type(P)]
#define is_big_number(p) t_big_number_p[type(p)]
#define is_t_integer(p) (type(p) == T_INTEGER)
#define is_t_ratio(p) (type(p) == T_RATIO)
#define is_t_real(p) (type(p) == T_REAL)
#define is_t_complex(p) (type(p) == T_COMPLEX)
#define is_t_big_integer(p) (type(p) == T_BIG_INTEGER)
#define is_t_big_ratio(p) (type(p) == T_BIG_RATIO)
#define is_t_big_real(p) (type(p) == T_BIG_REAL)
#define is_t_big_complex(p) (type(p) == T_BIG_COMPLEX)
#define is_free(p) (type(p) == T_FREE)
#define is_free_and_clear(p) (full_type(p) == T_FREE)
#define is_simple(P) t_simple_p[type(P)] /* eq? */
#define has_structure(P) ((t_structure_p[type(P)]) && ((!is_normal_vector(P)) || (!has_simple_elements(P))))
#define is_any_macro(P) t_any_macro_p[type(P)]
#define is_any_closure(P) t_any_closure_p[type(P)]
#define is_any_procedure(P) (type(P) >= T_CLOSURE)
#define has_closure_let(P) t_has_closure_let[type(P)]
#define is_simple_sequence(P) (t_sequence_p[type(P)])
#define is_sequence(P) ((t_sequence_p[type(P)]) || (has_methods(P)))
#define is_mutable_sequence(P) (((t_sequence_p[type(P)]) || (has_methods(P))) && (!is_immutable(P)))
#define is_mappable(P) (t_mappable_p[type(P)])
#define is_applicable(P) (t_applicable_p[type(P)])
/* this misses #() which is not applicable to anything, and "", and inapplicable c-objects like random-state */
#define is_procedure(p) ((t_procedure_p[type(p)]) || ((is_c_object(p)) && (is_safe_procedure(p))))
#define is_t_procedure(p) (t_procedure_p[type(p)])
/* the layout of these bits does matter in several cases -- don't shadow SYNTACTIC_PAIR and OPTIMIZED_PAIR */
#define TYPE_BITS 8
#define set_type_bit(p, b) full_type(p) |= (b)
#define clear_type_bit(p, b) full_type(p) &= (~(b))
#define has_type_bit(p, b) ((full_type(p) & (b)) != 0)
#define set_type0_bit(p, b) typesflag(p) |= (b)
#define clear_type0_bit(p, b) typesflag(p) &= (~(b))
#define has_type0_bit(p, b) ((typesflag(p) & (b)) != 0)
#define set_type1_bit(p, b) (p)->tf.opts.high_flag |= (b)
#define clear_type1_bit(p, b) (p)->tf.opts.high_flag &= (~(b))
#define has_type1_bit(p, b) (((p)->tf.opts.high_flag & (b)) != 0)
#define T_SYNTACTIC (1 << (TYPE_BITS + 1))
#define is_symbol_and_syntactic(p) (typesflag(T_Pos(p)) == (uint16_t)(T_SYMBOL | T_SYNTACTIC))
#define is_syntactic_symbol(p) has_type0_bit(T_Sym(p), T_SYNTACTIC)
#define is_syntactic_pair(p) has_type0_bit(T_Pair(p), T_SYNTACTIC)
#define clear_syntactic(p) clear_type0_bit(T_Pair(p), T_SYNTACTIC)
#define set_syntactic_pair(p) full_type(T_Pair(p)) = (T_PAIR | T_SYNTACTIC | (full_type(p) & (0xffffffffffff0000 & ~T_OPTIMIZED))) /* used only in pair_set_syntax_op */
/* this marks symbols that represent syntax objects, it should be in the second byte */
#define T_SIMPLE_ARG_DEFAULTS (1 << (TYPE_BITS + 2))
#define lambda_has_simple_defaults(p) has_type_bit(T_Pair(closure_body(p)), T_SIMPLE_ARG_DEFAULTS)
#define lambda_set_simple_defaults(p) set_type_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS)
/* are all lambda* default values simple? This is set on closure_body, so it doesn't mess up closure_is_ok_1 */
#define T_LIST_IN_USE T_SIMPLE_ARG_DEFAULTS
#define list_is_in_use(p) has_type0_bit(T_Pair(p), T_LIST_IN_USE)
#define set_list_in_use(p) set_type_bit(T_Pair(p), T_LIST_IN_USE)
#define clear_list_in_use(p) do {clear_type_bit(T_Pair(p), T_LIST_IN_USE); sc->current_safe_list = 0;} while (0)
/* since the safe lists are not in the heap, if the list_in_use bit is off, the list won't ne GC-protected even if
* it is gc_marked explicitly. This happens, for example, in copy_proper_list where we try to protect the original list
* by sc->u = lst; then in the GC, gc_mark(sc->u); but the safe_list probably is already marked, so its contents are not protected.
*/
/* if (!is_immutable(p)) free_vlist(sc, p) seems plausible here, but it got no hits in s7test and other cases */
#define T_ONE_FORM T_SIMPLE_ARG_DEFAULTS
#define set_closure_has_one_form(p) set_type_bit(T_Clo(p), T_ONE_FORM)
#define T_MULTIFORM (1 << (TYPE_BITS + 0))
#define set_closure_has_multiform(p) set_type_bit(T_Clo(p), T_MULTIFORM)
#define T_ONE_FORM_FX_ARG (T_ONE_FORM | T_MULTIFORM)
#define set_closure_one_form_fx_arg(p) set_type_bit(T_Clo(p), T_ONE_FORM_FX_ARG)
/* can't use T_HAS_FX here because closure_is_ok wants to examine typesflag */
#define T_OPTIMIZED (1 << (TYPE_BITS + 3))
#define set_optimized(p) set_type0_bit(T_Pair(p), T_OPTIMIZED)
#define clear_optimized(p) clear_type0_bit(T_Pair(p), T_OPTIMIZED | T_SYNTACTIC | T_HAS_FX | T_HAS_FN)
#define OPTIMIZED_PAIR (uint16_t)(T_PAIR | T_OPTIMIZED)
#define is_optimized(p) (typesflag(T_Pos(p)) == OPTIMIZED_PAIR)
/* optimizer flag for an expression that has optimization info, it should be in the second byte */
#define T_SCOPE_SAFE T_OPTIMIZED
#define is_scope_safe(p) has_type_bit(T_Fnc(p), T_SCOPE_SAFE)
#define set_scope_safe(p) set_type_bit(T_Fnc(p), T_SCOPE_SAFE)
#define T_SAFE_CLOSURE (1 << (TYPE_BITS + 4))
#define is_safe_closure(p) has_type0_bit(T_Clo(p), T_SAFE_CLOSURE)
#define set_safe_closure(p) set_type0_bit(T_Clo(p), T_SAFE_CLOSURE)
#define is_safe_closure_body(p) has_type0_bit(T_Pair(p), T_SAFE_CLOSURE)
#define set_safe_closure_body(p) set_type0_bit(T_Pair(p), T_SAFE_CLOSURE)
#define clear_safe_closure_body(p) clear_type0_bit(T_Pair(p), T_SAFE_CLOSURE)
/* optimizer flag for a closure body that is completely simple (every expression is safe)
* set_safe_closure happens only in define_funchcecked, clear only in procedure_source, bits only here
* this has to be separate from T_SAFE_PROCEDURE, and should be in the second byte (closure_is_ok_1 checks typesflag).
* define -> optimize_lambda sets safe -> define_funchecked -> make_funclet for the let
* similarly, named let -> optimize_lambda, then let creates the let if safe
* thereafter, optimizer uses OP_SAFE_CLOSURE* which calls update_let*
*/
#define T_DONT_EVAL_ARGS (1 << (TYPE_BITS + 5))
#define dont_eval_args(p) has_type0_bit(T_Pos(p), T_DONT_EVAL_ARGS)
/* this marks things that don't evaluate their arguments */
#define T_EXPANSION (1 << (TYPE_BITS + 6))
#define is_expansion(p) has_type0_bit(T_Any(p), T_EXPANSION)
#define clear_expansion(p) clear_type0_bit(T_Sym(p), T_EXPANSION)
/* this marks the symbol and its run-time macro value, distinguishing it from an ordinary macro */
#define T_MULTIPLE_VALUE (1 << (TYPE_BITS + 7))
#define is_multiple_value(p) has_type0_bit(T_Pos(p), T_MULTIPLE_VALUE)
#if S7_DEBUGGING
#define set_multiple_value(p) do {if (!in_heap(p)) {fprintf(stderr, "%s[%d]: mv\n", __func__, __LINE__); abort();} set_type0_bit(T_Pair(p), T_MULTIPLE_VALUE);} while (0)
#else
#define set_multiple_value(p) set_type0_bit(T_Pair(p), T_MULTIPLE_VALUE)
#endif
#define clear_multiple_value(p) clear_type0_bit(T_Pair(p), T_MULTIPLE_VALUE)
#define multiple_value(p) p
/* this bit marks a list (from "values") that is waiting for a chance to be spliced into its caller's argument list */
#define T_MATCHED T_MULTIPLE_VALUE
#define is_matched_pair(p) has_type0_bit(T_Pair(p), T_MATCHED)
#define clear_match_pair(p) clear_type0_bit(T_Pair(p), T_MATCHED)
#define set_match_pair(p) set_type0_bit(T_Pair(p), T_MATCHED)
#define set_match_symbol(p) set_type0_bit(T_Sym(p), T_MATCHED)
#define is_matched_symbol(p) has_type0_bit(T_Sym(p), T_MATCHED)
#define clear_match_symbol(p) clear_type0_bit(T_Sym(p), T_MATCHED)
#define T_GLOBAL (1 << (TYPE_BITS + 8))
#define T_LOCAL (1 << (TYPE_BITS + 12))
#define is_global(p) has_type_bit(T_Sym(p), T_GLOBAL)
#define set_global(p) do {if ((full_type(T_Sym(p)) & T_LOCAL) == 0) full_type(p) |= T_GLOBAL;} while (0)
/* T_LOCAL marks a symbol that has been used locally */
/* T_GLOBAL marks something defined (bound) at the top-level, and never defined locally */
#define REPORT_ROOTLET_REDEF 0
#if REPORT_ROOTLET_REDEF
/* to find who is stomping on our symbols: */
static void set_local_1(s7_scheme * sc, s7_pointer symbol,
const char *func, int32_t line);
#define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__)
#else
#define set_local(p) full_type(T_Sym(p)) = ((full_type(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC))
#endif
#define T_HIGH_C T_LOCAL
#define has_high_c(p) has_type_bit(T_Pair(p), T_HIGH_C)
#define set_has_high_c(p) set_type_bit(T_Pair(p), T_HIGH_C)
#define T_TC T_LOCAL
#define has_tc(p) has_type_bit(T_Pair(p), T_TC)
#define set_has_tc(p) set_type_bit(T_Pair(p), T_TC)
#define T_UNSAFE_DO T_GLOBAL
#define is_unsafe_do(p) has_type_bit(T_Pair(p), T_UNSAFE_DO)
#define set_unsafe_do(p) set_type_bit(T_Pair(p), T_UNSAFE_DO)
/* marks do-loops that resist optimization */
#define T_DOX_SLOT1 T_GLOBAL
#define has_dox_slot1(p) has_type_bit(T_Let(p), T_DOX_SLOT1)
#define set_has_dox_slot1(p) set_type_bit(T_Let(p), T_DOX_SLOT1)
/* marks a let that includes the dox_slot1 */
#define T_COLLECTED (1 << (TYPE_BITS + 9))
#define is_collected(p) has_type_bit(T_Seq(p), T_COLLECTED)
#define is_collected_unchecked(p) has_type_bit(p, T_COLLECTED)
#define set_collected(p) set_type_bit(T_Seq(p), T_COLLECTED)
/* #define clear_collected(p) clear_type_bit(T_Seq(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_LOCATION (1 << (TYPE_BITS + 10))
#define has_location(p) has_type_bit(T_Pair(p), T_LOCATION)
#define set_has_location(p) set_type_bit(T_Pair(p), T_LOCATION)
/* pair in question has line/file/position info added during read, or the environment has function placement info
* this bit should not be in the first byte -- SYNTACTIC_PAIR ignores it.
*/
#define T_LOADER_PORT T_LOCATION
#define is_loader_port(p) has_type_bit(T_Prt(p), T_LOADER_PORT)
#define set_loader_port(p) set_type_bit(T_Prt(p), T_LOADER_PORT)
#define clear_loader_port(p) clear_type_bit(T_Prt(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_SETTER T_LOCATION
#define symbol_has_setter(p) has_type_bit(T_Sym(p), T_HAS_SETTER)
#define symbol_set_has_setter(p) set_type_bit(T_Sym(p), T_HAS_SETTER)
#define slot_has_setter(p) has_type_bit(T_Slt(p), T_HAS_SETTER)
#define slot_set_has_setter(p) set_type_bit(T_Slt(p), T_HAS_SETTER)
/* marks a slot that has a setter or symbol that might have a setter */
#define T_WITH_LET_LET T_LOCATION
#define is_with_let_let(p) has_type_bit(T_Let(p), T_WITH_LET_LET)
#define set_with_let_let(p) set_type_bit(T_Let(p), T_WITH_LET_LET)
/* marks a let that is the argument to with-let */
#define T_SIMPLE_DEFAULTS T_LOCATION
#define c_func_has_simple_defaults(p) has_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS)
#define c_func_set_simple_defaults(p) set_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS)
#define c_func_clear_simple_defaults(p) clear_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS)
/* flag c_func_star arg defaults that need GC protection */
#define T_NO_SETTER T_LOCATION
#define closure_no_setter(p) has_type_bit(T_Clo(p), T_NO_SETTER)
#define closure_set_no_setter(p) set_type_bit(T_Clo(p), T_NO_SETTER)
#define T_SHARED (1 << (TYPE_BITS + 11))
#define is_shared(p) has_type_bit(T_Seq(p), T_SHARED)
#define set_shared(p) set_type_bit(T_Seq(p), T_SHARED)
#define is_collected_or_shared(p) has_type_bit(p, T_COLLECTED | T_SHARED)
#define clear_collected_and_shared(p) clear_type_bit(p, T_COLLECTED | T_SHARED) /* this can clear free cells = calloc */
/* T_LOCAL is bit 12 */
#define T_SAFE_PROCEDURE (1 << (TYPE_BITS + 13))
#define is_safe_procedure(p) has_type_bit(T_App(p), T_SAFE_PROCEDURE) /* was T_Pos 19-Apr-21 */
#define is_safe_or_scope_safe_procedure(p) ((full_type(T_Fnc(p)) & (T_SCOPE_SAFE | 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 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) set_type_bit(T_Pair(p), T_CHECKED)
#define is_checked(p) has_type_bit(T_Pair(p), T_CHECKED)
#define clear_checked(p) clear_type_bit(T_Pair(p), T_CHECKED)
#define set_checked_slot(p) set_type_bit(T_Slt(p), T_CHECKED)
#define is_checked_slot(p) has_type_bit(T_Slt(p), T_CHECKED)
#define clear_checked_slot(p) clear_type_bit(T_Slt(p), T_CHECKED)
#define T_ALL_INTEGER T_CHECKED
#define is_all_integer(p) has_type_bit(T_Sym(p), T_ALL_INTEGER)
#define set_all_integer(p) set_type_bit(T_Sym(p), T_ALL_INTEGER)
#define T_UNSAFE (1 << (TYPE_BITS + 15))
#define set_unsafe(p) set_type_bit(T_Pair(p), T_UNSAFE)
#define set_unsafely_optimized(p) full_type(T_Pair(p)) = (full_type(p) | T_UNSAFE | T_OPTIMIZED)
#define is_unsafe(p) has_type_bit(T_Pair(p), T_UNSAFE)
#define clear_unsafe(p) clear_type_bit(T_Pair(p), T_UNSAFE)
#define is_safely_optimized(p) ((full_type(T_Pair(p)) & (T_OPTIMIZED | T_UNSAFE)) == T_OPTIMIZED) /* was T_Pos 30-Jan-21 */
/* 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) has_type_bit(T_Sym(p), T_CLEAN_SYMBOL)
#define set_clean_symbol(p) set_type_bit(T_Sym(p), T_CLEAN_SYMBOL)
/* set if we know the symbol name can be printed without quotes (slashification) */
#define T_HAS_STEPPER T_UNSAFE
#define has_stepper(p) has_type_bit(T_Slt(p), T_HAS_STEPPER)
#define set_has_stepper(p) set_type_bit(T_Slt(p), T_HAS_STEPPER)
#define T_DOX_SLOT2 T_UNSAFE
#define has_dox_slot2(p) has_type_bit(T_Let(p), T_DOX_SLOT2)
#define set_has_dox_slot2(p) set_type_bit(T_Let(p), T_DOX_SLOT2)
/* marks a let that includes the dox_slot2 */
#define T_IMMUTABLE (1 << (TYPE_BITS + 16))
#define is_immutable(p) has_type_bit(T_Pos(p), T_IMMUTABLE)
#define set_immutable(p) set_type_bit(T_Pos(p), T_IMMUTABLE)
#define set_immutable_let(p) set_type_bit(T_Lid(p), T_IMMUTABLE)
#define is_immutable_port(p) has_type_bit(T_Prt(p), T_IMMUTABLE)
#define is_immutable_symbol(p) has_type_bit(T_Sym(p), T_IMMUTABLE)
#define is_immutable_slot(p) has_type_bit(T_Slt(p), T_IMMUTABLE)
#define is_immutable_pair(p) has_type_bit(T_Pair(p), T_IMMUTABLE)
#define is_immutable_vector(p) has_type_bit(T_Vec(p), T_IMMUTABLE)
#define is_immutable_string(p) has_type_bit(T_Str(p), T_IMMUTABLE)
/* T_IMMUTABLE is compatible with T_MUTABLE -- the latter is an internal bit for locally mutable numbers */
#define T_SETTER (1 << (TYPE_BITS + 17))
#define set_is_setter(p) set_type_bit(T_Sym(p), T_SETTER)
#define is_setter(p) has_type_bit(T_Sym(p), T_SETTER)
/* 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) set_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS)
#define allows_other_keys(p) has_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS)
#define c_function_set_allow_other_keys(p) set_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS)
#define c_function_allows_other_keys(p) has_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS)
/* marks arglist (or c_function*) that allows keyword args other than those in the parameter list;
* we can't allow (define* (f :allow-other-keys)...) because there's only one nil, and besides, it does say "other".
*/
#define T_LET_REMOVED T_SETTER
#define let_set_removed(p) set_type_bit(T_Let(p), T_LET_REMOVED)
#define let_removed(p) has_type_bit(T_Let(p), T_LET_REMOVED)
/* mark lets that have been removed from the heap or checked for that possibility */
#define T_HAS_EXPRESSION T_SETTER
#define slot_set_has_expression(p) set_type_bit(T_Slt(p), T_HAS_EXPRESSION)
#define slot_has_expression(p) has_type_bit(T_Slt(p), T_HAS_EXPRESSION)
#define T_MUTABLE (1 << (TYPE_BITS + 18))
#define is_mutable_number(p) has_type_bit(T_Num(p), T_MUTABLE)
#define is_mutable_integer(p) has_type_bit(T_Int(p), T_MUTABLE)
#define clear_mutable_number(p) clear_type_bit(T_Num(p), T_MUTABLE)
#define clear_mutable_integer(p) clear_type_bit(T_Int(p), T_MUTABLE)
/* used for mutable numbers, can occur with T_IMMUTABLE (outside view vs inside) */
#define T_HAS_KEYWORD T_MUTABLE
#define has_keyword(p) has_type_bit(T_Sym(p), T_HAS_KEYWORD)
#define set_has_keyword(p) set_type_bit(T_Sym(p), T_HAS_KEYWORD)
#define T_MARK_SEQ T_MUTABLE
#define is_mark_seq(p) has_type_bit(T_Itr(p), T_MARK_SEQ)
#define set_mark_seq(p) set_type_bit(T_Itr(p), T_MARK_SEQ)
/* used in iterators for GC mark of sequence */
#define T_STEP_END T_MUTABLE
#define is_step_end(p) has_type_bit(T_Slt(p), T_STEP_END)
#define step_end_fits(Slot, Len) ((is_step_end(Slot)) && (denominator(slot_value(Slot)) <= Len))
#define set_step_end(p) set_type_bit(T_Slt(p), T_STEP_END)
/* marks a slot that holds a do-loop's step-or-end variable, numerator=current, denominator=end */
#define T_NO_CELL_OPT T_MUTABLE
#define set_no_cell_opt(p) set_type_bit(T_Pair(p), T_NO_CELL_OPT)
#define no_cell_opt(p) has_type_bit(T_Pair(p), T_NO_CELL_OPT)
#define T_NO_INT_OPT T_SETTER
#define set_no_int_opt(p) set_type_bit(T_Pair(p), T_NO_INT_OPT)
#define no_int_opt(p) has_type_bit(T_Pair(p), T_NO_INT_OPT)
#define T_NO_FLOAT_OPT T_UNSAFE
#define set_no_float_opt(p) set_type_bit(T_Pair(p), T_NO_FLOAT_OPT)
#define no_float_opt(p) has_type_bit(T_Pair(p), T_NO_FLOAT_OPT)
#define T_NO_BOOL_OPT T_SAFE_STEPPER
#define set_no_bool_opt(p) set_type_bit(T_Pair(p), T_NO_BOOL_OPT)
#define no_bool_opt(p) has_type_bit(T_Pair(p), T_NO_BOOL_OPT)
#define T_INTEGER_KEYS T_SETTER
#define set_has_integer_keys(p) set_type_bit(T_Pair(p), T_INTEGER_KEYS)
#define has_integer_keys(p) has_type_bit(T_Pair(p), T_INTEGER_KEYS)
#define T_SAFE_STEPPER (1 << (TYPE_BITS + 19))
#define is_safe_stepper(p) has_type_bit(T_Slt(p), T_SAFE_STEPPER)
#define set_safe_stepper(p) set_type_bit(T_Slt(p), T_SAFE_STEPPER)
#define clear_safe_stepper(p) clear_type_bit(T_Slt(p), T_SAFE_STEPPER)
#define is_safe_stepper_expr(p) has_type_bit(T_Pair(p), T_SAFE_STEPPER)
#define set_safe_stepper_expr(p) set_type_bit(T_Pair(p), T_SAFE_STEPPER)
#define T_NUMBER_NAME T_SAFE_STEPPER
#define has_number_name(p) has_type_bit(T_Num(p), T_NUMBER_NAME)
#define set_has_number_name(p) set_type_bit(T_Num(p), T_NUMBER_NAME)
/* marks numbers that have a saved version of their string representation; this only matters in teq.scm, maybe tread.scm */
#define T_MAYBE_SAFE T_SAFE_STEPPER
#define is_maybe_safe(p) has_type_bit(T_Fnc(p), T_MAYBE_SAFE)
#define set_maybe_safe(p) set_type_bit(T_Fnc(p), T_MAYBE_SAFE)
#define T_PAIR_MACRO T_SAFE_STEPPER
#define has_pair_macro(p) has_type_bit(T_Mac(p), T_PAIR_MACRO)
#define set_has_pair_macro(p) set_type_bit(T_Mac(p), T_PAIR_MACRO)
#define T_HAS_LET_SET_FALLBACK T_SAFE_STEPPER
#define T_HAS_LET_REF_FALLBACK T_MUTABLE
#define has_let_ref_fallback(p) ((full_type(T_Lid(p)) & (T_HAS_LET_REF_FALLBACK | T_HAS_METHODS)) == (T_HAS_LET_REF_FALLBACK | T_HAS_METHODS))
#define has_let_set_fallback(p) ((full_type(T_Lid(p)) & (T_HAS_LET_SET_FALLBACK | T_HAS_METHODS)) == (T_HAS_LET_SET_FALLBACK | T_HAS_METHODS))
#define set_has_let_ref_fallback(p) set_type_bit(T_Let(p), T_HAS_LET_REF_FALLBACK)
#define set_has_let_set_fallback(p) set_type_bit(T_Let(p), T_HAS_LET_SET_FALLBACK)
#define has_let_fallback(p) has_type_bit(T_Lid(p), (T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK))
#define set_all_methods(p, e) full_type(T_Let(p)) |= (full_type(e) & (T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK))
#define T_WEAK_HASH T_SAFE_STEPPER
#define set_weak_hash_table(p) set_type_bit(T_Hsh(p), T_WEAK_HASH)
#define is_weak_hash_table(p) has_type_bit(T_Hsh(p), T_WEAK_HASH)
#define T_ALL_FLOAT T_SAFE_STEPPER
#define is_all_float(p) has_type_bit(T_Sym(p), T_ALL_FLOAT)
#define set_all_float(p) set_type_bit(T_Sym(p), T_ALL_FLOAT)
#define set_all_integer_and_float(p) set_type_bit(T_Sym(p), (T_ALL_INTEGER | T_ALL_FLOAT))
#define T_COPY_ARGS (1 << (TYPE_BITS + 20))
#define needs_copied_args(p) has_type_bit(T_Pos(p), T_COPY_ARGS) /* set via explicit T_COPY_ARGS, on T_Pos see s7_apply_function */
#define set_needs_copied_args(p) set_type_bit(T_Pair(p), T_COPY_ARGS)
#define clear_needs_copied_args(p) clear_type_bit(T_Pair(p), T_COPY_ARGS)
/* 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) has_type_bit(T_Sym(p), T_GENSYM)
/* symbol is from gensym (GC-able etc) */
#define T_FUNCLET T_GENSYM
#define is_funclet(p) has_type_bit(T_Let(p), T_FUNCLET)
#define set_funclet(p) set_type_bit(T_Let(p), T_FUNCLET)
/* this marks a funclet */
#define T_HASH_CHOSEN T_GENSYM
#define hash_chosen(p) has_type_bit(T_Hsh(p), T_HASH_CHOSEN)
#define hash_set_chosen(p) set_type_bit(T_Hsh(p), T_HASH_CHOSEN)
#define hash_clear_chosen(p) clear_type_bit(T_Hsh(p), T_HASH_CHOSEN)
#define T_DOCUMENTED T_GENSYM
#define is_documented(p) has_type_bit(T_Str(p), T_DOCUMENTED)
#define set_documented(p) set_type_bit(T_Str(p), T_DOCUMENTED)
/* this marks a symbol that has documentation (bit is set on name cell) */
#define T_FX_TREED T_GENSYM
#define is_fx_treed(p) has_type_bit(T_Pair(p), T_FX_TREED)
#define set_fx_treed(p) set_type_bit(T_Pair(p), T_FX_TREED)
#define T_SUBVECTOR T_GENSYM
#define is_subvector(p) has_type_bit(T_Vec(p), T_SUBVECTOR)
#define T_HAS_PENDING_VALUE T_GENSYM
#define slot_set_has_pending_value(p) set_type_bit(T_Slt(p), T_HAS_PENDING_VALUE)
#define slot_has_pending_value(p) has_type_bit(T_Slt(p), T_HAS_PENDING_VALUE)
#define slot_clear_has_pending_value(p) clear_type_bit(T_Slt(p), T_HAS_PENDING_VALUE)
#define T_HAS_METHODS (1 << (TYPE_BITS + 22))
#define has_methods(p) has_type_bit(T_Pos(p), T_HAS_METHODS)
#define has_active_methods(sc, p) ((has_type_bit(T_Pos(p), T_HAS_METHODS)) && (sc->has_openlets)) /* g_char #<eof> */
#define set_has_methods(p) set_type_bit(T_Met(p), T_HAS_METHODS)
#define clear_has_methods(p) clear_type_bit(T_Met(p), T_HAS_METHODS)
/* this marks an environment or closure that is "open" for generic functions etc, don't reuse this bit */
#define T_ITER_OK (1LL << (TYPE_BITS + 23))
#define iter_ok(p) has_type_bit(T_Itr(p), T_ITER_OK) /* was T_Pos 15-Apr-21 */
#define clear_iter_ok(p) clear_type_bit(T_Itr(p), T_ITER_OK)
#define T_STEP_END_OK T_ITER_OK
#define step_end_ok(p) has_type_bit(T_Pair(p), T_STEP_END_OK)
#define set_step_end_ok(p) set_type_bit(T_Pair(p), T_STEP_END_OK)
#define T_IMPLICIT_SET_OK T_ITER_OK
#define implicit_set_ok(p) has_type_bit(T_Pair(p), T_IMPLICIT_SET_OK)
#define set_implicit_set_ok(p) set_type_bit(T_Pair(p), T_IMPLICIT_SET_OK)
#define T_IN_ROOTLET T_ITER_OK
#define in_rootlet(p) has_type_bit(T_Slt(p), T_IN_ROOTLET)
#define set_in_rootlet(p) set_type_bit(T_Slt(p), T_IN_ROOTLET)
#define T_BOOL_FUNCTION T_ITER_OK
#define is_bool_function(p) has_type_bit(T_Prc(p), T_BOOL_FUNCTION)
#define set_is_bool_function(p) set_type_bit(T_Fnc(p), T_BOOL_FUNCTION)
/* it's faster here to use the high_flag bits rather than typeflag bits */
#define BIT_ROOM 16
#define T_FULL_SYMCONS (1LL << (TYPE_BITS + BIT_ROOM + 24))
#define T_SYMCONS (1 << 0)
#define is_possibly_constant(p) has_type1_bit(T_Sym(p), T_SYMCONS)
#define set_possibly_constant(p) set_type1_bit(T_Sym(p), T_SYMCONS)
#define is_probably_constant(p) has_type_bit(T_Sym(p), (T_FULL_SYMCONS | T_IMMUTABLE))
#define T_HAS_LET_ARG T_SYMCONS
#define has_let_arg(p) has_type1_bit(T_Prc(p), T_HAS_LET_ARG)
#define set_has_let_arg(p) set_type1_bit(T_Prc(p), T_HAS_LET_ARG)
/* p is a setter procedure, "let arg" refers to the setter's optional third (let) argument */
#define T_HASH_VALUE_TYPE T_SYMCONS
#define has_hash_value_type(p) has_type1_bit(T_Hsh(p), T_HASH_VALUE_TYPE)
#define set_has_hash_value_type(p) set_type1_bit(T_Hsh(p), T_HASH_VALUE_TYPE)
#define T_INT_OPTABLE T_SYMCONS
#define is_int_optable(p) has_type1_bit(T_Pair(p), T_INT_OPTABLE)
#define set_is_int_optable(p) set_type1_bit(T_Pair(p), T_INT_OPTABLE)
/* symbol free here */
#define T_FULL_HAS_LET_FILE (1LL << (TYPE_BITS + BIT_ROOM + 25))
#define T_HAS_LET_FILE (1 << 1)
#define has_let_file(p) has_type1_bit(T_Let(p), T_HAS_LET_FILE)
#define set_has_let_file(p) set_type1_bit(T_Let(p), T_HAS_LET_FILE)
#define clear_has_let_file(p) clear_type1_bit(T_Let(p), T_HAS_LET_FILE)
#define T_TYPED_VECTOR T_HAS_LET_FILE
#define is_typed_vector(p) has_type1_bit(T_Vec(p), T_TYPED_VECTOR)
#define set_typed_vector(p) set_type1_bit(T_Vec(p), T_TYPED_VECTOR)
#define T_TYPED_HASH_TABLE T_HAS_LET_FILE
#define is_typed_hash_table(p) has_type1_bit(T_Hsh(p), T_TYPED_HASH_TABLE)
#define set_typed_hash_table(p) set_type1_bit(T_Hsh(p), T_TYPED_HASH_TABLE)
#define T_BOOL_SETTER T_HAS_LET_FILE
#define c_function_has_bool_setter(p) has_type1_bit(T_Fnc(p), T_BOOL_SETTER)
#define c_function_set_has_bool_setter(p) set_type1_bit(T_Fnc(p), T_BOOL_SETTER)
#define T_REST_SLOT T_HAS_LET_FILE
#define is_rest_slot(p) has_type1_bit(T_Slt(p), T_REST_SLOT)
#define set_is_rest_slot(p) set_type1_bit(T_Slt(p), T_REST_SLOT)
#define T_NO_DEFAULTS T_HAS_LET_FILE
#define T_FULL_NO_DEFAULTS T_FULL_HAS_LET_FILE
#define has_no_defaults(p) has_type1_bit(T_Pcs(p), T_NO_DEFAULTS)
#define set_has_no_defaults(p) set_type1_bit(T_Pcs(p), T_NO_DEFAULTS)
/* pair=closure* body, transferred to closure* */
#define T_FULL_DEFINER (1LL << (TYPE_BITS + BIT_ROOM + 26))
#define T_DEFINER (1 << 2)
#define is_definer(p) has_type1_bit(T_Sym(p), T_DEFINER)
#define set_is_definer(p) set_type1_bit(T_Sym(p), T_DEFINER)
#define is_func_definer(p) has_type1_bit(T_Fnc(p), T_DEFINER)
#define set_func_is_definer(p) do {set_type1_bit(T_Fnc(initial_value(p)), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0)
#define is_syntax_definer(p) has_type1_bit(T_Syn(p), T_DEFINER)
#define set_syntax_is_definer(p) do {set_type1_bit(T_Syn(initial_value(p)), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0)
/* this marks "definers" like define and define-macro */
#define T_MACLET T_DEFINER
#define is_maclet(p) has_type1_bit(T_Let(p), T_MACLET)
#define set_maclet(p) set_type1_bit(T_Let(p), T_MACLET)
/* this marks a maclet */
#define T_HAS_FX T_DEFINER
#define set_has_fx(p) set_type1_bit(T_Pair(p), T_HAS_FX)
#define has_fx(p) has_type1_bit(T_Pair(p), T_HAS_FX)
#define clear_has_fx(p) clear_type1_bit(T_Pair(p), T_HAS_FX)
#define T_SLOT_DEFAULTS T_DEFINER
#define slot_defaults(p) has_type1_bit(T_Slt(p), T_SLOT_DEFAULTS)
#define set_slot_defaults(p) set_type1_bit(T_Slt(p), T_SLOT_DEFAULTS)
#define T_WEAK_HASH_ITERATOR T_DEFINER
#define is_weak_hash_iterator(p) has_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR)
#define set_weak_hash_iterator(p) set_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR)
#define clear_weak_hash_iterator(p) clear_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR)
#define T_HASH_KEY_TYPE T_DEFINER
#define has_hash_key_type(p) has_type1_bit(T_Hsh(p), T_HASH_KEY_TYPE)
#define set_has_hash_key_type(p) set_type1_bit(T_Hsh(p), T_HASH_KEY_TYPE)
#define T_FULL_BINDER (1LL << (TYPE_BITS + BIT_ROOM + 27))
#define T_BINDER (1 << 3)
#define set_syntax_is_binder(p) do {set_type1_bit(T_Syn(initial_value(p)), T_BINDER); set_type1_bit(T_Sym(p), T_BINDER);} while (0)
#define is_definer_or_binder(p) has_type1_bit(T_Sym(p), T_DEFINER | T_BINDER)
/* this marks "binders" like let */
#define T_SEMISAFE T_BINDER
#define is_semisafe(p) has_type1_bit(T_Fnc(p), T_SEMISAFE)
#define set_is_semisafe(p) set_type1_bit(T_Fnc(p), T_SEMISAFE)
/* #define T_TREE_COLLECTED T_FULL_BINDER */
#define T_SHORT_TREE_COLLECTED T_BINDER
#define tree_is_collected(p) has_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED)
#define tree_set_collected(p) set_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED)
#define tree_clear_collected(p) clear_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED)
#define T_SIMPLE_VALUES T_BINDER
#define has_simple_values(p) has_type1_bit(T_Hsh(p), T_SIMPLE_VALUES)
#define set_has_simple_values(p) set_type1_bit(T_Hsh(p), T_SIMPLE_VALUES)
#define T_VERY_SAFE_CLOSURE (1LL << (TYPE_BITS + BIT_ROOM + 28))
#define T_SHORT_VERY_SAFE_CLOSURE (1 << 4)
#define is_very_safe_closure(p) has_type1_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE)
#define set_very_safe_closure(p) set_type1_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE)
#define closure_bits(p) (full_type(T_Pair(p)) & (T_SAFE_CLOSURE | T_VERY_SAFE_CLOSURE | T_FULL_NO_DEFAULTS))
#define is_very_safe_closure_body(p) has_type1_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE)
#define set_very_safe_closure_body(p) set_type1_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE)
#define T_BAFFLE_LET T_SHORT_VERY_SAFE_CLOSURE
#define is_baffle_let(p) has_type1_bit(T_Let(p), T_BAFFLE_LET)
#define set_baffle_let(p) set_type1_bit(T_Let(p), T_BAFFLE_LET)
#define T_CYCLIC (1LL << (TYPE_BITS + BIT_ROOM + 29))
#define T_SHORT_CYCLIC (1 << 5)
#define is_cyclic(p) has_type1_bit(T_Seq(p), T_SHORT_CYCLIC)
#define set_cyclic(p) set_type1_bit(T_Seq(p), T_SHORT_CYCLIC)
#define T_CYCLIC_SET (1LL << (TYPE_BITS + BIT_ROOM + 30))
#define T_SHORT_CYCLIC_SET (1 << 6)
#define is_cyclic_set(p) has_type1_bit(T_Seq(p), T_SHORT_CYCLIC_SET) /* was T_Pos 30-Jan-21 */
#define set_cyclic_set(p) set_type1_bit(T_Seq(p), T_SHORT_CYCLIC_SET)
#define clear_cyclic_bits(p) clear_type_bit(p, T_COLLECTED | T_SHARED | T_CYCLIC | T_CYCLIC_SET)
#define T_KEYWORD (1LL << (TYPE_BITS + BIT_ROOM + 31))
#define T_SHORT_KEYWORD (1 << 7)
#define is_keyword(p) has_type1_bit(T_Pos(p), T_SHORT_KEYWORD)
/* this bit distinguishes a symbol from a symbol that is also a keyword */
#define T_FULL_SIMPLE_ELEMENTS (1LL << (TYPE_BITS + BIT_ROOM + 32))
#define T_SIMPLE_ELEMENTS (1 << 8)
#define has_simple_elements(p) has_type1_bit(T_Nvc(p), T_SIMPLE_ELEMENTS)
#define set_has_simple_elements(p) set_type1_bit(T_Nvc(p), T_SIMPLE_ELEMENTS)
#define c_function_has_simple_elements(p) has_type1_bit(T_Fnc(p), T_SIMPLE_ELEMENTS)
#define c_function_set_has_simple_elements(p) set_type1_bit(T_Fnc(p), T_SIMPLE_ELEMENTS)
/* c_func case here refers to boolean? et al -- structure element type declaration that ensures a simple object */
#define T_SIMPLE_KEYS T_SIMPLE_ELEMENTS
#define has_simple_keys(p) has_type1_bit(T_Hsh(p), T_SIMPLE_KEYS)
#define set_has_simple_keys(p) set_type1_bit(T_Hsh(p), T_SIMPLE_KEYS)
#define T_SAFE_SETTER T_SIMPLE_ELEMENTS
#define is_safe_setter(p) has_type1_bit(T_Sym(p), T_SAFE_SETTER)
#define set_is_safe_setter(p) set_type1_bit(T_Sym(p), T_SAFE_SETTER)
#define T_FLOAT_OPTABLE T_SIMPLE_ELEMENTS
#define is_float_optable(p) has_type1_bit(T_Pair(p), T_FLOAT_OPTABLE)
#define set_is_float_optable(p) set_type1_bit(T_Pair(p), T_FLOAT_OPTABLE)
#define T_FULL_CASE_KEY (1LL << (TYPE_BITS + BIT_ROOM + 33))
#define T_CASE_KEY (1 << 9)
#define is_case_key(p) has_type1_bit(T_Pos(p), T_CASE_KEY)
#define set_case_key(p) set_type1_bit(T_Sym(p), T_CASE_KEY)
#define T_OPT1_FUNC_LISTED T_CASE_KEY
#define opt1_func_listed(p) has_type1_bit(T_Pair(p), T_OPT1_FUNC_LISTED)
#define set_opt1_func_listed(p) set_type1_bit(T_Pair(p), T_OPT1_FUNC_LISTED)
#define T_FULL_HAS_GX (1LL << (TYPE_BITS + BIT_ROOM + 34))
#define T_HAS_GX (1 << 10)
#define has_gx(p) has_type1_bit(T_Pair(p), T_HAS_GX)
#define set_has_gx(p) set_type1_bit(T_Pair(p), T_HAS_GX)
#define T_FULL_UNKNOPT (1LL << (TYPE_BITS + BIT_ROOM + 35))
#define T_UNKNOPT (1 << 11)
#define is_unknopt(p) has_type1_bit(T_Pair(p), T_UNKNOPT)
#define set_is_unknopt(p) set_type1_bit(T_Pair(p), T_UNKNOPT)
#define T_MAC_OK T_UNKNOPT
#define mac_is_ok(p) has_type1_bit(T_Pair(p), T_MAC_OK)
#define set_mac_is_ok(p) set_type1_bit(T_Pair(p), T_MAC_OK)
/* marks a macro (via (macro...)) that has been checked -- easier (and slower) than making 4 or 5 more ops, op_macro_unchecked and so on */
#define T_FULL_SAFETY_CHECKED (1LL << (TYPE_BITS + BIT_ROOM + 36))
#define T_SAFETY_CHECKED (1 << 12)
#define is_safety_checked(p) has_type1_bit(T_Pair(p), T_SAFETY_CHECKED)
#define set_safety_checked(p) set_type1_bit(T_Pair(p), T_SAFETY_CHECKED)
#define T_FULL_HAS_FN (1LL << (TYPE_BITS + BIT_ROOM + 37))
#define T_HAS_FN (1 << 13)
#define set_has_fn(p) set_type1_bit(T_Pair(p), T_HAS_FN)
#define has_fn(p) has_type1_bit(T_Pair(p), T_HAS_FN)
#define UNUSED_BITS 0
#define T_GC_MARK 0x8000000000000000
#define is_marked(p) has_type_bit(p, T_GC_MARK)
#define set_mark(p) set_type_bit(T_Pos(p), T_GC_MARK)
#define clear_mark(p) clear_type_bit(p, T_GC_MARK)
/* using the sign bit, bit 23 (or 55) == 31 (or 63) for this makes a big difference in the GC */
#define T_UNHEAP 0x4000000000000000
#define T_SHORT_UNHEAP (1 << 14)
#define in_heap(p) (((T_Pos(p))->tf.opts.high_flag & T_SHORT_UNHEAP) == 0)
#define unheap(sc, p) set_type1_bit(T_Pos(p), T_SHORT_UNHEAP)
#define is_eof(p) ((T_Pos(p)) == eof_object)
#define is_true(Sc, p) ((T_Pos(p)) != Sc->F)
#define is_false(Sc, p) ((T_Pos(p)) == Sc->F)
#ifdef _MSC_VER
static s7_pointer make_boolean(s7_scheme * sc, bool val)
{
if (val)
return (sc->T);
return (sc->F);
}
#else
#define make_boolean(sc, Val) ((Val) ? sc->T : sc->F)
#endif
#define is_pair(p) (type(p) == T_PAIR)
#define is_mutable_pair(p) ((full_type(T_Pos(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_PAIR)
#define is_null(p) ((T_Pos(p)) == sc->nil)
#define is_not_null(p) ((T_Pos(p)) != sc->nil)
#define is_list(p) ((is_pair(p)) || (type(p) == T_NIL))
#define is_quoted_pair(p) ((is_pair(p)) && (car(p) == sc->quote_symbol))
#define is_unquoted_pair(p) ((is_pair(p)) && (car(p) != sc->quote_symbol))
#define is_quoted_symbol(p) ((is_pair(p)) && (car(p) == sc->quote_symbol) && (is_symbol(cadr(p))))
/* pair line/file/position */
#define PAIR_LINE_BITS 24
#define PAIR_FILE_BITS 12
#define PAIR_POSITION_BITS 28
#define PAIR_LINE_OFFSET 0
#define PAIR_FILE_OFFSET PAIR_LINE_BITS
#define PAIR_POSITION_OFFSET (PAIR_LINE_BITS + PAIR_FILE_BITS)
#define PAIR_LINE_MASK ((1 << PAIR_LINE_BITS) - 1)
#define PAIR_FILE_MASK ((1 << PAIR_FILE_BITS) - 1)
#define PAIR_POSITION_MASK ((1 << PAIR_POSITION_BITS) - 1)
#define port_location(Pt) (((port_line_number(Pt) & PAIR_LINE_MASK) << PAIR_LINE_OFFSET) | \
((port_file_number(Pt) & PAIR_FILE_MASK) << PAIR_FILE_OFFSET) | \
((port_position(Pt) & PAIR_POSITION_MASK) << PAIR_POSITION_OFFSET))
#define location_to_line(Loc) ((Loc >> PAIR_LINE_OFFSET) & PAIR_LINE_MASK)
#define location_to_file(Loc) ((Loc >> PAIR_FILE_OFFSET) & PAIR_FILE_MASK)
#define location_to_position(Loc) ((Loc >> PAIR_POSITION_OFFSET) & PAIR_POSITION_MASK)
#define pair_line_number(p) location_to_line(pair_location(p))
#define pair_file_number(p) location_to_file(pair_location(p))
#define pair_position(p) location_to_position(pair_location(p))
#if (!S7_DEBUGGING)
#define pair_location(p) (p)->object.sym_cons.location
#define pair_set_location(p, X) (p)->object.sym_cons.location = X
#define pair_raw_hash(p) (p)->object.sym_cons.hash
#define pair_set_raw_hash(p, X) (p)->object.sym_cons.hash = X
#define pair_raw_len(p) (p)->object.sym_cons.location
#define pair_set_raw_len(p, X) (p)->object.sym_cons.location = X
#define pair_raw_name(p) (p)->object.sym_cons.fstr
#define pair_set_raw_name(p, X) (p)->object.sym_cons.fstr = X
/* opt1 == raw_hash, opt2 == raw_name, opt3 == line|ctr + len, but hash/name/len only apply to the symbol table so there's no collision */
#define opt1(p, r) ((p)->object.cons.opt1)
#define set_opt1(p, x, r) (p)->object.cons.opt1 = x
#define opt2(p, r) ((p)->object.cons.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; clear_type_bit(p, T_LOCATION);} while (0)
#else
/* the 3 opt fields hold most of the varigated optimizer info, so they are used in many conflicting ways.
* the bits and funcs here try to track each such use, and report any cross-talk or collisions.
* all of this machinery vanishes if debugging is turned off.
*/
#define OPT1_SET (1 << 0)
#define OPT2_SET (1 << 1)
#define OPT3_SET (1 << 2)
#define OPT1_FAST (1 << 3) /* fast list in member/assoc circular list check */
#define OPT1_CFUNC (1 << 4) /* c-function */
#define OPT1_CLAUSE (1 << 5) /* case clause */
#define OPT1_LAMBDA (1 << 6) /* lambda(*) */
#define OPT1_SYM (1 << 7) /* symbol */
#define OPT1_PAIR (1 << 8) /* pair */
#define OPT1_CON (1 << 9) /* constant from eval's point of view */ /* 10 was opt1_goto, unused */
#define OPT1_ANY (1 << 11) /* anything -- deliberate unchecked case */
#define OPT1_HASH (1 << 12)
#define OPT1_MASK (OPT1_FAST | OPT1_CFUNC | OPT1_CLAUSE | OPT1_LAMBDA | OPT1_SYM | OPT1_PAIR | OPT1_CON | OPT1_ANY | OPT1_HASH)
#define opt1_is_set(p) (((T_Pair(p))->debugger_bits & OPT1_SET) != 0)
#define set_opt1_is_set(p) (T_Pair(p))->debugger_bits |= OPT1_SET
#define opt1_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT1_MASK) == Role)
#define set_opt1_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT1_MASK))
#define opt1(p, Role) opt1_1(sc, T_Pair(p), Role, __func__, __LINE__)
#define set_opt1(p, x, Role) set_opt1_1(T_Pair(p), x, Role)
#define OPT2_KEY (1 << 13) /* case key */
#define OPT2_SLOW (1 << 14) /* slow list in member/assoc circular list check */
#define OPT2_SYM (1 << 15) /* symbol */
#define OPT2_PAIR (1 << 16) /* pair */
#define OPT2_CON (1 << 17) /* constant as above */
#define OPT2_FX (1 << 18) /* fx (fx_*) func (sc, form) */
#define OPT2_FN (1 << 19) /* fn (s7_function) func (sc, arglist) */
#define OPT2_LAMBDA (1 << 20) /* lambda form */
#define OPT2_NAME (1 << 21)
#define OPT2_DIRECT (1LL << 32)
#define OPT2_INT (1LL << 33)
#define OPT2_MASK (OPT2_KEY | OPT2_SLOW | OPT2_SYM | OPT2_PAIR | OPT2_CON | OPT2_FX | OPT2_FN | OPT2_LAMBDA | OPT2_DIRECT | OPT2_NAME | OPT2_INT)
#define opt2_is_set(p) (((T_Pair(p))->debugger_bits & OPT2_SET) != 0)
#define set_opt2_is_set(p) (T_Pair(p))->debugger_bits |= OPT2_SET
#define opt2_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT2_MASK) == Role)
#define set_opt2_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT2_MASK))
#define opt2(p, Role) opt2_1(sc, T_Pair(p), Role, __func__, __LINE__)
#define set_opt2(p, x, Role) set_opt2_1(sc, T_Pair(p), (s7_pointer)(x), Role, __func__, __LINE__)
#define OPT3_ARGLEN (1 << 22) /* arglist length */
#define OPT3_SYM (1 << 23) /* expression symbol access */
#define OPT3_AND (1 << 24) /* and second clause */
#define OPT3_DIRECT (1 << 25) /* direct call info */
#define OPT3_ANY (1 << 26)
#define OPT3_LET (1 << 27) /* let or #f */
#define OPT3_CON (1 << 28)
#define OPT3_LOCATION (1 << 29)
#define OPT3_LEN (1 << 30)
#define OPT3_BYTE (1LL << 31)
#define OPT3_INT (1LL << 34)
#define OPT3_MASK (OPT3_ARGLEN | OPT3_SYM | OPT3_AND | OPT3_ANY | OPT3_LET | OPT3_BYTE | OPT3_LOCATION | OPT3_LEN | OPT3_DIRECT | OPT3_CON | OPT3_INT)
#define opt3_is_set(p) (((T_Pair(p))->debugger_bits & OPT3_SET) != 0)
#define set_opt3_is_set(p) (T_Pair(p))->debugger_bits |= OPT3_SET
#define opt3_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT3_MASK) == Role)
#define set_opt3_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT3_MASK))
#define opt3(p, Role) opt3_1(sc, T_Pair(p), Role, __func__, __LINE__)
#define set_opt3(p, x, Role) set_opt3_1(T_Pair(p), x, Role)
#define pair_location(p) opt3_location_1(sc, T_Pair(p), __func__, __LINE__)
#define pair_set_location(p, X) set_opt3_location_1(T_Pair(p), X)
#define pair_raw_hash(p) opt1_hash_1(sc, T_Pair(p), __func__, __LINE__)
#define pair_set_raw_hash(p, X) set_opt1_hash_1(T_Pair(p), X)
#define pair_raw_len(p) opt3_len_1(sc, T_Pair(p), __func__, __LINE__)
#define pair_set_raw_len(p, X) set_opt3_len_1(T_Pair(p), X)
#define pair_raw_name(p) opt2_name_1(sc, T_Pair(p), __func__, __LINE__)
#define pair_set_raw_name(p, X) set_opt2_name_1(T_Pair(p), X)
#define L_HIT (1LL << 40) /* "L_SET" is taken */
#define L_FUNC (1LL << 41)
#define L_DOX (1LL << 42)
#define L_CATCH (1LL << 43)
#define L_MASK (L_FUNC | L_DOX | L_CATCH)
#endif
#define opt1_fast(P) T_Lst(opt1(P, OPT1_FAST))
#define set_opt1_fast(P, X) set_opt1(P, T_Pair(X), OPT1_FAST)
#define opt1_cfunc(P) T_Pos(opt1(P, OPT1_CFUNC))
#define set_opt1_cfunc(P, X) set_opt1(P, T_Fnc(X), OPT1_CFUNC)
#define opt1_lambda_unchecked(P) opt1(P, OPT1_LAMBDA) /* can be free/null? from s7_call? */
#define opt1_lambda(P) T_Clo(opt1(P, OPT1_LAMBDA))
#define set_opt1_lambda(P, X) set_opt1(P, T_Clo(X), OPT1_LAMBDA)
#define set_opt1_lambda_add(P, X) do {set_opt1(P, T_Clo(X), OPT1_LAMBDA); add_opt1_func(sc, P);} while (0)
#define opt1_clause(P) T_Pos(opt1(P, OPT1_CLAUSE))
#define set_opt1_clause(P, X) set_opt1(P, T_Pos(X), OPT1_CLAUSE)
#define opt1_sym(P) T_Sym(opt1(P, OPT1_SYM))
#define set_opt1_sym(P, X) set_opt1(P, T_Sym(X), OPT1_SYM)
#define opt1_pair(P) T_Lst(opt1(P, OPT1_PAIR))
#define set_opt1_pair(P, X) set_opt1(P, T_Lst(X), OPT1_PAIR)
#define opt1_con(P) T_Pos(opt1(P, OPT1_CON))
#define set_opt1_con(P, X) set_opt1(P, T_Pos(X), OPT1_CON)
#define opt1_any(P) opt1(P, OPT1_ANY) /* can be free in closure_is_ok */
#define set_opt1_any(P, X) set_opt1(P, X, OPT1_ANY)
#define opt2_any(P) opt2(P, OPT2_KEY)
#define set_opt2_any(P, X) set_opt2(P, X, OPT2_KEY)
#define opt2_int(P) T_Int(opt2(P, OPT2_INT))
#define set_opt2_int(P, X) set_opt2(P, T_Int(X), OPT2_INT)
#define opt2_slow(P) T_Lst(opt2(P, OPT2_SLOW))
#define set_opt2_slow(P, X) set_opt2(P, T_Pair(X), OPT2_SLOW)
#define opt2_sym(P) T_Sym(opt2(P, OPT2_SYM))
#define set_opt2_sym(P, X) set_opt2(P, T_Sym(X), OPT2_SYM)
#define opt2_pair(P) T_Lst(opt2(P, OPT2_PAIR))
#define set_opt2_pair(P, X) set_opt2(P, T_Lst(X), OPT2_PAIR)
#define opt2_con(P) T_Pos(opt2(P, OPT2_CON))
#define set_opt2_con(P, X) set_opt2(P, T_Pos(X), OPT2_CON)
#define opt2_lambda(P) T_Pair(opt2(P, OPT2_LAMBDA))
#define set_opt2_lambda(P, X) set_opt2(P, T_Pair(X), OPT2_LAMBDA)
#define opt2_direct(P) opt2(P, OPT2_DIRECT)
#define set_opt2_direct(P, X) set_opt2(P, (s7_pointer)(X), OPT2_DIRECT)
#define opt3_arglen(P) T_Int(opt3(P, OPT3_ARGLEN))
#define set_opt3_arglen(P, X) set_opt3(P, T_Int(X), OPT3_ARGLEN)
#define opt3_int(P) T_Int(opt3(P, OPT3_INT))
#define set_opt3_int(P, X) set_opt3(P, T_Int(X), OPT3_INT)
#define opt3_sym(P) T_Sym(opt3(P, OPT3_SYM))
#define set_opt3_sym(P, X) set_opt3(P, T_Sym(X), OPT3_SYM)
#define opt3_con(P) T_Pos(opt3(P, OPT3_CON))
#define set_opt3_con(P, X) set_opt3(P, T_Pos(X), OPT3_CON)
#define opt3_pair(P) T_Pair(opt3(P, OPT3_AND))
#define set_opt3_pair(P, X) set_opt3(P, T_Pair(X), OPT3_AND)
#define opt3_any(P) opt3(P, OPT3_ANY)
#define set_opt3_any(P, X) set_opt3(P, X, OPT3_ANY)
#define opt3_let(P) T_Lid(opt3(P, OPT3_LET))
#define set_opt3_let(P, X) set_opt3(P, T_Lid(X), OPT3_LET)
#define opt3_direct(P) opt3(P, OPT3_DIRECT)
#define set_opt3_direct(P, X) set_opt3(P, (s7_pointer)(X), OPT3_DIRECT)
#if S7_DEBUGGING
#define opt3_byte(p) opt3_byte_1(sc, T_Pair(p), OPT3_BYTE, __func__, __LINE__)
#define set_opt3_byte(p, x) set_opt3_byte_1(T_Pair(p), x, OPT3_BYTE, __func__, __LINE__)
#else
#define opt3_byte(P) T_Pair(P)->object.cons_ext.opt_type /* op_if_is_type, opt_type == opt3 in cons_ext */
#define set_opt3_byte(P, X) do {T_Pair(P)->object.cons_ext.opt_type = X; clear_type_bit(P, T_LOCATION);} while (0)
#endif
#define pair_macro(P) opt2_sym(P)
#define set_pair_macro(P, Name) set_opt2_sym(P, Name)
#define fn_proc(f) ((s7_function)(opt2(f, OPT2_FN)))
#define fx_proc(f) ((s7_function)(opt2(f, OPT2_FX)))
#define fn_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.opt2))
#define fx_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.opt2)) /* unused */
#define set_fx(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FX); if (X) set_has_fx(f); else clear_has_fx(f);} while (0)
#define set_fx_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FX); set_has_fx(f);} while (0)
#define set_fn(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FN); if (X) set_has_fn(f); else clear_has_fx(f);} while (0)
#define set_fn_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FN); set_has_fn(f);} while (0)
#if WITH_GCC
#define fx_call(Sc, F) ({s7_pointer _P_; _P_ = F; fx_proc(_P_)(Sc, car(_P_));})
#define fc_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));})
#define fn_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));})
#else
#define fx_call(Sc, F) fx_proc(F)(Sc, car(F))
#define fc_call(Sc, F) fn_proc(F)(Sc, cdr(F))
#define fn_call(Sc, F) fn_proc(F)(Sc, cdr(F))
#endif
/* fx_call can affect the stack and sc->value */
#define car(p) (T_Pair(p))->object.cons.car
#define set_car(p, Val) car(p) = T_Pos(Val)
#define cdr(p) (T_Pair(p))->object.cons.cdr
#define set_cdr(p, Val) cdr(p) = T_Pos(Val)
#define unchecked_car(p) (T_Pos(p))->object.cons.car
#define unchecked_cdr(p) (T_Pos(p))->object.cons.cdr
#define caar(p) car(car(p))
#define cadr(p) car(cdr(p))
#define set_cadr(p, Val) car(cdr(p)) = T_Pos(Val)
#define cdar(p) cdr(car(p))
#define set_cdar(p, Val) cdr(car(p)) = T_Pos(Val)
#define cddr(p) cdr(cdr(p))
#define caaar(p) car(car(car(p)))
#define cadar(p) car(cdr(car(p)))
#define cdadr(p) cdr(car(cdr(p)))
#define caddr(p) car(cdr(cdr(p)))
#define set_caddr(p, Val) car(cdr(cdr(p))) = T_Pos(Val)
#define caadr(p) car(car(cdr(p)))
#define cdaar(p) cdr(car(car(p)))
#define cdddr(p) cdr(cdr(cdr(p)))
#define set_cdddr(p, Val) cdr(cdr(cdr(p))) = T_Pos(Val)
#define cddar(p) cdr(cdr(car(p)))
#define caaadr(p) car(car(car(cdr(p))))
#define caadar(p) car(car(cdr(car(p))))
#define cadaar(p) car(cdr(car(car(p))))
#define cadddr(p) car(cdr(cdr(cdr(p))))
#define caaddr(p) car(car(cdr(cdr(p))))
#define cddddr(p) cdr(cdr(cdr(cdr(p))))
#define caddar(p) car(cdr(cdr(car(p))))
#define cdadar(p) cdr(car(cdr(car(p))))
#define cdaddr(p) cdr(car(cdr(cdr(p))))
#define caaaar(p) car(car(car(car(p))))
#define cadadr(p) car(cdr(car(cdr(p))))
#define cdaadr(p) cdr(car(car(cdr(p))))
#define cdaaar(p) cdr(car(car(car(p))))
#define cdddar(p) cdr(cdr(cdr(car(p))))
#define cddadr(p) cdr(cdr(car(cdr(p))))
#define cddaar(p) cdr(cdr(car(car(p))))
#define cadaddr(p) cadr(caddr(p))
#define caddadr(p) caddr(cadr(p))
#define caddaddr(p) caddr(caddr(p))
#if WITH_GCC
/* slightly tricky because cons can be called recursively */
#define cons(Sc, A, B) ({s7_pointer _X_, _A_, _B_; _A_ = A; _B_ = B; new_cell(Sc, _X_, T_PAIR | T_SAFE_PROCEDURE); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;})
#else
#define cons(Sc, A, B) s7_cons(Sc, A, B)
#endif
#define list_1(Sc, A) cons(Sc, A, Sc->nil)
#define list_1_unchecked(Sc, A) cons_unchecked(Sc, A, Sc->nil)
#define list_2(Sc, A, B) cons_unchecked(Sc, A, cons(Sc, B, Sc->nil))
#define list_2_unchecked(Sc, A, B) cons_unchecked(Sc, A, cons_unchecked(Sc, B, Sc->nil))
#define list_3(Sc, A, B, C) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons(Sc, C, Sc->nil)))
#define list_4(Sc, A, B, C, D) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons_unchecked(Sc, C, cons(Sc, D, Sc->nil))))
#define is_string(p) (type(p) == T_STRING)
#define is_mutable_string(p) ((full_type(T_Pos(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_STRING)
#define string_value(p) (T_Str(p))->object.string.svalue
#define string_length(p) (T_Str(p))->object.string.length
#define string_hash(p) (T_Str(p))->object.string.hash
#define string_block(p) (T_Str(p))->object.string.block
#define unchecked_string_block(p) p->object.string.block
#define character(p) (T_Chr(p))->object.chr.c
#define is_character(p) (type(p) == T_CHARACTER)
#define upper_character(p) (T_Chr(p))->object.chr.up_c
#define is_char_alphabetic(p) (T_Chr(p))->object.chr.alpha_c
#define is_char_numeric(p) (T_Chr(p))->object.chr.digit_c
#define is_char_whitespace(p) (T_Chr(p))->object.chr.space_c
#define is_char_uppercase(p) (T_Chr(p))->object.chr.upper_c
#define is_char_lowercase(p) (T_Chr(p))->object.chr.lower_c
#define character_name(p) (T_Chr(p))->object.chr.c_name
#define character_name_length(p) (T_Chr(p))->object.chr.length
#define optimize_op(P) (T_Pos(P))->tf.opts.opt_choice
#define set_optimize_op(P, Op) (T_Pos(P))->tf.opts.opt_choice = Op
#define OP_HOP_MASK 0xfffe
#define optimize_op_match(P, Q) ((is_optimized(P)) && ((optimize_op(P) & OP_HOP_MASK) == (Q)))
#define op_no_hop(P) (optimize_op(P) & OP_HOP_MASK)
#define op_has_hop(P) ((optimize_op(P) & 1) != 0)
#define clear_optimize_op(P) set_optimize_op(P, OP_UNOPT)
#define set_safe_optimize_op(P, Q) do {set_optimized(P); set_optimize_op(P, Q);} while (0)
#define set_unsafe_optimize_op(P, Q) do {set_unsafely_optimized(P); set_optimize_op(P, Q);} while (0)
#define is_symbol(p) (type(p) == T_SYMBOL)
#define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p)))
#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(lookup_slot_from(p, sc->curlet))))
#define symbol_name_cell(p) T_Str((T_Sym(p))->object.sym.name)
#define symbol_set_name_cell(p, S) (T_Sym(p))->object.sym.name = T_Str(S)
#define symbol_name(p) string_value(symbol_name_cell(p))
#define symbol_name_length(p) string_length(symbol_name_cell(p))
#define gensym_block(p) symbol_name_cell(p)->object.string.gensym_block
#define pointer_map(p) (s7_int)((intptr_t)(p) >> 8)
#define symbol_id(p) (T_Sym(p))->object.sym.id
#define symbol_set_id_unchecked(p, X) (T_Sym(p))->object.sym.id = X
#if S7_DEBUGGING
static void symbol_set_id(s7_pointer p, s7_int id)
{
if (id < symbol_id(p)) {
fprintf(stderr, "id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n",
symbol_name(p), symbol_id(p), id);
abort();
}
(T_Sym(p))->object.sym.id = id;
}
#else
#define symbol_set_id(p, X) (T_Sym(p))->object.sym.id = X
#endif
/* we need 64-bits here, since we don't want this thing to wrap around, and lets are created at a great rate
* callgrind says this is faster than an uint32_t!
*/
#define symbol_info(p) (symbol_name_cell(p))->object.string.block
#define symbol_type(p) (block_size(symbol_info(p)) & 0xff) /* boolean function bool type */
#define symbol_set_type(p, Type) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff) | (Type & 0xff))
#define symbol_clear_type(p) block_size(symbol_info(p)) = 0
#define symbol_s7_let(p) ((uint8_t)((block_size(symbol_info(p)) >> 8) & 0xff)) /* *s7* field id */
#define symbol_set_s7_let(p, Field) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff00) | ((Field & 0xff) << 8))
#define initial_slot(p) T_Sld(symbol_info(p)->ex.ex_ptr)
#define set_initial_slot(p, Val) symbol_info(p)->ex.ex_ptr = T_Sld(Val)
#define global_slot(p) T_Sld((T_Sym(p))->object.sym.global_slot)
#define set_global_slot(p, Val) (T_Sym(p))->object.sym.global_slot = T_Sld(Val)
#define local_slot(p) T_Sln((T_Sym(p))->object.sym.local_slot)
#define set_local_slot(p, Val) (T_Sym(p))->object.sym.local_slot = T_Slt(Val)
#define initial_value(p) slot_value(initial_slot(T_Sym(p)))
#define local_value(p) slot_value(local_slot(T_Sym(p)))
#define unchecked_local_value(p) local_slot(p)->object.slt.val
#define global_value(p) slot_value(global_slot(T_Sym(p)))
#define keyword_symbol(p) symbol_info(p)->nx.ksym /* keyword only, so does not collide with documentation */
#define keyword_set_symbol(p, Val) symbol_info(p)->nx.ksym = T_Sym(Val)
#define symbol_help(p) symbol_info(p)->nx.documentation
#define symbol_set_help(p, Doc) symbol_info(p)->nx.documentation = Doc
#define symbol_tag(p) (T_Sym(p))->object.sym.tag
#define symbol_set_tag(p, Val) (T_Sym(p))->object.sym.tag = Val
#define symbol_ctr(p) (T_Sym(p))->object.sym.ctr /* needs to be in the symbol object (not symbol_info) for speed */
#define symbol_clear_ctr(p) (T_Sym(p))->object.sym.ctr = 0
#define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++
#define symbol_tag2(p) symbol_info(p)->ln.tag
#define symbol_set_tag2(p, Val) symbol_info(p)->ln.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_position(p) symbol_info(p)->dx.pos /* this only needs 32 of the available 64 bits */
#define symbol_set_position(p, Pos) symbol_info(p)->dx.pos = Pos
#define PD_POSITION_UNSET -1
#define symbol_set_local_slot_unchecked(Symbol, Id, Slot) \
do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id); symbol_increment_ctr(Symbol);} while (0)
#define symbol_set_local_slot_unchecked_and_unincremented(Symbol, Id, Slot) \
do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id);} while (0)
#define symbol_set_local_slot(Symbol, Id, Slot) \
do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id); symbol_increment_ctr(Symbol);} while (0)
#define symbol_set_local_slot_unincremented(Symbol, Id, Slot) \
do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id);} while (0)
/* set slot before id in case Slot is an expression that tries to find the current Symbol slot (using its old Id obviously) */
#define is_slot(p) (type(p) == T_SLOT)
#define slot_symbol(p) T_Sym((T_Slt(p))->object.slt.sym)
#define slot_set_symbol(p, Sym) (T_Slt(p))->object.slt.sym = T_Sym(Sym)
#define slot_value(p) T_Nmv((T_Slt(p))->object.slt.val)
#define slot_set_value(p, Val) (T_Slt(p))->object.slt.val = T_Nmv(Val)
#define slot_set_symbol_and_value(Slot, Symbol, Value) do {slot_set_symbol(Slot, Symbol); slot_set_value(Slot, Value);} while (0)
#define slot_set_value_with_hook(Slot, Value) \
do {if (hook_has_functions(sc->rootlet_redefinition_hook)) slot_set_value_with_hook_1(sc, Slot, T_Nmv(Value)); else slot_set_value(Slot, T_Nmv(Value));} while (0)
#define next_slot(p) T_Sln((T_Slt(p))->object.slt.nxt)
#define slot_set_next(p, Val) (T_Slt(p))->object.slt.nxt = T_Sln(Val)
#define slot_set_pending_value(p, Val) do {(T_Slt(p))->object.slt.pending_value = T_Nmv(Val); slot_set_has_pending_value(p);} while (0)
#define slot_simply_set_pending_value(p, Val) (T_Slt(p))->object.slt.pending_value = T_Nmv(Val)
#if S7_DEBUGGING
static s7_pointer slot_pending_value(s7_pointer p)
{
if (slot_has_pending_value(p))
return (p->object.slt.pending_value);
fprintf(stderr, "slot: no pending value\n");
abort();
}
static s7_pointer slot_expression(s7_pointer p)
{
if (slot_has_expression(p))
return (p->object.slt.expr);
fprintf(stderr, "slot: no expression\n");
abort();
}
#else
#define slot_pending_value(p) (T_Slt(p))->object.slt.pending_value
#define slot_expression(p) (T_Slt(p))->object.slt.expr
#endif
#define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Pos(Val); slot_set_has_expression(p);} while (0)
#define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Pos(Val)
#define slot_setter(p) T_Prc(T_Slt(p)->object.slt.expr)
#define slot_set_setter_1(p, Val) (T_Slt(p))->object.slt.expr = T_Prc(Val)
#if S7_DEBUGGING
#define tis_slot(p) ((p) && (T_Slt(p)))
#else
#define tis_slot(p) (p) /* used for loop through let slots which end in nil, not for general slot recognition */
#endif
#define slot_end(sc) NULL
#define is_slot_end(p) (!(p))
#define is_syntax(p) (type(p) == T_SYNTAX)
#define syntax_symbol(p) T_Sym((T_Syn(p))->object.syn.symbol)
#define syntax_set_symbol(p, Sym) (T_Syn(p))->object.syn.symbol = T_Sym(Sym)
#define syntax_opcode(p) (T_Syn(p))->object.syn.op
#define syntax_min_args(p) (T_Syn(p))->object.syn.min_args
#define syntax_max_args(p) (T_Syn(p))->object.syn.max_args
#define syntax_documentation(p) (T_Syn(p))->object.syn.documentation
#define pair_set_syntax_op(p, X) do {set_optimize_op(p, X); set_syntactic_pair(p);} while (0)
#define symbol_syntax_op_checked(p) ((is_syntactic_pair(p)) ? optimize_op(p) : symbol_syntax_op(car(p)))
#define symbol_syntax_op(p) syntax_opcode(global_value(p))
#define INITIAL_ROOTLET_SIZE 512
#define let_id(p) (T_Lid(p))->object.envr.id
#define let_set_id(p, Id) (T_Lid(p))->object.envr.id = Id
#define is_let(p) (type(p) == T_LET)
#define is_let_unchecked(p) (unchecked_type(p) == T_LET)
#define let_slots(p) T_Sln((T_Let(p))->object.envr.slots)
#define let_outlet(p) T_Lid((T_Let(p))->object.envr.nxt)
#define let_set_outlet(p, ol) (T_Let(p))->object.envr.nxt = T_Lid(ol)
#if S7_DEBUGGING
#define let_set_slots(p, Slot) do {if ((!in_heap(p)) && (Slot) && (in_heap(Slot))) fprintf(stderr, "let+slot mismatch\n"); T_Let(p)->object.envr.slots = T_Sln(Slot);} while (0)
#define C_Let(p, role) check_let_ref(p, role, __func__, __LINE__)
#define S_Let(p, role) check_let_set(p, role, __func__, __LINE__)
#else
#define let_set_slots(p, Slot) (T_Let(p))->object.envr.slots = T_Sln(Slot)
#define C_Let(p, role) p
#define S_Let(p, role) p
#endif
#define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.envr.edat.efnc.function)
#define funclet_set_function(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.function = T_Sym(F)
#define set_curlet(Sc, P) Sc->curlet = T_Lid(P)
#define let_baffle_key(p) (T_Let(p))->object.envr.edat.bafl.key
#define set_let_baffle_key(p, K) (T_Let(p))->object.envr.edat.bafl.key = K
#define let_line(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.line
#define let_set_line(p, L) (S_Let(p, L_FUNC))->object.envr.edat.efnc.line = L
#define let_file(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.file
#define let_set_file(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.file = F
#define let_dox_slot1(p) T_Slt((C_Let(p, L_DOX))->object.envr.edat.dox.dox1)
#define let_set_dox_slot1(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox1 = T_Slt(S); set_has_dox_slot1(p);} while (0)
#define let_dox_slot2(p) T_Sld((C_Let(p, L_DOX))->object.envr.edat.dox.dox2)
#define let_set_dox_slot2(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox2 = T_Slt(S); set_has_dox_slot2(p);} while (0)
#define let_dox_slot2_unchecked(p) T_Sld(C_Let(p, L_DOX)->object.envr.edat.dox.dox2)
#define let_set_dox_slot2_unchecked(p, S) do {S_Let(p, L_DOX)->object.envr.edat.dox.dox2 = T_Sld(S); set_has_dox_slot2(p);} while (0)
#define let_dox1_value(p) slot_value(let_dox_slot1(p))
#define let_dox2_value(p) slot_value(let_dox_slot2(p))
#define unique_name(p) (p)->object.unq.name /* not T_Uniq(p) here -- see make_unique */
#define unique_name_length(p) (p)->object.unq.len
#define is_unspecified(p) (type(p) == T_UNSPECIFIED)
#define unique_car(p) (p)->object.unq.car
#define unique_cdr(p) (p)->object.unq.cdr
#define is_undefined(p) (type(p) == T_UNDEFINED)
#define undefined_name(p) (T_Undf(p))->object.undef.name
#define undefined_name_length(p) (T_Undf(p))->object.undef.len
#define undefined_set_name_length(p, L) (T_Undf(p))->object.undef.len = L
#define eof_name(p) (T_Eof(p))->object.eof.name
#define eof_name_length(p) (T_Eof(p))->object.eof.len
#define is_any_vector(p) t_vector_p[type(p)]
#define is_normal_vector(p) (type(p) == T_VECTOR)
#define vector_length(p) (p)->object.vector.length
#define unchecked_vector_elements(p) (p)->object.vector.elements.objects
#define unchecked_vector_element(p, i) ((p)->object.vector.elements.objects[i])
#define vector_element(p, i) ((T_Vec(p))->object.vector.elements.objects[i])
#define vector_elements(p) (T_Vec(p))->object.vector.elements.objects
#define vector_getter(p) (T_Vec(p))->object.vector.vget
#define vector_setter(p) (T_Vec(p))->object.vector.setv.vset
#define vector_block(p) (T_Vec(p))->object.vector.block
#define unchecked_vector_block(p) p->object.vector.block
#define typed_vector_typer(p) T_Prc((T_Vec(p))->object.vector.setv.fset)
#define typed_vector_set_typer(p, Fnc) (T_Vec(p))->object.vector.setv.fset = T_Prc(Fnc)
#define typed_vector_gc_mark(p) ((is_c_function(typed_vector_typer(p))) ? c_function_marker(typed_vector_typer(p)) : mark_typed_vector_1)
#define typed_vector_typer_call(sc, p, Args) \
((is_c_function(typed_vector_typer(p))) ? c_function_call(typed_vector_typer(p))(sc, Args) : s7_apply_function(sc, typed_vector_typer(p), Args))
#define is_int_vector(p) (type(p) == T_INT_VECTOR)
#define int_vector(p, i) ((T_Ivc(p))->object.vector.elements.ints[i])
#define int_vector_ints(p) (T_Ivc(p))->object.vector.elements.ints
#define is_float_vector(p) (type(p) == T_FLOAT_VECTOR)
#define float_vector(p, i) ((T_Fvc(p))->object.vector.elements.floats[i])
#define float_vector_floats(p) (T_Fvc(p))->object.vector.elements.floats
#define is_byte_vector(p) (type(p) == T_BYTE_VECTOR)
#define byte_vector_length(p) (T_BVc(p))->object.vector.length
#define byte_vector_bytes(p) (T_BVc(p))->object.vector.elements.bytes
#define byte_vector(p, i) ((T_BVc(p))->object.vector.elements.bytes[i])
#define is_string_or_byte_vector(p) ((type(p) == T_STRING) || (type(p) == T_BYTE_VECTOR))
#define vector_dimension_info(p) ((vdims_t *)(T_Vec(p))->object.vector.block->ex.ex_info)
#define vector_set_dimension_info(p, d) (T_Vec(p))->object.vector.block->ex.ex_info = (void *)d
#define vector_ndims(p) vdims_rank(vector_dimension_info(p))
#define vector_dimension(p, i) vdims_dims(vector_dimension_info(p))[i]
#define vector_dimensions(p) vdims_dims(vector_dimension_info(p))
#define vector_offset(p, i) vdims_offsets(vector_dimension_info(p))[i]
#define vector_offsets(p) vdims_offsets(vector_dimension_info(p))
#define vector_rank(p) ((vector_dimension_info(p)) ? vector_ndims(p) : 1)
#define vector_has_dimension_info(p) (vector_dimension_info(p))
#define subvector_vector(p) T_Vec(((vector_dimension_info(T_SVec(p))) ? vdims_original(vector_dimension_info(p)) : (p)->object.vector.block->nx.ksym))
#define subvector_set_vector(p, vect) (T_SVec(p))->object.vector.block->nx.ksym = T_Vec(vect)
#define rootlet_element(p, i) unchecked_vector_element(p, i)
#define rootlet_elements(p) unchecked_vector_elements(p)
#define rootlet_block(p) unchecked_vector_block(p)
#define stack_element(p, i) unchecked_vector_element(T_Stk(p), i)
#define stack_elements(p) unchecked_vector_elements(T_Stk(p))
#define stack_block(p) unchecked_vector_block(T_Stk(p))
#define current_stack_top(Sc) ((Sc)->stack_end - (Sc)->stack_start)
#define temp_stack_top(p) (T_Stk(p))->object.stk.top
/* #define stack_flags(p) (T_Stk(p))->object.stk.flags */
#define stack_clear_flags(p) (T_Stk(p))->object.stk.flags = 0
#define stack_has_pairs(p) (((T_Stk(p))->object.stk.flags & 1) != 0)
#define stack_set_has_pairs(p) (T_Stk(p))->object.stk.flags |= 1
#define stack_has_counters(p) (((T_Stk(p))->object.stk.flags & 2) != 0)
#define stack_set_has_counters(p) (T_Stk(p))->object.stk.flags |= 2
#define is_hash_table(p) (type(p) == T_HASH_TABLE)
#define is_mutable_hash_table(p) ((full_type(T_Pos(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_HASH_TABLE)
#define hash_table_mask(p) (T_Hsh(p))->object.hasher.mask
#define hash_table_block(p) (T_Hsh(p))->object.hasher.block
#define unchecked_hash_table_block(p) p->object.hasher.block
#define hash_table_set_block(p, b) (T_Hsh(p))->object.hasher.block = b
#define hash_table_element(p, i) (T_Hsh(p))->object.hasher.elements[i]
#define hash_table_elements(p) (T_Hsh(p))->object.hasher.elements /* block data (dx) */
#define hash_table_entries(p) hash_table_block(p)->nx.nx_int
#define hash_table_checker(p) (T_Hsh(p))->object.hasher.hash_func
#define hash_table_mapper(p) (T_Hsh(p))->object.hasher.loc
#define hash_table_checker_locked(p) (hash_table_mapper(p) != default_hash_map)
#define hash_table_procedures(p) T_Lst(hash_table_block(p)->ex.ex_ptr)
#define hash_table_set_procedures(p, Lst) hash_table_block(p)->ex.ex_ptr = T_Lst(Lst)
#define hash_table_procedures_checker(p) car(hash_table_procedures(p))
#define hash_table_procedures_mapper(p) cdr(hash_table_procedures(p))
#define hash_table_set_procedures_mapper(p, f) set_cdr(hash_table_procedures(p), f)
#define hash_table_key_typer(p) T_Prc(opt1_any(hash_table_procedures(p)))
#define hash_table_set_key_typer(p, Fnc) set_opt1_any(p, T_Prc(Fnc))
#define hash_table_value_typer(p) T_Prc(opt2_any(hash_table_procedures(p)))
#define hash_table_set_value_typer(p, Fnc) set_opt2_any(p, T_Prc(Fnc))
#define weak_hash_iters(p) hash_table_block(p)->ln.tag
#if S7_DEBUGGING
#define T_Itr_Pos(p) titr_pos(sc, T_Itr(p), __func__, __LINE__)
#define T_Itr_Len(p) titr_len(sc, T_Itr(p), __func__, __LINE__)
#define T_Itr_Hash(p) titr_hash(sc, T_Itr(p), __func__, __LINE__)
#define T_Itr_Let(p) titr_let(sc, T_Itr(p), __func__, __LINE__)
#define T_Itr_Pair(p) titr_pair(sc, T_Itr(p), __func__, __LINE__)
#else
#define T_Itr_Pos(p) p
#define T_Itr_Len(p) p
#define T_Itr_Hash(p) p
#define T_Itr_Let(p) p
#define T_Itr_Pair(p) p
#endif
#define is_iterator(p) (type(p) == T_ITERATOR)
#define iterator_sequence(p) (T_Itr(p))->object.iter.obj
#define iterator_position(p) (T_Itr_Pos(p))->object.iter.lc.loc
#define iterator_length(p) (T_Itr_Len(p))->object.iter.lw.len
#define iterator_next(p) (T_Itr(p))->object.iter.next
#define iterator_is_at_end(p) (!iter_ok(p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */
#define iterator_slow(p) T_Lst((T_Itr_Pair(p))->object.iter.lw.slow)
#define iterator_set_slow(p, Val) (T_Itr_Pair(p))->object.iter.lw.slow = T_Lst(Val)
#define iterator_hash_current(p) (T_Itr_Hash(p))->object.iter.lw.hcur
#define iterator_current(p) (T_Itr(p))->object.iter.cur
#define iterator_current_slot(p) T_Sln((T_Itr_Let(p))->object.iter.lc.lcur)
#define iterator_set_current_slot(p, Val) (T_Itr_Let(p))->object.iter.lc.lcur = T_Sln(Val)
#define iterator_let_cons(p) (T_Itr_Let(p))->object.iter.cur
#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) (T_Prt(p))->object.prt.port
#define is_string_port(p) (port_type(p) == STRING_PORT)
#define is_file_port(p) (port_type(p) == FILE_PORT)
#define is_function_port(p) (port_type(p) == FUNCTION_PORT)
#define port_filename_block(p) port_port(p)->filename_block
#define port_filename(p) port_port(p)->filename
#define port_filename_length(p) port_port(p)->filename_length
#define port_file(p) port_port(p)->file
#define port_data_block(p) port_port(p)->block
#define unchecked_port_data_block(p) p->object.prt.port->block
#define port_line_number(p) port_port(p)->line_number
#define port_file_number(p) port_port(p)->file_number
#define port_data(p) (T_Prt(p))->object.prt.data
#define port_data_size(p) (T_Prt(p))->object.prt.size
#define port_position(p) (T_Prt(p))->object.prt.point
#define port_block(p) (T_Prt(p))->object.prt.block
#define port_type(p) port_port(p)->ptype
#define port_is_closed(p) port_port(p)->is_closed
#define port_set_closed(p, Val) port_port(p)->is_closed = Val /* this can't be a type bit because sweep checks it after the type has been cleared */
#define port_needs_free(p) port_port(p)->needs_free
#define port_next(p) port_block(p)->nx.next
#define port_original_input_string(p) port_port(p)->orig_str
#define port_output_function(p) port_port(p)->output_function /* these two are for function ports */
#define port_output_scheme_function(p) port_port(p)->orig_str
#define port_input_function(p) port_port(p)->input_function
#define port_input_scheme_function(p) port_port(p)->orig_str
#define current_input_port(Sc) Sc->input_port
#define set_current_input_port(Sc, P) Sc->input_port = P
#define current_output_port(Sc) Sc->output_port
#define set_current_output_port(Sc, P) Sc->output_port = P
#define port_read_character(p) port_port(p)->pf->read_character
#define port_read_line(p) port_port(p)->pf->read_line
#define port_display(p) port_port(p)->pf->displayer
#define port_write_character(p) port_port(p)->pf->write_character
#define port_write_string(p) port_port(p)->pf->write_string
#define port_read_semicolon(p) port_port(p)->pf->read_semicolon
#define port_read_white_space(p) port_port(p)->pf->read_white_space
#define port_read_name(p) port_port(p)->pf->read_name
#define port_read_sharp(p) port_port(p)->pf->read_sharp
#define port_close(p) port_port(p)->pf->close_port
#define is_c_function(f) (type(f) >= T_C_FUNCTION)
#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) (T_Fnc(f))->object.fnc.c_proc
#define c_function_call(f) (T_Fnc(f))->object.fnc.ff
#define c_function_required_args(f) (T_Fnc(f))->object.fnc.required_args
#define c_function_optional_args(f) (T_Fnc(f))->object.fnc.optional_args
#define c_function_all_args(f) (T_Fnc(f))->object.fnc.all_args
#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_setter(f) T_Prc(c_function_data(f)->setter)
#define c_function_set_setter(f, Val) c_function_data(f)->setter = T_Prc(Val)
#define c_function_block(f) (f)->object.fnc.c_proc->block /* no type checking here */
#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) T_Fnc(c_function_data(f)->generic_ff)
#define c_function_set_base(f, Val) c_function_data(f)->generic_ff = T_Fnc(Val)
#define c_function_marker(f) c_function_data(f)->cam.marker /* the mark function for the vector (mark_vector_1 etc) */
#define c_function_set_marker(f, Val) c_function_data(f)->cam.marker = Val
#define c_function_symbol(f) c_function_data(f)->sam.c_sym
#define c_function_bool_setter(f) c_function_data(f)->dam.bool_setter
#define c_function_set_bool_setter(f, Val) c_function_data(f)->dam.bool_setter = Val
#define c_function_arg_defaults(f) c_function_data(T_Fst(f))->dam.arg_defaults
#define c_function_call_args(f) c_function_data(T_Fst(f))->cam.call_args
#define c_function_arg_names(f) c_function_data(T_Fst(f))->sam.arg_names
#define set_c_function(X, f) do {set_opt1_cfunc(X, f); set_fn_direct(X, c_function_call(f));} while (0)
#define c_function_opt_data(f) c_function_data(f)->opt_data
#define is_c_macro(p) (type(p) == T_C_MACRO)
#define c_macro_data(f) (T_CMac(f))->object.fnc.c_proc
#define c_macro_call(f) (T_CMac(f))->object.fnc.ff
#define c_macro_name(f) c_macro_data(f)->name
#define c_macro_name_length(f) c_macro_data(f)->name_length
#define c_macro_required_args(f) (T_CMac(f))->object.fnc.required_args
#define c_macro_all_args(f) (T_CMac(f))->object.fnc.all_args
#define c_macro_setter(f) T_Prc(c_macro_data(f)->setter)
#define c_macro_set_setter(f, Val) c_macro_data(f)->setter = T_Prc(Val)
#define is_random_state(p) (type(p) == T_RANDOM_STATE)
#define random_gmp_state(p) (p)->object.rng.state /* sweep sees free cell in big_random_state gc_list and needs to call gmprandclear on its value */
#define random_seed(p) (T_Ran(p))->object.rng.seed
#define random_carry(p) (T_Ran(p))->object.rng.carry
#define continuation_block(p) (T_Con(p))->object.cwcc.block
#define continuation_stack(p) T_Stk(T_Con(p)->object.cwcc.stack)
#define continuation_set_stack(p, Val) (T_Con(p))->object.cwcc.stack = T_Stk(Val)
#define continuation_stack_end(p) (T_Con(p))->object.cwcc.stack_end
#define continuation_stack_start(p) (T_Con(p))->object.cwcc.stack_start
#define continuation_stack_top(p) (continuation_stack_end(p) - continuation_stack_start(p))
#define continuation_op_stack(p) (T_Con(p))->object.cwcc.op_stack
#define continuation_stack_size(p) continuation_block(p)->nx.ix.i1
#define continuation_op_loc(p) continuation_block(p)->nx.ix.i2
#define continuation_op_size(p) continuation_block(p)->ln.tag
#define continuation_key(p) continuation_block(p)->ex.ckey
/* this can overflow int32_t -- baffle_key is s7_int, so ckey should be also */
#define continuation_name(p) continuation_block(p)->dx.d_ptr
#define call_exit_goto_loc(p) (T_Got(p))->object.rexit.goto_loc
#define call_exit_op_loc(p) (T_Got(p))->object.rexit.op_stack_loc
#define call_exit_active(p) (T_Got(p))->object.rexit.active
#define call_exit_name(p) (T_Got(p))->object.rexit.name
#define is_continuation(p) (type(p) == T_CONTINUATION)
#define is_goto(p) (type(p) == T_GOTO)
#define is_macro(p) (type(p) == T_MACRO)
#define is_macro_star(p) (type(p) == T_MACRO_STAR)
#define is_bacro_star(p) (type(p) == T_BACRO_STAR)
#define is_either_macro(p) ((is_macro(p)) || (is_macro_star(p)))
#define is_either_bacro(p) ((type(p) == T_BACRO) || (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) T_Arg((T_Clo(p))->object.func.args)
#define closure_set_args(p, Val) (T_Clo(p))->object.func.args = T_Arg(Val)
#define closure_body(p) (T_Pair((T_Clo(p))->object.func.body))
#define closure_set_body(p, Val) (T_Clo(p))->object.func.body = T_Pair(Val)
#define closure_let(p) T_Lid((T_Clo(p))->object.func.env)
#define closure_set_let(p, L) (T_Clo(p))->object.func.env = T_Lid(L)
#define closure_arity(p) (T_Clo(p))->object.func.arity
#define closure_set_arity(p, A) (T_Clo(p))->object.func.arity = A
#define closure_setter(p) (T_Prc((T_Clo(p))->object.func.setter))
#define closure_set_setter(p, Val) (T_Clo(p))->object.func.setter = T_Prc(Val)
#define closure_map_list(p) (T_Pair((T_Clo(p))->object.func.setter))
#define closure_set_map_list(p, Val) (T_Clo(p))->object.func.setter = T_Pair(Val)
#define closure_setter_or_map_list(p) (T_Clo(p)->object.func.setter)
/* closure_map_list refers to a cyclic list detector in map; since in this case map makes a new closure for its own use,
* closure_map_list doesn't collide with closure_setter.
*/
#define CLOSURE_ARITY_NOT_SET 0x40000000
#define MAX_ARITY 0x20000000
#define closure_arity_unknown(p) (closure_arity(p) == CLOSURE_ARITY_NOT_SET)
#define is_thunk(Sc, Fnc) ((type(Fnc) >= T_GOTO) && (s7_is_aritable(Sc, Fnc, 0)))
#define hook_has_functions(p) (is_pair(s7_hook_functions(sc, T_Clo(p))))
#define catch_tag(p) (T_Cat(p))->object.rcatch.tag
#define catch_goto_loc(p) (T_Cat(p))->object.rcatch.goto_loc
#define catch_op_loc(p) (T_Cat(p))->object.rcatch.op_stack_loc
#define catch_handler(p) T_Pos((T_Cat(p))->object.rcatch.handler)
#define catch_set_handler(p, val) (T_Cat(p))->object.rcatch.handler = T_Pos(val)
#define catch_all_goto_loc(p) (C_Let(p, L_CATCH))->object.envr.edat.ctall.goto_loc
#define catch_all_set_goto_loc(p, L) (S_Let(p, L_CATCH))->object.envr.edat.ctall.goto_loc = L
#define catch_all_op_loc(p) (C_Let(p, L_CATCH))->object.envr.edat.ctall.op_stack_loc
#define catch_all_set_op_loc(p, L) (S_Let(p, L_CATCH))->object.envr.edat.ctall.op_stack_loc = L
#define dynamic_wind_state(p) (T_Dyn(p))->object.winder.state
#define dynamic_wind_in(p) (T_Dyn(p))->object.winder.in
#define dynamic_wind_out(p) (T_Dyn(p))->object.winder.out
#define dynamic_wind_body(p) (T_Dyn(p))->object.winder.body
#define is_c_object(p) (type(p) == T_C_OBJECT)
#define c_object_value(p) (T_Obj(p))->object.c_obj.value
#define c_object_type(p) (T_Obj(p))->object.c_obj.type
#define c_object_let(p) T_Lid((T_Obj(p))->object.c_obj.e)
#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.e = T_Lid(L)
#define c_object_s7(p) (T_Obj(p))->object.c_obj.sc
#define c_object_info(Sc, p) Sc->c_object_types[c_object_type(T_Obj(p))]
#define c_object_free(Sc, p) c_object_info(Sc, p)->free
#define c_object_mark(Sc, p) c_object_info(Sc, p)->mark
#define c_object_gc_mark(Sc, p) c_object_info(Sc, p)->gc_mark
#define c_object_gc_free(Sc, p) c_object_info(Sc, p)->gc_free
#define c_object_ref(Sc, p) c_object_info(Sc, p)->ref
#define c_object_getf(Sc, p) c_object_info(Sc, p)->getter
#define c_object_set(Sc, p) c_object_info(Sc, p)->set
#define c_object_setf(Sc, p) c_object_info(Sc, p)->setter
#if (!DISABLE_DEPRECATED)
#define c_object_print(Sc, p) c_object_info(Sc, p)->print
#endif
#define c_object_len(Sc, p) c_object_info(Sc, p)->length
#define c_object_eql(Sc, p) c_object_info(Sc, p)->eql
#define c_object_equal(Sc, p) c_object_info(Sc, p)->equal
#define c_object_equivalent(Sc, p) c_object_info(Sc, p)->equivalent
#define c_object_fill(Sc, p) c_object_info(Sc, p)->fill
#define c_object_copy(Sc, p) c_object_info(Sc, p)->copy
#define c_object_reverse(Sc, p) c_object_info(Sc, p)->reverse
#define c_object_to_list(Sc, p) c_object_info(Sc, p)->to_list
#define c_object_to_string(Sc, p) c_object_info(Sc, p)->to_string
#define c_object_scheme_name(Sc, p) T_Str(c_object_info(Sc, p)->scheme_name)
#define c_pointer(p) (T_Ptr(p))->object.cptr.c_pointer
#define c_pointer_type(p) (T_Ptr(p))->object.cptr.c_type
#define c_pointer_info(p) (T_Ptr(p))->object.cptr.info
#define c_pointer_weak1(p) (T_Ptr(p))->object.cptr.weak1
#define c_pointer_weak2(p) (T_Ptr(p))->object.cptr.weak2
#define c_pointer_set_weak1(p, q) (T_Ptr(p))->object.cptr.weak1 = T_Pos(q)
#define c_pointer_set_weak2(p, q) (T_Ptr(p))->object.cptr.weak2 = T_Pos(q)
#define is_c_pointer(p) (type(p) == T_C_POINTER)
#define is_counter(p) (type(p) == T_COUNTER)
#define counter_result(p) (T_Ctr(p))->object.ctr.result
#define counter_set_result(p, Val) (T_Ctr(p))->object.ctr.result = T_Pos(Val)
#define counter_list(p) (T_Ctr(p))->object.ctr.list
#define counter_set_list(p, Val) (T_Ctr(p))->object.ctr.list = T_Pos(Val)
#define counter_capture(p) (T_Ctr(p))->object.ctr.cap
#define counter_set_capture(p, Val) (T_Ctr(p))->object.ctr.cap = Val
#define counter_let(p) T_Lid((T_Ctr(p))->object.ctr.env)
#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.env = T_Lid(L)
#define counter_slots(p) T_Sln(T_Ctr(p)->object.ctr.slots)
#define counter_set_slots(p, Val) (T_Ctr(p))->object.ctr.slots = T_Sln(Val)
#if __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) (T_Int(p))->object.number.integer_value
#define set_integer(p, x) integer(p) = x
#define real(p) (T_Rel(p))->object.number.real_value
#define set_real(p, x) real(p) = x
#define numerator(p) (T_Frc(p))->object.number.fraction_value.numerator
#define denominator(p) (T_Frc(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) (T_Cmp(p))->object.number.complex_value.rl
#define set_real_part(p, x) real_part(p) = x
#define imag_part(p) (T_Cmp(p))->object.number.complex_value.im
#define set_imag_part(p, x) imag_part(p) = x
#if HAVE_COMPLEX_NUMBERS
#define to_c_complex(p) CMPLX(real_part(p), imag_part(p))
#endif
#if WITH_GMP
#define big_integer(p) ((T_Bgi(p))->object.number.bgi->n)
#define big_integer_nxt(p) (p)->object.number.bgi->nxt
#define big_integer_bgi(p) (p)->object.number.bgi
#define big_ratio(p) ((T_Bgf(p))->object.number.bgr->q)
#define big_ratio_nxt(p) (p)->object.number.bgr->nxt
#define big_ratio_bgr(p) (p)->object.number.bgr
#define big_real(p) ((T_Bgr(p))->object.number.bgf->x)
#define big_real_nxt(p) (p)->object.number.bgf->nxt
#define big_real_bgf(p) (p)->object.number.bgf
#define big_complex(p) ((T_Bgz(p))->object.number.bgc->z)
#define big_complex_nxt(p) (p)->object.number.bgc->nxt
#define big_complex_bgc(p) (p)->object.number.bgc
#endif
#if S7_DEBUGGING
static void set_type_1(s7_pointer p, uint64_t f, const char *func,
int line)
{
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->explicit_free_line = 0;
p->uses++;
if (((f) & TYPE_MASK) == T_FREE)
fprintf(stderr, "%d: set free, %p type to %" PRIx64 "\n", __LINE__,
p, (int64_t) (f));
else if (((f) & TYPE_MASK) >= NUM_TYPES)
fprintf(stderr, "%d: set invalid type, %p type to %" PRIx64 "\n",
__LINE__, p, (int64_t) (f));
else {
if (((full_type(p) & T_IMMUTABLE) != 0)
&& ((full_type(p) != (uint64_t) (f)))) {
fprintf(stderr,
"%s[%d]: set immutable %p type %d to %" ld64 "\n",
__func__, __LINE__, p, unchecked_type(p),
(int64_t) (f));
abort();
}
if (((full_type(p) & T_UNHEAP) != 0) && (((f) & T_UNHEAP) == 0))
fprintf(stderr, "%s[%d]: clearing unheap in set type!\n",
__func__, __LINE__);
}
full_type(p) = f;
}
#endif
#define number_name(p) (char *)((T_Num(p))->object.number_name.name + 1)
#define number_name_length(p) (T_Num(p))->object.number_name.name[0]
static void set_number_name(s7_pointer p, const char *name, int32_t len)
{
/* if no number name: teq +110 tread +30 tform +90 */
if ((len >= 0) && (len < NUMBER_NAME_SIZE) && (!is_mutable_number(p))) {
set_has_number_name(p);
number_name_length(p) = (uint8_t) len;
memcpy((void *) number_name(p), (void *) name, len);
(number_name(p))[len] = 0;
}
}
static s7_int s7_int_min = 0;
static int32_t s7_int_digits_by_radix[17];
#define S7_INT_BITS 63
#define S7_INT64_MAX 9223372036854775807LL
#define S7_INT64_MIN (int64_t)(-S7_INT64_MAX - 1LL)
#define S7_INT32_MAX 2147483647LL
#define S7_INT32_MIN (-S7_INT32_MAX - 1LL)
static void init_int_limits(void)
{
int32_t i;
#if WITH_GMP
#define S7_LOG_INT64_MAX 36.736800
#else
/* actually not safe = (log (- (expt 2 63) 1)) and (log (- (expt 2 31) 1)) (using 63 and 31 bits) */
#define S7_LOG_INT64_MAX 43.668274
#endif
s7_int_min = S7_INT64_MIN; /* see comment in s7_make_ratio -- we're trying to hack around a gcc bug (9.2.1 Ubuntu) */
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] =
(int32_t) (floor(S7_LOG_INT64_MAX / log((double) i)));
}
static s7_pointer make_permanent_integer_unchecked(s7_int i)
{
s7_pointer p;
p = (s7_pointer) Calloc(1, sizeof(s7_cell));
set_type_bit(p, T_IMMUTABLE | T_INTEGER | T_UNHEAP);
integer(p) = i;
return (p);
}
#define NUM_CHARS 256
#ifndef NUM_SMALL_INTS
#define NUM_SMALL_INTS 8192
/* 65536: tshoot -6, tvect -50, dup -26, trclo -27, tmap -48, tsort -14, tlet -16, trec -58, thash -40 */
#else
#if (NUM_SMALL_INTS < NUM_CHARS) /* g_char_to_integer assumes this is at least NUM_CHARS */
#error num_small_ints is less than num_chars which will not work
#endif
#endif
static s7_pointer *small_ints = NULL;
#define small_int(Val) small_ints[Val]
#define is_small_int(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */
static s7_pointer real_zero, real_NaN, complex_NaN, real_pi, real_one,
arity_not_set, max_arity, real_infinity, real_minus_infinity;
static s7_pointer int_zero, int_one, int_two, int_three, minus_one,
minus_two, mostfix, leastfix;
static void init_small_ints(void)
{
const char *ones[10] =
{ "0", "1", "2", "3", "4", "5", "6", "7", "8", "9" };
s7_cell *cells;
int32_t i;
small_ints =
(s7_pointer *) malloc(NUM_SMALL_INTS * sizeof(s7_pointer));
cells = (s7_cell *) calloc((NUM_SMALL_INTS), sizeof(s7_cell));
for (i = 0; i < NUM_SMALL_INTS; i++) {
s7_pointer p;
small_ints[i] = &cells[i];
p = small_ints[i];
set_type_bit(p, T_IMMUTABLE | T_INTEGER | T_UNHEAP);
integer(p) = i;
}
for (i = 0; i < 10; i++)
set_number_name(small_ints[i], ones[i], 1);
/* setup a few other numbers while we're here */
#define EXTRA_NUMBERS 11
cells = (s7_cell *) calloc(EXTRA_NUMBERS, sizeof(s7_cell));
#define init_real(Ptr, Num, Name, Name_Len) do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0)
#define init_real_no_name(Ptr, Num) do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num);} while (0)
#define init_complex(Ptr, Real, Imag, Name, Name_Len) \
do {set_full_type(Ptr, T_COMPLEX | T_IMMUTABLE | T_UNHEAP); set_real_part(Ptr, Real); set_imag_part(Ptr, Imag); set_number_name(Ptr, Name, Name_Len);} while (0)
real_zero = &cells[0];
init_real(real_zero, 0.0, "0.0", 3);
real_one = &cells[1];
init_real(real_one, 1.0, "1.0", 3);
real_NaN = &cells[2];
init_real(real_NaN, NAN, "+nan.0", 6);
complex_NaN = &cells[10];
init_complex(complex_NaN, NAN, NAN, "+nan.0+nan.0i", 13);
real_infinity = &cells[3];
init_real(real_infinity, INFINITY, "+inf.0", 6);
real_minus_infinity = &cells[4];
init_real(real_minus_infinity, -INFINITY, "-inf.0", 6);
real_pi = &cells[5];
init_real_no_name(real_pi, 3.1415926535897932384626433832795029L);
#define init_integer(Ptr, Num, Name, Name_Len) do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0)
#define init_integer_no_name(Ptr, Num) do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num);} while (0)
arity_not_set = &cells[6];
init_integer_no_name(arity_not_set, CLOSURE_ARITY_NOT_SET);
max_arity = &cells[7];
init_integer_no_name(max_arity, MAX_ARITY);
minus_one = &cells[8];
init_integer(minus_one, -1, "-1", 2);
minus_two = &cells[9];
init_integer(minus_two, -2, "-2", 2);
int_zero = small_ints[0];
int_one = small_ints[1];
int_two = small_ints[2];
int_three = small_ints[3];
mostfix = make_permanent_integer_unchecked(S7_INT64_MAX);
leastfix = make_permanent_integer_unchecked(s7_int_min);
set_number_name(mostfix, "9223372036854775807", 19);
set_number_name(leastfix, "-9223372036854775808", 20);
}
/* -------------------------------------------------------------------------------- */
#if (defined(__FreeBSD__)) || ((defined(__linux__)) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ > 17)) || (defined(__OpenBSD__)) || (defined(__NetBSD__))
static inline s7_int my_clock(void)
{
struct timespec ts;
clock_gettime(CLOCK_MONOTONIC, &ts);
/* coarse: 0.057u 0.007s, monotonic: 0.083u 0.007s, clock(): 0.624u 0.372s -- coarse since Linux 2.6.32, glibc > 2.17
* FreeBSD has CLOCK_MONOTONIC_FAST in place of COARSE, OpenBSD and netBSD have neither
* clock_getres places 1 in tv_nsec in linux, so I assume I divide billion/tv_nsec
* MacOSX has clock_get_time, and after Sierra 10.12 has clock_gettime
* apparently we include /usr/include/AvailabilityMacros.h, then #if MAC_OS_X_VERSION_MIN_REQUIRED >= MAC_OS_X_VERSION_10_12
* Windows has QueryPerformanceCounter or something
* maybe just check for POSIX compatibility?
*/
return (ts.tv_sec * 1000000000 + ts.tv_nsec); /* accumulated into s7_int so this should be ok: s7.h gives it 64 bits */
}
static s7_int ticks_per_second(void)
{
struct timespec ts;
clock_getres(CLOCK_MONOTONIC, &ts);
return ((ts.tv_nsec == 0) ? 1000000000 : (1000000000 / ts.tv_nsec));
}
#else
#define my_clock clock
#define ticks_per_second() CLOCKS_PER_SEC
#endif
#ifndef GC_TRIGGER_SIZE
#define GC_TRIGGER_SIZE 64
#endif
#if S7_DEBUGGING
static void try_to_call_gc_1(s7_scheme * sc, const char *func, int line);
#define try_to_call_gc(Sc) try_to_call_gc_1(Sc, __func__, __LINE__)
#else
static void try_to_call_gc(s7_scheme * sc);
#endif
#define GC_STATS 1
#define HEAP_STATS 2
#define STACK_STATS 4
#define PROTECTED_OBJECTS_STATS 8
#define show_gc_stats(Sc) ((Sc->gc_stats & GC_STATS) != 0)
#define show_stack_stats(Sc) ((Sc->gc_stats & STACK_STATS) != 0)
#define show_heap_stats(Sc) ((Sc->gc_stats & HEAP_STATS) != 0)
#define show_protected_objects_stats(Sc) ((Sc->gc_stats & PROTECTED_OBJECTS_STATS) != 0)
/* new_cell has to include the new cell's type. In the free list, it is 0 (T_FREE). If we remove it here,
* but then hit some error before setting the type, the GC sweep thinks it is a free cell already and
* does not return it to the free list: a memory leak.
*/
#if (!S7_DEBUGGING)
#define new_cell(Sc, Obj, Type) \
do { \
if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \
Obj = (*(--(Sc->free_heap_top))); \
set_full_type(Obj, Type); \
} while (0)
#define new_cell_no_check(Sc, Obj, Type) do {Obj = (*(--(Sc->free_heap_top))); set_full_type(Obj, Type);} while (0)
/* since sc->free_heap_trigger is GC_TRIGGER_SIZE above the free heap base, we don't need
* to check it repeatedly after the first such check.
*/
#else
#define 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))); \
Obj->debugger_bits = 0; Obj->gc_func = NULL; \
set_full_type(Obj, Type); \
} while (0)
#define new_cell_no_check(Sc, Obj, Type) \
do { \
Obj = (*(--(Sc->free_heap_top))); \
if (Sc->free_heap_top < Sc->free_heap) {fprintf(stderr, "free heap exhausted\n"); abort();}\
Obj->debugger_bits = 0; Obj->gc_func = NULL; \
set_full_type(Obj, Type); \
} while (0)
#endif
/* #define gc_if_at_trigger(Sc) if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc) */
#if WITH_GCC
#define make_integer(Sc, N) ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); })
#define make_real(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;})
#define make_real_unchecked(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell_no_check(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;})
#define make_complex_not_0i(Sc, R, I) ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, I); _C_;})
#define make_complex(Sc, R, I) \
({ s7_double _im_; _im_ = (I); ((_im_ == 0.0) ? make_real(Sc, R) : \
({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}) ); })
#define 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_real_unchecked(Sc, X) s7_make_real(Sc, X)
#define make_complex(Sc, R, I) s7_make_complex(Sc, R, I)
#define make_complex_not_0i(Sc, R, I) s7_make_complex(Sc, R, I)
#define real_to_double(Sc, X, Caller) s7_number_to_real_with_caller(Sc, X, Caller)
#define rational_to_double(Sc, X) s7_number_to_real(Sc, X)
#endif
static inline s7_pointer wrap_integer1(s7_scheme * sc, s7_int x)
{
if (is_small_int(x))
return (small_int(x));
integer(sc->integer_wrapper1) = x;
return (sc->integer_wrapper1);
}
static inline s7_pointer wrap_integer2(s7_scheme * sc, s7_int x)
{
if (is_small_int(x))
return (small_int(x));
integer(sc->integer_wrapper2) = x;
return (sc->integer_wrapper2);
}
static inline s7_pointer wrap_integer3(s7_scheme * sc, s7_int x)
{
if (is_small_int(x))
return (small_int(x));
integer(sc->integer_wrapper3) = x;
return (sc->integer_wrapper3);
}
static inline s7_pointer wrap_real1(s7_scheme * sc, s7_double x)
{
real(sc->real_wrapper1) = x;
return (sc->real_wrapper1);
}
static inline s7_pointer wrap_real2(s7_scheme * sc, s7_double x)
{
real(sc->real_wrapper2) = x;
return (sc->real_wrapper2);
}
/* --------------------------------------------------------------------------------
* local versions of some standard C library functions
* timing tests involving these are very hard to interpret, local_memset is faster using int64_t than int32_t
*/
static void local_memset(void *s, uint8_t val, size_t n)
{
uint8_t *s2;
#if S7_ALIGNED
s2 = (uint8_t *) s;
#else
#if (defined(__x86_64__) || defined(__i386__))
if (n >= 8) {
int64_t ival;
int64_t *s1 = (int64_t *) s;
size_t n8 = n >> 3;
ival = val | (val << 8) | (val << 16) | (((uint64_t) val) << 24); /* uint64_t casts make gcc/clang/fsanitize happy */
ival = (((uint64_t) ival) << 32) | ival;
do {
*s1++ = ival;
} while (--n8 > 0);
n &= 7;
s2 = (uint8_t *) s1;
} else
s2 = (uint8_t *) s;
#else
s2 = (uint8_t *) s;
#endif
#endif
while (n > 0) {
*s2++ = val;
n--;
}
}
static inline s7_int safe_strlen(const char *str)
{
/* this is safer than strlen, and slightly faster */
const char *tmp = str;
if ((!tmp) || (!(*tmp)))
return (0);
for (; *tmp; ++tmp);
return (tmp - str);
}
static char *copy_string_with_length(const char *str, s7_int len)
{
char *newstr;
#if S7_DEBUGGING
if ((len <= 0) || (!str))
fprintf(stderr, "%s[%d]: len: %" ld64 ", str: %s\n", __func__,
__LINE__, len, str);
#endif
if (len > (1LL << 48))
return (NULL); /* squelch an idiotic warning */
newstr = (char *) Malloc(len + 1);
if (len != 0)
memcpy((void *) newstr, (void *) str, len);
newstr[len] = '\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 c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2))
/* scheme strings can have embedded nulls. */
static bool safe_strcmp(const char *s1, const char *s2)
{
if ((!s1) || (!s2))
return (s1 == s2);
return (local_strcmp(s1, s2));
}
static bool local_strncmp(const char *s1, const char *s2, size_t n)
{
#if ((!S7_ALIGNED) && (defined(__x86_64__) || defined(__i386__))) /* unaligned accesses are safe on i386 hardware, sez everyone */
if (n >= 8) {
size_t n8 = n >> 3;
int64_t *is1 = (int64_t *) s1, *is2 = (int64_t *) s2;
do {
if (*is1++ != *is2++)
return (false);
} while (--n8 > 0);
s1 = (const char *) is1;
s2 = (const char *) is2;
n &= 7;
}
#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 Sentinel size_t catstrs(char *dst, size_t len, ...)
{ /* NULL-terminated arg list */
const char *s, *dend;
char *d = dst;
va_list ap;
dend = (const char *) (dst + len - 1); /* -1 for null at end? */
while ((*d) && (d < dend))
d++; /* stop at NULL or end-of-buffer */
va_start(ap, len);
for (s = va_arg(ap, const char *); s != NULL;
s = va_arg(ap, const char *))
while ((*s) && (d < dend)) {
*d++ = *s++;
}
*d = '\0';
va_end(ap);
return (d - dst);
}
static Sentinel size_t catstrs_direct(char *dst, const char *s1, ...)
{ /* NULL-terminated arg list, dst is destination only (assumed empty), all args known to fit in dst */
const char *s;
char *d = dst;
va_list ap;
va_start(ap, s1);
for (s = s1; s != NULL; s = va_arg(ap, const char *))
while (*s) {
*d++ = *s++;
}
*d = '\0';
va_end(ap);
return (d - dst);
}
static char *pos_int_to_str(s7_scheme * sc, s7_int num, s7_int * len,
char endc)
{
char *p, *op;
p = (char *) (sc->int_to_str3 + 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 char *pos_int_to_str_direct(s7_scheme * sc, s7_int num)
{
char *p;
p = (char *) (sc->int_to_str4 + INT_TO_STR_SIZE - 1);
*p-- = '\0';
do {
*p-- = "0123456789"[num % 10];
num /= 10;
} while (num);
return ((char *) (p + 1));
}
static char *pos_int_to_str_direct_1(s7_scheme * sc, s7_int num)
{
char *p;
p = (char *) (sc->int_to_str5 + INT_TO_STR_SIZE - 1);
*p-- = '\0';
do {
*p-- = "0123456789"[num % 10];
num /= 10;
} while (num);
return ((char *) (p + 1));
}
#if S7_DEBUGGING && WITH_GCC
static s7_pointer lookup_1(s7_scheme * sc, s7_pointer symbol);
#define lookup(Sc, Sym) check_null_sym(Sc, lookup_1(Sc, Sym), Sym, __LINE__, __func__)
static s7_pointer check_null_sym(s7_scheme * sc, s7_pointer p,
s7_pointer sym, int32_t line,
const char *func);
#define lookup_unexamined(Sc, Sym) lookup_1(Sc, Sym)
#else
static inline s7_pointer lookup(s7_scheme * sc, s7_pointer symbol);
#define lookup_unexamined(Sc, Sym) lookup(Sc, Sym)
#endif
#if WITH_GCC
#if S7_DEBUGGING
#define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup_1(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
#else
#define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
#endif
#else
#define lookup_checked(Sc, Sym) lookup(Sc, Sym)
#endif
static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e);
static s7_pointer object_to_truncated_string(s7_scheme * sc, s7_pointer p,
s7_int len);
static s7_pointer wrap_string(s7_scheme * sc, const char *str, s7_int len);
static s7_pointer cons_unchecked(s7_scheme * sc, s7_pointer a,
s7_pointer b);
static s7_pointer unbound_variable(s7_scheme * sc, s7_pointer sym);
static s7_pointer find_method_with_let(s7_scheme * sc, s7_pointer let,
s7_pointer symbol);
static const char *type_name(s7_scheme * sc, s7_pointer arg,
article_t article);
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->unused 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->unused, Sc->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->unused, Sc->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->unused, 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->unused, 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)
/* ---------------- evaluator ops ---------------- */
/* C=constant, S=symbol, A=fx-callable, Q=quote, N=any number of next >= 1, FX=list of A's, P=parlous?, O=one form, M=multiform */
enum { OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_protect used below as boundary marker */
OP_SAFE_C_NC, HOP_SAFE_C_NC, OP_SAFE_C_S, HOP_SAFE_C_S,
OP_SAFE_C_SS, HOP_SAFE_C_SS, OP_SAFE_C_SC, HOP_SAFE_C_SC, OP_SAFE_C_CS,
HOP_SAFE_C_CS, OP_SAFE_C_CQ, HOP_SAFE_C_CQ,
OP_SAFE_C_SSS, HOP_SAFE_C_SSS, OP_SAFE_C_SCS, HOP_SAFE_C_SCS,
OP_SAFE_C_SSC, HOP_SAFE_C_SSC, OP_SAFE_C_CSS, HOP_SAFE_C_CSS,
OP_SAFE_C_SCC, HOP_SAFE_C_SCC, OP_SAFE_C_CSC, HOP_SAFE_C_CSC,
OP_SAFE_C_CCS, HOP_SAFE_C_CCS,
OP_SAFE_C_NS, HOP_SAFE_C_NS, OP_SAFE_C_opNCq, HOP_SAFE_C_opNCq,
OP_SAFE_C_opSq, HOP_SAFE_C_opSq,
OP_SAFE_C_opSSq, HOP_SAFE_C_opSSq, OP_SAFE_C_opSCq, HOP_SAFE_C_opSCq,
OP_SAFE_C_opCSq, HOP_SAFE_C_opCSq, OP_SAFE_C_S_opSq, HOP_SAFE_C_S_opSq,
OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, OP_SAFE_C_S_opSCq,
HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq,
OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, OP_SAFE_C_opSq_C,
HOP_SAFE_C_opSq_C,
OP_SAFE_C_opSq_opSq, HOP_SAFE_C_opSq_opSq, OP_SAFE_C_S_opSSq,
HOP_SAFE_C_S_opSSq, OP_SAFE_C_C_opSq, HOP_SAFE_C_C_opSq,
OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, OP_SAFE_C_opSSq_C,
HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq,
OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq, OP_SAFE_C_opSSq_opSq,
HOP_SAFE_C_opSSq_opSq, OP_SAFE_C_opSq_opSSq, HOP_SAFE_C_opSq_opSSq,
OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, OP_SAFE_C_opCSq_S,
HOP_SAFE_C_opCSq_S, OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C,
OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S, OP_SAFE_C_op_opSqq,
HOP_SAFE_C_op_opSqq,
OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq,
HOP_SAFE_C_op_opSq_Sq, OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS,
OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_SA,
HOP_SAFE_C_SA, OP_SAFE_C_AS, HOP_SAFE_C_AS,
OP_SAFE_C_CA, HOP_SAFE_C_CA, OP_SAFE_C_AC, HOP_SAFE_C_AC,
OP_SAFE_C_AAA, HOP_SAFE_C_AAA, OP_SAFE_C_4A, HOP_SAFE_C_4A,
OP_SAFE_C_NA, HOP_SAFE_C_NA, OP_SAFE_C_ALL_CA, HOP_SAFE_C_ALL_CA,
OP_SAFE_C_SSA, HOP_SAFE_C_SSA, OP_SAFE_C_SAS, HOP_SAFE_C_SAS,
OP_SAFE_C_SAA, HOP_SAFE_C_SAA,
OP_SAFE_C_CSA, HOP_SAFE_C_CSA, OP_SAFE_C_SCA, HOP_SAFE_C_SCA,
OP_SAFE_C_ASS, HOP_SAFE_C_ASS,
OP_SAFE_C_CAC, HOP_SAFE_C_CAC, OP_SAFE_C_AGG, HOP_SAFE_C_AGG,
OP_SAFE_C_opAq, HOP_SAFE_C_opAq, OP_SAFE_C_opAAq, HOP_SAFE_C_opAAq,
OP_SAFE_C_opAAAq, HOP_SAFE_C_opAAAq,
OP_SAFE_C_S_opAq, HOP_SAFE_C_S_opAq, OP_SAFE_C_opAq_S,
HOP_SAFE_C_opAq_S,
OP_SAFE_C_S_opAAq, HOP_SAFE_C_S_opAAq, OP_SAFE_C_S_opAAAq,
HOP_SAFE_C_S_opAAAq,
OP_SAFE_C_STAR, HOP_SAFE_C_STAR, OP_SAFE_C_STAR_A, HOP_SAFE_C_STAR_A,
OP_SAFE_C_STAR_AA, HOP_SAFE_C_STAR_AA, OP_SAFE_C_STAR_NA,
HOP_SAFE_C_STAR_NA,
OP_SAFE_C_P, HOP_SAFE_C_P,
OP_THUNK, HOP_THUNK, OP_THUNK_ANY, HOP_THUNK_ANY, OP_SAFE_THUNK,
HOP_SAFE_THUNK, OP_SAFE_THUNK_A, HOP_SAFE_THUNK_A,
OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_S_O, HOP_CLOSURE_S_O,
OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_O, HOP_CLOSURE_A_O,
OP_CLOSURE_P, HOP_CLOSURE_P,
OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA,
OP_CLOSURE_PP, HOP_CLOSURE_PP,
OP_CLOSURE_FA, HOP_CLOSURE_FA, OP_CLOSURE_SS, HOP_CLOSURE_SS,
OP_CLOSURE_SS_O, HOP_CLOSURE_SS_O,
OP_CLOSURE_SC, HOP_CLOSURE_SC, OP_CLOSURE_SC_O, HOP_CLOSURE_SC_O,
OP_CLOSURE_3S, HOP_CLOSURE_3S, OP_CLOSURE_4S, HOP_CLOSURE_4S,
OP_CLOSURE_AA, HOP_CLOSURE_AA, OP_CLOSURE_AA_O, HOP_CLOSURE_AA_O,
OP_CLOSURE_3A, HOP_CLOSURE_3A, OP_CLOSURE_4A, HOP_CLOSURE_4A,
OP_CLOSURE_NA, HOP_CLOSURE_NA, OP_CLOSURE_ASS, HOP_CLOSURE_ASS,
OP_CLOSURE_SAS, HOP_CLOSURE_SAS, OP_CLOSURE_AAS, HOP_CLOSURE_AAS,
OP_CLOSURE_SAA, HOP_CLOSURE_SAA, OP_CLOSURE_ASA, HOP_CLOSURE_ASA,
OP_CLOSURE_NS, HOP_CLOSURE_NS,
OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_S_O,
HOP_SAFE_CLOSURE_S_O,
OP_SAFE_CLOSURE_S_A, HOP_SAFE_CLOSURE_S_A, OP_SAFE_CLOSURE_S_TO_S,
HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC,
HOP_SAFE_CLOSURE_S_TO_SC,
OP_SAFE_CLOSURE_P, HOP_SAFE_CLOSURE_P, OP_SAFE_CLOSURE_P_A,
HOP_SAFE_CLOSURE_P_A,
OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA,
HOP_SAFE_CLOSURE_PA, OP_SAFE_CLOSURE_PP, HOP_SAFE_CLOSURE_PP,
OP_SAFE_CLOSURE_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_A_O,
HOP_SAFE_CLOSURE_A_O, OP_SAFE_CLOSURE_A_A, HOP_SAFE_CLOSURE_A_A,
OP_SAFE_CLOSURE_A_TO_SC, HOP_SAFE_CLOSURE_A_TO_SC,
OP_SAFE_CLOSURE_SS, HOP_SAFE_CLOSURE_SS, OP_SAFE_CLOSURE_SS_O,
HOP_SAFE_CLOSURE_SS_O, OP_SAFE_CLOSURE_SS_A, HOP_SAFE_CLOSURE_SS_A,
OP_SAFE_CLOSURE_SC, HOP_SAFE_CLOSURE_SC, OP_SAFE_CLOSURE_SC_O,
HOP_SAFE_CLOSURE_SC_O,
OP_SAFE_CLOSURE_AA, HOP_SAFE_CLOSURE_AA, OP_SAFE_CLOSURE_AA_O,
HOP_SAFE_CLOSURE_AA_O, OP_SAFE_CLOSURE_AA_A, HOP_SAFE_CLOSURE_AA_A,
OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA, OP_SAFE_CLOSURE_SSA,
HOP_SAFE_CLOSURE_SSA,
OP_SAFE_CLOSURE_AGG, HOP_SAFE_CLOSURE_AGG, OP_SAFE_CLOSURE_3A,
HOP_SAFE_CLOSURE_3A, OP_SAFE_CLOSURE_NA, HOP_SAFE_CLOSURE_NA,
OP_SAFE_CLOSURE_3S, HOP_SAFE_CLOSURE_3S, OP_SAFE_CLOSURE_NS,
HOP_SAFE_CLOSURE_NS,
OP_SAFE_CLOSURE_3S_A, HOP_SAFE_CLOSURE_3S_A,
OP_ANY_CLOSURE_3P, HOP_ANY_CLOSURE_3P, OP_ANY_CLOSURE_4P,
HOP_ANY_CLOSURE_4P, OP_ANY_CLOSURE_NA, HOP_ANY_CLOSURE_NA,
OP_ANY_CLOSURE_NP, HOP_ANY_CLOSURE_NP,
OP_CLOSURE_STAR_A, HOP_CLOSURE_STAR_A, OP_CLOSURE_STAR_NA,
HOP_CLOSURE_STAR_NA,
OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A,
OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA,
OP_SAFE_CLOSURE_STAR_AA_O, HOP_SAFE_CLOSURE_STAR_AA_O,
OP_SAFE_CLOSURE_STAR_A1, HOP_SAFE_CLOSURE_STAR_A1,
OP_SAFE_CLOSURE_STAR_KA, HOP_SAFE_CLOSURE_STAR_KA, OP_CLOSURE_STAR_KA,
HOP_CLOSURE_STAR_KA, OP_SAFE_CLOSURE_STAR_3A,
HOP_SAFE_CLOSURE_STAR_3A,
OP_SAFE_CLOSURE_STAR_NA, HOP_SAFE_CLOSURE_STAR_NA,
OP_SAFE_CLOSURE_STAR_NA_0, HOP_SAFE_CLOSURE_STAR_NA_0,
OP_SAFE_CLOSURE_STAR_NA_1, HOP_SAFE_CLOSURE_STAR_NA_1,
OP_SAFE_CLOSURE_STAR_NA_2, HOP_SAFE_CLOSURE_STAR_NA_2,
OP_CALL_WITH_EXIT, HOP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_O,
HOP_CALL_WITH_EXIT_O,
OP_C_CATCH, HOP_C_CATCH, OP_C_CATCH_ALL, HOP_C_CATCH_ALL,
OP_C_CATCH_ALL_O, HOP_C_CATCH_ALL_O, OP_C_CATCH_ALL_A,
HOP_C_CATCH_ALL_A,
OP_C_S_opSq, HOP_C_S_opSq, 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_AP, HOP_C_AP,
OP_C_A, HOP_C_A, OP_C_AA, HOP_C_AA, OP_C, HOP_C, OP_C_NA, HOP_C_NA,
OP_CL_S, HOP_CL_S, OP_CL_SS, HOP_CL_SS, OP_CL_A, HOP_CL_A, OP_CL_AA,
HOP_CL_AA, OP_CL_NA, HOP_CL_NA,
OP_CL_FA, HOP_CL_FA, OP_CL_SAS, HOP_CL_SAS, OP_CL_S_opSq,
HOP_CL_S_opSq,
OP_SAFE_C_PP, HOP_SAFE_C_PP, OP_SAFE_C_FF, HOP_SAFE_C_FF,
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_AP, HOP_SAFE_C_AP, OP_SAFE_C_PA, HOP_SAFE_C_PA,
OP_SAFE_C_PS, HOP_SAFE_C_PS, OP_SAFE_C_PC, HOP_SAFE_C_PC,
OP_SAFE_C_SSP, HOP_SAFE_C_SSP, OP_ANY_C_NP, HOP_ANY_C_NP,
OP_SAFE_C_3P, HOP_SAFE_C_3P,
/* end of h_opts */
OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL,
OP_MACRO_D, OP_MACRO_STAR_D,
OP_WITH_IO, OP_WITH_IO_1, OP_WITH_OUTPUT_TO_STRING, OP_WITH_IO_C,
OP_CALL_WITH_OUTPUT_STRING,
OP_S, OP_S_S, OP_S_C, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_P_S,
OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA,
OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A, OP_IMPLICIT_CONTINUATION_A,
OP_IMPLICIT_ITERATE,
OP_IMPLICIT_VECTOR_REF_A, OP_IMPLICIT_VECTOR_REF_AA,
OP_IMPLICIT_VECTOR_SET_3, OP_IMPLICIT_VECTOR_SET_4,
OP_IMPLICIT_STRING_REF_A, OP_IMPLICIT_C_OBJECT_REF_A,
OP_IMPLICIT_PAIR_REF_A, OP_IMPLICIT_PAIR_REF_AA,
OP_IMPLICIT_HASH_TABLE_REF_A, OP_IMPLICIT_LET_REF_C,
OP_IMPLICIT_LET_REF_A, OP_IMPLICIT_S7_LET_REF_S,
OP_IMPLICIT_S7_LET_SET_SA,
OP_UNKNOWN, OP_UNKNOWN_NS, OP_UNKNOWN_NA, OP_UNKNOWN_G, OP_UNKNOWN_GG,
OP_UNKNOWN_A, OP_UNKNOWN_AA, OP_UNKNOWN_NP,
OP_SYM, OP_GLOBAL_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY,
HOP_SSA_DIRECT, HOP_HASH_TABLE_INCREMENT, OP_CLEAR_OPTS,
OP_READ_INTERNAL, OP_EVAL,
OP_EVAL_ARGS, OP_EVAL_ARGS1, OP_EVAL_ARGS2, OP_EVAL_ARGS3,
OP_EVAL_ARGS4, OP_EVAL_ARGS5,
OP_APPLY, OP_EVAL_MACRO, OP_LAMBDA, OP_QUOTE, OP_QUOTE_UNCHECKED,
OP_MACROEXPAND, OP_CALL_CC,
OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN_HOOK, OP_BEGIN_NO_HOOK,
OP_BEGIN_UNCHECKED, OP_BEGIN_2_UNCHECKED, OP_BEGIN_NA, OP_BEGIN_AA,
OP_IF, OP_IF1, OP_WHEN, OP_UNLESS, OP_SET, OP_SET1, OP_SET2,
OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2,
OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1,
OP_LET_TEMPORARILY, OP_LET_TEMP_UNCHECKED, OP_LET_TEMP_INIT1,
OP_LET_TEMP_INIT2, OP_LET_TEMP_DONE, OP_LET_TEMP_DONE1,
OP_LET_TEMP_S7, OP_LET_TEMP_FX, OP_LET_TEMP_FX_1, OP_LET_TEMP_SETTER,
OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND,
OP_LET_TEMP_SETTER_UNWIND,
OP_LET_TEMP_A_A,
OP_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE,
OP_COND_SIMPLE_O, OP_COND1_SIMPLE_O,
OP_AND, OP_OR,
OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION,
OP_DEFINE_EXPANSION_STAR, OP_MACRO, OP_MACRO_STAR,
OP_CASE,
OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE,
OP_READ_QUASIQUOTE, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES,
OP_READ_VECTOR, OP_READ_BYTE_VECTOR, OP_READ_INT_VECTOR,
OP_READ_FLOAT_VECTOR, OP_READ_DONE,
OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_DONE,
OP_SPLICE_VALUES, OP_NO_VALUES, OP_FLUSH_VALUES,
OP_CATCH, OP_DYNAMIC_WIND, OP_DYNAMIC_UNWIND,
OP_DYNAMIC_UNWIND_PROFILE, OP_PROFILE_IN,
OP_DEFINE_CONSTANT, OP_DEFINE_CONSTANT1,
OP_DO, OP_DO_END, OP_DO_END1, OP_DO_STEP, OP_DO_STEP2, OP_DO_INIT,
OP_DEFINE_STAR, OP_LAMBDA_STAR, OP_LAMBDA_STAR_DEFAULT, OP_ERROR_QUIT,
OP_UNWIND_INPUT, OP_UNWIND_OUTPUT,
OP_ERROR_HOOK_QUIT,
OP_WITH_LET, OP_WITH_LET1, OP_WITH_LET_UNCHECKED, OP_WITH_LET_S,
OP_WITH_UNLET_S,
OP_WITH_BAFFLE, OP_WITH_BAFFLE_UNCHECKED, OP_EXPANSION,
OP_FOR_EACH, OP_FOR_EACH_1, OP_FOR_EACH_2, OP_FOR_EACH_3,
OP_MAP, OP_MAP_1, OP_MAP_2, OP_MAP_GATHER, OP_MAP_GATHER_1,
OP_MAP_GATHER_2, OP_MAP_GATHER_3,
OP_BARRIER, OP_DEACTIVATE_GOTO,
OP_DEFINE_BACRO, OP_DEFINE_BACRO_STAR, OP_BACRO, OP_BACRO_STAR,
OP_GET_OUTPUT_STRING,
OP_SORT, OP_SORT1, OP_SORT2, OP_SORT3, OP_SORT_PAIR_END,
OP_SORT_VECTOR_END, OP_SORT_STRING_END,
OP_EVAL_STRING,
OP_MEMBER_IF, OP_ASSOC_IF, OP_MEMBER_IF1, OP_ASSOC_IF1,
OP_LAMBDA_UNCHECKED, OP_LET_UNCHECKED, OP_CATCH_1, OP_CATCH_2,
OP_CATCH_ALL,
OP_SET_UNCHECKED, OP_SET_SYMBOL_C, OP_SET_SYMBOL_S, OP_SET_SYMBOL_P,
OP_SET_SYMBOL_A,
OP_SET_NORMAL, OP_SET_PAIR, OP_SET_DILAMBDA, OP_SET_DILAMBDA_P,
OP_SET_DILAMBDA_P_1, OP_SET_DILAMBDA_SA_A,
OP_SET_PAIR_A, OP_SET_PAIR_P, OP_SET_PAIR_ZA,
OP_SET_PAIR_P_1, OP_SET_FROM_SETTER, OP_SET_FROM_LET_TEMP, OP_SET_PWS,
OP_SET_LET_S, OP_SET_LET_FX, OP_SET_SAFE,
OP_INCREMENT_BY_1, OP_DECREMENT_BY_1, OP_SET_CONS,
OP_INCREMENT_SS, OP_INCREMENT_SP, OP_INCREMENT_SA, OP_INCREMENT_SAA,
OP_LETREC_UNCHECKED, OP_LETREC_STAR_UNCHECKED, OP_COND_UNCHECKED,
OP_LAMBDA_STAR_UNCHECKED, OP_DO_UNCHECKED, OP_DEFINE_UNCHECKED,
OP_DEFINE_STAR_UNCHECKED, OP_DEFINE_FUNCHECKED,
OP_DEFINE_CONSTANT_UNCHECKED,
OP_DEFINE_WITH_SETTER,
OP_LET_NO_VARS, OP_NAMED_LET, OP_NAMED_LET_NO_VARS, OP_NAMED_LET_A,
OP_NAMED_LET_AA, OP_NAMED_LET_FX, OP_NAMED_LET_STAR,
OP_LET_FX_OLD, OP_LET_FX_NEW, OP_LET_2A_OLD, OP_LET_2A_NEW,
OP_LET_3A_OLD, OP_LET_3A_NEW,
OP_LET_opSSq_OLD, OP_LET_opSSq_NEW, OP_LET_opSSq_E_OLD,
OP_LET_opSSq_E_NEW, OP_LET_opaSSq_OLD, OP_LET_opaSSq_NEW,
OP_LET_opaSSq_E_OLD, OP_LET_opaSSq_E_NEW,
OP_LET_ONE_OLD, OP_LET_ONE_NEW, OP_LET_ONE_P_OLD, OP_LET_ONE_P_NEW,
OP_LET_ONE_OLD_1, OP_LET_ONE_NEW_1, OP_LET_ONE_P_OLD_1,
OP_LET_ONE_P_NEW_1,
OP_LET_A_OLD, OP_LET_A_NEW, OP_LET_A_P_OLD, OP_LET_A_P_NEW,
OP_LET_A_A_OLD, OP_LET_A_A_NEW, OP_LET_A_FX_OLD, OP_LET_A_FX_NEW,
OP_LET_A_OLD_2, OP_LET_A_NEW_2,
OP_LET_STAR_FX, OP_LET_STAR_FX_A,
OP_CASE_A_E_S, OP_CASE_A_I_S, OP_CASE_A_G_S, OP_CASE_A_E_G,
OP_CASE_A_G_G, OP_CASE_A_S_S, OP_CASE_A_S_G,
OP_CASE_S_E_S, OP_CASE_S_I_S, OP_CASE_S_G_S, OP_CASE_S_E_G,
OP_CASE_S_G_G, OP_CASE_S_S_S, OP_CASE_S_S_G,
OP_CASE_P_E_S, OP_CASE_P_I_S, OP_CASE_P_G_S, OP_CASE_P_E_G,
OP_CASE_P_G_G, OP_CASE_P_S_S, OP_CASE_P_S_G,
OP_CASE_E_S, OP_CASE_I_S, OP_CASE_G_S, OP_CASE_E_G, OP_CASE_G_G,
OP_CASE_S_S, OP_CASE_S_G,
OP_IF_UNCHECKED, OP_AND_P, OP_AND_P1, OP_AND_AP, OP_AND_PAIR_P,
OP_AND_SAFE_P1, OP_AND_SAFE_P2, OP_AND_SAFE_P3, OP_AND_SAFE_P_REST,
OP_AND_2A, OP_AND_3A, OP_AND_N, OP_AND_S_2,
OP_OR_P, OP_OR_P1, OP_OR_AP, OP_OR_2A, OP_OR_3A, OP_OR_N, OP_OR_S_2,
OP_OR_S_TYPE_2,
OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2A,
OP_WHEN_AND_3A, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P,
OP_IF_A_C_C, OP_IF_A_A, OP_IF_A_A_A, OP_IF_S_A_A, OP_IF_AND2_S_A,
OP_IF_NOT_A_A, OP_IF_NOT_A_A_A,
OP_IF_B_A, OP_IF_B_P, OP_IF_B_R, OP_IF_B_A_P, OP_IF_B_P_A, OP_IF_B_P_P,
OP_IF_B_N_N,
OP_IF_A_A_P, OP_IF_A_P_A, OP_IF_S_P_A, OP_IF_IS_TYPE_S_P_A,
OP_IF_IS_TYPE_S_A_A,
OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N,
OP_IF_opSq_P, OP_IF_opSq_P_P, OP_IF_opSq_R, OP_IF_opSq_N,
OP_IF_opSq_N_N,
OP_IF_IS_TYPE_S_P, OP_IF_IS_TYPE_S_P_P, OP_IF_IS_TYPE_S_R,
OP_IF_IS_TYPE_S_N, OP_IF_IS_TYPE_S_N_N,
OP_IF_A_P, OP_IF_A_P_P, OP_IF_A_R, OP_IF_A_N, OP_IF_A_N_N,
OP_IF_AND2_P, OP_IF_AND2_P_P, OP_IF_AND2_R, OP_IF_AND2_N,
OP_IF_AND2_N_N,
OP_IF_AND3_P, OP_IF_AND3_P_P, OP_IF_AND3_R, OP_IF_AND3_N, OP_IF_AND3_N_N, /* or3 got few hits */
OP_IF_P_P, OP_IF_P_P_P, OP_IF_P_R, OP_IF_P_N, OP_IF_P_N_N,
OP_IF_ANDP_P, OP_IF_ANDP_P_P, OP_IF_ANDP_R, OP_IF_ANDP_N,
OP_IF_ANDP_N_N,
OP_IF_ORP_P, OP_IF_ORP_P_P, OP_IF_ORP_R, OP_IF_ORP_N, OP_IF_ORP_N_N,
OP_IF_OR2_P, OP_IF_OR2_P_P, OP_IF_OR2_R, OP_IF_OR2_N, OP_IF_OR2_N_N,
OP_IF_PP, OP_IF_PPP, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP,
OP_COND_FX_FX, OP_COND_FX_NP, OP_COND_FX_NP_1, OP_COND_FX_2E,
OP_COND_FX_3E, OP_COND_FX_NP_O,
OP_COND_FEED, OP_COND_FEED_1,
OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP,
OP_SAFE_DOTIMES_STEP_O,
OP_SAFE_DO, OP_SAFE_DO_STEP, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_O,
OP_DOX_NO_BODY, OP_DOX_PENDING_NO_BODY, OP_DOX_INIT,
OP_DOTIMES_P, OP_DOTIMES_STEP_O,
OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1,
OP_DO_NO_BODY_FX_VARS, OP_DO_NO_BODY_FX_VARS_STEP,
OP_DO_NO_BODY_FX_VARS_STEP_1,
OP_SAFE_C_P_1, OP_SAFE_C_PP_1, OP_SAFE_C_PP_3_MV, OP_SAFE_C_PP_5,
OP_SAFE_C_PP_6_MV,
OP_SAFE_C_3P_1, OP_SAFE_C_3P_2, OP_SAFE_C_3P_3, OP_SAFE_C_3P_1_MV,
OP_SAFE_C_3P_2_MV, OP_SAFE_C_3P_3_MV,
OP_SAFE_C_SP_1, OP_SAFE_C_SP_MV, OP_SAFE_CONS_SP_1, OP_SAFE_LIST_SP_1,
OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1,
OP_SAFE_C_PS_1, OP_SAFE_C_PC_1, OP_SAFE_C_PS_MV, OP_SAFE_C_PC_MV,
OP_EVAL_MACRO_MV, OP_MACROEXPAND_1, OP_APPLY_LAMBDA,
OP_INCREMENT_SP_1, OP_INCREMENT_SP_MV, OP_ANY_C_NP_1, OP_ANY_C_NP_MV_1,
OP_SAFE_C_SSP_1, OP_SAFE_C_SSP_MV_1,
OP_C_P_1, OP_C_P_MV, OP_C_AP_1, OP_C_AP_MV, OP_ANY_C_NP_2,
OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV,
OP_SET_WITH_LET_1, OP_SET_WITH_LET_2,
OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_PP_1, OP_CLOSURE_P_1,
OP_SAFE_CLOSURE_P_1, OP_SAFE_CLOSURE_P_A_1, OP_SAFE_CLOSURE_AP_1,
OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_PP_1,
OP_ANY_CLOSURE_3P_1, OP_ANY_CLOSURE_3P_2, OP_ANY_CLOSURE_3P_3,
OP_ANY_CLOSURE_NP_1, OP_ANY_CLOSURE_NP_MV_1,
OP_ANY_CLOSURE_4P_1, OP_ANY_CLOSURE_4P_2, OP_ANY_CLOSURE_4P_3,
OP_ANY_CLOSURE_4P_4, OP_ANY_CLOSURE_NP_2,
OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA,
OP_TC_OR_A_AND_A_LAA, OP_TC_OR_A_A_AND_A_A_LA,
OP_TC_OR_A_AND_A_A_L3A, OP_TC_AND_A_OR_A_A_LA, OP_TC_OR_A_AND_A_A_LA,
OP_TC_WHEN_LAA, OP_TC_LET_WHEN_LAA, OP_TC_LET_UNLESS_LAA,
OP_TC_COND_A_Z_A_Z_LAA, OP_TC_COND_A_Z_A_LAA_Z,
OP_TC_COND_A_Z_A_LAA_LAA, OP_TC_LET_COND,
OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_Z_L3A, OP_TC_IF_A_L3A_Z,
OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z,
OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z,
OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_IF_A_Z_IF_A_LAA_Z,
OP_TC_IF_A_Z_IF_A_L3A_L3A,
OP_TC_COND_A_Z_A_Z_LA, OP_TC_COND_A_Z_A_LA_Z, OP_TC_COND_A_Z_LA,
OP_TC_COND_A_LA_Z, OP_TC_COND_A_Z_LAA, OP_TC_COND_A_LAA_Z,
OP_TC_LET_IF_A_Z_LA, OP_TC_LET_IF_A_Z_LAA, OP_TC_IF_A_Z_LET_IF_A_Z_LAA,
OP_TC_CASE_LA, OP_TC_AND_A_IF_A_Z_LA, OP_TC_AND_A_IF_A_LA_Z,
OP_RECUR_IF_A_A_opA_LAq, OP_RECUR_IF_A_opA_LAq_A,
OP_RECUR_IF_A_A_opLA_Aq, OP_RECUR_IF_A_opLA_Aq_A,
OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_opLA_LAq_A,
OP_RECUR_IF_A_A_opA_LA_LAq, OP_RECUR_IF_A_opA_LA_LAq_A,
OP_RECUR_IF_A_A_opLA_LA_LAq, OP_RECUR_IF_A_A_IF_A_A_opLA_LAq,
OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq,
OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A,
OP_RECUR_IF_A_A_opA_L3Aq,
OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq, OP_RECUR_IF_A_A_AND_A_LAA_LAA,
OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq, /* same as cond case below */
OP_RECUR_COND_A_A_opA_LAq, OP_RECUR_COND_A_A_opA_LAAq,
OP_RECUR_COND_A_A_A_A_opLA_LAq, OP_RECUR_COND_A_A_A_A_opLAA_LAAq,
OP_RECUR_COND_A_A_A_A_opA_LAAq,
OP_RECUR_COND_A_A_A_LAA_LopA_LAAq, OP_RECUR_COND_A_A_A_LAA_opA_LAAq,
OP_RECUR_AND_A_OR_A_LAA_LAA,
NUM_OPS
};
#define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_LA))
typedef enum { E_C_P, E_C_PP, E_C_CP, E_C_SP, E_C_PC,
E_C_PS
} combine_op_t;
static const char *op_names[NUM_OPS] = {
"unopt", "gc_protect",
"safe_c_nc", "h_safe_c_nc", "safe_c_s", "h_safe_c_s",
"safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs",
"h_safe_c_cs", "safe_c_cq", "h_safe_c_cq",
"safe_c_sss", "h_safe_c_sss", "safe_c_scs", "h_safe_c_scs",
"safe_c_ssc", "h_safe_c_ssc", "safe_c_css", "h_safe_c_css",
"safe_c_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc",
"safe_c_ccs", "h_safe_c_ccs",
"safe_c_ns", "h_safe_c_ns", "safe_c_opncq", "h_safe_c_opncq",
"safe_c_opsq", "h_safe_c_opsq",
"safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq",
"safe_c_opcsq", "h_safe_c_opcsq", "safe_c_s_opsq", "h_safe_c_s_opsq",
"safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq",
"h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq",
"safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c",
"safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq",
"h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq",
"safe_c_opcsq_c", "h_safe_c_opcsq_c", "safe_c_opssq_c",
"h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq",
"safe_c_opssq_opssq", "h_safe_c_opssq_opssq", "safe_c_opssq_opsq",
"h_safe_c_opssq_opsq", "safe_c_opsq_opssq", "h_safe_c_opsq_opssq",
"safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s",
"h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c",
"safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", "safe_c_op_opsqq",
"h_safe_c_op_opsqq",
"safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq",
"h_safe_c_op_opsq_sq", "safe_c_opsq_cs", "h_safe_c_opsq_cs",
"safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_sa",
"h_safe_c_sa", "safe_c_as", "h_safe_c_as",
"safe_c_ca", "h_safe_c_ca", "safe_c_ac", "h_safe_c_ac", "safe_c_aaa",
"h_safe_c_aaa", "safe_c_4a", "h_safe_c_4a",
"safe_c_na", "h_safe_c_na", "safe_c_all_ca", "h_safe_c_all_ca",
"safe_c_ssa", "h_safe_c_ssa", "safe_c_sas", "h_safe_c_sas",
"safe_c_saa", "h_safe_c_saa",
"safe_c_csa", "h_safe_c_csa", "safe_c_sca", "h_safe_c_sca",
"safe_c_ass", "h_safe_c_ass",
"safe_c_cac", "h_safe_c_cac", "safe_c_agg", "h_safe_c_agg",
"safe_c_opaq", "h_safe_c_opaq", "safe_c_opaaq", "h_safe_c_opaaq",
"safe_c_opaaaq", "h_safe_c_opaaaq",
"safe_c_s_opaq", "h_safe_c_s_opaq", "safe_c_opaq_s", "h_safe_c_opaq_s",
"safe_c_s_opaaq", "h_safe_c_s_opaaq", "safe_c_s_opaaaq",
"h_safe_c_s_opaaaq",
"safe_c_function*", "h_safe_c_function*", "safe_c_function*_a",
"h_safe_c_function*_a",
"safe_c_function*_aa", "h_safe_c_function*_aa", "safe_c_function*_fx",
"h_safe_c_function*_fx",
"safe_c_p", "h_safe_c_p",
"thunk", "h_thunk", "thunk_any", "h_thunk_any", "safe_thunk",
"h_safe_thunk", "safe_thunk_a", "h_safe_thunk_a",
"closure_s", "h_closure_s", "closure_s_o", "h_closure_s_o",
"closure_a", "h_closure_a", "closure_a_o", "h_closure_a_o",
"closure_p", "h_closure_p",
"closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa",
"closure_pp", "h_closure_pp",
"closure_fa", "h_closure_fa", "closure_ss", "h_closure_ss",
"closure_ss_o", "h_closure_ss_o",
"closure_sc", "h_closure_sc", "closure_sc_o", "h_closure_sc_o",
"closure_3s", "h_closure_3s", "closure_4s", "h_closure_4s",
"closure_aa", "h_closure_aa", "closure_aa_o", "h_closure_aa_o",
"closure_3a", "h_closure_3a", "closure_4a", "h_closure_4a",
"closure_na", "h_closure_na", "closure_ass", "h_closure_ass",
"closure_sas", "h_closure_sas ", "closure_aas", "h_closure_aas",
"closure_saa", "h_closure_saa", "closure_asa", "h_closure_asa",
"closure_ns", "h_closure_ns",
"safe_closure_s", "h_safe_closure_s", "safe_closure_s_o",
"h_safe_closure_s_o",
"safe_closure_s_a", "h_safe_closure_s_a", "safe_closure_s_to_s",
"h_safe_closure_s_to_s", "safe_closure_s_to_sc",
"h_safe_closure_s_to_sc",
"safe_closure_p", "h_safe_closure_p", "safe_closure_p_a",
"h_safe_closure_p_a",
"safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa",
"h_safe_closure_pa", "safe_closure_pp", "h_safe_closure_pp",
"safe_closure_a", "h_safe_closure_a", "safe_closure_a_o",
"h_safe_closure_a_o", "safe_closure_a_a", "h_safe_closure_a_a",
"safe_closure_a_to_sc", "h_safe_closure_a_to_sc",
"safe_closure_ss", "h_safe_closure_ss", "safe_closure_ss_o",
"h_safe_closure_ss_o", "safe_closure_ss_a", "h_safe_closure_ss_a",
"safe_closure_sc", "h_safe_closure_sc", "safe_closure_sc_o",
"h_safe_closure_sc_o",
"safe_closure_aa", "h_safe_closure_aa", "safe_closure_aa_o",
"h_safe_closure_aa_o", "safe_closure_aa_a", "h_safe_closure_aa_a",
"safe_closure_saa", "h_safe_closure_saa", "safe_closure_ssa",
"h_safe_closure_ssa",
"safe_closure_agg", "h_safe_closure_agg", "safe_closure_3a",
"h_safe_closure_3a", "safe_closure_na", "h_safe_closure_na",
"safe_closure_3s", "h_safe_closure_3s", "safe_closure_ns",
"h_safe_closure_ns",
"safe_closure_3s_a", "h_safe_closure_3s_a",
"any_closure_3p", "h_any_closure_3p", "any_closure_4p",
"h_any_closure_4p", "any_closure_na", "h_any_closure_na",
"any_closure_np", "h_any_closure_np",
"closure*_a", "h_closure*_a", "closure*_fx", "h_closure*_fx",
"safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa",
"h_safe_closure*_aa",
"safe_closure*_aa_o", "h_safe_closure*_aa_o", "safe_closure*_a1",
"h_safe_closure*_a1",
"safe_closure*_ka", "h_safe_closure*_ka", "closure*_ka",
"h_closure*_ka", "safe_closure*_3a", "h_safe_closure*_3a",
"safe_closure*_fx", "h_safe_closure*_fx", "safe_closure*_fx_0",
"h_safe_closure*_fx_0",
"safe_closure*_fx_1", "h_safe_closure*_fx_1", "safe_closure*_fx_2",
"h_safe_closure*_fx_2",
"call_with_exit", "h_call_with_exit", "call_with_exit_o",
"h_call_with_exit_o",
"c_catch", "h_c_catch", "c_catch_all", "h_c_catch_all",
"c_catch_all_o", "h_c_catch_all_o", "c_catch_all_a",
"h_c_catch_all_a",
"c_s_opsq", "h_c_s_opsq", "c_ss", "h_c_ss", "c_s", "h_c_s", "read_s",
"h_read_s", "c_p", "h_c_p", "c_ap", "h_c_ap",
"c_a", "h_c_a", "c_aa", "h_c_aa", "c", "h_c", "c_fx", "h_c_fx",
"cl_s", "h_cl_s", "cl_ss", "h_cl_ss", "cl_a", "h_cl_a", "cl_aa",
"h_cl_aa",
"cl_na", "h_cl_na", "cl_fa", "h_cl_fa", "cl_sas", "h_cl_sas",
"cl_s_opsq", "h_cl_s_opsq",
"safe_c_pp", "h_safe_c_pp", "safe_c_ff", "h_safe_c_ff",
"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_ap", "h_safe_c_ap", "safe_c_pa", "h_safe_c_pa",
"safe_c_ps", "h_safe_c_ps", "safe_c_pc", "h_safe_c_pc",
"safe_c_ssp", "h_safe_c_ssp", "any_c_np", "h_any_c_np",
"safe_c_3p", "h_safe_c_3p",
"apply_ss", "apply_sa", "apply_sl",
"macro_d", "macro*_d",
"with_input_from_string", "with_input_from_string_1",
"with_output_to_string", "with_input_from_string_c",
"call_with_output_string",
"s", "s_s", "s_c", "s_a", "s_aa", "a_a", "a_aa", "p_s", "p_s_1",
"map_for_each_fa", "map_for_each_faa",
"implicit_goto", "implicit_goto_a", "implicit_continuation_a",
"implicit_iterate",
"implicit_vector_ref_a", "implicit_vector_ref_aa",
"implicit_vector_set_3", "implicit_vector_set_4",
"implicit_string_ref_a", "implicit_c_object_ref_a",
"implicit_pair_ref_a", "implicit_pair_ref_aa",
"implicit_hash_table_ref_a", "implicit_let_ref_c",
"implicit_let_ref_a", "implicit_*s7*_ref_s",
"implicit_*s7*_set_sa",
"unknown_thunk", "unknown_ns", "unknown_na", "unknown_g", "unknown_gg",
"unknown_a", "unknown_aa", "unknown_np",
"symbol", "global-symbol", "constant", "pair_sym", "pair_pair",
"pair_any",
"h_ssa_direct", "h_hash_table_increment", "clear_opts",
"read_internal", "eval",
"eval_args", "eval_args1", "eval_args2", "eval_args3", "eval_args4",
"eval_args5",
"apply", "eval_macro", "lambda", "quote", "quote_unchecked",
"macroexpand", "call/cc",
"define", "define1", "begin", "begin_hook", "begin_no_hook",
"begin_unchecked", "begin_2_unchecked", "begin_na", "begin_aa",
"if", "if1", "when", "unless", "set", "set1", "set2",
"let", "let1", "let*", "let*1", "let*2",
"letrec", "letrec1", "letrec*", "letrec*1",
"let_temporarily", "let_temp_unchecked", "let_temp_init1",
"let_temp_init2", "let_temp_done", "let_temp_done1",
"let_temp_s7", "let_temp_fx", "let_temp_fx_1", "let_temp_setter",
"let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind",
"let_temp_a_a",
"cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple",
"cond_simple_o", "cond1_simple_o",
"and", "or",
"define_macro", "define_macro*", "define_expansion",
"define_expansion*", "macro", "macro*",
"case", "read_list", "read_next", "read_dot", "read_quote",
"read_quasiquote", "read_unquote", "read_apply_values",
"read_vector", "read_byte_vector", "read_int_vector",
"read_float_vector", "read_done",
"load_return_if_eof", "load_close_and_pop_if_eof", "eval_done",
"splice_values", "no_values", "flush_values",
"catch", "dynamic_wind", "dynamic_unwind", "dynamic_unwind_profile",
"profile_in",
"define_constant", "define_constant1",
"do", "do_end", "do_end1", "do_step", "do_step2", "do_init",
"define*", "lambda*", "lambda*_default", "error_quit", "unwind_input",
"unwind_output",
"error_hook_quit",
"with_let", "with_let1", "with_let_unchecked", "with_let_s",
"with_unlet_s",
"with_baffle", "with_baffle_unchecked", "expansion",
"for_each", "for_each_1", "for_each_2", "for_each_3",
"map", "map_1", "map_2", "map_gather", "map_gather_1", "map_gather_2",
"map_gather_3",
"barrier", "deactivate_goto",
"define_bacro", "define_bacro*", "bacro", "bacro*",
"get_output_string",
"sort", "sort1", "sort2", "sort3", "sort_pair_end", "sort_vector_end",
"sort_string_end",
"eval_string",
"member_if", "assoc_if", "member_if1", "assoc_if1",
"lambda_unchecked", "let_unchecked", "catch_1", "catch_2", "catch_all",
"set_unchecked", "set_symbol_c", "set_symbol_s", "set_symbol_p",
"set_symbol_a",
"set_normal", "set_pair", "set_dilambda", "set_dilambda_p",
"set_dilambda_p_1", "set_dilambda_sa_a",
"set_pair_a", "set_pair_p", "set_pair_za",
"set_pair_p_1", "set_from_setter", "set_from_let_temp", "set_pws",
"set_let_s", "set_let_fx", "set_safe",
"increment_1", "decrement_1", "set_cons",
"increment_ss", "increment_sp", "increment_sa", "increment_saa",
"letrec_unchecked", "letrec*_unchecked", "cond_unchecked",
"lambda*_unchecked", "do_unchecked", "define_unchecked",
"define*_unchecked", "define_funchecked",
"define_constant_unchecked",
"define_with_setter",
"let_no_vars", "named_let", "named_let_no_vars", "named_let_a",
"named_let_aa", "named_let_fx", "named_let*",
"let_fx_old", "let_fx_new", "let_2a_old", "let_2a_new", "let_3a_old",
"let_3a_new",
"let_opssq_old", "let_opssq_new", "let_opssq_e_old", "let_opssq_e_new",
"let_opassq_old", "let_opassq_new", "let_opassq_e_old",
"let_opassq_e_new",
"let_one_old", "let_one_new", "let_one_p_old", "let_one_p_new",
"let_one_old_1", "let_one_new_1", "let_one_p_old_1", "let_one_p_new_1",
"let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new",
"let_a_a_old", "let_a_a_new", "let_a_fx_old", "let_a_fx_new",
"let_a_old_2", "let_a_new_2",
"let*_fx", "let*_fx_a",
"case_a_e_s", "case_a_i_s", "case_a_g_s", "case_a_e_g", "case_a_g_g",
"case_a_s_s", "case_a_s_g",
"case_s_e_s", "case_s_i_s", "case_s_g_s", "case_s_e_g", "case_s_g_g",
"case_s_s_s", "case_s_s_g",
"case_p_e_s", "case_p_i_s", "case_p_g_s", "case_p_e_g", "case_p_g_g",
"case_p_s_s", "case_p_s_g",
"case_e_s", "case_i_s", "case_g_s", "case_e_g", "case_g_g", "case_s_s",
"case_s_g",
"if_unchecked", "and_p", "and_p1", "and_ap", "and_pair_p",
"and_safe_p1", "op_and_safe_p2", "and_safe_p3", "and_safe_p_rest",
"and_2a", "and_3a", "and_n", "and_s_2",
"or_p", "or_p1", "or_ap", "or_2a", "or_3a", "or_n", "or_s_2",
"or_s_type_2",
"when_s", "when_a", "when_p", "when_and_ap", "when_and_2a",
"when_and_3a", "unless_s", "unless_a", "unless_p",
"if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a",
"if_not_a_a", "if_not_a_a_a",
"if_b_a", "if_b_p", "if_b_r", "if_b_a_p", "if_b_p_a", "if_b_p_p",
"if_b_n_n",
"if_a_a_p", "if_a_p_a", "if_s_p_a", "if_is_type_s_p_a",
"if_is_type_s_a_a",
"if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n",
"if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n",
"if_is_type_s_p", "if_is_type_s_p_p", "if_is_type_s_r",
"if_is_type_s_n", "if_is_type_s_n_n",
"if_a_p", "if_a_p_p", "if_a_r", "if_a_n", "if_a_n_n",
"if_and2_p", "if_and2_p_p", "if_and2_r", "if_and2_n", "if_and2_n_n",
"if_and3_p", "if_and3_p_p", "if_and3_r", "if_and3_n", "if_and3_n_n",
"if_p_p", "if_p_p_p", "if_p_r", "if_p_n", "if_p_n_n",
"if_andp_p", "if_andp_p_p", "if_andp_r", "if_andp_n", "if_andp_n_n",
"if_orp_p", "if_orp_p_p", "if_orp_r", "if_orp_n", "if_orp_n_n",
"if_or2_p", "if_or2_p_p", "if_or2_r", "if_or2_n", "if_or2_n_n",
"if_pp", "if_ppp", "if_pr", "if_prr", "when_pp", "unless_pp",
"cond_fx_fx", "cond_fx_np", "cond_fx_np_1", "cond_fx_2e", "cond_fx_3e",
"cond_fx_np_o",
"cond_feed", "cond_feed_1",
"simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step",
"safe_dotimes_step_o",
"safe_do", "safe_do_step", "dox", "dox_step", "dox_step_o",
"dox_no_body", "dox_pending_no_body", "dox_init",
"dotimes_p", "dotimes_step_o",
"do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1",
"do_no_body_fx_vars", "do_no_body_fx_vars_step",
"do_no_body_fx_vars_step_1",
"safe_c_p_1", "safe_c_pp_1", "safe_c_pp_3_mv", "safe_c_pp_5",
"safe_c_pp_6_mv",
"safe_c_3p_1", "safe_c_3p_2", "safe_c_3p_3", "safe_c_3p_1_mv",
"safe_c_3p_2_mv", "safe_c_3p_3_mv",
"safe_c_sp_1", "safe_c_sp_mv", "safe_cons_sp_1", "safe_list_sp_1",
"safe_add_sp_1", "safe_multiply_sp_1",
"safe_c_ps_1", "safe_c_pc_1", "safe_c_ps_mv", "safe_c_pc_mv",
"eval_macro_mv", "macroexpand_1", "apply_lambda",
"increment_sp_1", "increment_sp_mv", "any_c_np_1", "any_c_np_mv_1",
"safe_c_ssp_1", "safe_c_ssp_mv_1",
"c_p_1", "c_p_mv", "c_ap_1", "c_ap_mv", "any_c_np_2", "safe_c_pa_1",
"safe_c_pa_mv",
"set_with_let_1", "set_with_let_2",
"closure_ap_1", "closure_pa_1", "closure_pp_1", "closure_p_1",
"safe_closure_p_1", "safe_closure_p_a_1", "safe_closure_ap_1",
"safe_closure_pa_1", "safe_closure_pp_1",
"any_closure_3p_1", "any_closure_3p_2", "any_closure_3p_3",
"any_closure_np_1", "any_closure_np_mv_1",
"any_closure_4p_1", "any_closure_4p_2", "any_closure_4p_3",
"any_closure_4p_4", "any_closure_np_2",
"tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa",
"tc_or_a_and_a_laa", "tc_or_a_a_and_a_a_la",
"tc_or_a_and_a_a_l3a", "tc_and_a_or_a_a_la", "tc_or_a_and_a_a_la",
"tc_when_laa", "tc_let_when_laa", "tc_let_unless_laa",
"tc_cond_a_z_a_z_laa", "tc_cond_a_z_a_laa_z", "tc_cond_a_z_a_laa_laa",
"tc_let_cond",
"tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_z_l3a", "tc_if_a_l3a_z",
"tc_if_a_la_z", "tc_if_a_laa_z",
"tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa",
"tc_if_a_z_if_a_laa_z", "tc_if_a_z_if_a_l3a_l3a",
"tc_cond_a_z_a_z_la", "tc_cond_a_z_a_la_z", "tc_cond_a_z_la",
"tc_cond_a_la_z", "tc_cond_a_z_laa", "tc_cond_a_laa_z",
"tc_let_if_a_z_la", "tc_let_if_a_z_laa", "if_a_z_let_if_a_z_laa",
"tc_case_la", "tc_and_a_if_a_z_la", "tc_and_a_if_a_la_z",
"recur_if_a_a_opa_laq", "recur_if_a_opa_laq_a", "recur_if_a_a_opla_aq",
"recur_if_a_opla_aq_a",
"recur_if_a_a_opla_laq", "recur_if_a_opla_laq_a",
"recur_if_a_a_opa_la_laq", "recur_if_a_opa_la_laq_a",
"recur_if_a_a_opla_la_laq", "recur_if_a_a_if_a_a_opla_laq",
"recur_if_a_a_if_a_a_oplaa_laaq",
"recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a",
"recur_if_a_a_opa_l3aq",
"recur_if_a_a_lopl3a_l3a_l3aq", "recur_if_a_a_and_a_laa_laa",
"recur_if_a_a_if_a_laa_opa_laaq",
"recur_cond_a_a_op_a_laq", "recur_cond_a_a_op_a_laaq",
"recur_cond_a_a_a_a_opla_laq", "recur_cond_a_a_a_a_oplaa_laaq",
"recur_cond_a_a_a_a_opa_laaq",
"recur_cond_a_a_a_laa_lopa_laaq", "recur_cond_a_a_a_laa_opa_laaq",
"recur_and_a_or_a_laa_laa",
};
#define is_safe_c_op(op) ((op >= OP_SAFE_C_NC) && (op < OP_THUNK))
#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_NP))
#define is_h_safe_c_d(P) (optimize_op(P) == HOP_SAFE_C_NC)
#define is_safe_c_s(P) ((optimize_op(P) == OP_SAFE_C_S) || (optimize_op(P) == HOP_SAFE_C_S))
#define is_h_safe_c_s(P) (optimize_op(P) == HOP_SAFE_C_S)
#define FIRST_UNHOPPABLE_OP OP_APPLY_SS
static bool is_h_optimized(s7_pointer p)
{
return ((is_optimized(p)) && (op_has_hop(p)) && (optimize_op(p) < FIRST_UNHOPPABLE_OP) && /* was OP_S? */
(optimize_op(p) > OP_GC_PROTECT));
}
/* -------------------------------- internal debugging apparatus -------------------------------- */
static int64_t heap_location(s7_scheme * sc, s7_pointer p)
{
heap_block_t *hp;
for (hp = sc->heap_blocks; hp; hp = hp->next)
if (((intptr_t) p >= hp->start) && ((intptr_t) p < hp->end))
return (hp->offset +
(((intptr_t) p - hp->start) / sizeof(s7_cell)));
return (((s7_big_pointer) p)->big_hloc);
}
#if TRAP_SEGFAULT
#include <signal.h>
static Jmp_Buf senv; /* global here is not a problem -- it is used only to protect s7_is_valid */
static volatile sig_atomic_t can_jump = 0;
static void segv(int32_t ignored)
{
if (can_jump)
LongJmp(senv, 1);
}
#endif
bool s7_is_valid(s7_scheme * sc, s7_pointer arg)
{
bool result = false;
if (!arg)
return (false);
#if TRAP_SEGFAULT
if (SetJmp(senv, 1) == 0) {
void (*old_segv)(int32_t sig);
can_jump = 1;
old_segv = signal(SIGSEGV, segv);
#endif
if ((unchecked_type(arg) > T_FREE) &&
(unchecked_type(arg) < NUM_TYPES)) {
if (!in_heap(arg))
result = true;
else {
int64_t loc;
loc = heap_location(sc, arg);
if ((loc >= 0) && (loc < sc->heap_size))
result = (sc->heap[loc] == arg);
}
}
#if TRAP_SEGFAULT
signal(SIGSEGV, old_segv);
} else
result = false;
can_jump = 0;
#endif
return (result);
}
void s7_show_let(s7_scheme * sc)
{ /* debugging convenience */
s7_pointer olet;
for (olet = sc->curlet; is_let(T_Lid(olet)); olet = let_outlet(olet)) {
if (olet == sc->owlet)
fprintf(stderr, "(owlet): ");
else if (is_funclet(olet))
fprintf(stderr, "(%s funclet): ",
display(funclet_function(olet)));
else if (olet == sc->shadow_rootlet)
fprintf(stderr, "(shadow rootlet): ");
fprintf(stderr, "%s\n", display(olet));
}
}
#define safe_print(Code) \
do { \
bool old_open, old_stop; \
old_open = sc->has_openlets; \
old_stop = sc->stop_at_error; \
sc->has_openlets = false; \
sc->stop_at_error = false; \
Code; \
sc->stop_at_error = old_stop; \
sc->has_openlets = old_open; \
} while (0)
void s7_show_history(s7_scheme * sc)
{
#if WITH_HISTORY
if (sc->cur_code == sc->history_sink)
fprintf(stderr, "history diabled\n");
else {
int32_t i, size = sc->history_size;
s7_pointer p;
fprintf(stderr, "history:\n");
for (i = 0, p = cdr(sc->cur_code); i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */
safe_print(fprintf(stderr, "%d: %s\n", i, display_80(car(p))));
fprintf(stderr, "\n");
}
#else
fprintf(stderr, "%s\n", display(sc->cur_code));
#endif
}
#define stack_code(Stack, Loc) stack_element(Stack, Loc - 3)
#define stack_let(Stack, Loc) stack_element(Stack, Loc - 2)
#define stack_args(Stack, Loc) stack_element(Stack, Loc - 1)
#define stack_op(Stack, Loc) ((opcode_t)(stack_element(Stack, Loc)))
void s7_show_stack(s7_scheme * sc)
{
int64_t i;
fprintf(stderr, "stack:\n");
for (i = current_stack_top(sc) - 1; i >= 3; i -= 4)
fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, i)]);
}
static char *describe_type_bits(s7_scheme * sc, s7_pointer obj)
{ /* used outside S7_DEBUGGING in display_any (fallback for display_functions) */
uint64_t full_typ = full_type(obj);
uint8_t typ = unchecked_type(obj);
char *buf;
char str[900];
str[0] = '\0';
catstrs(str, 900, /* if debugging, all of these bits are being watched, so we need to access them directly */
/* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */
((full_typ & T_MULTIFORM) !=
0) ? ((is_any_closure(obj)) ? (((full_typ & T_ONE_FORM) != 0)
? " closure-one-form-has-fx" :
" closure-multiform") : " ?0?")
: "",
/* bit 9 */
((full_typ & T_SYNTACTIC) !=
0) ? (((is_pair(obj)) || (is_syntax(obj))
|| (is_normal_symbol(obj))) ? " syntactic" : " ?1?") :
"",
/* bit 10 */
((full_typ & T_SIMPLE_ARG_DEFAULTS) !=
0) ? ((is_pair(obj)) ? " simple-args|in-use"
: ((is_any_closure(obj)) ? " closure-one-form" :
" ?2?")) : "",
/* bit 11 */
((full_typ & T_OPTIMIZED) !=
0) ? ((is_c_function(obj)) ? " scope-safe" : ((is_pair(obj)) ?
" optimized" :
" ?3?")) : "",
/* bit 12 */
((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj))
|| (is_pair(obj))) ?
" safe-closure" : " ?4?")
: "",
/* bit 13 */
((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj))
|| (is_syntax(obj))) ?
" dont-eval-args" :
" ?5?") : "",
/* bit 14 */
((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj))
|| (is_either_macro(obj)))
? " expansion" : " ?6?") :
"",
/* bit 15 */
((full_typ & T_MULTIPLE_VALUE) !=
0) ? ((is_symbol(obj)) ? " matched" : ((is_pair(obj)) ?
" values|matched" :
" ?7?")) : "",
/* bit 16 */
((full_typ & T_GLOBAL) != 0) ? ((is_pair(obj)) ? " unsafe-do" :
(((is_symbol(obj))
|| (is_syntax(obj))) ?
" global" : ((is_let(obj)) ?
" dox_slot1" :
" ?8?"))) : "",
/* bit 17 */
((full_typ & T_COLLECTED) != 0) ? " collected" : "",
/* bit 18 */
((full_typ & T_LOCATION) !=
0) ? ((is_pair(obj)) ? " line-number" : ((is_input_port(obj))
? " loader-port"
: ((is_let(obj)) ?
" with-let"
: ((is_any_procedure(obj)) ? " simple-defaults" : (((is_normal_symbol(obj)) || (is_slot(obj))) ? " has-setter" : " ?10?"))))) : "",
/* bit 19 */
((full_typ & T_SHARED) !=
0) ? ((is_sequence(obj)) ? " shared" : " ?11?") : "",
/* bit 20 */
((full_typ & T_LOCAL) !=
0) ? ((is_normal_symbol(obj)) ? " local" : ((is_pair(obj)) ?
" high-c" :
" ?12?")) : "",
/* bit 21 */
((full_typ & T_SAFE_PROCEDURE) !=
0) ? ((is_applicable(obj)) ? " safe-procedure" : " ?13?") :
"",
/* bit 22 */
((full_typ & T_CHECKED) != 0) ? (((is_pair(obj))
|| (is_slot(obj))) ?
" checked" : ((is_symbol(obj))
? " all-integer"
: " ?14?")) :
"",
/* bit 23 */
((full_typ & T_UNSAFE) !=
0) ? ((is_symbol(obj)) ? " clean-symbol" : ((is_slot(obj)) ?
" has-stepper"
: ((is_pair(obj))
?
" unsafely-opt|no-float-opt"
: ((is_let
(obj)) ?
" dox-slot2"
:
" ?15?"))))
: "",
/* bit 24 */
((full_typ & T_IMMUTABLE) != 0) ? " immutable" : "",
/* bit 25 */
((full_typ & T_SETTER) !=
0) ? ((is_normal_symbol(obj)) ? " setter" : ((is_pair(obj)) ?
" allow-other-keys|no-int-opt"
: ((is_slot(obj))
?
" has-expression"
: ((is_c_function_star(obj)) ? " allow-other-keys" : " ?17?")))) : "",
/* bit 26 */
((full_typ & T_MUTABLE) !=
0) ? ((is_number(obj)) ? " mutable" : ((is_symbol(obj)) ?
" has-keyword"
: ((is_let(obj)) ?
" let-ref-fallback"
: ((is_iterator
(obj)) ?
" mark-sequence"
: ((is_slot(obj))
? " step-end"
: ((is_let
(obj)) ?
" ref-fallback"
: ((is_pair
(obj))
?
" no-opt"
:
" ?18?")))))))
: "",
/* bit 27 */
((full_typ & T_SAFE_STEPPER) !=
0) ? ((is_let(obj)) ? " set-fallback" : ((is_slot(obj)) ?
" safe-stepper"
: ((is_c_function
(obj)) ?
" maybe-safe"
: ((is_number
(obj)) ?
" print-name"
: ((is_pair
(obj)) ?
" direct-opt"
: ((is_hash_table(obj)) ? " weak-hash" : ((is_any_macro(obj)) ? " pair-macro-set" : ((is_symbol(obj)) ? " all-float" : " ?19?")))))))) : "",
/* bit 28, for c_function case see sc->apply */
((full_typ & T_COPY_ARGS) !=
0) ? (((is_pair(obj)) || (is_any_macro(obj))
|| (is_syntax(obj)) || (is_any_closure(obj))
|| (is_c_function(obj))) ? " copy-args" : " ?20?") :
"",
/* bit 29 */
((full_typ & T_GENSYM) != 0) ? ((is_let(obj)) ? " funclet" :
((is_normal_symbol(obj)) ?
" gensym" : ((is_string(obj))
?
" documented-symbol"
: ((is_hash_table
(obj)) ?
" hash-chosen"
: ((is_pair
(obj)) ?
" fx-treed"
: ((is_any_vector(obj)) ? " subvector" : ((is_slot(obj)) ? " has-pending-value" : ((is_any_closure(obj)) ? " unknopt" : " ?21?")))))))) : "",
/* bit 30 */
((full_typ & T_HAS_METHODS) !=
0) ? (((is_let(obj)) || (is_c_object(obj))
|| (is_any_closure(obj)) || (is_any_macro(obj))
|| (is_c_pointer(obj))) ? " has-methods" : " ?22?") :
"",
/* bit 31 */
((full_typ & T_ITER_OK) !=
0) ? ((is_iterator(obj)) ? " iter-ok" : ((is_pair(obj)) ?
" step-end-ok/set-implicit-ok"
: ((is_slot(obj)) ?
" in-rootlet"
: ((is_c_function
(obj)) ?
" bool-function"
: " ?23?")))) :
"",
/* bit 24+24 */
((full_typ & T_FULL_SYMCONS) !=
0) ? ((is_symbol(obj)) ? " possibly-constant"
: ((is_procedure(obj)) ? " has-let-arg"
: ((is_hash_table(obj)) ? " has-value-type"
: ((is_pair(obj)) ? " int-optable" : " ?24?")))) :
"",
/* bit 25+24 */
((full_typ & T_FULL_HAS_LET_FILE) !=
0) ? ((is_let(obj)) ? " has-let-file" : ((is_any_vector(obj))
? " typed-vector"
: ((is_hash_table
(obj)) ?
" typed-hash-table"
: ((is_c_function
(obj)) ?
" has-bool-setter"
: ((is_slot
(obj)) ?
" rest-slot"
: (((is_pair
(obj))
||
(is_closure_star
(obj)))
?
" no-defaults"
:
" ?25?"))))))
: "",
/* bit 26+24 */
((full_typ & T_FULL_DEFINER) !=
0) ? ((is_normal_symbol(obj)) ? " definer" : ((is_pair(obj)) ?
" has-fx"
: ((is_slot
(obj)) ?
" slot-defaults"
: ((is_iterator(obj)) ? " weak-hash-iterator" : ((is_hash_table(obj)) ? " has-key-type" : ((is_let(obj)) ? " maclet" : ((is_c_function(obj)) ? " func-definer" : ((is_syntax(obj)) ? " syntax-definer" : " ?26?")))))))) : "",
/* bit 27+24 */
((full_typ & T_FULL_BINDER) !=
0) ? ((is_pair(obj)) ? " tree-collected"
: ((is_hash_table(obj)) ? " simple-values"
: ((is_normal_symbol(obj)) ? " binder"
: ((is_c_function(obj)) ? " safe-args" :
" ?27?")))) : "",
/* bit 28+24 */
((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? (((is_pair(obj))
||
(is_any_closure
(obj))) ?
" very-safe-closure"
: ((is_let(obj)) ?
" baffle-let" :
" ?28?")) : "",
/* bit 29+24 */
((full_typ & T_CYCLIC) !=
0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)])
|| (is_any_closure(obj))) ? " cyclic" : " ?29?") : "",
/* bit 30+24 */
((full_typ & T_CYCLIC_SET) !=
0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)])
|| (is_any_closure(obj))) ? " cyclic-set" : " ?30?") :
"",
/* bit 31+24 */
((full_typ & T_KEYWORD) !=
0) ? ((is_symbol(obj)) ? " keyword" : " ?31?") : "",
/* bit 32+24 */
((full_typ & T_FULL_SIMPLE_ELEMENTS) !=
0) ? ((is_normal_vector(obj)) ? " simple-elements"
: ((is_hash_table(obj)) ? " simple-keys"
: ((is_normal_symbol(obj)) ? " safe-setter"
: ((is_pair(obj)) ? " float-optable"
: ((typ >=
T_C_MACRO) ? " function-simple-elements" :
" 32?"))))) : "",
/* bit 33+24 */
((full_typ & T_FULL_CASE_KEY) !=
0) ? ((is_symbol(obj)) ? " case-key" : ((is_pair(obj)) ?
" opt1-func-listed" :
" ?33?")) : "",
/* bit 34+24 */
((full_typ & T_FULL_HAS_GX) !=
0) ? ((is_pair(obj)) ? " has-gx" : " ?34?") : "",
/* bit 35+24 */
((full_typ & T_FULL_UNKNOPT) !=
0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "",
/* bit 36+24 */
((full_typ & T_FULL_SAFETY_CHECKED) !=
0) ? ((is_pair(obj)) ? " safety-checked" : " ?36?") : "",
/* bit 37+24 */
((full_typ & T_FULL_HAS_FN) !=
0) ? ((is_pair(obj)) ? " has-fn" : " ?37") : "",
/* bit 62 */
((full_typ & T_UNHEAP) != 0) ? " unheap" : "",
/* bit 63 */
((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "",
((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "",
((is_symbol(obj))
&& (((uint8_t) (symbol_type(obj) & 0xff) >= NUM_TYPES)
|| ((symbol_type(obj) & ~0xffff) !=
0))) ? " bad-symbol-type" : "", NULL);
buf = (char *) Malloc(1024);
snprintf(buf, 1024,
"type: %s? (%d), opt_op: %d, flags: #x%" PRIx64 "%s",
type_name(sc, obj, NO_ARTICLE),
typ, optimize_op(obj), full_typ, str);
return (buf);
}
/* snprintf returns the number of bytes that would have been written: (display (c-pointer 123123123 (symbol (make-string 130 #\a)))) */
#define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len))
#if S7_DEBUGGING
static bool has_odd_bits(s7_pointer obj)
{
uint64_t full_typ = full_type(obj);
if ((full_typ & UNUSED_BITS) != 0)
return (true);
if (((full_typ & T_MULTIFORM) != 0) && (!is_any_closure(obj)))
return (true);
if (((full_typ & T_KEYWORD) != 0)
&& ((!is_symbol(obj)) || (!is_global(obj)) || (is_gensym(obj))))
return (true);
if (((full_typ & T_SYNTACTIC) != 0) && (!is_syntax(obj))
&& (!is_pair(obj)) && (!is_normal_symbol(obj)))
return (true);
if (((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) && (!is_pair(obj))
&& (!is_any_closure(obj)))
return (true);
if (((full_typ & T_OPTIMIZED) != 0) && (!is_c_function(obj))
&& (!is_pair(obj)))
return (true);
if (((full_typ & T_SAFE_CLOSURE) != 0) && (!is_any_closure(obj))
&& (!is_pair(obj)))
return (true);
if (((full_typ & T_SAFE_PROCEDURE) != 0) && (!is_applicable(obj)))
return (true);
if (((full_typ & T_EXPANSION) != 0) && (!is_normal_symbol(obj))
&& (!is_either_macro(obj)))
return (true);
if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol(obj))
&& (!is_pair(obj)))
return (true);
if (((full_typ & T_GLOBAL) != 0) && (!is_pair(obj))
&& (!is_symbol(obj)) && (!is_let(obj)) && (!is_syntax(obj)))
return (true);
if (((full_typ & T_ITER_OK) != 0) && (!is_iterator(obj))
&& (!is_pair(obj)) && (!is_slot(obj)) && (!is_c_function(obj)))
return (true);
if (((full_typ & T_LOCAL) != 0) && (!is_normal_symbol(obj))
&& (!is_pair(obj)))
return (true);
if (((full_typ & T_UNSAFE) != 0) && (!is_symbol(obj))
&& (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj)))
return (true);
if (((full_typ & T_VERY_SAFE_CLOSURE) != 0) && (!is_pair(obj))
&& (!is_any_closure(obj)) && (!is_let(obj)))
return (true);
if (((full_typ & T_FULL_CASE_KEY) != 0) && (!is_symbol(obj))
&& (!is_pair(obj)))
return (true);
if (((full_typ & T_FULL_UNKNOPT) != 0) && (!is_pair(obj)))
return (true);
if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair(obj)))
return (true);
if (((full_typ & T_FULL_HAS_GX) != 0) && (!is_pair(obj))
&& (!is_any_closure(obj)))
return (true);
if (((full_typ & T_DONT_EVAL_ARGS) != 0) && (!is_any_macro(obj))
&& (!is_syntax(obj)))
return (true);
if (((full_typ & T_CHECKED) != 0) && (!is_slot(obj)) && (!is_pair(obj))
&& (!is_symbol(obj)))
return (true);
if (((full_typ & T_SHARED) != 0) && (!t_sequence_p[type(obj)])
&& (!t_structure_p[type(obj)]) && (!is_any_closure(obj)))
return (true);
if (((full_typ & T_COPY_ARGS) != 0) &&
(!is_pair(obj)) && (!is_any_macro(obj)) && (!is_any_closure(obj))
&& (!is_c_function(obj)) && (!is_syntax(obj)))
return (true);
if (((full_typ & T_FULL_SYMCONS) != 0) &&
(!is_symbol(obj)) && (!is_procedure(obj)) && (!is_let(obj))
&& (!is_hash_table(obj)) && (!is_pair(obj)))
return (true);
if (((full_typ & T_FULL_BINDER) != 0) &&
((!is_pair(obj)) && (!is_hash_table(obj))
&& (!is_normal_symbol(obj)) && (!is_c_function(obj))
&& (!is_syntax(obj))))
return (true);
if (((full_typ & T_FULL_DEFINER) != 0) &&
(!is_normal_symbol(obj)) && (!is_c_function(obj))
&& (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj))
&& (!is_hash_table(obj)) && (!is_let(obj)) && (!is_syntax(obj)))
return (true);
if (((full_typ & T_FULL_HAS_LET_FILE) != 0) &&
(!is_let(obj)) && (!is_any_vector(obj)) && (!is_hash_table(obj))
&& (!is_c_function(obj)) && (!is_slot(obj)) && (!is_pair(obj))
&& (!is_closure_star(obj)))
return (true);
if (((full_typ & T_SAFE_STEPPER) != 0) &&
(!is_let(obj)) && (!is_slot(obj)) && (!is_c_function(obj))
&& (!is_number(obj)) && (!is_pair(obj)) && (!is_hash_table(obj))
&& (!is_any_macro(obj)) && (!is_symbol(obj)))
return (true);
if (((full_typ & T_SETTER) != 0) &&
(!is_slot(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj))
&& (!is_let(obj)) && (!is_c_function_star(obj)))
return (true);
if (((full_typ & T_LOCATION) != 0) &&
(!is_pair(obj)) && (!is_input_port(obj)) && (!is_let(obj))
&& (!is_any_procedure(obj)) && (!is_symbol(obj))
&& (!is_slot(obj)))
return (true);
if (((full_typ & T_MUTABLE) != 0) &&
(!is_number(obj)) && (!is_symbol(obj)) && (!is_let(obj))
&& (!is_iterator(obj)) && (!is_slot(obj)) && (!is_let(obj))
&& (!is_pair(obj)))
return (true);
if (((full_typ & T_GENSYM) != 0) && (!is_slot(obj))
&& (!is_any_closure(obj)) && (!is_let(obj)) && (!is_symbol(obj))
&& (!is_string(obj)) && (!is_hash_table(obj)) && (!is_pair(obj))
&& (!is_any_vector(obj)))
return (true);
if (((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) &&
((!is_normal_vector(obj)) && (!is_hash_table(obj))
&& (!is_normal_symbol(obj)) && (!is_pair(obj))
&& (unchecked_type(obj) < T_C_MACRO)))
return (true);
if (((full_typ & T_CYCLIC) != 0) && (!is_simple_sequence(obj))
&& (!t_structure_p[type(obj)]) && (!is_any_closure(obj)))
return (true);
if (((full_typ & T_CYCLIC_SET) != 0) && (!is_simple_sequence(obj))
&& (!t_structure_p[type(obj)]) && (!is_any_closure(obj)))
return (true);
if (((full_typ & T_FULL_HAS_FN) != 0) && (!is_pair(obj)))
return (true);
if (is_symbol(obj)) {
if ((uint8_t) (symbol_type(obj) & 0xff) >= NUM_TYPES)
return (true);
if ((symbol_type(obj) & ~0xffff) != 0)
return (true);
}
if ((signed_type(obj) == 0) && ((full_typ & T_GC_MARK) != 0))
return (true);
return (false);
}
static const char *check_name(s7_scheme * sc, int32_t typ)
{
if ((typ >= 0) && (typ < NUM_TYPES)) {
s7_pointer p;
p = sc->prepackaged_type_names[typ];
if (is_string(p))
return (string_value(p));
}
return ("unknown type!");
}
#if REPORT_ROOTLET_REDEF
static void set_local_1(s7_scheme * sc, s7_pointer symbol,
const char *func, int32_t line)
{
if (is_global(symbol)) {
fprintf(stderr, "%s[%d]: %s%s%s in %s\n",
func, line,
BOLD_TEXT, s7_object_to_c_string(sc, symbol), UNBOLD_TEXT,
display_80(sc->cur_code));
/* gdb_break(); */
}
full_type(symbol) =
(full_type(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));
}
#endif
static char *safe_object_to_string(s7_pointer p)
{
char *buf;
buf = (char *) Malloc(128);
snprintf(buf, 128, "type: %d", unchecked_type(p));
return (buf);
}
static void complain(const char *complaint, s7_pointer p, const char *func,
int line, uint8_t typ)
{
fprintf(stderr, complaint, BOLD_TEXT, func, line,
check_name(cur_sc, typ), safe_object_to_string(p),
UNBOLD_TEXT);
if (cur_sc->stop_at_error)
abort();
}
static char *show_debugger_bits(s7_pointer obj);
static s7_pointer check_ref(s7_pointer p, uint8_t expected_type,
const char *func, int32_t line,
const char *func1, const char *func2)
{
if (!p)
fprintf(stderr, "%s[%d]: null pointer passed to check_ref\n", func,
line);
else {
uint8_t typ = unchecked_type(p);
if (typ != expected_type) {
if ((!func1) || (typ != T_FREE)) {
fprintf(stderr, "%s%s[%d]: not %s, but %s (%s)%s\n",
BOLD_TEXT,
func, line, check_name(cur_sc, expected_type),
check_name(cur_sc, typ), safe_object_to_string(p),
UNBOLD_TEXT);
if (cur_sc->stop_at_error)
abort();
} else
if ((strcmp(func, func1) != 0) &&
((!func2) || (strcmp(func, func2) != 0))) {
fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n",
BOLD_TEXT, func, line, check_name(cur_sc,
expected_type),
UNBOLD_TEXT);
if (cur_sc->stop_at_error)
abort();
}
}
}
return (p);
}
static s7_pointer check_let_ref(s7_pointer p, uint64_t role,
const char *func, int32_t line)
{
check_ref(p, T_LET, func, line, NULL, NULL);
if ((p->debugger_bits & L_HIT) == 0)
fprintf(stderr, "%s[%d]: let not set\n", func, line);
if ((p->debugger_bits & L_MASK) != role)
fprintf(stderr, "%s[%d]: let bad role\n", func, line);
return (p);
}
static s7_pointer check_let_set(s7_pointer p, uint64_t role,
const char *func, int32_t line)
{
check_ref(p, T_LET, func, line, NULL, NULL);
p->debugger_bits &= (~L_MASK);
p->debugger_bits |= (L_HIT | role);
return (p);
}
static s7_pointer check_ref2(s7_pointer p, uint8_t expected_type,
int32_t other_type, const char *func,
int32_t line, const char *func1,
const char *func2)
{
if (!p)
fprintf(stderr, "%s[%d]: null pointer passed to check_ref2\n",
func, line);
else {
uint8_t 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, int32_t line)
{
uint8_t typ = unchecked_type(p);
if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT) && (typ != T_FREE))
complain("%s%s[%d]: not a port, but %s (%s)%s\n", p, func, line,
typ);
return (p);
}
static s7_pointer check_ref4(s7_pointer p, const char *func, int32_t line)
{
if ((strcmp(func, "sweep") != 0) &&
(strcmp(func, "process_multivector") != 0)) {
uint8_t typ = unchecked_type(p);
if (!t_vector_p[typ])
complain("%s%s[%d]: not a vector, but %s (%s)%s\n", p, func,
line, typ);
}
return (p);
}
static s7_pointer check_ref5(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ = unchecked_type(p);
if (!t_has_closure_let[typ])
complain("%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, line,
typ);
return (p);
}
static s7_pointer check_ref6(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ = unchecked_type(p);
if (typ < T_C_MACRO)
complain("%s%s[%d]: not a c function, but %s (%s)%s\n", p, func,
line, typ);
return (p);
}
static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ = unchecked_type(p);
if ((typ < T_INTEGER) || (typ > T_COMPLEX))
complain("%s%s[%d]: not a number, but %s (%s)%s\n", p, func, line,
typ);
return (p);
}
static s7_pointer check_ref8(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ = unchecked_type(p);
if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && (!is_any_closure(p))) /* closure as iterator -- see s7test */
complain("%s%s[%d]: not a sequence or structure, but %s (%s)%s\n",
p, func, line, typ);
return (p);
}
static s7_pointer check_ref9(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ = unchecked_type(p);
if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure(p))
&& (!is_any_macro(p)) && (typ != T_C_POINTER))
complain("%s%s[%d]: not a possible method holder, but %s (%s)%s\n",
p, func, line, typ);
return (p);
}
static s7_pointer check_ref10(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ = unchecked_type(p);
if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL))
complain("%s%s[%d]: arglist is %s (%s)%s?\n", p, func, line, typ);
return (p);
}
static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ = unchecked_type(p);
if ((!t_applicable_p[typ]) && (p != cur_sc->F))
complain("%s%s[%d]: applicable object is %s (%s)%s?\n", p, func,
line, typ);
return (p);
}
static s7_pointer check_ref12(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ;
if (is_slot_end(p))
return (p);
typ = unchecked_type(p);
if ((typ != T_SLOT) && (typ != T_NIL)) /* unset slots are nil */
complain("%s%s[%d]: slot is %s (%s)%s?\n", p, func, line, typ);
return (p);
}
static s7_pointer check_ref13(s7_pointer p, const char *func, int32_t line)
{
if (!is_any_vector(p))
complain("%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line,
unchecked_type(p));
if (!is_subvector(p))
complain
("%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p,
func, line, unchecked_type(p));
return (p);
}
static s7_pointer check_ref14(s7_pointer p, const char *func, int32_t line)
{
if ((!is_any_procedure(p)) && (!s7_is_boolean(p)))
complain("%s%s[%d]: procedure setter is %s (%s)%s?\n", p, func,
line, unchecked_type(p));
return (p);
}
static s7_pointer check_ref15(s7_pointer p, const char *func, int32_t line)
{ /* called in mark_let so s7_scheme* for cur_sc is difficult */
uint8_t typ;
check_nref(p, func, line);
typ = unchecked_type(p);
if ((is_multiple_value(p)) && (!safe_strcmp(func, "mark_slot"))) /* match == multiple-values which causes false error messages */
complain("%s%s[%d]: slot value is a multiple-value, %s (%s)%s?\n",
p, func, line, typ);
if (has_odd_bits(p)) {
char *s;
fprintf(stderr, "odd bits: %s\n", s =
describe_type_bits(cur_sc, p));
free(s);
}
return (p);
}
static s7_pointer check_ref16(s7_pointer p, const char *func, int32_t line)
{
uint8_t typ;
check_nref(p, func, line);
typ = unchecked_type(p);
if ((typ != T_LET) && (typ != T_NIL))
complain("%s%s[%d]: not a let or nil, but %s (%s)%s\n", p, func,
line, typ);
return (p);
}
static s7_pointer check_ref17(s7_pointer p, const char *func, int32_t line)
{
if ((!is_any_macro(p)) || (is_c_macro(p)))
complain("%s%s[%d]: macro is %s (%s)%s?\n", p, func, line,
unchecked_type(p));
return (p);
}
static s7_pointer check_cell(s7_scheme * sc, s7_pointer p,
const char *func, int32_t line)
{
if (!p) {
fprintf(stderr, "%s%s[%d]: null pointer!%s\n", BOLD_TEXT, func,
line, UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
} else if (unchecked_type(p) >= NUM_TYPES) {
fprintf(stderr,
"%s%s[%d]: attempt to use messed up cell (type: %d)%s\n",
BOLD_TEXT, func, line, unchecked_type(p), UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
return (p);
}
static void print_gc_info(s7_scheme * sc, s7_pointer obj, int32_t line)
{
if (!obj)
fprintf(stderr, "[%d]: obj is %p\n", line, obj);
else if (unchecked_type(obj) != T_FREE)
fprintf(stderr, "[%d]: %p type is %d?\n", line, obj,
unchecked_type(obj));
else {
s7_int free_type;
char *bits;
char fline[128];
free_type = full_type(obj);
full_type(obj) = obj->current_alloc_type;
printing_gc_info = true;
bits = describe_type_bits(sc, obj); /* this func called in type macro */
printing_gc_info = false;
full_type(obj) = free_type;
if (obj->explicit_free_line > 0)
snprintf(fline, 128, ", freed at %d, ",
obj->explicit_free_line);
fprintf(stderr,
"%s%p is free (line %d, alloc type: %s %" ld64 " #x%"
PRIx64
" (%s)), current: %s[%d], previous: %s[%d], %sgc: %s[%d]%s\n",
BOLD_TEXT, obj, line,
s7_type_names[obj->current_alloc_type & 0xff],
obj->current_alloc_type, obj->current_alloc_type, bits,
obj->current_alloc_func, obj->current_alloc_line,
obj->previous_alloc_func, obj->previous_alloc_line,
(obj->explicit_free_line > 0) ? fline : "", obj->gc_func,
obj->gc_line, UNBOLD_TEXT);
free(bits);
}
if (sc->stop_at_error)
abort();
}
static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line)
{
check_cell(cur_sc, p, func, line);
if (unchecked_type(p) == T_FREE) {
fprintf(stderr, "%s%s[%d]: attempt to use free cell%s\n",
BOLD_TEXT, func, line, UNBOLD_TEXT);
print_gc_info(cur_sc, p, line);
}
return (p);
}
static const char *opt1_role_name(uint64_t role)
{
if (role == OPT1_FAST)
return ("opt1_fast");
if (role == OPT1_CFUNC)
return ("opt1_cfunc");
if (role == OPT1_LAMBDA)
return ("opt_lambda");
if (role == OPT1_CLAUSE)
return ("opt1_clause");
if (role == OPT1_SYM)
return ("opt1_sym");
if (role == OPT1_PAIR)
return ("opt1_pair");
if (role == OPT1_CON)
return ("opt1_con");
if (role == OPT1_ANY)
return ("opt1_any");
return ((role == OPT1_HASH) ? "opt1_hash" : "opt1_unknown");
}
static const char *opt2_role_name(uint64_t role)
{
if (role == OPT2_FX)
return ("opt2_fx");
if (role == OPT2_FN)
return ("opt2_fn");
if (role == OPT2_KEY)
return ("opt2_any");
if (role == OPT2_SLOW)
return ("opt2_slow");
if (role == OPT2_SYM)
return ("opt2_sym");
if (role == OPT2_PAIR)
return ("opt2_pair");
if (role == OPT2_CON)
return ("opt2_con");
if (role == OPT2_LAMBDA)
return ("opt2_lambda");
if (role == OPT2_DIRECT)
return ("opt2_direct");
if (role == OPT2_INT)
return ("opt2_int");
return ((role == OPT2_NAME) ? "opt2_raw_name" : "opt2_unknown");
}
static const char *opt3_role_name(uint64_t role)
{
if (role == OPT3_ARGLEN)
return ("opt3_arglen");
if (role == OPT3_SYM)
return ("opt3_sym");
if (role == OPT3_CON)
return ("opt3_con");
if (role == OPT3_AND)
return ("opt3_pair");
if (role == OPT3_ANY)
return ("opt3_any");
if (role == OPT3_LET)
return ("opt3_let");
if (role == OPT3_BYTE)
return ("opt3_byte");
if (role == OPT3_DIRECT)
return ("direct_opt3");
if (role == OPT3_LEN)
return ("opt3_len");
if (role == OPT3_INT)
return ("opt3_int");
return ((role == OPT3_LOCATION) ? "opt3_location" : "opt3_unknown");
}
static char *show_debugger_bits(s7_pointer p)
{
char *bits_str;
int64_t bits = p->debugger_bits;
bits_str = (char *) Malloc(512);
snprintf(bits_str, 512,
" %s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s",
((bits & OPT1_SET) != 0) ? " opt1_set" : "",
((bits & OPT1_FAST) != 0) ? " opt1_fast" : "",
((bits & OPT1_CFUNC) != 0) ? " opt1_cfunc" : "",
((bits & OPT1_CLAUSE) != 0) ? " opt1_clause" : "",
((bits & OPT1_LAMBDA) != 0) ? " opt_lambda" : "",
((bits & OPT1_SYM) != 0) ? " opt1_sym" : "",
((bits & OPT1_PAIR) != 0) ? " opt1_pair" : "",
((bits & OPT1_CON) != 0) ? " opt1_con" : "",
((bits & OPT1_ANY) != 0) ? " opt1_any" : "",
((bits & OPT1_HASH) != 0) ? " opt1_raw_hash" : "",
((bits & OPT2_SET) != 0) ? " opt2_set" : "",
((bits & OPT2_KEY) != 0) ? " opt2_any" : "",
((bits & OPT2_SLOW) != 0) ? " opt2_slow" : "",
((bits & OPT2_SYM) != 0) ? " opt2_sym" : "",
((bits & OPT2_PAIR) != 0) ? " opt2_pair" : "",
((bits & OPT2_CON) != 0) ? " opt2_con" : "",
((bits & OPT2_FX) != 0) ? " opt2_fx" : "",
((bits & OPT2_FN) != 0) ? " opt2_fn" : "",
((bits & OPT2_LAMBDA) != 0) ? " opt2_lambda" : "",
((bits & OPT2_DIRECT) != 0) ? " opt2_direct" : "",
((bits & OPT2_NAME) != 0) ? " opt2_raw_name" : "",
((bits & OPT2_INT) != 0) ? " opt2_int" : "",
((bits & OPT3_SET) != 0) ? " opt3_set" : "",
((bits & OPT3_ARGLEN) != 0) ? " opt3_arglen" : "",
((bits & OPT3_SYM) != 0) ? " opt3_sym" : "",
((bits & OPT3_CON) != 0) ? " opt3_con" : "",
((bits & OPT3_AND) != 0) ? " opt3_pair " : "",
((bits & OPT3_ANY) != 0) ? " opt3_any " : "",
((bits & OPT3_LET) != 0) ? " opt3_let " : "",
((bits & OPT3_BYTE) != 0) ? " opt3_byte " : "",
((bits & OPT3_DIRECT) != 0) ? " opt3_direct" : "",
((bits & OPT3_LOCATION) != 0) ? " opt3_location" : "",
((bits & OPT3_LEN) != 0) ? " opt3_len" : "",
((bits & OPT3_INT) != 0) ? " opt3_int" : "",
((bits & L_HIT) != 0) ? " let_set" : "",
((bits & L_FUNC) != 0) ? " let_func" : "",
((bits & L_DOX) != 0) ? " let_dox" : "",
((bits & L_CATCH) != 0) ? " let_catch" : "");
return (bits_str);
}
static void show_opt1_bits(s7_pointer p, const char *func, int32_t line,
uint64_t role)
{
char *bits;
bits = show_debugger_bits(p);
fprintf(stderr,
"%s%s[%d]%s: opt1: %p->%p wants %s, debugger bits are %" PRIx64
"%s but expects %lx", BOLD_TEXT, func, line, UNBOLD_TEXT, p,
p->object.cons.opt1, opt1_role_name(role), p->debugger_bits,
bits, role);
free(bits);
}
static s7_pointer opt1_1(s7_scheme * sc, s7_pointer p, uint64_t role,
const char *func, int32_t line)
{
if ((!opt1_is_set(p)) ||
((!opt1_role_matches(p, role)) && (role != OPT1_ANY))) {
show_opt1_bits(p, func, line, role);
if (sc->stop_at_error)
abort();
}
return (p->object.cons.opt1);
}
static void base_opt1(s7_pointer p, uint64_t role)
{
set_opt1_role(p, role);
set_opt1_is_set(p);
}
static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, uint64_t role)
{
/* if ((opt1_role_matches(p, OPT1_LAMBDA)) && (role != OPT1_LAMBDA)) fprintf(stderr, "reset opt1_lambda to %s\n", opt1_role_name(role)); */
p->object.cons.opt1 = x;
base_opt1(p, role);
return (x);
}
static uint64_t opt1_hash_1(s7_scheme * sc, s7_pointer p, const char *func,
int32_t line)
{
if ((!opt1_is_set(p)) || (!opt1_role_matches(p, OPT1_HASH))) {
show_opt1_bits(p, func, line, (uint64_t) OPT1_HASH);
if (sc->stop_at_error)
abort();
}
return (p->object.sym_cons.hash);
}
static void set_opt1_hash_1(s7_pointer p, uint64_t x)
{
p->object.sym_cons.hash = x;
base_opt1(p, OPT1_HASH);
}
static void show_opt2_bits(s7_pointer p, const char *func, int32_t line,
uint64_t role)
{
char *bits;
bits = show_debugger_bits(p);
fprintf(stderr,
"%s%s[%d]%s: opt2: %p->%p wants %s, debugger bits are %" PRIx64
"%s but expects %lx %s", BOLD_TEXT, func, line, UNBOLD_TEXT, p,
p->object.cons.opt2, opt2_role_name(role), p->debugger_bits,
bits, role, opt2_role_name(role));
free(bits);
}
static bool f_call_func_mismatch(const char *func)
{
return ((!safe_strcmp(func, "check_and")) && /* these reflect set_fx|unchecked where the destination checks for null fx_proc */
(!safe_strcmp(func, "check_or")) &&
(!safe_strcmp(func, "eval")) &&
(!safe_strcmp(func, "set_any_c_np")) &&
(!safe_strcmp(func, "set_any_closure_np")) &&
(!safe_strcmp(func, "optimize_func_two_args")) &&
(!safe_strcmp(func, "optimize_func_many_args")) &&
(!safe_strcmp(func, "optimize_func_three_args")) &&
(!safe_strcmp(func, "fx_c_ff")) &&
(!safe_strcmp(func, "op_map_for_each_fa")) &&
(!safe_strcmp(func, "op_map_for_each_faa")));
}
static s7_pointer opt2_1(s7_scheme * sc, s7_pointer p, uint64_t role,
const char *func, int32_t line)
{
if (!p) {
fprintf(stderr, "%s%s[%d]: opt2 null!\n%s", BOLD_TEXT, func, line,
UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
if ((!opt2_is_set(p)) || (!opt2_role_matches(p, role))) {
show_opt2_bits(p, func, line, role);
if (sc->stop_at_error)
abort();
}
return (p->object.cons.opt2);
}
static void base_opt2(s7_pointer p, uint64_t role)
{
set_opt2_role(p, role);
set_opt2_is_set(p);
}
static void set_opt2_1(s7_scheme * sc, s7_pointer p, s7_pointer x,
uint64_t role, const char *func, int32_t line)
{
if ((role == OPT2_FX) && (x == NULL) && (f_call_func_mismatch(func)))
fprintf(stderr, "%s[%d]: set fx_proc for %s to null (%s%s%s)\n",
func, line,
string_value(object_to_truncated_string(sc, p, 80)),
((is_h_optimized(car(p)))
&& (is_safe_c_op(optimize_op(car(p))))) ? BOLD_TEXT : "",
op_names[optimize_op(car(p))], ((is_h_optimized(car(p)))
&&
(is_safe_c_op
(optimize_op(car(p))))) ?
UNBOLD_TEXT : "");
if ((role != OPT2_FX) && (role != OPT2_DIRECT) && (has_fx(p))) /* sometimes opt2_direct just specializes fx */
fprintf(stderr, "%s[%d]: overwrite has_fx: %s %s\n", func, line,
opt2_role_name(role), display_80(p));
p->object.cons.opt2 = x;
base_opt2(p, role);
}
static const char *opt2_name_1(s7_scheme * sc, s7_pointer p,
const char *func, int32_t line)
{
if ((!opt2_is_set(p)) || (!opt2_role_matches(p, OPT2_NAME))) {
show_opt2_bits(p, func, line, (uint64_t) OPT2_NAME);
if (sc->stop_at_error)
abort();
}
return (p->object.sym_cons.fstr);
}
static void set_opt2_name_1(s7_pointer p, const char *str)
{
p->object.sym_cons.fstr = str;
base_opt2(p, OPT2_NAME);
}
static void show_opt3_bits(s7_pointer p, const char *func, int32_t line,
uint64_t role)
{
char *bits;
bits = show_debugger_bits(p);
fprintf(stderr, "%s%s[%d]%s: opt3: %s %" PRIx64 "%s", BOLD_TEXT, func,
line, UNBOLD_TEXT, opt3_role_name(role), p->debugger_bits,
bits);
free(bits);
}
static void check_opt3_bits(s7_scheme * sc, s7_pointer p, uint64_t role,
const char *func, int32_t line)
{
if ((!opt3_is_set(p)) || (!opt3_role_matches(p, role))) {
show_opt3_bits(p, func, line, role);
if (sc->stop_at_error)
abort();
}
}
static s7_pointer opt3_1(s7_scheme * sc, s7_pointer p, uint64_t role,
const char *func, int32_t line)
{
check_opt3_bits(sc, p, role, func, line);
return (p->object.cons.opt3);
}
static void base_opt3(s7_pointer p, uint64_t role)
{
set_opt3_role(p, role);
set_opt3_is_set(p);
}
static void set_opt3_1(s7_pointer p, s7_pointer x, uint64_t role)
{
clear_type_bit(p, T_LOCATION);
p->object.cons.opt3 = x;
base_opt3(p, role);
}
static uint8_t opt3_byte_1(s7_scheme * sc, s7_pointer p, uint64_t role,
const char *func, int32_t line)
{
check_opt3_bits(sc, p, role, func, line);
return (p->object.cons_ext.opt_type);
}
static void set_opt3_byte_1(s7_pointer p, uint8_t x, uint64_t role,
const char *func, int32_t line)
{
clear_type_bit(p, T_LOCATION);
p->object.cons_ext.opt_type = x;
base_opt3(p, role);
}
static uint64_t opt3_location_1(s7_scheme * sc, s7_pointer p,
const char *func, int32_t line)
{
if ((!opt3_is_set(p)) ||
((p->debugger_bits & OPT3_LOCATION) == 0) || (!has_location(p))) {
show_opt3_bits(p, func, line, (uint64_t) OPT3_LOCATION);
if (sc->stop_at_error)
abort();
}
return (p->object.sym_cons.location);
}
static void set_opt3_location_1(s7_pointer p, uint64_t x)
{
p->object.sym_cons.location = x;
(p)->debugger_bits = (OPT3_LOCATION | (p->debugger_bits & ~OPT3_LEN)); /* turn on line, cancel len */
set_opt3_is_set(p);
}
static uint64_t opt3_len_1(s7_scheme * sc, s7_pointer p, const char *func,
int32_t line)
{
if ((!opt3_is_set(p)) ||
((p->debugger_bits & OPT3_LEN) == 0) || (has_location(p))) {
show_opt3_bits(p, func, line, (uint64_t) OPT3_LEN);
if (sc->stop_at_error)
abort();
}
return (p->object.sym_cons.location);
}
static void set_opt3_len_1(s7_pointer p, uint64_t x)
{
clear_type_bit(p, T_LOCATION);
p->object.sym_cons.location = x;
(p)->debugger_bits =
(OPT3_LEN | (p->debugger_bits & ~(OPT3_LOCATION)));
set_opt3_is_set(p);
}
static void print_debugging_state(s7_scheme * sc, s7_pointer obj,
s7_pointer port)
{
/* show current state, current allocated state, and previous allocated state */
char *current_bits, *allocated_bits, *previous_bits, *str;
int64_t save_full_type;
s7_int len, nlen;
const char *excl_name;
block_t *b;
excl_name = (is_free(obj)) ? "free cell!" : "unknown object!";
current_bits = describe_type_bits(sc, obj);
save_full_type = full_type(obj);
full_type(obj) = obj->current_alloc_type;
allocated_bits = describe_type_bits(sc, obj);
full_type(obj) = obj->previous_alloc_type;
previous_bits = describe_type_bits(sc, obj);
full_type(obj) = save_full_type;
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;
b = mallocate(sc, len);
str = (char *) block_data(b);
nlen = snprintf(str, len,
"\n<%s %s,\n current: %s[%d] %s,\n previous: %s[%d] %s\n %d uses>",
excl_name, current_bits,
obj->current_alloc_func, obj->current_alloc_line,
allocated_bits, obj->previous_alloc_func,
obj->previous_alloc_line, previous_bits, obj->uses);
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, clamp_length(nlen, len), port);
liberate(sc, b);
}
static s7_pointer symbol_to_local_slot(s7_scheme * sc, s7_pointer symbol,
s7_pointer e);
static s7_pointer check_null_sym(s7_scheme * sc, s7_pointer p,
s7_pointer sym, int32_t line,
const char *func)
{
if (!p) {
s7_pointer slot;
char *s;
fprintf(stderr, "%s%s[%d]: %s unbound%s\n", BOLD_TEXT, func, line,
symbol_name(sym), UNBOLD_TEXT);
fprintf(stderr,
" symbol_id: %" ld64 ", let_id: %" ld64 ", bits: %s",
symbol_id(sym), let_id(sc->curlet), s =
describe_type_bits(sc, sym));
free(s);
slot = symbol_to_local_slot(sc, sym, sc->curlet);
if (is_slot(slot))
fprintf(stderr, ", slot: %s", display(slot));
fprintf(stderr, "\n");
if (sc->stop_at_error)
abort();
}
return (p);
}
#endif /* S7_DEBUGGING */
/* -------------------------------- end internal debugging apparatus -------------------------------- */
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_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_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_car(sc->plist_2_2, x2);
return (sc->plist_2);
}
static s7_pointer set_plist_3(s7_scheme * sc, s7_pointer x1, s7_pointer x2,
s7_pointer x3)
{
return (set_wlist_3(sc->plist_3, x1, x2, x3));
}
static s7_pointer set_qlist_2(s7_scheme * sc, s7_pointer x1, s7_pointer x2)
{
set_car(sc->qlist_2, x1);
set_cadr(sc->qlist_2, x2);
return (sc->qlist_2);
}
static s7_pointer set_qlist_3(s7_scheme * sc, s7_pointer x1, s7_pointer x2,
s7_pointer x3)
{
set_car(sc->qlist_3, x1);
set_cadr(sc->qlist_3, x2);
set_caddr(sc->qlist_3, x3);
return (sc->qlist_3);
}
static s7_pointer set_clist_1(s7_scheme * sc, s7_pointer x1)
{ /* for c_object length method etc, a "weak" list */
set_car(sc->clist_1, x1);
return (sc->clist_1);
}
static s7_pointer set_dlist_1(s7_scheme * sc, s7_pointer x1)
{ /* another like clist: temp usage, "weak" (not gc_marked), but permanent list */
set_car(sc->dlist_1, x1);
return (sc->dlist_1);
}
static s7_pointer set_ulist_1(s7_scheme * sc, s7_pointer x1, s7_pointer x2)
{
set_car(sc->u1_1, x1);
set_cdr(sc->u1_1, x2);
return (sc->u1_1);
}
static s7_pointer set_ulist_2(s7_scheme * sc, s7_pointer x1, s7_pointer x2,
s7_pointer x3)
{
set_car(sc->u2_1, x1);
set_car(sc->u2_2, x2);
set_cdr(sc->u2_2, x3);
return (sc->u2_1);
}
static int32_t position_of(s7_pointer p, s7_pointer args)
{
int32_t i;
for (i = 1; p != args; i++, args = cdr(args));
return (i);
}
#define call_method(Sc, Obj, Method, Args) s7_apply_function(Sc, Method, Args)
s7_pointer s7_method(s7_scheme * sc, s7_pointer obj, s7_pointer method)
{
if (has_active_methods(sc, obj))
return (find_method_with_let(sc, obj, method));
return (sc->undefined);
}
/* if a method is shadowing a built-in like abs, it should expect the same args as abs and behave the same -- no multiple values etc. */
#define check_method(Sc, Obj, Method, Args) \
{ \
s7_pointer func; \
if ((has_active_methods(Sc, Obj)) && \
((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \
return(call_method(Sc, Obj, func, Args)); \
}
static s7_pointer apply_boolean_method(s7_scheme * sc, s7_pointer obj,
s7_pointer method)
{
s7_pointer func;
func = find_method_with_let(sc, obj, method);
if (func == sc->undefined)
return (sc->F);
return (call_method(sc, obj, func, set_plist_1(sc, obj)));
}
static s7_pointer missing_method_error(s7_scheme * sc, s7_pointer method,
s7_pointer obj)
{
return (s7_error
(sc, sc->missing_method_symbol,
set_elist_3(sc, missing_method_string, method, obj)));
}
#define check_boolean_method(Sc, Checker, Method, Args) \
{ \
s7_pointer p = car(Args); \
if (Checker(p)) return(Sc->T); \
if (!has_active_methods(Sc, p)) return(Sc->F); \
return(apply_boolean_method(Sc, p, Method)); \
}
static s7_pointer find_and_apply_method(s7_scheme * sc, s7_pointer obj,
s7_pointer sym, s7_pointer args)
{
s7_pointer func;
func = find_method_with_let(sc, obj, sym);
if (func != sc->undefined)
return (call_method(sc, obj, func, args));
return (missing_method_error(sc, sym, obj));
}
static s7_pointer method_or_bust(s7_scheme * sc, s7_pointer obj,
s7_pointer method, s7_pointer args,
uint8_t typ, int32_t num)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method(sc, obj, method, args));
return (wrong_type_argument(sc, method, num, obj, typ));
}
static s7_pointer method_or_bust_p(s7_scheme * sc, s7_pointer obj,
s7_pointer method, uint8_t typ)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method
(sc, obj, method, set_plist_1(sc, obj)));
return (wrong_type_argument(sc, method, 1, obj, typ));
}
static s7_pointer method_or_bust_pp(s7_scheme * sc, s7_pointer obj,
s7_pointer method, s7_pointer x1,
s7_pointer x2, uint8_t typ,
int32_t num)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method
(sc, obj, method, set_plist_2(sc, x1, x2)));
return (wrong_type_argument(sc, method, num, obj, typ));
}
static s7_pointer method_or_bust_ppp(s7_scheme * sc, s7_pointer obj,
s7_pointer method, s7_pointer x1,
s7_pointer x2, s7_pointer x3,
uint8_t typ, int32_t num)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method
(sc, obj, method, set_plist_3(sc, x1, x2, x3)));
return (wrong_type_argument(sc, method, num, obj, typ));
}
static s7_pointer immutable_object_error(s7_scheme * sc, s7_pointer info)
{
return (s7_error(sc, sc->immutable_error_symbol, info));
}
static s7_pointer mutable_method_or_bust(s7_scheme * sc, s7_pointer obj,
s7_pointer method,
s7_pointer args, uint8_t typ,
int32_t num)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method(sc, obj, method, args));
if (type(obj) != typ)
return (wrong_type_argument(sc, method, num, obj, typ));
if (is_immutable(obj))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string, method, obj)));
return (wrong_type_argument(sc, method, num, obj, typ));
}
static s7_pointer mutable_method_or_bust_ppp(s7_scheme * sc,
s7_pointer obj,
s7_pointer method,
s7_pointer x1, s7_pointer x2,
s7_pointer x3, uint8_t typ,
int32_t num)
{
return (mutable_method_or_bust
(sc, obj, method, set_plist_3(sc, x1, x2, x3), typ, num));
}
static s7_pointer method_or_bust_one_arg(s7_scheme * sc, s7_pointer obj,
s7_pointer method,
s7_pointer args, uint8_t typ)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method(sc, obj, method, args));
return (simple_wrong_type_argument(sc, method, obj, typ));
}
static s7_pointer method_or_bust_one_arg_p(s7_scheme * sc, s7_pointer obj,
s7_pointer method, uint8_t typ)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method
(sc, obj, method, set_plist_1(sc, obj)));
return (simple_wrong_type_argument(sc, method, obj, typ));
}
static s7_pointer method_or_bust_with_type(s7_scheme * sc, s7_pointer obj,
s7_pointer method,
s7_pointer args, s7_pointer typ,
int32_t num)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method(sc, obj, method, args));
return (wrong_type_argument_with_type(sc, method, num, obj, typ));
}
static s7_pointer method_or_bust_with_type_pp(s7_scheme * sc,
s7_pointer obj,
s7_pointer method,
s7_pointer x1, s7_pointer x2,
s7_pointer typ, int32_t num)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method
(sc, obj, method, set_plist_2(sc, x1, x2)));
return (wrong_type_argument_with_type(sc, method, num, obj, typ));
}
static s7_pointer method_or_bust_with_type_pi(s7_scheme * sc,
s7_pointer obj,
s7_pointer method,
s7_pointer x1, s7_int x2,
s7_pointer typ)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method
(sc, obj, method,
set_plist_2(sc, x1, make_integer(sc, x2))));
return (wrong_type_argument_with_type(sc, method, 1, obj, typ));
}
static s7_pointer method_or_bust_with_type_pf(s7_scheme * sc,
s7_pointer obj,
s7_pointer method,
s7_pointer x1, s7_double x2,
s7_pointer typ)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method
(sc, obj, method, set_plist_2(sc, x1, make_real(sc, x2))));
return (wrong_type_argument_with_type(sc, method, 1, obj, typ));
}
static s7_pointer method_or_bust_with_type_one_arg(s7_scheme * sc,
s7_pointer obj,
s7_pointer method,
s7_pointer args,
s7_pointer typ)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method(sc, obj, method, args));
return (simple_wrong_type_argument_with_type(sc, method, obj, typ));
}
static s7_pointer method_or_bust_with_type_one_arg_p(s7_scheme * sc,
s7_pointer obj,
s7_pointer method,
s7_pointer typ)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method
(sc, obj, method, set_plist_1(sc, obj)));
return (simple_wrong_type_argument_with_type(sc, method, obj, typ));
}
#define eval_error_any(Sc, ErrType, ErrMsg, Len, Obj) \
s7_error(Sc, ErrType, set_elist_2(Sc, wrap_string(Sc, ErrMsg, Len), Obj))
#define eval_error(Sc, ErrMsg, Len, Obj) \
eval_error_any(Sc, Sc->syntax_error_symbol, ErrMsg, Len, Obj)
#define eval_error_with_caller(Sc, ErrMsg, Len, Caller, Obj) \
s7_error(Sc, Sc->syntax_error_symbol, set_elist_3(Sc, wrap_string(Sc, ErrMsg, Len), Caller, Obj))
#define eval_error_with_caller2(Sc, ErrMsg, Len, Caller, Name, Obj) \
s7_error(Sc, Sc->syntax_error_symbol, set_elist_4(Sc, wrap_string(Sc, ErrMsg, Len), Caller, Name, Obj))
/* -------------------------------- constants -------------------------------- */
/* #f and #t */
s7_pointer s7_f(s7_scheme * sc)
{
return (sc->F);
}
s7_pointer s7_t(s7_scheme * sc)
{
return (sc->T);
}
/* () */
s7_pointer s7_nil(s7_scheme * sc)
{
return (sc->nil);
}
bool s7_is_null(s7_scheme * sc, s7_pointer p)
{
return (is_null(p));
}
static bool is_null_b_p(s7_pointer p)
{
return (type(p) == T_NIL);
} /* faster than b_7p because opt_b_p is faster */
static s7_pointer g_is_null(s7_scheme * sc, s7_pointer args)
{
#define H_is_null "(null? obj) returns #t if obj is the empty list"
#define Q_is_null sc->pl_bt
check_boolean_method(sc, is_null, sc->is_null_symbol, args);
}
/* #<undefined> and #<unspecified> */
s7_pointer s7_undefined(s7_scheme * sc)
{
return (sc->undefined);
}
s7_pointer s7_unspecified(s7_scheme * sc)
{
return (sc->unspecified);
}
bool s7_is_unspecified(s7_scheme * sc, s7_pointer val)
{
return (is_unspecified(val));
}
static s7_pointer g_is_undefined(s7_scheme * sc, s7_pointer args)
{
#define H_is_undefined "(undefined? val) returns #t if val is #<undefined> or its reader equivalent"
#define Q_is_undefined sc->pl_bt
check_boolean_method(sc, is_undefined, sc->is_undefined_symbol, args);
}
static s7_pointer g_is_unspecified(s7_scheme * sc, s7_pointer args)
{
#define H_is_unspecified "(unspecified? val) returns #t if val is #<unspecified>"
#define Q_is_unspecified sc->pl_bt
check_boolean_method(sc, is_unspecified, sc->is_unspecified_symbol,
args);
}
/* -------------------------------- eof-object? -------------------------------- */
s7_pointer eof_object = NULL; /* #<eof> is an entry in the chars array, so it's not a part of sc */
s7_pointer s7_eof_object(s7_scheme * sc)
{
return (eof_object);
}
static s7_pointer g_is_eof_object(s7_scheme * sc, s7_pointer args)
{
#define H_is_eof_object "(eof-object? val) returns #t if val is the end-of-file object"
#define Q_is_eof_object sc->pl_bt
check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args);
}
static bool is_eof_object_b_p(s7_pointer p)
{
return (p == eof_object);
}
/* -------------------------------- not -------------------------------- */
static bool not_b_7p(s7_scheme * sc, s7_pointer p)
{
return (p == sc->F);
}
bool s7_boolean(s7_scheme * sc, s7_pointer x)
{
return (x != sc->F);
}
s7_pointer s7_make_boolean(s7_scheme * sc, bool x)
{
return (make_boolean(sc, x));
}
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 sc->pl_bt
return ((car(args) == sc->F) ? sc->T : sc->F);
}
/* -------------------------------- boolean? -------------------------------- */
bool s7_is_boolean(s7_pointer x)
{
return (type(x) == T_BOOLEAN);
}
static s7_pointer g_is_boolean(s7_scheme * sc, s7_pointer args)
{
#define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f"
#define Q_is_boolean sc->pl_bt
check_boolean_method(sc, s7_is_boolean, sc->is_boolean_symbol, args);
}
/* -------------------------------- constant? -------------------------------- */
static inline bool is_constant_symbol(s7_scheme * sc, s7_pointer sym)
{
if (is_immutable_symbol(sym)) /* for keywords */
return (true);
if (is_possibly_constant(sym)) {
s7_pointer slot;
slot = lookup_slot_from(sym, sc->curlet);
return ((is_slot(slot)) && (is_immutable_slot(slot)));
}
return (false);
}
#define is_constant(sc, p) ((type(p) != T_SYMBOL) || (is_constant_symbol(sc, p)))
static s7_pointer g_is_constant(s7_scheme * sc, s7_pointer args)
{
#define H_is_constant "(constant? obj) returns #t if obj either evaluates to itself, or is a symbol whose binding is constant"
#define Q_is_constant sc->pl_bt
return (make_boolean(sc, is_constant(sc, car(args))));
}
static bool is_constant_b_7p(s7_scheme * sc, s7_pointer p)
{
return (is_constant(sc, p));
}
static s7_pointer is_constant_p_p(s7_scheme * sc, s7_pointer p)
{
return (make_boolean(sc, is_constant(sc, p)));
}
/* -------------------------------- immutable? -------------------------------- */
bool s7_is_immutable(s7_pointer p)
{
return (is_immutable(p));
}
static s7_pointer g_is_immutable(s7_scheme * sc, s7_pointer args)
{
#define H_is_immutable "(immutable? sequence) returns #t if the sequence is immutable"
#define Q_is_immutable sc->pl_bt
s7_pointer p = car(args);
#if 0 /* strikes me as confusing, constant above refers to local define-constant, the symbol itself is always immutable */
if (is_symbol(p)) {
s7_pointer slot;
slot = lookup_slot_from(p, sc->curlet);
if ((is_slot(slot)) && (is_immutable_slot(slot)))
return (sc->T);
}
#endif
if (is_number(p))
return (sc->T); /* should these be marked immutable? should we use (type != SYMBOL) as above? */
return (make_boolean(sc, is_immutable(p)));
}
/* -------------------------------- immutable! -------------------------------- */
s7_pointer s7_immutable(s7_pointer p)
{
set_immutable(p);
return (p);
}
static s7_pointer g_immutable(s7_scheme * sc, s7_pointer args)
{
#define H_immutable "(immutable! sequence) declares that the sequence's entries can't be changed. The sequence is returned."
#define Q_immutable s7_make_signature(sc, 2, sc->T, sc->T)
s7_pointer p = car(args);
if (is_symbol(p)) {
s7_pointer slot;
slot = lookup_slot_from(p, sc->curlet);
if (is_slot(slot)) {
set_immutable(slot);
return (p); /* symbol is not set immutable ? */
}
}
set_immutable(p);
return (p);
}
/* there's no way to make a slot setter (as setter) immutable (t_multiform as bit) */
/* -------------------------------- GC -------------------------------- */
/* in most code, pairs, lets, and slots dominate the heap -- each about 25% to 40% of the
* total cell allocations. In snd-test, reals are 50%. slots need not be in the heap,
* but moving them out to their own free list was actually slower because we need (in that
* case) to manage them in the sweep process by tracking lets.
*/
#if S7_DEBUGGING
static s7_int gc_protect_2(s7_scheme * sc, s7_pointer x, int32_t line)
{
s7_int loc;
loc = s7_gc_protect(sc, x);
if (loc > 8192) {
fprintf(stderr, "infinite loop or memory leak at line %d %s?\n",
line,
string_value(s7_object_to_string
(sc, current_code(sc), false)));
abort();
}
return (loc);
}
#define gc_protect_1(Sc, X) gc_protect_2(Sc, X, __LINE__)
#else
#define gc_protect_1(Sc, X) s7_gc_protect(Sc, X)
#endif
static void resize_gc_protect(s7_scheme * sc)
{
s7_int i, size = sc->protected_objects_size, new_size;
block_t *ob, *nb;
new_size = 2 * size;
ob = vector_block(sc->protected_objects);
nb = reallocate(sc, ob, new_size * sizeof(s7_pointer));
block_info(nb) = NULL;
vector_block(sc->protected_objects) = nb;
vector_elements(sc->protected_objects) = (s7_pointer *) block_data(nb);
vector_length(sc->protected_objects) = new_size;
sc->protected_objects_size = new_size;
sc->gpofl = (s7_int *) Realloc(sc->gpofl, new_size * sizeof(s7_int));
for (i = size; i < new_size; i++) {
vector_element(sc->protected_objects, i) = sc->unused;
sc->gpofl[++sc->gpofl_loc] = i;
}
}
s7_int s7_gc_protect(s7_scheme * sc, s7_pointer x)
{
s7_int loc;
if (sc->gpofl_loc < 0)
resize_gc_protect(sc);
loc = sc->gpofl[sc->gpofl_loc--];
vector_element(sc->protected_objects, loc) = x;
return (loc);
}
void s7_gc_unprotect_at(s7_scheme * sc, s7_int loc)
{
if (loc < sc->protected_objects_size) {
if (vector_element(sc->protected_objects, loc) != sc->unused)
sc->gpofl[++sc->gpofl_loc] = loc;
#if S7_DEBUGGING
else
fprintf(stderr,
"redundant gc_unprotect_at location %" ld64 "\n", loc);
#endif
vector_element(sc->protected_objects, loc) = sc->unused;
}
}
s7_pointer s7_gc_protected_at(s7_scheme * sc, s7_int loc)
{
s7_pointer obj = sc->unspecified;
if (loc < sc->protected_objects_size)
obj = vector_element(sc->protected_objects, loc);
if (obj == sc->unused)
return (sc->unspecified);
return (obj);
}
#define gc_protected_at(Sc, Loc) vector_element(Sc->protected_objects, Loc)
s7_pointer s7_gc_protect_via_location(s7_scheme * sc, s7_pointer x,
s7_int loc)
{
vector_element(sc->protected_objects, loc) = x;
return (x);
}
s7_pointer s7_gc_unprotect_via_location(s7_scheme * sc, s7_int loc)
{
vector_element(sc->protected_objects, loc) = sc->F;
return (sc->F);
}
static void (*mark_function[NUM_TYPES])(s7_pointer p);
void s7_mark(s7_pointer p)
{
if (!is_marked(p))
(*mark_function[unchecked_type(p)]) (p);
}
static inline void gc_mark(s7_pointer p)
{
if (!is_marked(p))
(*mark_function[unchecked_type(p)]) (p);
}
static inline void mark_slot(s7_pointer p)
{
set_mark(T_Slt(p));
gc_mark(slot_value(p));
if (slot_has_setter(p))
gc_mark(slot_setter(p));
if (slot_has_pending_value(p))
gc_mark(slot_pending_value(p));
set_mark(slot_symbol(p));
}
static void mark_noop(s7_pointer p)
{
}
static void close_output_port(s7_scheme * sc, s7_pointer p);
static void remove_gensym_from_symbol_table(s7_scheme * sc,
s7_pointer sym);
static void cull_weak_hash_table(s7_scheme * sc, s7_pointer table);
static void process_iterator(s7_scheme * sc, s7_pointer s1)
{
if (is_weak_hash_iterator(s1)) {
s7_pointer h;
clear_weak_hash_iterator(s1);
h = iterator_sequence(s1);
if (unchecked_type(h) == T_HASH_TABLE) {
if ((S7_DEBUGGING) && (weak_hash_iters(h) == 0))
fprintf(stderr, "in gc weak has iters wrapping under!\n");
weak_hash_iters(h)--;
}
}
}
static void process_multivector(s7_scheme * sc, s7_pointer s1)
{
vdims_t *info;
info = vector_dimension_info(s1); /* a multidimensional empty vector can have dimension info, wrapped vectors always have dimension info */
if ((info) && (info != sc->wrap_only)) {
if (vector_elements_should_be_freed(info)) { /* a kludge for foreign code convenience */
free(vector_elements(s1));
vector_elements_should_be_freed(info) = false;
}
liberate(sc, info);
vector_set_dimension_info(s1, NULL);
}
liberate(sc, vector_block(s1));
}
static void process_input_string_port(s7_scheme * sc, s7_pointer s1)
{
#if S7_DEBUGGING
/* this set of ports is a subset of the ports that respond true to is_string_port --
* the latter include file ports fully read into local memory; see read_file which uses add_input_port, not add_input_string_port
*/
if (port_filename(s1))
fprintf(stderr, "string input port has a filename: %s\n",
port_filename(s1));
if (port_needs_free(s1))
fprintf(stderr, "string input port needs data release\n");
#endif
liberate(sc, port_block(s1));
}
static void free_port_data(s7_scheme * sc, s7_pointer s1)
{
if (port_data(s1)) {
liberate(sc, port_data_block(s1));
port_data_block(s1) = NULL;
port_data(s1) = NULL;
port_data_size(s1) = 0;
}
port_needs_free(s1) = false;
}
static void close_input_function(s7_scheme * sc, s7_pointer p);
static void process_input_port(s7_scheme * sc, s7_pointer s1)
{
if (!port_is_closed(s1)) {
if (is_file_port(s1)) {
if (port_file(s1)) {
fclose(port_file(s1));
port_file(s1) = NULL;
}
} else if (is_function_port(s1))
close_input_function(sc, s1);
}
if (port_needs_free(s1))
free_port_data(sc, s1);
if (port_filename(s1)) {
liberate(sc, port_filename_block(s1));
port_filename(s1) = NULL;
}
liberate(sc, port_block(s1));
}
static void process_output_port(s7_scheme * sc, s7_pointer s1)
{
close_output_port(sc, s1); /* needed for free filename, etc */
liberate(sc, port_block(s1));
if (port_needs_free(s1)) {
if (port_data_block(s1)) {
liberate(sc, port_data_block(s1));
port_data_block(s1) = NULL;
}
port_needs_free(s1) = false;
}
}
static void process_continuation(s7_scheme * sc, s7_pointer s1)
{
continuation_op_stack(s1) = NULL;
liberate_block(sc, continuation_block(s1));
}
#if WITH_GMP
#if ((__GNU_MP_VERSION < 6) || ((__GNU_MP_VERSION == 6) && (__GNU_MP_VERSION_MINOR == 0)))
static int mpq_cmp_z(const mpq_t op1, const mpz_t op2)
{
mpq_t z1;
int result;
mpq_init(z1);
mpq_set_z(z1, op2);
result = mpq_cmp(op1, z1);
mpq_clear(z1);
return (result);
}
#endif
static s7_int big_integer_to_s7_int(s7_scheme * sc, mpz_t n);
static s7_int s7_integer_checked(s7_scheme * sc, s7_pointer p)
{ /* "checked" = gmp range check */
if (is_t_integer(p))
return (integer(p));
if (is_t_big_integer(p))
return (big_integer_to_s7_int(sc, big_integer(p)));
return (0);
}
static void free_big_integer(s7_scheme * sc, s7_pointer p)
{
big_integer_nxt(p) = sc->bigints;
sc->bigints = big_integer_bgi(p);
big_integer_bgi(p) = NULL;
}
static void free_big_ratio(s7_scheme * sc, s7_pointer p)
{
big_ratio_nxt(p) = sc->bigrats;
sc->bigrats = big_ratio_bgr(p);
big_ratio_bgr(p) = NULL;
}
static void free_big_real(s7_scheme * sc, s7_pointer p)
{
big_real_nxt(p) = sc->bigflts;
sc->bigflts = big_real_bgf(p);
big_real_bgf(p) = NULL;
}
static void free_big_complex(s7_scheme * sc, s7_pointer p)
{
big_complex_nxt(p) = sc->bigcmps;
sc->bigcmps = big_complex_bgc(p);
big_complex_bgc(p) = NULL;
}
#else
#define s7_integer_checked(Sc, P) integer(P)
#endif
static void free_hash_table(s7_scheme * sc, s7_pointer table);
static void sweep(s7_scheme * sc)
{
s7_int i, j;
s7_pointer s1;
gc_list_t *gp;
#define process_gc_list(Code) \
if (gp->loc > 0) \
{ \
for (i = 0, j = 0; i < gp->loc; i++) \
{ \
s1 = gp->list[i]; \
if (is_free_and_clear(s1)) \
{ \
Code; \
} \
else gp->list[j++] = s1; \
} \
gp->loc = j; \
} \
gp = sc->strings;
process_gc_list(liberate(sc, string_block(s1)))
gp = sc->gensyms;
process_gc_list(remove_gensym_from_symbol_table(sc, s1);
liberate(sc, gensym_block(s1)))
if (gp->loc == 0)
mark_function[T_SYMBOL] = mark_noop;
gp = sc->undefineds;
process_gc_list(free(undefined_name(s1)))
gp = sc->c_objects;
process_gc_list((c_object_gc_free(sc, s1))
? (void) (*(c_object_gc_free(sc, s1))) (sc, s1)
: (void) (*(c_object_free(sc, s1))) (c_object_value
(s1)))
gp = sc->lambdas;
process_gc_list(liberate(sc, c_function_block(s1)))
gp = sc->vectors;
process_gc_list(liberate(sc, vector_block(s1)))
gp = sc->multivectors;
process_gc_list(process_multivector(sc, s1));
gp = sc->hash_tables;
if (gp->loc > 0) {
for (i = 0, j = 0; i < gp->loc; i++) {
s1 = gp->list[i];
if (is_free_and_clear(s1))
free_hash_table(sc, s1);
else {
if ((is_weak_hash_table(s1)) && (weak_hash_iters(s1) == 0))
cull_weak_hash_table(sc, s1);
gp->list[j++] = s1;
}
}
gp->loc = j;
}
gp = sc->weak_hash_iterators;
process_gc_list(process_iterator(sc, s1));
gp = sc->opt1_funcs;
if (gp->loc > 0) {
for (i = 0, j = 0; i < gp->loc; i++) {
s1 = gp->list[i];
if (!is_free_and_clear(s1))
gp->list[j++] = s1;
}
gp->loc = j;
}
gp = sc->input_ports;
process_gc_list(process_input_port(sc, s1));
gp = sc->input_string_ports;
process_gc_list(process_input_string_port(sc, s1));
gp = sc->output_ports;
process_gc_list(process_output_port(sc, s1));
gp = sc->continuations;
process_gc_list(process_continuation(sc, s1));
gp = sc->weak_refs;
if (gp->loc > 0) {
for (i = 0, j = 0; i < gp->loc; i++) {
s1 = gp->list[i];
if (!is_free_and_clear(s1)) {
if (is_free_and_clear(c_pointer_weak1(s1)))
c_pointer_weak1(s1) = sc->F;
if (is_free_and_clear(c_pointer_weak2(s1)))
c_pointer_weak2(s1) = sc->F;
if ((c_pointer_weak1(s1) != sc->F) ||
(c_pointer_weak2(s1) != sc->F))
gp->list[j++] = s1;
}
}
gp->loc = j;
}
#if WITH_GMP
gp = sc->big_integers;
process_gc_list(free_big_integer(sc, s1))
gp = sc->big_ratios;
process_gc_list(free_big_ratio(sc, s1))
gp = sc->big_reals;
process_gc_list(free_big_real(sc, s1))
gp = sc->big_complexes;
process_gc_list(free_big_complex(sc, s1))
gp = sc->big_random_states;
process_gc_list(gmp_randclear(random_gmp_state(s1)))
#endif
}
static inline void add_to_gc_list(gc_list_t * gp, s7_pointer p)
{
if (gp->loc == gp->size) {
gp->size *= 2;
gp->list =
(s7_pointer *) realloc(gp->list,
gp->size * sizeof(s7_pointer));
}
gp->list[gp->loc++] = p;
}
static gc_list_t *make_gc_list(void)
{
gc_list_t *gp;
#define INIT_GC_CACHE_SIZE 4
gp = (gc_list_t *) malloc(sizeof(gc_list_t));
gp->size = INIT_GC_CACHE_SIZE;
gp->loc = 0;
gp->list = (s7_pointer *) malloc(gp->size * sizeof(s7_pointer));
return (gp);
}
static void just_mark(s7_pointer p)
{
set_mark(p);
}
static void add_gensym(s7_scheme * sc, s7_pointer p)
{
add_to_gc_list(sc->gensyms, p);
mark_function[T_SYMBOL] = just_mark;
}
#define add_c_object(sc, p) add_to_gc_list(sc->c_objects, p)
#define add_hash_table(sc, p) add_to_gc_list(sc->hash_tables, p)
#define add_string(sc, p) add_to_gc_list(sc->strings, p)
#define add_input_port(sc, p) add_to_gc_list(sc->input_ports, p)
#define add_input_string_port(sc, p) add_to_gc_list(sc->input_string_ports, p)
#define add_output_port(sc, p) add_to_gc_list(sc->output_ports, p)
#define add_continuation(sc, p) add_to_gc_list(sc->continuations, p)
#define add_undefined(sc, p) add_to_gc_list(sc->undefineds, p)
#define add_vector(sc, p) add_to_gc_list(sc->vectors, p)
#define add_multivector(sc, p) add_to_gc_list(sc->multivectors, p)
#define add_lambda(sc, p) add_to_gc_list(sc->lambdas, p)
#define add_weak_ref(sc, p) add_to_gc_list(sc->weak_refs, p)
#define add_weak_hash_iterator(sc, p) add_to_gc_list(sc->weak_hash_iterators, p)
#define add_opt1_func(sc, p) do {if (!opt1_func_listed(p)) add_to_gc_list(sc->opt1_funcs, p); set_opt1_func_listed(p);} while (0)
#if WITH_GMP
#define add_big_integer(sc, p) add_to_gc_list(sc->big_integers, p)
#define add_big_ratio(sc, p) add_to_gc_list(sc->big_ratios, p)
#define add_big_real(sc, p) add_to_gc_list(sc->big_reals, p)
#define add_big_complex(sc, p) add_to_gc_list(sc->big_complexes, p)
#define add_big_random_state(sc, p) add_to_gc_list(sc->big_random_states, p)
#endif
static void init_gc_caches(s7_scheme * sc)
{
sc->strings = make_gc_list();
sc->gensyms = make_gc_list();
sc->undefineds = make_gc_list();
sc->vectors = make_gc_list();
sc->multivectors = make_gc_list();
sc->hash_tables = make_gc_list();
sc->input_ports = make_gc_list();
sc->input_string_ports = make_gc_list();
sc->output_ports = make_gc_list();
sc->continuations = make_gc_list();
sc->c_objects = make_gc_list();
sc->lambdas = make_gc_list();
sc->weak_refs = make_gc_list();
sc->weak_hash_iterators = make_gc_list();
sc->opt1_funcs = make_gc_list();
#if WITH_GMP
sc->big_integers = make_gc_list();
sc->big_ratios = make_gc_list();
sc->big_reals = make_gc_list();
sc->big_complexes = make_gc_list();
sc->big_random_states = make_gc_list();
sc->ratloc = NULL;
#endif
/* slightly unrelated... */
sc->setters_size = 4;
sc->setters_loc = 0;
sc->setters =
(s7_pointer *) malloc(sc->setters_size * sizeof(s7_pointer));
}
static s7_pointer permanent_cons(s7_scheme * sc, s7_pointer a,
s7_pointer b, uint64_t type);
static void add_setter(s7_scheme * sc, s7_pointer p, s7_pointer setter)
{
/* setters GC-protected. The c_function_setter field can't be used because the built-in functions
* are often removed from the heap and never thereafter marked. Only closures and macros are protected here.
*/
s7_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(sc, p, setter, T_PAIR | T_IMMUTABLE);
}
static void mark_symbol_vector(s7_pointer p, s7_int len)
{
set_mark(p);
if (mark_function[T_SYMBOL] != mark_noop) { /* else no gensyms */
s7_int i;
s7_pointer *e = vector_elements(p);
for (i = 0; i < len; i++)
if (is_gensym(e[i]))
set_mark(e[i]);
}
}
static void mark_simple_vector(s7_pointer p, s7_int len)
{
s7_int i;
s7_pointer *e = vector_elements(p);
set_mark(p);
for (i = 0; i < len; i++)
set_mark(e[i]);
}
static void just_mark_vector(s7_pointer p, s7_int len)
{
set_mark(p);
}
static void mark_vector_1(s7_pointer p, s7_int top)
{
s7_pointer *tp = (s7_pointer *) (vector_elements(p)), *tend, *tend4;
set_mark(p);
if (!tp)
return;
tend = (s7_pointer *) (tp + top);
tend4 = (s7_pointer *) (tend - 8);
while (tp <= tend4)
LOOP_8(gc_mark(*tp++));
while (tp < tend)
gc_mark(*tp++);
}
static void mark_typed_vector_1(s7_pointer p, s7_int top)
{ /* for typed vectors with closure setters */
gc_mark(typed_vector_typer(p));
mark_vector_1(p, top);
}
static void mark_let(s7_pointer let)
{
s7_pointer x;
for (x = let; is_let(x) && (!is_marked(x)); x = let_outlet(x)) { /* let can be sc->nil, e.g. closure_let */
s7_pointer y;
set_mark(x);
if (has_dox_slot1(x))
mark_slot(let_dox_slot1(x));
if ((has_dox_slot2(x)) && (is_slot(let_dox_slot2(x))))
mark_slot(let_dox_slot2(x));
for (y = let_slots(x); tis_slot(y); y = next_slot(y))
if (!is_marked(y)) /* slot value might be the enclosing let */
mark_slot(y);
}
}
#if WITH_HISTORY
static void gc_owlet_mark(s7_pointer tp)
{
/* gc_mark but if tp is a pair ignore the marked bit on unheaped entries */
if (is_pair(tp)) {
s7_pointer p = tp;
do {
set_mark(p);
gc_mark(car(p)); /* does this need to be gc_owlet_mark? I can't find a case */
p = cdr(p);
} while ((is_pair(p)) && (p != tp) && ((!in_heap(p)) || (!is_marked(p)))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */
gc_mark(p);
} else if (!is_marked(tp))
(*mark_function[unchecked_type(tp)]) (tp);
}
#endif
static void mark_owlet(s7_scheme * sc)
{
#if WITH_HISTORY
{
s7_pointer p1, p2, p3;
int32_t i;
for (i = 1, p1 = sc->eval_history1, p2 = sc->eval_history2, p3 =
sc->history_pairs;; i++, p2 = cdr(p2), p3 = cdr(p3)) {
set_mark(p1); /* pointless? they're permanent */
set_mark(p2);
set_mark(p3);
gc_owlet_mark(car(p1));
gc_owlet_mark(car(p2));
gc_owlet_mark(car(p3));
p1 = cdr(p1);
if (p1 == sc->eval_history1)
break; /* these are circular lists */
}
}
#endif
/* sc->error_type and friends are slots in owlet */
mark_slot(sc->error_type);
slot_set_value(sc->error_data, sc->F); /* or maybe mark_tree(slot_value(sc->error_data)) ? */
mark_slot(sc->error_data);
mark_slot(sc->error_code);
mark_slot(sc->error_line);
mark_slot(sc->error_file);
mark_slot(sc->error_position);
#if WITH_HISTORY
mark_slot(sc->error_history);
#endif
set_mark(sc->owlet);
mark_let(let_outlet(sc->owlet));
}
static void mark_c_pointer(s7_pointer p)
{
set_mark(p);
gc_mark(c_pointer_type(p));
gc_mark(c_pointer_info(p));
}
static void mark_c_proc_star(s7_pointer p)
{
set_mark(p);
if ((!c_func_has_simple_defaults(p)) && (c_function_call_args(p))) { /* NULL if not a safe function */
s7_pointer arg;
for (arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg))
gc_mark(car(arg));
}
}
static void mark_pair(s7_pointer p)
{
do {
set_mark(p);
gc_mark(car(p)); /* expanding this to avoid recursion is slower */
p = cdr(p);
} while ((is_pair(p)) && (!is_marked(p))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */
gc_mark(p);
}
static void mark_counter(s7_pointer p)
{
set_mark(p);
gc_mark(counter_result(p));
gc_mark(counter_list(p));
gc_mark(counter_let(p));
}
static void mark_closure(s7_pointer p)
{
set_mark(p);
gc_mark(closure_args(p));
gc_mark(closure_body(p));
mark_let(closure_let(p));
gc_mark(closure_setter_or_map_list(p));
}
static void mark_stack_1(s7_pointer p, s7_int top)
{
s7_pointer *tp = (s7_pointer *) (stack_elements(p)), *tend;
set_mark(p);
if (!tp)
return;
tend = (s7_pointer *) (tp + top);
while (tp < tend) {
gc_mark(*tp++);
gc_mark(*tp++);
gc_mark(*tp++);
tp++;
}
}
static void mark_stack(s7_pointer p)
{
/* we can have a bare stack waiting for a continuation to hold it if the new_cell for the continuation triggers the GC! But we need a top-of-stack?? */
mark_stack_1(p, temp_stack_top(p));
}
static void mark_continuation(s7_pointer p)
{
set_mark(p);
if (!is_marked(continuation_stack(p))) /* can these be cyclic? */
mark_stack_1(continuation_stack(p), continuation_stack_top(p));
gc_mark(continuation_op_stack(p));
}
static void mark_vector(s7_pointer p)
{
if (is_typed_vector(p))
typed_vector_gc_mark(p) (p, vector_length(p));
else
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 subvector field either points to the
* parent vector, or it is sc->F, so we need to check for a vector parent if
* the current is multidimensional (this will include 1-dim slices). We need
* to keep the parent case separate (i.e. sc->F means the current is the original)
* so that we only free once (or remove_from_heap once).
*
* If we have a subvector of a subvector, and the middle and original are not otherwise
* in use, we mark the middle one, but (since it itself is not in use anywhere else)
* we don't mark the original! So we need to follow the share-vector chain marking every one.
*
* To remove a cell from the heap, we need its current heap location so that we can replace it.
* The heap is allocated as needed in monolithic blocks of (say) 1/2M s7_cells. When a cell
* is replaced, the new cell (at heap[x] say) is no longer from the original block. Since the
* GC clears all type bits when it frees a cell, we can't use a type bit to distinguish the
* replacements from the originals, but we need that info because in the base case, we use
* the distance of the cell from the base cell to get "x", its location. In the replacement
* case, we add the location at the end of the s7_cell (s7_big_cell). We track the current
* heap blocks via the sc->heap_blocks list. To get the location of "p" above, we run through
* that list looking for a block it fits in. If none is found, we assume it is an s7_big_cell
* and use the saved location.
*/
if (is_subvector(p))
mark_vector_possibly_shared(subvector_vector(p));
/* mark_vector_1 does not check the marked bit, so if subvector below is in a cycle involving
* the calling vector, we get infinite recursion unless we check the mark bit here.
*/
if (!is_marked(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 (is_subvector(p))
mark_int_or_float_vector_possibly_shared(subvector_vector(p));
set_mark(p);
}
static void mark_c_object(s7_pointer p)
{
set_mark(p);
if (c_object_gc_mark(c_object_s7(p), p))
(*(c_object_gc_mark(c_object_s7(p), p))) (c_object_s7(p), p);
else
(*(c_object_mark(c_object_s7(p), p))) (c_object_value(p));
}
static void mark_catch(s7_pointer p)
{
set_mark(p);
gc_mark(catch_tag(p));
gc_mark(catch_handler(p));
}
static void mark_dynamic_wind(s7_pointer p)
{
set_mark(p);
gc_mark(dynamic_wind_in(p));
gc_mark(dynamic_wind_out(p));
gc_mark(dynamic_wind_body(p));
}
/* if is_typed_hash_table then if c_function_marker(key|value_typer) is just_mark_vector, we can ignore that field,
* if it's mark_simple_vector, we just set_mark (key|value), else we gc_mark (none of this is implemented yet)
*/
static void mark_hash_table(s7_pointer p)
{
set_mark(p);
gc_mark(hash_table_procedures(p));
if (hash_table_entries(p) > 0) {
s7_int len = hash_table_mask(p) + 1;
hash_entry_t **entries = hash_table_elements(p), **last;
last = (hash_entry_t **) (entries + len);
if ((is_weak_hash_table(p)) && (weak_hash_iters(p) == 0))
while (entries < last) {
hash_entry_t *xp;
for (xp = *entries++; xp; xp = hash_entry_next(xp))
gc_mark(hash_entry_value(xp));
for (xp = *entries++; xp; xp = hash_entry_next(xp))
gc_mark(hash_entry_value(xp));
} else
while (entries < last) { /* counting entries here was slightly faster */
hash_entry_t *xp;
for (xp = *entries++; xp; xp = hash_entry_next(xp)) {
gc_mark(hash_entry_key(xp));
gc_mark(hash_entry_value(xp));
}
for (xp = *entries++; xp; xp = hash_entry_next(xp)) {
gc_mark(hash_entry_key(xp));
gc_mark(hash_entry_value(xp));
}
}
}
}
static void mark_iterator(s7_pointer p)
{
set_mark(p);
gc_mark(iterator_sequence(p));
if (is_mark_seq(p))
gc_mark(iterator_current(p));
}
static void mark_input_port(s7_pointer p)
{
set_mark(p);
gc_mark(port_input_scheme_function(p)); /* this is also a string port's string */
}
static void mark_output_port(s7_pointer p)
{
set_mark(p);
if (is_function_port(p))
gc_mark(port_output_scheme_function(p));
}
#define clear_type(p) full_type(p) = T_FREE
static void init_mark_functions(void)
{
mark_function[T_FREE] = mark_noop;
mark_function[T_UNDEFINED] = just_mark;
mark_function[T_EOF] = mark_noop;
mark_function[T_UNSPECIFIED] = mark_noop;
mark_function[T_NIL] = mark_noop;
mark_function[T_UNUSED] = mark_noop;
mark_function[T_BOOLEAN] = mark_noop;
mark_function[T_SYNTAX] = mark_noop;
mark_function[T_CHARACTER] = mark_noop;
mark_function[T_SYMBOL] = mark_noop; /* this changes to just_mark when gensyms are in the heap */
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_RANDOM_STATE] = just_mark;
mark_function[T_GOTO] = just_mark;
mark_function[T_OUTPUT_PORT] = just_mark; /* changed to mark_output_port if output function ports are active */
mark_function[T_C_MACRO] = just_mark;
mark_function[T_C_POINTER] = mark_c_pointer;
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;
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_INPUT_PORT] = mark_input_port;
mark_function[T_VECTOR] = mark_vector; /* this changes if subvector 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_BYTE_VECTOR] = just_mark;
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_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_LET] = mark_let;
mark_function[T_STACK] = mark_stack;
mark_function[T_COUNTER] = mark_counter;
mark_function[T_SLOT] = mark_slot;
}
static void mark_op_stack(s7_scheme * sc)
{
s7_pointer *p = sc->op_stack, *tp = sc->op_stack_now;
while (p < tp)
gc_mark(*p++);
}
static void mark_input_port_stack(s7_scheme * sc)
{
s7_pointer *p, *tp;
tp = (s7_pointer *) (sc->input_port_stack + sc->input_port_stack_loc);
for (p = sc->input_port_stack; p < tp; p++)
gc_mark(*p);
}
static void mark_rootlet(s7_scheme * sc)
{
s7_pointer ge = sc->rootlet;
s7_pointer *tmp, *top;
tmp = rootlet_elements(ge);
top = (s7_pointer *) (tmp + sc->rootlet_entries);
set_mark(ge);
while (tmp < top)
gc_mark(slot_value(*tmp++));
/* slot_setter is handled below with an explicit list -- more code than its worth probably */
/* we're not marking slot_symbol above which makes me worry that a top-level gensym won't be protected
* (apply define (gensym) '(32)), then try to get the GC to clobber {gensym}-0,
* but I can't get it to break, so they must be protected somehow; apparently they are
* removed from the heap! At least: (define-macro (defit) (let ((n (gensym))) `(define (,n) (format #t "fun")))) (defit)
* removes the function from the heap (protecting the gensym).
*/
}
/* arrays for permanent_objects are not needed yet: init: cells: 0, lets: 0, s7test: cells: 4, lets: 10, snd-test: cells: 14, lets: 1147 */
/* mark_closure calls mark_let on closure_let(func) which marks slot values.
* if we move rootlet to end, unmarked closures at that point could mark let/slot but not slot value?
* or save safe-closure lets to handle all at end? or a gc_list of safe closure lets and only mark let if not safe?
*/
static void mark_permanent_objects(s7_scheme * sc)
{
gc_obj_t *g;
for (g = sc->permanent_objects; g; g = (gc_obj_t *) (g->nxt))
gc_mark(g->p);
/* permanent_objects also has lets (removed from heap) -- should they be handled like permanent_lets?
* if unmarked should either be removed from the list and perhaps placed on a free list?
* if outlet is free can the let potentially be in use?
* there are many more permanent_lets(slots) than permanent objects
*/
}
/* do we mark funclet slot values from the function as root? Maybe treat them like permanent_lets here? */
static void unmark_permanent_objects(s7_scheme * sc)
{
gc_obj_t *g;
for (g = sc->permanent_objects; g; g = (gc_obj_t *) (g->nxt))
clear_mark(g->p);
for (g = sc->permanent_lets; g; g = (gc_obj_t *) (g->nxt)) /* there are lets and slots in this list */
clear_mark(g->p);
}
#if (!MS_WINDOWS)
#include <time.h>
#include <sys/time.h>
#endif
#if S7_DEBUGGING
static bool has_odd_bits(s7_pointer obj);
#endif
static char *describe_type_bits(s7_scheme * sc, s7_pointer obj);
static s7_pointer make_symbol(s7_scheme * sc, const char *name);
static void s7_warn(s7_scheme * sc, s7_int len, const char *ctrl, ...);
#if S7_DEBUGGING
#define call_gc(Sc) gc(Sc, __func__, __LINE__)
static int64_t gc(s7_scheme * sc, const char *func, int line)
#else
#define call_gc(Sc) gc(Sc)
static int64_t gc(s7_scheme * sc)
#endif
{
s7_cell **old_free_heap_top;
s7_int i;
s7_pointer p;
sc->gc_start = my_clock();
sc->gc_calls++;
#if S7_DEBUGGING
sc->last_gc_line = line;
#endif
sc->continuation_counter = 0;
mark_rootlet(sc);
mark_owlet(sc);
gc_mark(sc->code);
if (sc->args)
gc_mark(sc->args);
gc_mark(sc->curlet); /* not mark_let because op_any_closure_3p uses sc->curlet as a temp!! */
mark_current_code(sc); /* probably redundant if with_history */
mark_stack_1(sc->stack, current_stack_top(sc));
gc_mark(sc->u);
gc_mark(sc->v);
gc_mark(sc->w);
gc_mark(sc->x);
gc_mark(sc->y);
gc_mark(sc->z);
gc_mark(sc->value);
gc_mark(sc->temp1);
gc_mark(sc->temp2);
gc_mark(sc->temp3);
gc_mark(sc->temp4);
gc_mark(sc->temp5);
gc_mark(sc->temp6);
gc_mark(sc->temp7);
gc_mark(sc->temp8);
gc_mark(sc->temp9);
set_mark(current_input_port(sc));
mark_input_port_stack(sc);
set_mark(current_output_port(sc));
set_mark(sc->error_port);
gc_mark(sc->stacktrace_defaults);
gc_mark(sc->autoload_table);
gc_mark(sc->default_rng);
/* permanent lists that might escape and therefore need GC protection */
mark_pair(sc->temp_cell_2);
gc_mark(car(sc->t1_1));
gc_mark(car(sc->t2_1));
gc_mark(car(sc->t2_2));
gc_mark(car(sc->t3_1));
gc_mark(car(sc->t3_2));
gc_mark(car(sc->t3_3));
gc_mark(car(sc->t4_1));
gc_mark(car(sc->plist_1));
/* gc_mark(car(sc->clist_1)); *//* unnecessary, I think */
gc_mark(car(sc->plist_2));
gc_mark(cadr(sc->plist_2));
gc_mark(car(sc->qlist_2));
gc_mark(cadr(sc->qlist_2));
gc_mark(car(sc->qlist_3));
gc_mark(cadr(sc->qlist_3));
gc_mark(caddr(sc->qlist_3));
gc_mark(car(sc->u1_1));
gc_mark(car(sc->u2_1));
gc_mark(sc->rec_p1);
gc_mark(sc->rec_p2);
for (p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p))
gc_mark(car(p));
for (p = sc->simple_wrong_type_arg_info; is_pair(p); p = cdr(p))
gc_mark(car(p));
for (p = sc->out_of_range_info; is_pair(p); p = cdr(p))
gc_mark(car(p));
for (p = sc->simple_out_of_range_info; is_pair(p); p = cdr(p))
gc_mark(car(p));
gc_mark(car(sc->elist_1));
gc_mark(car(sc->elist_2));
gc_mark(cadr(sc->elist_2));
for (p = sc->plist_3; is_pair(p); p = cdr(p))
gc_mark(car(p));
for (p = sc->elist_3; is_pair(p); p = cdr(p))
gc_mark(car(p));
for (p = sc->elist_4; is_pair(p); p = cdr(p))
gc_mark(car(p));
for (p = sc->elist_5; is_pair(p); p = cdr(p))
gc_mark(car(p));
for (i = 1; i < NUM_SAFE_LISTS; i++)
if ((is_pair(sc->safe_lists[i])) &&
(list_is_in_use(sc->safe_lists[i])))
for (p = sc->safe_lists[i]; is_pair(p); p = cdr(p))
gc_mark(car(p));
for (i = 0; i < sc->setters_loc; i++)
gc_mark(cdr(sc->setters[i]));
for (i = 0; i < sc->num_fdats; i++)
if (sc->fdats[i])
gc_mark(sc->fdats[i]->curly_arg);
if (sc->rec_stack) {
just_mark(sc->rec_stack);
for (i = 0; i < sc->rec_loc; i++)
gc_mark(sc->rec_els[i]);
}
mark_vector(sc->protected_objects);
mark_vector(sc->protected_setters);
set_mark(sc->protected_setter_symbols);
/* 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 + sc->gc_temps_size;
if (tmps_top > sc->previous_free_heap_top)
tmps_top = sc->previous_free_heap_top;
while (tmps < tmps_top)
gc_mark(*tmps++);
}
mark_op_stack(sc);
mark_permanent_objects(sc);
if (sc->profiling_gensyms) {
profile_data_t *pd = sc->profile_data;
for (i = 0; i < pd->top; i++)
if (is_gensym(pd->funcs[i]))
set_mark(pd->funcs[i]);
}
{
gc_list_t *gp = sc->opt1_funcs;
for (i = 0; i < gp->loc; i++) {
s7_pointer s1;
s1 = T_Pair(gp->list[i]);
if ((is_marked(s1)) && (!is_marked(opt1_any(s1)))) /* opt1_lambda, but op_unknown* can change to opt1_cfunc etc */
gc_mark(opt1_any(s1)); /* not set_mark -- need to protect let/body/args as well */
}
}
/* free up all unmarked objects */
old_free_heap_top = sc->free_heap_top;
{
s7_pointer *fp = sc->free_heap_top, *tp = sc->heap, *heap_top;
heap_top = (s7_pointer *) (sc->heap + sc->heap_size);
#if S7_DEBUGGING
#define gc_object(Tp) \
p = (*Tp++); \
if (signed_type(p) > 0) \
{ \
p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \
/* if (unchecked_type(p) == T_PAIR) {p->object.cons.opt1 = NULL; p->object.cons.opt2 = NULL; p->object.cons.opt3 = NULL;} */\
if (has_odd_bits(p)) {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(sc, p)); free(s);} \
signed_type(p) = 0; \
(*fp++) = p; \
} \
else if (signed_type(p) < 0) clear_mark(p);
#else
#define gc_object(Tp) p = (*Tp++); if (signed_type(p) > 0) {signed_type(p) = 0; (*fp++) = p;} else if (signed_type(p) < 0) clear_mark(p);
/* this appears to be about 10% faster than the previous form
* if the sign bit is on, but no other bits, this version will take no action (it thinks the cell is on the free list), but
* it means we've marked a free cell as in-use: since types are set as soon as removed from the free list, this has to be a bug
* (this case is caught by has_odd_bits). If ignored, the type will be set, and later the bit cleared, so no problem?
* An alternate form that simply calls clear_mark (no check for < 0) appears to be the same speed even in cases with lots
* of long-lived objects.
*/
#endif
while (tp < heap_top) { /* != here or ^ makes no difference, and going to 64 (from 32) doesn't matter */
LOOP_8(gc_object(tp));
LOOP_8(gc_object(tp));
LOOP_8(gc_object(tp));
LOOP_8(gc_object(tp));
}
/* I tried using pthreads here, since there is no need for a lock in this loop, but the *fp++ part needs to
* be local to each thread, then merged at the end. In my timing tests, the current version was faster.
* If NUM_THREADS=2, and all thread variables are local, surely there's no "false sharing"?
*/
sc->free_heap_top = fp;
sweep(sc);
}
unmark_permanent_objects(sc);
sc->gc_freed = (int64_t) (sc->free_heap_top - old_free_heap_top);
sc->gc_total_freed += sc->gc_freed;
sc->gc_end = my_clock();
sc->gc_total_time += (sc->gc_end - sc->gc_start);
if (sc->gc_stats != 0) {
if (show_gc_stats(sc)) {
#if (!MS_WINDOWS)
s7_warn(sc, 256,
"gc freed %" ld64 "/%" ld64 " (free: %" p64
"), time: %f\n", sc->gc_freed, sc->heap_size,
(intptr_t) (sc->free_heap_top - sc->free_heap),
(double) (sc->gc_end -
sc->gc_start) / ticks_per_second());
#else
s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n",
sc->gc_freed, sc->heap_size);
#endif
}
if (show_protected_objects_stats(sc)) {
s7_int len, num;
len = vector_length(sc->protected_objects); /* allocated at startup */
for (i = 0, num = 0; i < len; i++)
if (vector_element(sc->protected_objects, i) != sc->unused)
num++;
s7_warn(sc, 256,
"gc-protected-objects: %" ld64 " in use of %" ld64
"\n", num, len);
}
}
sc->previous_free_heap_top = sc->free_heap_top;
return (sc->gc_freed);
}
#define GC_RESIZE_HEAP_BY_4_FRACTION 0.67
/* .5+.1: test -3?, dup +86, tmap +45, tsort -3, thash +305. .85+.7: dup -5 */
static void resize_heap_to(s7_scheme * sc, int64_t size)
{
int64_t old_size = sc->heap_size, old_free, k;
s7_cell *cells;
s7_pointer p;
s7_cell **cp;
heap_block_t *hp;
old_free = sc->free_heap_top - sc->free_heap;
if (size == 0) {
/* (sc->heap_size < 2048000) *//* 8192000 here improves various gc benchmarks only slightly */
/* maybe the choice of 4 should depend on how much space was freed rather than the current heap_size? */
if (old_free < old_size * sc->gc_resize_heap_by_4_fraction)
sc->heap_size *= 4; /* *8 if < 1M (or whatever) doesn't make much difference */
else
sc->heap_size *= 2;
} else if (size > sc->heap_size)
while (sc->heap_size < size)
sc->heap_size *= 2;
else
return;
/* do not call new_cell here! */
if (((2 * sc->heap_size * sizeof(s7_cell *)) +
((sc->heap_size - old_size) * sizeof(s7_cell))) >= SIZE_MAX) {
s7_warn(sc, 256,
"heap size requested, %" ld64 " => %" ld64
" bytes, is greater than size_t: %" ld64 "\n",
sc->heap_size,
(2 * sc->heap_size * sizeof(s7_cell *)) +
((sc->heap_size - old_size) * sizeof(s7_cell)), SIZE_MAX);
sc->heap_size = old_size + 64000;
}
cp = (s7_cell **) realloc(sc->heap, sc->heap_size * sizeof(s7_cell *));
if (cp)
sc->heap = cp;
else {
s7_warn(sc, 256,
"heap reallocation failed! tried to get %" ld64
" bytes (will retry with a smaller amount)\n",
(int64_t) (sc->heap_size * sizeof(s7_cell *)));
sc->heap_size = old_size + 64000;
sc->heap =
(s7_cell **) Realloc(sc->heap,
sc->heap_size * sizeof(s7_cell *));
}
sc->free_heap =
(s7_cell **) Realloc(sc->free_heap,
sc->heap_size * sizeof(s7_cell *));
sc->free_heap_trigger = (s7_cell **) (sc->free_heap + GC_TRIGGER_SIZE);
sc->free_heap_top = sc->free_heap + old_free; /* incremented below, added old_free 21-Aug-12?!? */
cells = (s7_cell *) Calloc(sc->heap_size - old_size, sizeof(s7_cell));
add_saved_pointer(sc, (void *) cells);
for (p = cells, k = old_size; k < sc->heap_size;) {
LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++);
LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++);
LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++);
LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++);
}
hp = (heap_block_t *) Malloc(sizeof(heap_block_t));
hp->start = (intptr_t) cells;
hp->end =
(intptr_t) cells + ((sc->heap_size - old_size) * sizeof(s7_cell));
hp->offset = old_size;
hp->next = sc->heap_blocks;
sc->heap_blocks = hp;
sc->previous_free_heap_top = sc->free_heap_top;
if (show_heap_stats(sc)) {
char *str;
str =
string_value(object_to_truncated_string
(sc, current_code(sc), 80));
if (size != 0)
s7_warn(sc, 512,
"heap grows to %" ld64 " (old free/size: %" ld64 "/%"
ld64 ", requested %" ld64 ") from %s\n", sc->heap_size,
old_free, old_size, size, str);
else
s7_warn(sc, 512,
"heap grows to %" ld64 " (old free/size: %" ld64 "/%"
ld64 ") from %s\n", sc->heap_size, old_free, old_size,
str);
}
if (sc->heap_size >= sc->max_heap_size)
s7_error(sc, make_symbol(sc, "heap-too-big"),
set_elist_3(sc,
wrap_string(sc,
"heap has grown past (*s7* 'max-heap-size): ~S > ~S",
50), wrap_integer1(sc,
sc->max_heap_size),
wrap_integer2(sc, sc->heap_size)));
}
#define resize_heap(Sc) resize_heap_to(Sc, 0)
#ifndef GC_RESIZE_HEAP_FRACTION
#define GC_RESIZE_HEAP_FRACTION 0.8
/* 1/2 is ok, 3/4 speeds up some GC benchmarks, 7/8 is a bit faster, 95/100 comes to a halt (giant heap)
* in my tests, only tvect.scm ends up larger if 3/4 used
*/
#endif
#if S7_DEBUGGING
static void try_to_call_gc_1(s7_scheme * sc, const char *func, int line)
#else
static void try_to_call_gc(s7_scheme * sc)
#endif
{
/* called only from new_cell */
if (sc->gc_off) /* we can't just return here! Someone needs a new cell, and once the heap free list is exhausted, segfault */
resize_heap(sc);
else {
#if (!S7_DEBUGGING)
int64_t freed_heap;
freed_heap = gc(sc);
if (freed_heap < (sc->heap_size * sc->gc_resize_heap_fraction))
resize_heap(sc);
#else
gc(sc, func, line);
if ((int64_t) (sc->free_heap_top - sc->free_heap) <
(sc->heap_size * sc->gc_resize_heap_fraction))
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)
/* g_gc can't be called in a situation where these lists matter (I think...) */
set_elist_1(sc, sc->nil);
set_plist_1(sc, sc->nil);
set_elist_2(sc, sc->nil, sc->nil);
set_plist_2(sc, sc->nil, sc->nil);
/* set_clist_1(sc, sc->nil); *//* not gc_marked */
set_qlist_2(sc, sc->nil, sc->nil);
set_qlist_3(sc, sc->nil, sc->nil, sc->nil);
set_elist_3(sc, sc->nil, sc->nil, sc->nil);
set_plist_3(sc, sc->nil, sc->nil, sc->nil);
set_elist_4(sc, sc->nil, sc->nil, sc->nil, sc->nil);
set_elist_5(sc, sc->nil, sc->nil, sc->nil, sc->nil, sc->nil);
if (is_not_null(args)) {
if (!s7_is_boolean(car(args)))
return (method_or_bust_one_arg
(sc, car(args), sc->gc_symbol, args, T_BOOLEAN));
sc->gc_off = (car(args) == sc->F);
if (sc->gc_off)
return (sc->F);
}
call_gc(sc);
return (sc->unspecified);
}
s7_pointer s7_gc_on(s7_scheme * sc, bool on)
{
sc->gc_off = !on;
return (s7_make_boolean(sc, on));
}
#if S7_DEBUGGING
static void check_free_heap_size_1(s7_scheme * sc, s7_int size,
const char *func, int line)
#define check_free_heap_size(Sc, Size) check_free_heap_size_1(Sc, Size, __func__, __LINE__)
#else
static void check_free_heap_size(s7_scheme * sc, s7_int size)
#endif
{
s7_int free_cells;
free_cells = sc->free_heap_top - sc->free_heap;
if (free_cells < size) {
#if S7_DEBUGGING
gc(sc, func, line);
#else
gc(sc);
#endif
while ((sc->free_heap_top - sc->free_heap) < size)
resize_heap(sc);
}
}
#define ALLOC_POINTER_SIZE 256
static s7_cell *alloc_pointer(s7_scheme * sc)
{
if (sc->alloc_pointer_k == ALLOC_POINTER_SIZE) { /* if either no current block or the block is used up, make a new block */
sc->permanent_cells += ALLOC_POINTER_SIZE;
sc->alloc_pointer_cells =
(s7_cell *) Calloc(ALLOC_POINTER_SIZE, sizeof(s7_cell));
add_saved_pointer(sc, sc->alloc_pointer_cells);
sc->alloc_pointer_k = 0;
}
return (&(sc->alloc_pointer_cells[sc->alloc_pointer_k++]));
}
#define ALLOC_BIG_POINTER_SIZE 256
static s7_big_cell *alloc_big_pointer(s7_scheme * sc, int64_t loc)
{
s7_big_pointer p;
if (sc->alloc_big_pointer_k == ALLOC_BIG_POINTER_SIZE) {
sc->permanent_cells += ALLOC_BIG_POINTER_SIZE;
sc->alloc_big_pointer_cells =
(s7_big_cell *) Calloc(ALLOC_BIG_POINTER_SIZE,
sizeof(s7_big_cell));
add_saved_pointer(sc, sc->alloc_big_pointer_cells);
sc->alloc_big_pointer_k = 0;
}
p = (&(sc->alloc_big_pointer_cells[sc->alloc_big_pointer_k++]));
p->big_hloc = loc;
/* needed if this new pointer is itself petrified later -- it's not from one of the heap blocks,
* but it's in the heap, and we'll need to know where it is in the heap to replace it
*/
return (p);
}
static void add_permanent_object(s7_scheme * sc, s7_pointer obj)
{ /* called by remove_from_heap */
gc_obj_t *g;
g = (gc_obj_t *) Malloc(sizeof(gc_obj_t));
g->p = obj;
g->nxt = sc->permanent_objects;
sc->permanent_objects = g;
}
static void add_permanent_let_or_slot(s7_scheme * sc, s7_pointer obj)
{
gc_obj_t *g;
g = (gc_obj_t *) Malloc(sizeof(gc_obj_t));
g->p = obj;
g->nxt = sc->permanent_lets;
sc->permanent_lets = g;
}
#if S7_DEBUGGING
static const char *type_name_from_type(int32_t typ, article_t article);
#define free_cell(Sc, P) free_cell_1(Sc, P, __LINE__)
static void free_cell_1(s7_scheme * sc, s7_pointer p, int32_t line)
#else
static void free_cell(s7_scheme * sc, s7_pointer p)
#endif
{
#if S7_DEBUGGING
/* anything that needs gc_list attention should not be freed here */
uint8_t typ = unchecked_type(p);
if ((t_freeze_p[typ]) || ((typ == T_SYMBOL) && (is_gensym(p))))
fprintf(stderr, "free_cell of %s?\n",
type_name_from_type(typ, NO_ARTICLE));
p->debugger_bits = 0;
p->explicit_free_line = line;
#endif
clear_type(p);
(*(sc->free_heap_top++)) = p;
}
static inline s7_pointer petrify(s7_scheme * sc, s7_pointer x)
{
s7_pointer p;
int64_t loc;
loc = heap_location(sc, x);
p = (s7_pointer) alloc_big_pointer(sc, loc);
sc->heap[loc] = p;
free_cell(sc, p);
unheap(sc, x); /* set_immutable(x); *//* if there are GC troubles, this might catch them? */
return (x);
}
static inline void s7_remove_from_heap(s7_scheme * sc, s7_pointer x)
{
/* global functions are very rarely redefined, so we can remove the function body from the heap when it is defined */
if (!in_heap(x))
return;
if (is_pair(x)) {
s7_pointer p = x;
do {
petrify(sc, p);
s7_remove_from_heap(sc, car(p));
p = cdr(p);
} while (is_pair(p) && (in_heap(p)));
if (in_heap(p))
petrify(sc, p);
return;
}
switch (type(x)) {
case T_LET:
if (is_funclet(x))
set_immutable(x);
case T_HASH_TABLE:
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_SYMBOL:
if (is_gensym(x)) {
s7_int i;
gc_list_t *gp;
int64_t loc;
loc = heap_location(sc, x);
sc->heap[loc] = (s7_pointer) alloc_big_pointer(sc, loc);
free_cell(sc, sc->heap[loc]);
unheap(sc, x);
gp = sc->gensyms;
for (i = 0; i < gp->loc; i++) /* sc->gensyms reaches size 512 during s7test, but this search is called 3 times and costs nothing */
if (gp->list[i] == x) {
s7_int j;
for (j = i + 1; i < gp->loc - 1; i++, j++)
gp->list[i] = gp->list[j];
gp->list[i] = NULL;
gp->loc--;
if (gp->loc == 0)
mark_function[T_SYMBOL] = mark_noop;
break;
}
}
return;
case T_CLOSURE:
case T_CLOSURE_STAR:
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
/* these need to be GC-protected! */
add_permanent_object(sc, x);
return;
default:
break;
}
petrify(sc, x);
}
/* -------------------------------- stacks -------------------------------- */
#define OP_STACK_INITIAL_SIZE 64
#if S7_DEBUGGING
static void push_op_stack(s7_scheme * sc, s7_pointer op)
{
(*sc->op_stack_now++) = T_Pos(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 (sc->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 (sc->stop_at_error)
abort();
}
return (T_Pos(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)
{
int32_t 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)
{
int32_t i, loc, new_size;
loc = (int32_t) (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 = (uint32_t) new_size;
sc->op_stack_now = (s7_pointer *) (sc->op_stack + loc);
sc->op_stack_end = (s7_pointer *) (sc->op_stack + sc->op_stack_size);
}
#if S7_DEBUGGING
#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__)
static void pop_stack_1(s7_scheme * sc, const char *func, int line)
{
sc->stack_end -= 4;
if (sc->stack_end < sc->stack_start) {
fprintf(stderr, "%s%s[%d]: stack underflow%s\n", BOLD_TEXT, func,
line, UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
/* here and in push_stack, both code and args might be non-free only because they've been retyped
* inline (as in named let) -- they actually don't make sense in these cases, but are ignored,
* and are carried around as GC protection in other cases.
*/
sc->code = T_Pos(sc->stack_end[0]);
sc->curlet = T_Pos(sc->stack_end[1]); /* not T_Lid, see op_any_closure_3p_end et al (stack used to pass args, not curlet) */
sc->args = sc->stack_end[2];
sc->cur_op = (opcode_t) (sc->stack_end[3]);
if (sc->cur_op >= NUM_OPS) {
fprintf(stderr,
"%s%s[%d]: pop_stack invalid opcode: %" p64 " %s\n",
BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1])) && (sc->cur_op != OP_ANY_CLOSURE_3P_3)) /* used as third GC protection field */
fprintf(stderr, "%s[%d]: curlet not a let: %s\n", func, line,
op_names[sc->cur_op]);
}
#define pop_stack_no_op(Sc) pop_stack_no_op_1(Sc, __func__, __LINE__)
static void pop_stack_no_op_1(s7_scheme * sc, const char *func, int line)
{
sc->stack_end -= 4;
if (sc->stack_end < sc->stack_start) {
fprintf(stderr, "%s%s[%d]: stack underflow%s\n", BOLD_TEXT, func,
line, UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
sc->code = T_Pos(sc->stack_end[0]);
if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(sc->stack_end[1]))
&& (!is_null(sc->stack_end[1])))
fprintf(stderr, "%s[%d]: curlet not a let\n", func, line);
sc->curlet = T_Pos(sc->stack_end[1]); /* not T_Lid: gc_protect can set this directly (not through push_stack) to anything */
sc->args = sc->stack_end[2];
}
#define push_stack(Sc, Op, Args, Code) \
do {s7_pointer *_end_; _end_ = Sc->stack_end; push_stack_1(Sc, Op, Args, Code, _end_, __func__, __LINE__);} while (0)
static void push_stack_1(s7_scheme * sc, opcode_t op, s7_pointer args,
s7_pointer code, s7_pointer * end,
const char *func, int line)
{
if (sc->stack_end >= sc->stack_start + sc->stack_size) {
fprintf(stderr, "%s%s[%d]: stack overflow%s\n", BOLD_TEXT, func,
line, UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
if (sc->stack_end >= sc->stack_resize_trigger)
fprintf(stderr, "%s%s[%d]: stack resize skipped%s\n", BOLD_TEXT,
func, line, UNBOLD_TEXT);
if (sc->stack_end != end)
fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func,
line);
if (op >= NUM_OPS) {
fprintf(stderr,
"%s%s[%d]: push_stack invalid opcode: %" p64 " %s\n",
BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
if (code)
sc->stack_end[0] = T_Pos(code);
sc->stack_end[1] = T_Lid(sc->curlet);
if ((args) && (unchecked_type(args) != T_FREE))
sc->stack_end[2] = T_Pos(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->unused)
#define push_stack_no_let_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused)
#define push_stack_no_args(Sc, Op, Code) push_stack(Sc, Op, Sc->unused, Code)
#define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code)
#define push_stack_op(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused)
#define push_stack_op_let(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused)
#define push_stack_direct(Sc, Op) push_stack(Sc, Op, Sc->args, Sc->code)
#define push_stack_no_args_direct(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->code)
/* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */
#else
#define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0)
#define pop_stack_no_op(Sc) {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0)
#define push_stack(Sc, Op, Args, Code) \
do { \
Sc->stack_end[0] = Code; \
Sc->stack_end[1] = Sc->curlet; \
Sc->stack_end[2] = Args; \
Sc->stack_end[3] = (s7_pointer)(Op); \
Sc->stack_end += 4; \
} while (0)
#define push_stack_direct(Sc, Op) \
do { \
memcpy((void *)(Sc->stack_end), (void *)Sc, 3 * sizeof(s7_pointer)); \
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[1] = Sc->curlet; \
Sc->stack_end[2] = Args; \
Sc->stack_end[3] = (s7_pointer)(Op); \
Sc->stack_end += 4; \
} while (0)
#define push_stack_no_let_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->curlet; \
Sc->stack_end[3] = (s7_pointer)(Op); \
Sc->stack_end += 4; \
} while (0)
#define push_stack_no_args_direct(Sc, Op) \
do { \
memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \
Sc->stack_end[3] = (s7_pointer)(Op); \
Sc->stack_end += 4; \
} while (0)
#define push_stack_no_let(Sc, Op, Args, Code) \
do { \
Sc->stack_end[0] = Code; \
Sc->stack_end[2] = Args; \
Sc->stack_end[3] = (s7_pointer)(Op); \
Sc->stack_end += 4; \
} while (0)
#define push_stack_op(Sc, Op) \
do { \
Sc->stack_end[3] = (s7_pointer)(Op); \
Sc->stack_end += 4; \
} while (0)
#define push_stack_op_let(Sc, Op) \
do { \
Sc->stack_end[1] = Sc->curlet; \
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.
*/
#if S7_DEBUGGING
#define unstack(Sc) unstack_1(Sc, __func__, __LINE__)
static void unstack_1(s7_scheme * sc, const char *func, int line)
{
sc->stack_end -= 4;
if (((opcode_t) sc->stack_end[3]) != OP_GC_PROTECT) {
fprintf(stderr, "%s%s[%d]: popped %s?%s\n", BOLD_TEXT, func, line,
op_names[(opcode_t) sc->stack_end[3]], UNBOLD_TEXT);
fprintf(stderr, " code: %s, args: %s\n", display(sc->code),
display(sc->args));
fprintf(stderr, " cur_code: %s, estr: %s\n",
display(current_code(sc)),
display(s7_name_to_value(sc, "estr")));
if (sc->stop_at_error)
abort();
}
}
#define unstack_with(Sc, Op) unstack_2(Sc, Op, __func__, __LINE__)
static void unstack_2(s7_scheme * sc, opcode_t op, const char *func,
int line)
{
sc->stack_end -= 4;
if (((opcode_t) sc->stack_end[3]) != op) {
fprintf(stderr, "%s%s[%d]: popped %s?%s\n", BOLD_TEXT, func, line,
op_names[(opcode_t) sc->stack_end[3]], UNBOLD_TEXT);
fprintf(stderr, " code: %s, args: %s\n", display(sc->code),
display(sc->args));
fprintf(stderr, " cur_code: %s, estr: %s\n",
display(current_code(sc)),
display(s7_name_to_value(sc, "estr")));
if (sc->stop_at_error)
abort();
}
}
#else
#define unstack(sc) sc->stack_end -= 4
#define unstack_with(sc, op) sc->stack_end -= 4
#endif
#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]) */
/* 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_op(sc, OP_EVAL_DONE);
}
static void resize_stack(s7_scheme * sc)
{
uint64_t loc;
uint32_t new_size;
block_t *ob, *nb;
loc = current_stack_top(sc);
new_size = sc->stack_size * 2;
/* how can we trap infinite recursion? Is a warning in order here? I think I'll add 'max-stack-size */
if (new_size > sc->max_stack_size)
s7_error(sc, make_symbol(sc, "stack-too-big"),
set_elist_1(sc,
wrap_string(sc,
"stack has grown past (*s7* 'max-stack-size)",
43)));
ob = stack_block(sc->stack);
nb = reallocate(sc, ob, new_size * sizeof(s7_pointer));
block_info(nb) = NULL;
stack_block(sc->stack) = nb;
stack_elements(sc->stack) = (s7_pointer *) block_data(nb);
if (!stack_elements(sc->stack))
s7_error(sc, make_symbol(sc, "stack-too-big"),
set_elist_1(sc,
wrap_string(sc, "no room to expand stack?",
24)));
{
s7_pointer *orig = stack_elements(sc->stack);
s7_int i = sc->stack_size, left;
left = new_size - i - 8;
while (i <= left)
LOOP_8(orig[i++] = sc->nil);
for (; i < new_size; i++)
orig[i] = sc->nil;
}
vector_length(sc->stack) = new_size;
sc->stack_size = new_size;
sc->stack_start = stack_elements(sc->stack);
sc->stack_end = (s7_pointer *) (sc->stack_start + loc);
/* sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + sc->stack_size / 2); */
sc->stack_resize_trigger =
(s7_pointer *) (sc->stack_start +
(new_size - STACK_RESIZE_TRIGGER));
if (show_stack_stats(sc))
s7_warn(sc, 128, "stack grows to %u\n", new_size);
}
#define check_stack_size(Sc) do {if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc);} while (0)
s7_pointer s7_gc_protect_via_stack(s7_scheme * sc, s7_pointer x)
{
push_stack_no_let_no_code(sc, OP_GC_PROTECT, x);
return (x);
}
s7_pointer s7_gc_unprotect_via_stack(s7_scheme * sc, s7_pointer x)
{
unstack(sc);
return (x);
}
#define stack_protected1(Sc) Sc->stack_end[-2]
#define stack_protected2(Sc) Sc->stack_end[-4]
#define stack_protected3(Sc) Sc->stack_end[-3]
static inline void gc_protect_via_stack(s7_scheme * sc, s7_pointer val)
{
sc->stack_end[2] = val;
sc->stack_end[3] = (s7_pointer) OP_GC_PROTECT;
sc->stack_end += 4;
}
#define gc_protect_2_via_stack(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y;} while (0)
/* often X and Y are fx_calls, so push X, then set Y */
/* -------------------------------- symbols -------------------------------- */
static inline uint64_t raw_string_hash(const uint8_t * key, s7_int len)
{
if (len <= 8) {
uint64_t xs[1] = { 0 };
memcpy((void *) xs, (void *) key, len);
return (xs[0]);
} else {
uint64_t xs[2] = { 0, 0 };
memcpy((void *) xs, (void *) key, (len > 16) ? 16 : len); /* compiler complaint here is bogus */
return (xs[0] + xs[1]);
}
}
static uint8_t *alloc_symbol(s7_scheme * sc)
{
#define SYMBOL_SIZE (3 * sizeof(s7_cell) + sizeof(block_t))
#define ALLOC_SYMBOL_SIZE (64 * SYMBOL_SIZE)
uint8_t *result;
if (sc->alloc_symbol_k == ALLOC_SYMBOL_SIZE) {
sc->alloc_symbol_cells = (uint8_t *) Malloc(ALLOC_SYMBOL_SIZE);
add_saved_pointer(sc, sc->alloc_symbol_cells);
sc->alloc_symbol_k = 0;
}
result = &(sc->alloc_symbol_cells[sc->alloc_symbol_k]);
sc->alloc_symbol_k += SYMBOL_SIZE;
return (result);
}
static s7_pointer make_permanent_slot(s7_scheme * sc, s7_pointer symbol,
s7_pointer value);
static inline s7_pointer make_symbol_with_length(s7_scheme * sc,
const char *name,
s7_int len);
static inline s7_pointer new_symbol(s7_scheme * sc, const char *name,
s7_int len, uint64_t hash,
uint32_t location)
{
/* name might not be null-terminated, these are permanent symbols even in s7_gensym; g_gensym handles everything separately */
s7_pointer x, str, p;
uint8_t *base, *val;
base = alloc_symbol(sc);
x = (s7_pointer) base;
str = (s7_pointer) (base + sizeof(s7_cell));
p = (s7_pointer) (base + 2 * sizeof(s7_cell));
val = (uint8_t *) permalloc(sc, len + 1);
memcpy((void *) val, (void *) name, len);
val[len] = '\0';
full_type(str) = T_STRING | T_IMMUTABLE | T_UNHEAP; /* avoid debugging confusion involving set_type (also below) */
string_length(str) = len;
string_value(str) = (char *) val;
string_hash(str) = hash;
full_type(x) = T_SYMBOL | T_UNHEAP;
symbol_set_name_cell(x, str);
set_global_slot(x, sc->undefined); /* was sc->nil */
symbol_info(x) = (block_t *) (base + 3 * sizeof(s7_cell));
set_initial_slot(x, sc->undefined);
symbol_set_local_slot_unchecked_and_unincremented(x, 0LL, sc->nil);
symbol_set_tag(x, 0);
symbol_set_tag2(x, 0);
symbol_clear_ctr(x); /* alloc_symbol uses malloc */
symbol_clear_type(x);
symbol_set_position(x, PD_POSITION_UNSET);
if ((len > 1) && /* not 0, otherwise : is a keyword */
((name[0] == ':') || (name[len - 1] == ':'))) { /* see s7test under keyword? for troubles if both colons are present */
s7_pointer slot, ksym;
set_type_bit(x, T_IMMUTABLE | T_KEYWORD | T_GLOBAL);
set_optimize_op(str, OP_CON);
ksym =
make_symbol_with_length(sc,
(name[0] ==
':') ? (char *) (name + 1) : name,
len - 1);
keyword_set_symbol(x, ksym);
set_has_keyword(ksym);
/* the keyword symbol needs to be permanent (not a gensym) else we have to laboriously gc-protect it */
if ((is_gensym(ksym)) && (in_heap(ksym)))
s7_remove_from_heap(sc, ksym);
slot = make_permanent_slot(sc, x, x);
set_global_slot(x, slot);
set_local_slot(x, slot);
}
full_type(p) = T_PAIR | T_IMMUTABLE | T_UNHEAP; /* add x to the symbol table */
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, (uint64_t) len); /* symbol name length, so it ought to fit! */
pair_set_raw_name(p, string_value(str));
return (x);
}
static inline s7_pointer make_symbol_with_length(s7_scheme * sc,
const char *name,
s7_int len)
{
s7_pointer x;
uint64_t hash;
uint32_t location;
hash = raw_string_hash((const uint8_t *) 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))
&& ((uint64_t) 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)) && ((uint64_t) 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)
{
return ((name) ? make_symbol_with_length(sc, name, safe_strlen(name)) :
sc->F);
}
static s7_pointer symbol_table_find_by_name(s7_scheme * sc,
const char *name,
uint64_t hash,
uint32_t location, s7_int len)
{
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_with_length(name, pair_raw_name(x), len)))
return (car(x));
return (sc->nil);
}
s7_pointer s7_symbol_table_find_name(s7_scheme * sc, const char *name)
{
uint64_t hash;
uint32_t location;
s7_pointer result;
s7_int len;
hash = raw_string_hash((const uint8_t *) name, len =
safe_strlen(name));
location = hash % SYMBOL_TABLE_SIZE;
result = symbol_table_find_by_name(sc, name, hash, location, len);
if (is_null(result))
return (NULL);
return (result);
}
/* -------------------------------- symbol-table -------------------------------- */
static inline s7_pointer make_simple_vector(s7_scheme * sc, s7_int len);
static s7_pointer g_symbol_table(s7_scheme * sc, s7_pointer 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, *entries = vector_elements(sc->symbol_table);
int32_t 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.
* (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 < SYMBOL_TABLE_SIZE; i++)
for (x = entries[i]; is_not_null(x); x = cdr(x))
syms++;
sc->w = make_simple_vector(sc, syms);
els = vector_elements(sc->w);
for (i = 0, j = 0; i < SYMBOL_TABLE_SIZE; i++)
for (x = entries[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? */
int32_t i;
s7_pointer x;
for (i = 0; i < SYMBOL_TABLE_SIZE; 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,
void *data), void *data)
{
int32_t i;
s7_pointer x;
for (i = 0; i < SYMBOL_TABLE_SIZE; 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 (false);
}
/* -------------------------------- gensym -------------------------------- */
static void remove_gensym_from_symbol_table(s7_scheme * sc, s7_pointer sym)
{
/* sym is a free cell at this point (we're called after the GC), but the name_cell is still intact */
s7_pointer x, name = symbol_name_cell(sym);
uint32_t location;
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);
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));
return;
}
if (S7_DEBUGGING)
fprintf(stderr, "could not remove %s?\n", string_value(name));
}
}
s7_pointer s7_gensym(s7_scheme * sc, const char *prefix)
{
block_t *b;
char *name;
uint32_t location;
s7_int len;
uint64_t hash;
s7_pointer x;
len = safe_strlen(prefix) + 32;
b = mallocate(sc, len);
name = (char *) block_data(b);
/* there's no point in heroic efforts here to avoid name collisions -- the user can screw up no matter what we do */
name[0] = '\0';
len =
catstrs(name, len, "{", (prefix) ? prefix : "", "}-",
pos_int_to_str_direct(sc, sc->gensym_counter++),
(char *) NULL);
hash = raw_string_hash((const uint8_t *) name, len);
location = hash % SYMBOL_TABLE_SIZE;
x = new_symbol(sc, name, len, hash, location); /* not T_GENSYM -- might be called from outside */
liberate(sc, b);
return (x);
}
static bool is_gensym_b_p(s7_pointer g)
{
return ((is_symbol(g)) && (is_gensym(g)));
}
static s7_pointer g_is_gensym(s7_scheme * sc, s7_pointer args)
{
#define H_is_gensym "(gensym? sym) returns #t if sym is a gensym"
#define Q_is_gensym sc->pl_bt
check_boolean_method(sc, is_gensym_b_p, sc->is_gensym_symbol, args);
}
static s7_pointer g_gensym(s7_scheme * sc, s7_pointer args)
{
#define H_gensym "(gensym (prefix \"gensym\")) returns a new, unused symbol"
#define Q_gensym s7_make_signature(sc, 2, sc->is_gensym_symbol, sc->is_string_symbol)
const char *prefix;
char *name, *p, *base;
s7_int len, plen, nlen;
uint32_t location;
uint64_t hash;
s7_pointer x, str, stc;
block_t *b, *ib;
/* get symbol name */
if (is_not_null(args)) {
s7_pointer gname;
gname = car(args);
if (!is_string(gname))
return (method_or_bust_one_arg
(sc, gname, sc->gensym_symbol, args, T_STRING));
prefix = string_value(gname);
plen = safe_strlen(prefix);
} else {
prefix = "gensym";
plen = 6;
}
len = plen + 32; /* why 32 -- we need room for the gensym_counter integer, but (length "9223372036854775807") = 19 */
b = mallocate(sc, len + sizeof(block_t) + 2 * sizeof(s7_cell));
/* only 16 of block_t size is actually needed here because only the ln.tag (symbol_tag2) field is used in the embedded block_t */
base = (char *) block_data(b);
str = (s7_cell *) base;
stc = (s7_cell *) (base + sizeof(s7_cell));
ib = (block_t *) (base + 2 * sizeof(s7_cell));
name = (char *) (base + sizeof(block_t) + 2 * sizeof(s7_cell));
name[0] = '{';
if (plen > 0)
memcpy((void *) (name + 1), prefix, plen);
name[plen + 1] = '}';
name[plen + 2] = '-'; /* {gensym}-nnn */
p = pos_int_to_str(sc, sc->gensym_counter++, &len, '\0');
memcpy((void *) (name + plen + 3), (void *) p, len);
nlen = len + plen + 2;
if ((S7_DEBUGGING) && ((s7_int) strlen(name) != nlen))
fprintf(stderr, "%s[%d]: %s len: %" ld64 " != %" ld64 "\n",
__func__, __LINE__, name, nlen, (s7_int) strlen(name));
hash = raw_string_hash((const uint8_t *) name, nlen);
location = hash % SYMBOL_TABLE_SIZE;
if ((WITH_WARNINGS) &&
(!is_null
(symbol_table_find_by_name(sc, name, hash, location, nlen))))
s7_warn(sc, nlen + 32, "%s is already in use!", name);
/* make-string for symbol name */
if (S7_DEBUGGING)
full_type(str) = 0; /* here and below, this is needed to avoid set_type check errors (mallocate above) */
set_full_type(str, T_STRING | T_IMMUTABLE | T_UNHEAP);
string_length(str) = nlen;
string_value(str) = name;
string_hash(str) = hash;
/* allocate the symbol in the heap so GC'd when inaccessible */
new_cell(sc, x, T_SYMBOL | T_GENSYM);
symbol_set_name_cell(x, str);
symbol_info(x) = ib;
set_global_slot(x, sc->undefined); /* set_initial_slot(x, sc->undefined); */
symbol_set_local_slot_unchecked(x, 0LL, sc->nil);
symbol_clear_ctr(x);
symbol_set_tag(x, 0);
symbol_set_tag2(x, 0);
symbol_clear_type(x);
symbol_set_position(x, PD_POSITION_UNSET);
gensym_block(x) = b;
/* place new symbol in symbol-table */
if (S7_DEBUGGING)
full_type(stc) = 0;
set_full_type(stc, T_PAIR | T_IMMUTABLE | T_UNHEAP);
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, (uint64_t) string_length(str));
pair_set_raw_name(stc, string_value(str));
add_gensym(sc, x);
return (x);
}
/* -------------------------------- syntax? -------------------------------- */
bool s7_is_syntax(s7_pointer p)
{
return (is_syntax(p));
}
static s7_pointer g_is_syntax(s7_scheme * sc, s7_pointer args)
{
#define H_is_syntax "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)"
#define Q_is_syntax sc->pl_bt
check_boolean_method(sc, is_syntax, sc->is_syntax_symbol, args);
}
/* -------------------------------- symbol? -------------------------------- */
bool s7_is_symbol(s7_pointer p)
{
return (is_symbol(p));
}
static s7_pointer g_is_symbol(s7_scheme * sc, s7_pointer args)
{
#define H_is_symbol "(symbol? obj) returns #t if obj is a symbol"
#define Q_is_symbol sc->pl_bt
check_boolean_method(sc, is_symbol, sc->is_symbol_symbol, args);
}
const char *s7_symbol_name(s7_pointer p)
{
return (symbol_name(p));
}
s7_pointer s7_name_to_value(s7_scheme * sc, const char *name)
{
return (s7_symbol_value(sc, make_symbol(sc, name)));
}
/* should this also handle non-symbols such as "+nan.0"? */
/* -------------------------------- symbol->string -------------------------------- */
static Inline s7_pointer inline_make_string_with_length(s7_scheme * sc,
const char *str,
s7_int len)
{
s7_pointer x;
new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE);
string_block(x) = mallocate(sc, len + 1);
string_value(x) = (char *) block_data(string_block(x));
if (len > 0)
memcpy((void *) string_value(x), (void *) str, len);
string_value(x)[len] = 0;
string_length(x) = len;
string_hash(x) = 0;
add_string(sc, x);
return (x);
}
static inline s7_pointer make_string_with_length(s7_scheme * sc,
const char *str,
s7_int len)
{
return (inline_make_string_with_length(sc, str, len));
}
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 = car(args);
if (!is_symbol(sym))
return (method_or_bust_one_arg
(sc, sym, sc->symbol_to_string_symbol, args, T_SYMBOL));
/* s7_make_string uses strlen which stops at an embedded null */
return (inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy */
}
static s7_pointer g_symbol_to_string_uncopied(s7_scheme * sc,
s7_pointer args)
{
s7_pointer sym = car(args);
if (!is_symbol(sym))
return (method_or_bust_one_arg
(sc, sym, sc->symbol_to_string_symbol, args, T_SYMBOL));
if (is_gensym(sym))
return (make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy of gensym name (which will be freed) */
return (symbol_name_cell(sym));
}
static s7_pointer symbol_to_string_p_p(s7_scheme * sc, s7_pointer sym)
{
if (!is_symbol(sym))
return (method_or_bust_one_arg
(sc, sym, sc->symbol_to_string_symbol,
set_plist_1(sc, sym), T_SYMBOL));
return (inline_make_string_with_length
(sc, symbol_name(sym), symbol_name_length(sym)));
}
static s7_pointer symbol_to_string_uncopied_p(s7_scheme * sc,
s7_pointer sym)
{
if (!is_symbol(sym))
return (method_or_bust_one_arg
(sc, sym, sc->symbol_to_string_symbol,
set_plist_1(sc, sym), T_SYMBOL));
if (is_gensym(sym))
return (make_string_with_length
(sc, symbol_name(sym), symbol_name_length(sym)));
return (symbol_name_cell(sym));
}
/* -------------------------------- string->symbol -------------------------------- */
static inline s7_pointer g_string_to_symbol_1(s7_scheme * sc,
s7_pointer str,
s7_pointer caller)
{
if (!is_string(str))
return (method_or_bust_one_arg_p(sc, str, caller, T_STRING));
if (string_length(str) > 0)
return (make_symbol_with_length
(sc, string_value(str), string_length(str)));
return (simple_wrong_type_argument_with_type
(sc, caller, str, wrap_string(sc, "a non-null string", 17)));
}
static s7_pointer g_string_to_symbol(s7_scheme * sc, s7_pointer args)
{
#define H_string_to_symbol "(string->symbol str) returns the string str converted to a symbol"
#define Q_string_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol)
return (g_string_to_symbol_1
(sc, car(args), sc->string_to_symbol_symbol));
}
static s7_pointer string_to_symbol_p_p(s7_scheme * sc, s7_pointer p)
{
return (g_string_to_symbol_1(sc, p, sc->string_to_symbol_symbol));
}
/* -------------------------------- symbol -------------------------------- */
static s7_pointer g_string_append_1(s7_scheme * sc, s7_pointer args,
s7_pointer caller);
static s7_pointer 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)
s7_int len = 0, cur_len;
s7_pointer p, sym;
block_t *b;
char *name;
for (p = args; is_pair(p); p = cdr(p))
if (is_string(car(p)))
len += string_length(car(p));
else
break;
if (is_pair(p)) {
if (is_null(cdr(args)))
return (g_string_to_symbol_1
(sc, car(args), sc->symbol_symbol));
return (g_string_to_symbol_1
(sc, g_string_append_1(sc, args, sc->symbol_symbol),
sc->symbol_symbol));
}
if (len == 0)
return (simple_wrong_type_argument_with_type
(sc, sc->symbol_symbol, car(args),
wrap_string(sc, "a non-null string", 17)));
b = mallocate(sc, len + 1);
name = (char *) block_data(b);
/* can't use catstrs_direct here because it stops at embedded null */
cur_len = 0;
for (p = args; is_pair(p); p = cdr(p)) {
s7_pointer str = car(p);
if (string_length(str) > 0) {
memcpy((void *) (name + cur_len), (void *) string_value(str),
string_length(str));
cur_len += string_length(str);
}
}
name[len] = '\0';
sym = make_symbol_with_length(sc, name, len);
liberate(sc, b);
return (sym);
}
static s7_pointer symbol_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
char buf[256];
s7_int len;
if ((!is_string(p1)) || (!is_string(p2)))
return (g_symbol(sc, set_plist_2(sc, p1, p2)));
len = string_length(p1) + string_length(p2);
if ((len == 0) || (len >= 256))
return (g_symbol(sc, set_plist_2(sc, p1, p2)));
memcpy((void *) buf, (void *) string_value(p1), string_length(p1));
memcpy((void *) (buf + string_length(p1)), (void *) string_value(p2),
string_length(p2));
return (make_symbol_with_length(sc, buf, len));
}
/* -------- symbol sets -------- */
static inline s7_pointer add_symbol_to_list(s7_scheme * sc, s7_pointer sym)
{
symbol_set_tag(sym, sc->syms_tag);
symbol_set_tag2(sym, sc->syms_tag2);
return (sym);
}
static inline void clear_symbol_list(s7_scheme * sc)
{
sc->syms_tag++;
if (sc->syms_tag == 0) {
sc->syms_tag = 1; /* we're assuming (in let_equal) that this tag is not 0 */
sc->syms_tag2++;
}
}
#define symbol_is_in_list(Sc, Sym) ((symbol_tag(Sym) == Sc->syms_tag) && (symbol_tag2(Sym) == Sc->syms_tag2))
/* -------------------------------- lets/slots -------------------------------- */
static Inline s7_pointer make_let(s7_scheme * sc, s7_pointer old_let)
{
s7_pointer x;
new_cell(sc, x, T_LET | T_SAFE_PROCEDURE);
let_set_id(x, ++sc->let_number);
let_set_slots(x, slot_end(sc));
let_set_outlet(x, old_let);
return (x);
}
static inline s7_pointer make_let_slowly(s7_scheme * sc,
s7_pointer old_let)
{
s7_pointer x;
new_cell(sc, x, T_LET | T_SAFE_PROCEDURE);
let_set_id(x, ++sc->let_number);
let_set_slots(x, slot_end(sc));
let_set_outlet(x, old_let);
return (x);
}
static inline s7_pointer make_simple_let(s7_scheme * sc)
{ /* called only in op_let_fx */
s7_pointer let;
new_cell(sc, let, T_LET | T_SAFE_PROCEDURE);
let_set_id(let, sc->let_number + 1);
let_set_slots(let, slot_end(sc));
let_set_outlet(let, sc->curlet);
return (let);
}
static Inline s7_pointer make_let_with_slot(s7_scheme * sc,
s7_pointer old_let,
s7_pointer symbol,
s7_pointer value)
{
s7_pointer new_let, slot;
new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE);
let_set_id(new_let, ++sc->let_number);
let_set_outlet(new_let, old_let);
new_cell_no_check(sc, slot, T_SLOT);
slot_set_symbol_and_value(slot, symbol, value);
symbol_set_local_slot(symbol, sc->let_number, slot);
slot_set_next(slot, slot_end(sc));
let_set_slots(new_let, slot);
return (new_let);
}
static Inline s7_pointer make_let_with_two_slots(s7_scheme * sc,
s7_pointer old_let,
s7_pointer symbol1,
s7_pointer value1,
s7_pointer symbol2,
s7_pointer value2)
{
/* we leave value1/value2 computation order to the C compiler here -- in the old macro, it was explicitly value1 then value2
* this means any let in old scheme code that actually depends on the order may break -- it should be let*.
*/
s7_pointer new_let, slot1, slot2;
new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE);
let_set_id(new_let, ++sc->let_number);
let_set_outlet(new_let, old_let);
new_cell_no_check(sc, slot1, T_SLOT);
slot_set_symbol_and_value(slot1, symbol1, value1);
symbol_set_local_slot(symbol1, sc->let_number, slot1);
let_set_slots(new_let, slot1);
new_cell_no_check(sc, slot2, T_SLOT);
slot_set_symbol_and_value(slot2, symbol2, value2);
symbol_set_local_slot(symbol2, sc->let_number, slot2);
slot_set_next(slot2, slot_end(sc));
slot_set_next(slot1, slot2);
return (new_let);
}
/* in all these functions, symbol_set_local_slot should follow slot_set_value so that we can evaluate the slot's value in its old state. */
static inline void add_slot_unchecked(s7_scheme * sc, s7_pointer let,
s7_pointer symbol, s7_pointer value,
uint64_t id)
{
s7_pointer slot;
new_cell_no_check(sc, slot, T_SLOT);
slot_set_symbol_and_value(slot, symbol, value);
slot_set_next(slot, let_slots(let));
let_set_slots(let, slot);
set_local(symbol);
symbol_set_local_slot(symbol, id, slot);
}
#define add_slot(Sc, Let, Symbol, Value) add_slot_unchecked(Sc, Let, Symbol, Value, let_id(Let))
static inline s7_pointer add_slot_checked(s7_scheme * sc, s7_pointer let,
s7_pointer symbol,
s7_pointer value)
{
s7_pointer slot;
new_cell(sc, slot, T_SLOT);
slot_set_symbol_and_value(slot, symbol, value);
symbol_set_local_slot(symbol, let_id(let), slot);
slot_set_next(slot, let_slots(let));
let_set_slots(let, slot);
return (slot);
}
static inline s7_pointer add_slot_checked_with_id(s7_scheme * sc,
s7_pointer let,
s7_pointer symbol,
s7_pointer value)
{
s7_pointer slot;
new_cell(sc, slot, T_SLOT);
slot_set_symbol_and_value(slot, symbol, value);
set_local(symbol);
if (let_id(let) >= symbol_id(symbol))
symbol_set_local_slot(symbol, let_id(let), slot);
slot_set_next(slot, let_slots(let));
let_set_slots(let, slot);
return (slot);
}
static s7_pointer add_slot_unchecked_with_id(s7_scheme * sc,
s7_pointer let,
s7_pointer symbol,
s7_pointer value)
{
s7_pointer slot;
new_cell_no_check(sc, slot, T_SLOT);
slot_set_symbol_and_value(slot, symbol, value);
set_local(symbol);
if (let_id(let) >= symbol_id(symbol))
symbol_set_local_slot(symbol, let_id(let), slot);
slot_set_next(slot, let_slots(let));
let_set_slots(let, slot);
return (slot);
}
static Inline s7_pointer add_slot_at_end(s7_scheme * sc, uint64_t id,
s7_pointer last_slot,
s7_pointer symbol,
s7_pointer value)
{
s7_pointer slot;
new_cell_no_check(sc, slot, T_SLOT);
slot_set_symbol_and_value(slot, symbol, value);
slot_set_next(slot, slot_end(sc));
symbol_set_local_slot(symbol, id, slot);
slot_set_next(last_slot, slot);
return (slot);
}
static inline void make_let_with_three_slots(s7_scheme * sc,
s7_pointer func,
s7_pointer val1,
s7_pointer val2,
s7_pointer val3)
{
s7_pointer last_slot, cargs = closure_args(func);
sc->curlet =
make_let_with_two_slots(sc, closure_let(func), car(cargs), val1,
cadr(cargs), val2);
last_slot = next_slot(let_slots(sc->curlet));
add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(cargs), val3);
}
static inline void make_let_with_four_slots(s7_scheme * sc,
s7_pointer func,
s7_pointer val1,
s7_pointer val2,
s7_pointer val3,
s7_pointer val4)
{
s7_pointer last_slot, cargs = closure_args(func);
sc->curlet =
make_let_with_two_slots(sc, closure_let(func), car(cargs), val1,
cadr(cargs), val2);
cargs = cddr(cargs);
last_slot = next_slot(let_slots(sc->curlet));
last_slot =
add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(cargs),
val3);
add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(cargs), val4);
}
static s7_pointer reuse_as_let(s7_scheme * sc, s7_pointer let,
s7_pointer next_let)
{
/* we're reusing let here as a let -- it was probably a pair */
#if S7_DEBUGGING
let->debugger_bits = 0;
if (!in_heap(let))
fprintf(stderr, "reusing an unheaped let?\n");
#endif
set_full_type(let, T_LET | T_SAFE_PROCEDURE);
let_set_slots(let, slot_end(sc));
let_set_outlet(let, next_let);
let_set_id(let, ++sc->let_number);
return (let);
}
static s7_pointer reuse_as_slot(s7_scheme * sc, s7_pointer slot,
s7_pointer symbol, s7_pointer value)
{
#if S7_DEBUGGING
slot->debugger_bits = 0;
if (!in_heap(slot))
fprintf(stderr, "reusing a permanent cell?\n");
if (is_multiple_value(value)) {
fprintf(stderr, "%s%s[%d]: multiple-value %s %s%s\n", BOLD_TEXT,
__func__, __LINE__, display(value), display(sc->code),
UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
#endif
set_full_type(slot, T_SLOT);
slot_set_symbol_and_value(slot, symbol, value);
return (slot);
}
#define update_slot(Slot, Val, Id) do {s7_pointer sym; slot_set_value(Slot, Val); sym = slot_symbol(Slot); symbol_set_local_slot_unincremented(sym, Id, Slot);} while (0)
static s7_pointer update_let_with_slot(s7_scheme * sc, s7_pointer let,
s7_pointer val)
{
s7_pointer slot = let_slots(let);
uint64_t id;
id = ++sc->let_number;
let_set_id(let, id);
update_slot(slot, val, id);
return (let);
}
static s7_pointer update_let_with_two_slots(s7_scheme * sc, s7_pointer let,
s7_pointer val1,
s7_pointer val2)
{
s7_pointer slot = let_slots(let);
uint64_t id;
id = ++sc->let_number;
let_set_id(let, id);
update_slot(slot, val1, id);
slot = next_slot(slot);
update_slot(slot, val2, id);
return (let);
}
static s7_pointer update_let_with_three_slots(s7_scheme * sc,
s7_pointer let,
s7_pointer val1,
s7_pointer val2,
s7_pointer val3)
{
s7_pointer slot = let_slots(let);
uint64_t id;
id = ++sc->let_number;
let_set_id(let, id);
update_slot(slot, val1, id);
slot = next_slot(slot);
update_slot(slot, val2, id);
slot = next_slot(slot);
update_slot(slot, val3, id);
return (let);
}
static s7_pointer update_let_with_four_slots(s7_scheme * sc,
s7_pointer let,
s7_pointer val1,
s7_pointer val2,
s7_pointer val3,
s7_pointer val4)
{
s7_pointer slot = let_slots(let);
uint64_t id;
id = ++sc->let_number;
let_set_id(let, id);
update_slot(slot, val1, id);
slot = next_slot(slot);
update_slot(slot, val2, id);
slot = next_slot(slot);
update_slot(slot, val3, id);
slot = next_slot(slot);
update_slot(slot, val4, id);
return (let);
}
static s7_pointer make_permanent_slot(s7_scheme * sc, s7_pointer symbol,
s7_pointer value)
{
s7_pointer slot;
slot = alloc_pointer(sc);
set_full_type(slot, T_SLOT | T_UNHEAP);
slot_set_symbol_and_value(slot, symbol, value);
return (slot);
}
static s7_pointer make_permanent_let(s7_scheme * sc, s7_pointer vars)
{
s7_pointer let, var, slot;
let = alloc_pointer(sc);
set_full_type(let, T_LET | T_SAFE_PROCEDURE | T_UNHEAP);
let_set_id(let, ++sc->let_number);
let_set_outlet(let, sc->curlet);
slot = make_permanent_slot(sc, caar(vars), sc->F);
add_permanent_let_or_slot(sc, slot);
symbol_set_local_slot(caar(vars), sc->let_number, slot);
let_set_slots(let, slot);
for (var = cdr(vars); is_pair(var); var = cdr(var)) {
s7_pointer last_slot;
last_slot = slot;
slot = make_permanent_slot(sc, caar(var), sc->F);
add_permanent_let_or_slot(sc, slot);
symbol_set_local_slot(caar(var), sc->let_number, slot);
slot_set_next(last_slot, slot);
}
slot_set_next(slot, slot_end(sc));
add_permanent_let_or_slot(sc, let); /* need to mark outlet and maybe slot values */
return (let);
}
static s7_pointer find_let(s7_scheme * sc, s7_pointer obj)
{
if (is_let(obj))
return (obj);
switch (type(obj)) {
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
case T_CLOSURE:
case T_CLOSURE_STAR:
return (closure_let(obj));
case T_C_OBJECT:
return (c_object_let(obj));
case T_C_POINTER:
if ((is_let(c_pointer_info(obj))) &&
(c_pointer_info(obj) != sc->rootlet))
return (c_pointer_info(obj));
}
return (sc->nil);
}
static s7_pointer call_setter(s7_scheme * sc, s7_pointer slot,
s7_pointer old_value);
static inline s7_pointer checked_slot_set_value(s7_scheme * sc,
s7_pointer y,
s7_pointer value)
{
if (slot_has_setter(y))
slot_set_value(y, call_setter(sc, y, value));
else {
if (is_immutable_slot(y))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->let_set_symbol, slot_symbol(y))));
slot_set_value(y, value);
}
return (slot_value(y));
}
static s7_pointer let_fill(s7_scheme * sc, s7_pointer args)
{
s7_pointer e = car(args), val, p;
if ((e == sc->rootlet) || (e == sc->s7_let))
eval_error(sc, "attempt to fill! ~S?", 20, e);
if (e == sc->owlet) /* (owlet) copies sc->owlet, so this probably can't happen */
return (out_of_range
(sc, sc->fill_symbol, int_one, e,
wrap_string(sc, "can't fill! owlet", 17)));
if (is_funclet(e))
return (out_of_range
(sc, sc->fill_symbol, int_one, e,
wrap_string(sc, "can't fill! a funclet", 21)));
val = cadr(args);
for (p = let_slots(e); tis_slot(p); p = next_slot(p))
checked_slot_set_value(sc, p, val);
return (val);
}
static s7_pointer find_method(s7_scheme * sc, s7_pointer let,
s7_pointer symbol)
{
s7_pointer slot;
if (symbol_id(symbol) == 0) /* this means the symbol has never been used locally, so how can it be a method? */
return (sc->undefined);
slot = lookup_slot_from(symbol, let);
if (slot != global_slot(symbol))
return (slot_value(slot));
return (sc->undefined);
}
static s7_pointer find_method_with_let(s7_scheme * sc, s7_pointer let,
s7_pointer symbol)
{
return (find_method(sc, find_let(sc, let), symbol));
}
static s7_int s7_let_length(void);
static s7_int let_length(s7_scheme * sc, s7_pointer e)
{
/* used by length, applicable_length, copy, and some length optimizations */
s7_int i;
s7_pointer p;
if (e == sc->rootlet)
return (sc->rootlet_entries);
if (e == sc->s7_let)
return (s7_let_length());
if (has_active_methods(sc, e)) {
s7_pointer length_func;
length_func = find_method(sc, e, sc->length_symbol);
if (length_func != sc->undefined) {
p = call_method(sc, e, length_func, set_plist_1(sc, e));
return ((s7_is_integer(p)) ? s7_integer_checked(sc, p) : -1); /* ?? */
}
}
for (i = 0, p = let_slots(e); tis_slot(p); i++, p = next_slot(p));
return (i);
}
static void slot_set_setter(s7_pointer p, s7_pointer val)
{
if ((type(val) == T_C_FUNCTION) && (c_function_has_bool_setter(val)))
slot_set_setter_1(p, c_function_bool_setter(val));
else
slot_set_setter_1(p, val);
}
static void slot_set_value_with_hook_1(s7_scheme * sc, s7_pointer slot,
s7_pointer value)
{
/* (set! (hook-functions *rootlet-redefinition-hook*) (list (lambda (hook) (format *stderr* "~A ~A~%" (hook 'symbol) (hook 'value))))) */
s7_pointer symbol = slot_symbol(slot);
if ((global_slot(symbol) == slot) && (value != slot_value(slot)))
s7_call(sc, sc->rootlet_redefinition_hook,
set_elist_2(sc, symbol, value));
slot_set_value(slot, value);
}
static void remove_function_from_heap(s7_scheme * sc, s7_pointer value);
static void remove_let_from_heap(s7_scheme * sc, s7_pointer lt)
{
s7_pointer p;
for (p = let_slots(lt); tis_slot(p); p = next_slot(p)) {
s7_pointer val = slot_value(p);
if ((has_closure_let(val)) && (in_heap(closure_args(val))))
remove_function_from_heap(sc, val);
}
let_set_removed(lt);
}
static void add_slot_to_rootlet(s7_scheme * sc, s7_pointer slot)
{
s7_pointer ge;
ge = sc->rootlet;
rootlet_element(ge, sc->rootlet_entries++) = slot;
set_in_rootlet(slot);
if (sc->rootlet_entries >= vector_length(ge)) {
s7_int i, len;
block_t *ob, *nb;
vector_length(ge) *= 2;
len = vector_length(ge);
ob = rootlet_block(ge);
nb = reallocate(sc, ob, len * sizeof(s7_pointer));
block_info(nb) = NULL;
rootlet_block(ge) = nb;
rootlet_elements(ge) = (s7_pointer *) block_data(nb);
for (i = sc->rootlet_entries; i < len; i++)
rootlet_element(ge, i) = sc->nil;
}
}
static void remove_function_from_heap(s7_scheme * sc, s7_pointer value)
{
s7_pointer lt;
s7_remove_from_heap(sc, closure_args(value));
s7_remove_from_heap(sc, closure_body(value));
/* remove closure if it's local to current func (meaning (define f (let ...) (lambda ...)) removes the enclosing let) */
lt = closure_let(value); /* closure_let and all its outlets can't be rootlet */
if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) {
lt = let_outlet(lt);
if ((is_let(lt)) && (!let_removed(lt))
&& (lt != sc->shadow_rootlet)) {
remove_let_from_heap(sc, lt);
lt = let_outlet(lt);
if ((is_let(lt)) && (!let_removed(lt))
&& (lt != sc->shadow_rootlet))
remove_let_from_heap(sc, lt);
}
}
}
s7_pointer s7_make_slot(s7_scheme * sc, s7_pointer let, s7_pointer symbol,
s7_pointer value)
{
if ((!is_let(let)) || (let == sc->rootlet)) {
s7_pointer slot;
if (is_immutable(sc->rootlet))
return (immutable_object_error
(sc,
set_elist_2(sc,
wrap_string(sc,
"can't define '~S; rootlet is immutable",
38), symbol)));
if ((sc->safety == NO_SAFETY) && (has_closure_let(value)))
remove_function_from_heap(sc, value);
/* 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);
symbol_increment_ctr(symbol);
slot_set_value_with_hook(slot, value);
return (slot);
}
slot = make_permanent_slot(sc, symbol, value);
add_slot_to_rootlet(sc, slot);
set_global_slot(symbol, slot);
if (symbol_id(symbol) == 0) { /* never defined locally? */
if ((!is_gensym(symbol)) && (initial_slot(symbol) == sc->undefined) && (!in_heap(value)) && /* else initial_slot value can be GC'd if symbol set! (initial != global, initial unprotected) */
((!sc->unlet) || /* init_unlet creates sc->unlet, after that initial_slot is for c_functions?? */
(is_c_function(value))))
set_initial_slot(symbol,
make_permanent_slot(sc, symbol, value));
set_local_slot(symbol, slot);
set_global(symbol);
}
symbol_increment_ctr(symbol);
if (is_gensym(symbol))
s7_remove_from_heap(sc, symbol);
return (slot);
}
return (add_slot_checked_with_id(sc, let, symbol, value));
/* there are about as many lets as local variables -- this strikes me as surprising, but it holds up across a lot of code. */
}
static s7_pointer make_slot(s7_scheme * sc, s7_pointer variable,
s7_pointer value)
{
s7_pointer y;
new_cell(sc, y, T_SLOT);
slot_set_symbol_and_value(y, variable, 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."
#define Q_is_let sc->pl_bt
check_boolean_method(sc, is_let, sc->is_let_symbol, args);
}
/* -------------------------------- funclet? -------------------------------- */
static s7_pointer g_is_funclet(s7_scheme * sc, s7_pointer args)
{
#define H_is_funclet "(funclet? obj) returns #t if obj is a funclet (a function's environment)."
#define Q_is_funclet sc->pl_bt
s7_pointer lt = car(args);
if ((is_let(lt)) && ((is_funclet(lt)) || (is_maclet(lt))))
return (sc->T);
if (!has_active_methods(sc, lt))
return (sc->F);
return (apply_boolean_method(sc, lt, sc->is_funclet_symbol));
}
/* -------------------------------- unlet -------------------------------- */
static s7_pointer 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);
#define UNLET_ENTRIES 512 /* 397 if not --disable-deprecated etc */
static void init_unlet(s7_scheme * sc)
{
int32_t i, k = 0;
s7_pointer x;
s7_pointer *inits, *els;
block_t *block;
sc->unlet = (s7_pointer) Calloc(1, sizeof(s7_cell));
set_full_type(sc->unlet, T_VECTOR | T_UNHEAP);
vector_length(sc->unlet) = UNLET_ENTRIES;
block = mallocate(sc, UNLET_ENTRIES * sizeof(s7_pointer));
vector_block(sc->unlet) = block;
vector_elements(sc->unlet) = (s7_pointer *) block_data(block);
vector_set_dimension_info(sc->unlet, NULL);
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);
els = vector_elements(sc->symbol_table);
inits[k++] = initial_slot(sc->else_symbol);
for (i = 0; i < SYMBOL_TABLE_SIZE; i++)
for (x = els[i]; is_not_null(x); x = cdr(x)) {
s7_pointer sym = car(x);
if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) {
s7_pointer val = initial_value(sym);
if ((is_c_function(val)) || (is_syntax(val))) /* we assume the initial_slot value needs no GC protection */
inits[k++] = initial_slot(sym);
/* non-c_functions that are not set! (and therefore initial_slot GC) protected by default:
* make-hook hook-functions
* if these initial_slot values are added to unlet, they need explicit GC protection.
*/
if ((S7_DEBUGGING) && (k >= UNLET_ENTRIES))
fprintf(stderr, "unlet overflow\n");
}
}
}
static s7_pointer g_unlet(s7_scheme * sc, s7_pointer args)
{
/* add sc->unlet bindings to the current environment */
#define H_unlet "(unlet) returns a let that establishes the original bindings of all the predefined functions"
#define Q_unlet s7_make_signature(sc, 1, sc->is_let_symbol)
/* 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 only looks at the local env chain
* (that is, if env is not the global env, then the global env is not searched).
*/
int32_t i;
s7_pointer *inits;
s7_pointer x;
sc->w = make_let_slowly(sc, sc->curlet);
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 ((x != global_value(sym)) || /* it has been changed globally */
((!is_global(sym)) && /* it might be shadowed locally */
(s7_symbol_local_value(sc, sym, sc->curlet) !=
global_value(sym))))
add_slot_checked_with_id(sc, 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 sc->pl_bt
s7_pointer e = car(args); /* if e is not a let, should this raise an error? -- no, easier to use this way in cond */
check_method(sc, e, sc->is_openlet_symbol, args);
return (make_boolean(sc, has_methods(e)));
}
/* -------------------------------- openlet -------------------------------- */
s7_pointer s7_openlet(s7_scheme * sc, s7_pointer e)
{
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 let 'e might have an over-riding method."
#define Q_openlet sc->pcl_e
s7_pointer e = car(args), elet, func;
if ((e == sc->rootlet) || (e == sc->nil))
s7_error(sc, sc->out_of_range_symbol,
set_elist_1(sc,
wrap_string(sc, "can't openlet rootlet",
21)));
elet = find_let(sc, e); /* returns nil if no let found, so has to follow error check above */
if (!is_let(elet))
return (simple_wrong_type_argument_with_type
(sc, sc->openlet_symbol, e, a_let_string));
if ((has_active_methods(sc, e)) &&
((func =
find_method(sc, elet, sc->openlet_symbol)) != sc->undefined))
return (call_method(sc, e, func, args));
set_has_methods(e);
return (e);
}
/* -------------------------------- coverlet -------------------------------- */
static s7_pointer g_coverlet(s7_scheme * sc, s7_pointer args)
{
#define H_coverlet "(coverlet e) undoes an earlier openlet."
#define Q_coverlet sc->pcl_e
s7_pointer e = car(args);
sc->temp3 = e;
check_method(sc, e, sc->coverlet_symbol, set_plist_1(sc, e));
sc->temp3 = sc->nil;
if ((e == sc->rootlet) || (e == sc->s7_let))
s7_error(sc, sc->out_of_range_symbol,
set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17),
e));
if ((is_let(e)) ||
(has_closure_let(e)) ||
((is_c_object(e)) && (c_object_let(e) != sc->nil)) ||
((is_c_pointer(e)) && (is_let(c_pointer_info(e))))) {
clear_has_methods(e);
return (e);
}
return (simple_wrong_type_argument_with_type
(sc, sc->coverlet_symbol, e, a_let_string));
}
/* -------------------------------- varlet -------------------------------- */
static void append_let(s7_scheme * sc, s7_pointer new_e, s7_pointer old_e)
{
s7_pointer x;
if ((old_e == sc->rootlet) || (new_e == sc->s7_let))
return;
if (new_e == sc->rootlet)
for (x = let_slots(old_e); tis_slot(x); x = next_slot(x)) {
s7_pointer 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);
} else if (old_e == sc->s7_let) {
s7_pointer iter, carrier;
s7_int gc_loc;
iter = s7_make_iterator(sc, sc->s7_let);
gc_loc = s7_gc_protect(sc, iter);
carrier = cons_unchecked(sc, sc->F, sc->F);
iterator_current(iter) = carrier;
set_mark_seq(iter); /* so carrier is GC protected by mark_iterator */
while (true) {
s7_pointer y;
y = s7_iterate(sc, iter);
if (iterator_is_at_end(iter))
break;
add_slot_checked_with_id(sc, new_e, car(y), cdr(y));
}
s7_gc_unprotect_at(sc, gc_loc);
} else
for (x = let_slots(old_e); tis_slot(x); x = next_slot(x))
add_slot_checked_with_id(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */
}
static s7_pointer check_c_object_let(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 let, s7_pointer symbol,
s7_pointer value)
{
if (!is_let(let))
return (wrong_type_argument_with_type
(sc, sc->varlet_symbol, 1, let, a_let_string));
if (!is_symbol(symbol))
return (wrong_type_argument_with_type
(sc, sc->varlet_symbol, 2, symbol, a_symbol_string));
if ((is_slot(global_slot(symbol))) &&
(is_syntax(global_value(symbol))))
return (wrong_type_argument_with_type
(sc, sc->varlet_symbol, 2, symbol,
wrap_string(sc, "a non-syntactic name", 20)));
if (let == sc->rootlet) {
if (is_slot(global_slot(symbol)))
slot_set_value(global_slot(symbol), value);
else
s7_make_slot(sc, let, symbol, value);
} else
add_slot_checked_with_id(sc, let, symbol, value);
return (value);
}
static s7_pointer g_varlet(s7_scheme * sc, s7_pointer args)
{
#define H_varlet "(varlet let ...) adds its arguments (a let, a cons: symbol . value, or two arguments, the symbol and its value) \
to the let let, and returns let. (varlet (curlet) 'a 1) adds 'a to the current environment with the value 1."
#define Q_varlet s7_make_circular_signature(sc, 2, 4, sc->is_let_symbol, \
s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \
s7_make_signature(sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, sc->is_let_symbol), \
sc->T)
/* varlet = with-let + define */
s7_pointer x, e = car(args), val;
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));
if ((is_immutable(e)) || (e == sc->s7_let))
return (s7_error
(sc, sc->immutable_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"can't (varlet ~{~S~^ ~}), ~S is immutable",
41), args, e)));
}
for (x = cdr(args); is_pair(x); x = cdr(x)) {
s7_pointer sym, p = car(x);
switch (type(p)) {
case T_SYMBOL:
sym = (is_keyword(p)) ? keyword_symbol(p) : p;
if (!is_pair(cdr(x)))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, value_is_missing_string,
sc->varlet_symbol, car(x)));
if (is_constant_symbol(sc, sym))
return (wrong_type_argument_with_type
(sc, sc->varlet_symbol, position_of(x, args), sym,
a_non_constant_symbol_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));
if (is_constant_symbol(sc, sym))
return (wrong_type_argument_with_type
(sc, sc->varlet_symbol, position_of(x, args), sym,
a_non_constant_symbol_string));
val = cdr(p);
break;
case T_LET:
append_let(sc, e,
check_c_object_let(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 (e == sc->rootlet) {
if (is_slot(global_slot(sym))) {
if (is_syntax(global_value(sym)))
return (wrong_type_argument_with_type
(sc, sc->varlet_symbol, position_of(x, args),
p, wrap_string(sc, "a non-syntactic keyword",
23)));
/* 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_with_hook(global_slot(sym), val);
} else
s7_make_slot(sc, e, sym, val);
} else {
if ((has_let_fallback(e)) &&
((sym == sc->let_ref_fallback_symbol)
|| (sym == sc->let_set_fallback_symbol)))
return (s7_error
(sc, sc->out_of_range_symbol,
set_elist_2(sc,
wrap_string(sc,
"varlet can't shadow ~S",
22), sym)));
add_slot_checked_with_id(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 let 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 = car(args), syms;
s7_int the_un_id;
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));
if ((is_immutable(e)) || (e == sc->s7_let))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->cutlet_symbol, e)));
}
/* besides removing the slot we have to make sure the symbol_id does not match else
* let-ref and others will use the old slot! What's the un-id? Perhaps the next one?
* (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b)
*/
the_un_id = ++sc->let_number;
for (syms = cdr(args); is_pair(syms); syms = cdr(syms)) {
s7_pointer sym = car(syms), slot;
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 {
if ((has_let_fallback(e)) &&
((sym == sc->let_ref_fallback_symbol)
|| (sym == sc->let_set_fallback_symbol)))
return (s7_error
(sc, sc->out_of_range_symbol,
set_elist_2(sc,
wrap_string(sc,
"cutlet can't remove ~S",
22), sym)));
slot = let_slots(e);
if (tis_slot(slot)) {
if (slot_symbol(slot) == sym) {
let_set_slots(e, next_slot(let_slots(e)));
symbol_set_id(sym, the_un_id);
} else {
s7_pointer last_slot = slot;
for (slot = next_slot(let_slots(e)); tis_slot(slot);
last_slot = slot, slot = next_slot(slot))
if (slot_symbol(slot) == sym) {
symbol_set_id(sym, the_un_id);
slot_set_next(last_slot, next_slot(slot));
break;
}
}
}
}
}
return (e);
}
/* -------------------------------- sublet -------------------------------- */
static s7_pointer sublet_1(s7_scheme * sc, s7_pointer e,
s7_pointer bindings, s7_pointer caller)
{
s7_pointer new_e;
new_e =
(e == sc->rootlet) ? make_let_slowly(sc,
sc->nil) : make_let_slowly(sc,
e);
set_all_methods(new_e, e);
if (!is_null(bindings)) {
s7_pointer x;
sc->temp3 = new_e;
for (x = bindings; is_pair(x); x = cdr(x)) {
s7_pointer p = car(x), sym, val;
switch (type(p)) {
/* should this insist on one style of field arg? i.e. (cons sym val) throughout, or :sym val etc? */
case T_SYMBOL:
sym = (is_keyword(p)) ? keyword_symbol(p) : p;
if (!is_pair(cdr(x)))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, value_is_missing_string,
caller, car(x)));
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, 1 + position_of(x, bindings), p,
a_symbol_string));
if (is_keyword(sym))
sym = keyword_symbol(sym);
val = cdr(p);
break;
case T_LET:
append_let(sc, new_e, check_c_object_let(sc, p, caller));
continue;
default:
return (wrong_type_argument_with_type
(sc, caller, 1 + position_of(x, bindings), p,
a_symbol_string));
}
if (is_constant_symbol(sc, sym))
return (wrong_type_argument_with_type
(sc, caller, 1 + position_of(x, bindings), sym,
a_non_constant_symbol_string));
if ((is_slot(global_slot(sym)))
&& (is_syntax(global_value(sym))))
return (wrong_type_argument_with_type
(sc, caller, 2, sym,
wrap_string(sc, "a non-syntactic name", 20)));
/* here we know new_e is a let and is not rootlet */
add_slot_checked_with_id(sc, new_e, sym, val); /* add_slot without let_id check or is it set_local will not work here */
if (sym == sc->let_ref_fallback_symbol)
set_has_let_ref_fallback(new_e);
else if (sym == sc->let_set_fallback_symbol)
set_has_let_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 let ...) adds its arguments (each a let or a cons: '(symbol . value)) to let, and returns the new let."
#define Q_sublet Q_varlet
s7_pointer 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 a let, a cons: '(symbol . value), or a keyword/value pair, to a new let, and returns the \
new let. (inlet :a 1 :b 2) or (inlet '(a . 1) '(b . 2))"
#define Q_inlet s7_make_circular_signature(sc, 1, 2, sc->is_let_symbol, sc->T)
return (sublet_1(sc, sc->rootlet, args, sc->inlet_symbol));
}
#define g_inlet s7_inlet
static s7_pointer g_simple_inlet(s7_scheme * sc, s7_pointer args)
{
/* here all args are paired with normal symbol/value, no fallbacks, no immutable symbols etc */
s7_pointer new_e, x;
int64_t id;
new_e = make_let_slowly(sc, sc->nil);
sc->temp3 = new_e;
id = let_id(new_e);
for (x = args; is_pair(x); x = cddr(x)) {
s7_pointer symbol = car(x);
if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */
symbol = keyword_symbol(symbol);
if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */
return (wrong_type_argument_with_type
(sc, sc->inlet_symbol, 1, symbol,
a_non_constant_symbol_string));
add_slot_unchecked(sc, new_e, symbol, cadr(x), id);
}
sc->temp3 = sc->nil;
return (new_e);
}
static s7_pointer inlet_p_pp(s7_scheme * sc, s7_pointer symbol,
s7_pointer value)
{
s7_pointer x;
if (!is_symbol(symbol))
return (sublet_1
(sc, sc->nil, set_plist_2(sc, symbol, value),
sc->inlet_symbol));
if (is_keyword(symbol))
symbol = keyword_symbol(symbol);
if (is_constant_symbol(sc, symbol))
return (wrong_type_argument_with_type
(sc, sc->inlet_symbol, 1, symbol,
a_non_constant_symbol_string));
if ((is_global(symbol)) && (is_syntax(global_value(symbol))))
return (wrong_type_argument_with_type
(sc, sc->inlet_symbol, 1, symbol,
wrap_string(sc, "a non-syntactic name", 20)));
new_cell(sc, x, T_LET | T_SAFE_PROCEDURE);
sc->temp3 = x;
let_set_id(x, ++sc->let_number);
let_set_outlet(x, sc->nil);
let_set_slots(x, slot_end(sc));
add_slot_unchecked(sc, x, symbol, value, let_id(x));
sc->temp3 = sc->nil;
return (x);
}
static s7_pointer g_local_inlet(s7_scheme * sc, s7_int num_args, ...)
{
va_list ap;
s7_int i;
s7_pointer new_e;
int64_t id;
new_e = make_let_slowly(sc, sc->nil);
sc->temp3 = new_e;
id = let_id(new_e);
va_start(ap, num_args);
for (i = 0; i < num_args; i += 2) {
s7_pointer symbol, value;
symbol = va_arg(ap, s7_pointer);
value = va_arg(ap, s7_pointer);
if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */
symbol = keyword_symbol(symbol);
add_slot_unchecked(sc, new_e, symbol, value, id);
}
va_end(ap);
sc->temp3 = sc->nil;
return (new_e);
}
static bool is_proper_quote(s7_scheme * sc, s7_pointer p)
{
return ((is_quoted_pair(p)) &&
(is_pair(cdr(p))) &&
(is_null(cddr(p))) && (is_global(sc->quote_symbol)));
}
static s7_pointer inlet_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
if (!ops)
return (f);
if ((args > 0) && ((args % 2) == 0)) {
s7_pointer p;
for (p = cdr(expr); is_pair(p); p = cddr(p))
if (!is_keyword(car(p))) {
s7_pointer sym;
if (!is_proper_quote(sc, car(p))) /* 'abs etc, but tricky: ':abs */
return (f);
sym = cadar(p);
if ((!is_symbol(sym)) || (is_possibly_constant(sym)) || /* define-constant etc */
(is_syntactic_symbol(sym)) || /* (inlet 'if 3) */
((is_slot(global_slot(sym))) &&
(is_syntax(global_value(sym)))) ||
(sym == sc->let_ref_fallback_symbol) ||
(sym == sc->let_set_fallback_symbol))
return (f);
}
return (sc->simple_inlet);
}
return (f);
}
/* -------------------------------- let->list -------------------------------- */
static s7_pointer proper_list_reverse_in_place(s7_scheme * sc,
s7_pointer list);
s7_pointer s7_let_to_list(s7_scheme * sc, s7_pointer let)
{
s7_pointer x;
sc->temp3 = sc->w;
sc->w = sc->nil;
if (let == sc->rootlet) {
s7_int i, lim2 = sc->rootlet_entries;
s7_pointer *entries = rootlet_elements(let);
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;
s7_int gc_loc = -1;
/* need to check make-iterator method before dropping into let->list */
if ((has_active_methods(sc, let)) &&
((func =
find_method(sc, let,
sc->make_iterator_symbol)) != sc->undefined))
iter = call_method(sc, let, func, set_plist_1(sc, let));
else if (let == sc->s7_let) { /* (let->list *s7*) via s7_let_make_iterator */
iter = s7_make_iterator(sc, let);
gc_loc = s7_gc_protect(sc, iter);
} else
iter = sc->nil;
if (is_null(iter))
for (x = let_slots(let); tis_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 = proper_list_reverse_in_place(sc, sc->w);
}
if (gc_loc != -1)
s7_gc_unprotect_at(sc, gc_loc);
}
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 let) returns let's bindings as a list of cons's: '(symbol . value)."
#define Q_let_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_let_symbol)
s7_pointer let = car(args);
check_method(sc, let, sc->let_to_list_symbol, args);
if (!is_let(let)) {
if (is_c_object(let))
let = c_object_let(let);
else if (is_c_pointer(let))
let = c_pointer_info(let);
if (!is_let(let))
return (simple_wrong_type_argument_with_type
(sc, sc->let_to_list_symbol, let, a_let_string));
}
return (s7_let_to_list(sc, let));
}
#endif
/* -------------------------------- let-ref -------------------------------- */
static s7_pointer call_let_ref_fallback(s7_scheme * sc, s7_pointer let,
s7_pointer symbol)
{
s7_pointer p;
push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code);
p = s7_apply_function(sc,
find_method(sc, let,
sc->let_ref_fallback_symbol),
set_qlist_2(sc, let, symbol));
unstack(sc);
sc->code = T_Pos(sc->stack_end[0]);
sc->value = T_Pos(sc->stack_end[2]);
return (p);
}
static s7_pointer call_let_set_fallback(s7_scheme * sc, s7_pointer let,
s7_pointer symbol,
s7_pointer value)
{
s7_pointer p;
push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code);
p = s7_apply_function(sc,
find_method(sc, let,
sc->let_set_fallback_symbol),
set_qlist_3(sc, let, symbol, value));
unstack(sc);
sc->code = T_Pos(sc->stack_end[0]);
sc->value = T_Pos(sc->stack_end[2]);
return (p);
}
inline s7_pointer s7_let_ref(s7_scheme * sc, s7_pointer let,
s7_pointer symbol)
{
s7_pointer x, y;
/* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */
if (!is_let(let))
return (wrong_type_argument_with_type
(sc, sc->let_ref_symbol, 1, let, a_let_string));
if (!is_symbol(symbol)) {
#if S7_DEBUGGING
if ((let != sc->rootlet) && (has_let_ref_fallback(let)))
#else
if (has_let_ref_fallback(let))
#endif
return (call_let_ref_fallback(sc, let, symbol));
return (wrong_type_argument_with_type
(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string));
}
if (!is_global(sc->let_ref_symbol))
check_method(sc, let, sc->let_ref_symbol,
set_plist_2(sc, let, symbol));
/* a let-ref method is almost impossible to write without creating an infinite loop:
* any reference to the let will probably call let-ref somewhere, calling us again, and looping.
* This is not a problem in c-objects and funclets because c-object-ref and funclet-ref don't exist.
* After much wasted debugging, I decided to make let-ref and let-set! immutable.
*/
if (is_keyword(symbol))
symbol = keyword_symbol(symbol);
if (let == sc->rootlet) {
y = global_slot(symbol);
return ((is_slot(y)) ? slot_value(y) : sc->undefined);
}
if (let_id(let) == symbol_id(symbol))
return (local_value(symbol)); /* this obviously has to follow the rootlet check */
for (x = let; is_let(x); x = let_outlet(x))
for (y = let_slots(x); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == symbol)
return (slot_value(y));
if (has_methods(let)) { /* this is not a redundant check -- if has_methods, don't check global slot */
/* If a let is a mock-hash-table (for example), implicit
* indexing of the hash-table collides with the same thing for the let (field names
* versus keys), and we can't just try again here because that makes it too easy to
* get into infinite recursion. So, 'let-ref-fallback...
*/
if (has_let_ref_fallback(let))
return (call_let_ref_fallback(sc, let, symbol));
} else {
y = global_slot(symbol); /* (let () ((curlet) 'pi)) */
if (is_slot(y))
return (slot_value(y));
}
return (sc->undefined);
}
static s7_pointer g_let_ref(s7_scheme * sc, s7_pointer args)
{
#define H_let_ref "(let-ref let sym) returns the value of the symbol sym in the let"
#define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol)
return (s7_let_ref(sc, car(args), cadr(args)));
}
static s7_pointer slot_in_let(s7_scheme * sc, s7_pointer e, s7_pointer sym)
{
s7_pointer y;
for (y = let_slots(e); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == sym)
return (y);
return (sc->undefined);
}
static s7_pointer lint_let_ref_p_pp(s7_scheme * sc, s7_pointer lt,
s7_pointer sym)
{
s7_pointer x, y;
for (x = lt; is_let(x); x = let_outlet(x))
for (y = let_slots(x); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == sym)
return (slot_value(y));
if (has_methods(lt)) {
if (has_let_ref_fallback(lt))
return (call_let_ref_fallback(sc, lt, sym));
} else {
y = global_slot(sym);
if (is_slot(y))
return (slot_value(y));
}
return (sc->undefined);
}
static inline s7_pointer g_lint_let_ref(s7_scheme * sc, s7_pointer args)
{
s7_pointer lt = car(args), y, sym;
if (!is_let(lt))
return (wrong_type_argument_with_type
(sc, sc->let_ref_symbol, 1, lt, a_let_string));
sym = cadr(args);
for (y = let_slots(lt); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == sym)
return (slot_value(y));
return (lint_let_ref_p_pp(sc, let_outlet(lt), sym));
}
static s7_pointer let_ref_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if ((!ops) || (!is_global(sc->let_ref_symbol)))
return (f);
if (optimize_op(expr) == HOP_SAFE_C_opSq_C) {
s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
if ((car(arg1) == sc->cdr_symbol) &&
(is_quoted_symbol(arg2)) &&
(!is_possibly_constant(cadr(arg2)))) {
set_opt3_sym(cdr(expr), cadr(arg2));
return (sc->lint_let_ref);
}
}
return (f);
}
static bool op_implicit_let_ref_c(s7_scheme * sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
if (!is_let(s)) {
sc->last_function = s;
return (false);
}
sc->value = s7_let_ref(sc, T_Pos(s), opt3_con(sc->code));
return (true);
}
static bool op_implicit_let_ref_a(s7_scheme * sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
if (!is_let(s)) {
sc->last_function = s;
return (false);
}
sc->value = s7_let_ref(sc, s, fx_call(sc, cdr(sc->code)));
return (true);
}
/* -------------------------------- let-set! -------------------------------- */
static s7_pointer let_set_1(s7_scheme * sc, s7_pointer let,
s7_pointer symbol, s7_pointer value)
{
s7_pointer x, y;
if (is_keyword(symbol))
symbol = keyword_symbol(symbol);
symbol_increment_ctr(symbol);
if (let == sc->rootlet) {
if (is_constant_symbol(sc, symbol)) /* (let-set! (rootlet) 'pi #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))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
wrap_string(sc,
"let-set!: ~A is not defined in ~A",
33), symbol, let)));
if (is_syntax(slot_value(y)))
return (wrong_type_argument_with_type
(sc, sc->let_set_symbol, 2, symbol,
wrap_string(sc, "a non-syntactic keyword", 23)));
if (slot_has_setter(y))
slot_set_value(y, call_setter(sc, y, value));
else
slot_set_value(y, value);
return (slot_value(y));
}
if (let_id(let) == symbol_id(symbol)) {
y = local_slot(symbol);
if (is_slot(y))
return (checked_slot_set_value(sc, y, value));
}
for (x = let; is_let(x); x = let_outlet(x))
for (y = let_slots(x); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == symbol)
return (checked_slot_set_value(sc, y, value));
if ((has_methods(let)) && (has_let_set_fallback(let)))
return (call_let_set_fallback(sc, let, symbol, value));
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
wrap_string(sc,
"let-set!: ~A is not defined in ~A",
33), symbol, let)));
/* not sure about this -- what's the most useful choice? */
}
s7_pointer s7_let_set(s7_scheme * sc, s7_pointer let, s7_pointer symbol,
s7_pointer value)
{
if (!is_let(let))
return (wrong_type_argument_with_type
(sc, sc->let_set_symbol, 1, let, a_let_string));
if (!is_symbol(symbol)) {
if (has_let_set_fallback(let))
return (call_let_set_fallback(sc, let, symbol, value));
return (wrong_type_argument_with_type
(sc, sc->let_set_symbol, 2, symbol, a_symbol_string));
}
if (!is_global(sc->let_set_symbol))
check_method(sc, let, sc->let_set_symbol,
set_plist_3(sc, let, symbol, value));
return (let_set_1(sc, let, symbol, value));
}
static s7_pointer g_let_set(s7_scheme * sc, s7_pointer args)
{
/* (let ((a 1)) (set! ((curlet) 'a) 32) a) */
#define H_let_set "(let-set! let sym val) sets the symbol sym's value in the let to val"
#define Q_let_set s7_make_signature(sc, 4, sc->T, sc->is_let_symbol, sc->is_symbol_symbol, sc->T)
return (s7_let_set(sc, car(args), cadr(args), caddr(args)));
}
static s7_pointer let_set_p_ppp_2(s7_scheme * sc, s7_pointer p1,
s7_pointer p2, s7_pointer p3)
{
if (!is_symbol(p2))
return (wrong_type_argument_with_type
(sc, sc->let_set_symbol, 2, p2, a_symbol_string));
return (let_set_1(sc, p1, p2, p3));
}
static s7_pointer g_lint_let_set(s7_scheme * sc, s7_pointer args)
{
s7_pointer y, lt = car(args), sym, val;
if (!is_let(lt))
return (wrong_type_argument_with_type
(sc, sc->let_set_symbol, 1, lt, a_let_string));
sym = cadr(args);
val = caddr(args);
if (lt != sc->rootlet) {
s7_pointer x;
for (x = lt; is_let(x); x = let_outlet(x))
for (y = let_slots(x); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == sym) {
if (slot_has_setter(y))
slot_set_value(y, call_setter(sc, y, val));
else
slot_set_value(y, val);
return (slot_value(y));
}
if ((has_methods(lt)) && (has_let_set_fallback(lt)))
return (call_let_set_fallback(sc, lt, sym, val));
}
y = global_slot(sym);
if (!is_slot(y))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
wrap_string(sc,
"let-set!: ~A is not defined in ~A",
33), sym, lt)));
if (slot_has_setter(y))
slot_set_value(y, call_setter(sc, y, val));
else
slot_set_value(y, val);
return (slot_value(y));
}
static s7_pointer let_set_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if ((!ops) || (!is_global(sc->let_set_symbol)))
return (f);
if (optimize_op(expr) == HOP_SAFE_C_opSq_CS) {
s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 =
cadddr(expr);
if ((car(arg1) == sc->cdr_symbol)
&& (car(arg2) == sc->quote_symbol) && (is_symbol(cadr(arg2)))
&& (!is_possibly_constant(cadr(arg2)))
&& (!is_possibly_constant(arg3)))
return (sc->lint_let_set);
}
return (f);
}
static s7_pointer reverse_slots(s7_scheme * sc, s7_pointer list)
{
s7_pointer p = list, result = slot_end(sc), q;
while (tis_slot(p)) {
q = next_slot(p);
slot_set_next(p, result);
result = p;
p = q;
}
return (result);
}
static s7_pointer let_copy(s7_scheme * sc, s7_pointer let)
{
if (is_let(let)) {
s7_pointer new_e;
if (let == sc->rootlet) /* (copy (rootlet)) or (copy (funclet abs)) etc */
return (sc->rootlet);
/* we can't make copy handle lets-as-objects specially because the make-object function in define-class uses copy to make a new object!
* So if it is present, we get it here, and then there's almost surely trouble.
*/
new_e = make_let_slowly(sc, let_outlet(let));
set_all_methods(new_e, let);
sc->temp3 = new_e;
if (tis_slot(let_slots(let))) {
s7_int id = let_id(new_e);
s7_pointer x, y = NULL;
for (x = let_slots(let); tis_slot(x); x = next_slot(x)) {
s7_pointer z;
new_cell(sc, z, T_SLOT);
slot_set_symbol_and_value(z, slot_symbol(x),
slot_value(x));
if (symbol_id(slot_symbol(z)) != id) /* keep shadowing intact */
symbol_set_local_slot(slot_symbol(x), id, z);
if (slot_has_setter(x)) {
slot_set_setter(z, slot_setter(x));
slot_set_has_setter(z);
}
if (y)
slot_set_next(y, z);
else
let_set_slots(new_e, z);
slot_set_next(z, slot_end(sc)); /* 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 let 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);
}
/* shadow_rootlet is a convenience for foreign function writers -- the C code can act as if it were loading everything into rootlet,
* but when actually loaded, everything can be shunted into a separate namespace (*motif* for example).
*/
s7_pointer s7_shadow_rootlet(s7_scheme * sc)
{
return (sc->shadow_rootlet);
}
s7_pointer s7_set_shadow_rootlet(s7_scheme * sc, s7_pointer let)
{
s7_pointer old_let = sc->shadow_rootlet;
sc->shadow_rootlet = let;
return (old_let); /* like s7_set_curlet below */
}
/* -------------------------------- curlet -------------------------------- */
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++;
return ((is_let(sc->curlet)) ? sc->curlet : sc->rootlet);
}
s7_pointer s7_curlet(s7_scheme * sc)
{
sc->capture_let_counter++;
return (sc->curlet);
}
static void update_symbol_ids(s7_scheme * sc, s7_pointer e)
{
s7_pointer p;
for (p = let_slots(e); tis_slot(p); p = next_slot(p)) {
s7_pointer sym = slot_symbol(p);
if (symbol_id(sym) != sc->let_number)
symbol_set_local_slot_unincremented(sym, sc->let_number, p);
}
}
s7_pointer s7_set_curlet(s7_scheme * sc, s7_pointer e)
{
s7_pointer old_e = sc->curlet;
set_curlet(sc, e);
if ((is_let(e)) && (let_id(e) > 0)) { /* might be () [id=-1] or rootlet [id=0?] etc */
let_set_id(e, ++sc->let_number);
update_symbol_ids(sc, e);
}
return (old_e);
}
/* -------------------------------- outlet -------------------------------- */
s7_pointer s7_outlet(s7_scheme * sc, s7_pointer let)
{
if ((let == sc->rootlet) || (is_null(let_outlet(let))))
return (sc->rootlet);
return (let_outlet(let));
}
s7_pointer outlet_p_p(s7_scheme * sc, s7_pointer let)
{
if (!is_let(let))
return (s7_wrong_type_arg_error(sc, "outlet", 1, let, "a let")); /* not a method call here! */
if ((let == sc->rootlet) || (is_null(let_outlet(let))))
return (sc->rootlet);
return (let_outlet(let));
}
static s7_pointer g_outlet(s7_scheme * sc, s7_pointer args)
{
#define H_outlet "(outlet let) is the environment that contains let."
#define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol)
return (outlet_p_p(sc, car(args)));
}
static s7_pointer g_set_outlet(s7_scheme * sc, s7_pointer args)
{
/* (let ((a 1)) (let ((b 2)) (set! (outlet (curlet)) (rootlet)) ((curlet) 'a))) */
s7_pointer let = car(args), new_outer;
if (!is_let(let))
return (s7_wrong_type_arg_error
(sc, "set! outlet", 1, let, "a let"));
if ((is_immutable(let)) || (let == sc->s7_let))
return (s7_wrong_type_arg_error
(sc, "set! outlet", 1, let, "a mutable 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 (let != sc->rootlet) {
/* here it's possible to get cyclic let chains; maybe do this check only if safety>0 */
s7_pointer lt;
for (lt = new_outer; (is_let(lt)) && (lt != sc->rootlet);
lt = let_outlet(lt))
if (let == lt)
s7_error(sc, s7_make_symbol(sc, "cyclic-let"),
set_elist_2(sc,
wrap_string(sc,
"set! (outlet ~A) creates a cyclic let chain",
43), let));
let_set_outlet(let, (new_outer == sc->rootlet) ? sc->nil : new_outer); /* outlet rootlet->() so that slot search can use is_let(outlet) I think */
}
return (new_outer);
}
/* -------------------------------- symbol lookup -------------------------------- */
static inline s7_pointer lookup_from(s7_scheme * sc,
const s7_pointer symbol, s7_pointer e)
{
#if S7_DEBUGGING
if ((!is_let(e)) && (!is_null(e))) {
fprintf(stderr, "%s[%d]: e is not a let\n", __func__, __LINE__);
if (sc != cur_sc)
fprintf(stderr, "sc != cur_sc\n");
/* how to show calling code? last stack op is sc->stack_end[3] */
}
#endif
if (let_id(e) == symbol_id(symbol))
return (local_value(symbol));
if (symbol_id(symbol) < let_id(e)) {
do {
e = let_outlet(e);
} while (symbol_id(symbol) < let_id(e));
if (let_id(e) == symbol_id(symbol))
return (local_value(symbol));
}
for (; is_let(e); e = let_outlet(e)) {
s7_pointer y;
for (y = let_slots(e); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == symbol)
return (slot_value(y));
}
if (is_slot(global_slot(symbol)))
return (global_value(symbol));
#if WITH_GCC
return (NULL); /* much faster than various alternatives */
#else
return (unbound_variable(sc, symbol));
#endif
}
static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e)
{
if (let_id(e) == symbol_id(symbol))
return (local_slot(symbol));
if (symbol_id(symbol) < let_id(e)) {
do {
e = let_outlet(e);
} while (symbol_id(symbol) < let_id(e));
if (let_id(e) == symbol_id(symbol))
return (local_slot(symbol));
}
for (; is_let(e); e = let_outlet(e)) {
s7_pointer y;
for (y = let_slots(e); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == symbol)
return (y);
}
return (global_slot(symbol));
}
#if WITH_GCC && S7_DEBUGGING
static s7_pointer lookup_1(s7_scheme * sc, const s7_pointer symbol)
#else
static inline s7_pointer lookup(s7_scheme * sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */
#endif
{
return (lookup_from(sc, symbol, sc->curlet));
}
s7_pointer s7_slot(s7_scheme * sc, s7_pointer symbol)
{
return (lookup_slot_from(symbol, sc->curlet));
}
s7_pointer s7_slot_value(s7_pointer slot)
{
return (slot_value(slot));
}
s7_pointer s7_slot_set_value(s7_scheme * sc, s7_pointer slot,
s7_pointer value)
{
slot_set_value(slot, value);
return (value);
}
void s7_slot_set_real_value(s7_scheme * sc, s7_pointer slot,
s7_double value)
{
set_real(slot_value(slot), value);
}
static s7_pointer symbol_to_local_slot(s7_scheme * sc, s7_pointer symbol,
s7_pointer e)
{
if (!is_let(e))
return (global_slot(symbol));
if (symbol_id(symbol) != 0) {
s7_pointer y;
for (y = let_slots(e); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == symbol)
return (y);
}
return (sc->undefined);
}
s7_pointer s7_symbol_value(s7_scheme * sc, s7_pointer sym)
{
s7_pointer x;
x = lookup_slot_from(sym, sc->curlet);
return ((is_slot(x)) ? slot_value(x) : sc->undefined);
}
s7_pointer s7_symbol_local_value(s7_scheme * sc, s7_pointer sym,
s7_pointer let)
{
/* restrict the search to local let outward */
if ((let == sc->rootlet) || (is_global(sym)))
return ((is_slot(global_slot(sym))) ? global_value(sym) :
sc->undefined);
if (!is_let(let))
return (s7_symbol_value(sc, sym));
if (let_id(let) == symbol_id(sym))
return (local_value(sym));
if (symbol_id(sym) < let_id(let)) {
do {
let = let_outlet(let);
} while (symbol_id(sym) < let_id(let));
if (let_id(let) == symbol_id(sym))
return (local_value(sym));
}
for (; is_let(let); let = let_outlet(let)) {
s7_pointer y;
for (y = let_slots(let); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == sym)
return (slot_value(y));
}
/* need to check rootlet before giving up */
if (is_slot(global_slot(sym)))
return (global_value(sym));
/* (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e))) -> #<undefined> not 1 */
return (sc->undefined); /* 29-Nov-17 */
}
/* -------------------------------- symbol->value -------------------------------- */
#define lookup_global(Sc, Sym) ((is_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym))
static s7_pointer g_s7_let_ref_fallback(s7_scheme * sc, s7_pointer args);
static s7_pointer g_s7_let_set_fallback(s7_scheme * sc, s7_pointer args);
static s7_pointer g_symbol_to_value(s7_scheme * sc, s7_pointer args)
{
#define H_symbol_to_value "(symbol->value sym (let (curlet))) returns the binding of (the value associated with) the \
symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32"
#define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol)
/* (symbol->value 'x e) => (e 'x)? */
s7_pointer sym = car(args);
if (!is_symbol(sym))
return (method_or_bust
(sc, sym, sc->symbol_to_value_symbol, args, T_SYMBOL, 1));
if (is_not_null(cdr(args))) {
s7_pointer local_let = cadr(args);
if (local_let == sc->unlet_symbol)
return ((is_slot(initial_slot(sym))) ? initial_value(sym) :
sc->undefined);
if (!is_let(local_let))
return (method_or_bust_with_type
(sc, local_let, sc->symbol_to_value_symbol, args,
a_let_string, 2));
if (local_let == sc->s7_let)
return (g_s7_let_ref_fallback
(sc, set_qlist_2(sc, local_let, sym)));
return (s7_symbol_local_value(sc, sym, local_let));
}
if (is_global(sym))
return (global_value(sym));
return (s7_symbol_value(sc, sym));
}
s7_pointer s7_symbol_set_value(s7_scheme * sc, s7_pointer sym,
s7_pointer val)
{
s7_pointer x; /* if immutable should this return an error? */
x = lookup_slot_from(sym, sc->curlet);
if (is_slot(x))
slot_set_value(x, val); /* with_hook? */
return (val);
}
/* -------------------------------- symbol->dynamic-value -------------------------------- */
static s7_pointer find_dynamic_value(s7_scheme * sc, s7_pointer x,
s7_pointer sym, int64_t * id)
{
for (; symbol_id(sym) < let_id(x); x = let_outlet(x));
if (let_id(x) == symbol_id(sym)) {
(*id) = let_id(x);
return (local_value(sym));
}
for (; (is_let(x)) && (let_id(x) > (*id)); x = let_outlet(x)) {
s7_pointer y;
for (y = let_slots(x); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == sym) {
(*id) = let_id(x);
return (slot_value(y));
}
}
return (sc->unused);
}
static s7_pointer g_symbol_to_dynamic_value(s7_scheme * sc,
s7_pointer args)
{
#define H_symbol_to_dynamic_value "(symbol->dynamic-value sym) returns the dynamic binding of the symbol sym"
#define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)
s7_pointer sym = car(args), val;
int64_t i, top_id;
if (!is_symbol(sym))
return (method_or_bust
(sc, sym, sc->symbol_to_dynamic_value_symbol, args,
T_SYMBOL, 1));
if (is_global(sym))
return (global_value(sym));
if (let_id(sc->curlet) == symbol_id(sym))
return (local_value(sym));
top_id = -1;
val = find_dynamic_value(sc, sc->curlet, sym, &top_id);
if (top_id == symbol_id(sym))
return (val);
for (i = current_stack_top(sc) - 1; i > 0; i -= 4)
if (is_let_unchecked(stack_let(sc->stack, i))) { /* OP_GC_PROTECT let slot can be anything (even free) */
s7_pointer cur_val;
cur_val =
find_dynamic_value(sc, stack_let(sc->stack, i), sym,
&top_id);
if (cur_val != sc->unused)
val = cur_val;
if (top_id == symbol_id(sym))
return (val);
}
return ((val == sc->unused) ? s7_symbol_value(sc, sym) : val);
}
typedef bool (safe_sym_t) (s7_scheme * sc, s7_pointer sym, s7_pointer e);
static bool direct_memq(s7_pointer symbol, s7_pointer symbols)
{
s7_pointer x;
for (x = symbols; is_pair(x); x = cdr(x))
if (car(x) == symbol)
return (true);
return (false);
}
static bool direct_assq(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))) ||
(direct_assq(sym, e)) ||
(is_slot(lookup_slot_from(sym, sc->curlet))));
}
static bool let_symbol_is_safe(s7_scheme * sc, s7_pointer sym,
s7_pointer e)
{
if (is_slot(global_slot(sym)))
return (true);
if (is_null(e))
e = sc->rootlet;
return ((!is_with_let_let(e)) &&
(is_slot(lookup_slot_from(sym, sc->curlet))));
}
static bool let_symbol_is_safe_or_listed(s7_scheme * sc, s7_pointer sym,
s7_pointer e)
{
return ((symbol_is_in_list(sc, sym)) ||
(let_symbol_is_safe(sc, sym, e)));
}
static bool let_star_symbol_is_safe(s7_scheme * sc, s7_pointer sym,
s7_pointer e)
{
return ((symbol_is_in_list(sc, sym)) ||
(is_slot(global_slot(sym))) ||
((is_let(e)) && (!is_with_let_let(e))
&& (is_slot(lookup_slot_from(sym, sc->curlet)))));
}
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)));
}
static inline s7_pointer collect_variables(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))
sc->w = cons(sc, add_symbol_to_list(sc, caar(p)), sc->w);
return (sc->w);
}
static s7_pointer collect_parameters(s7_scheme * sc, s7_pointer lst,
s7_pointer e)
{
/* collect local variable names from lambda arglists (pre-error-check) */
s7_pointer p;
s7_int the_un_id;
the_un_id = ++sc->let_number;
if (is_symbol(lst)) {
symbol_set_id(lst, the_un_id);
return (cons(sc, add_symbol_to_list(sc, lst), e));
}
sc->w = e;
for (p = lst; is_pair(p); p = cdr(p)) {
s7_pointer car_p = car(p);
if (is_pair(car_p))
car_p = car(car_p);
if (is_normal_symbol(car_p)) {
symbol_set_id(car_p, the_un_id);
sc->w = cons(sc, add_symbol_to_list(sc, car_p), sc->w);
}
}
if (is_symbol(p)) { /* rest arg */
symbol_set_id(p, the_un_id);
sc->w = cons(sc, add_symbol_to_list(sc, p), sc->w);
}
return (sc->w);
}
typedef enum { OPT_F, OPT_T, OPT_OOPS } opt_t;
static opt_t optimize(s7_scheme * sc, s7_pointer code, int32_t hop,
s7_pointer e);
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) >= FIRST_UNHOPPABLE_OP) || /* avoid clearing hop ops, fx_function and op_unknown* need to be cleared */
(!op_has_hop(p))))) {
clear_optimized(p); /* includes T_SYNTACTIC */
clear_optimize_op(p);
}
clear_all_optimizations(sc, cdr(p));
clear_all_optimizations(sc, car(p));
}
}
static s7_pointer add_trace(s7_scheme * sc, s7_pointer code)
{
if ((is_pair(car(code))) && (caar(code) == sc->trace_in_symbol))
return (code);
return (cons_unchecked
(sc,
list_2(sc, sc->trace_in_symbol,
list_1(sc, sc->curlet_symbol)), code));
}
static s7_pointer add_profile(s7_scheme * sc, s7_pointer code)
{
s7_pointer p;
if ((is_pair(car(code))) && (caar(code) == sc->profile_in_symbol))
return (code);
p = cons_unchecked(sc,
list_2(sc, sc->profile_in_symbol,
list_1(sc, sc->curlet_symbol)), code);
set_unsafe_optimize_op(car(p), OP_PROFILE_IN);
return (p);
}
static bool tree_has_definers(s7_scheme * sc, s7_pointer tree)
{
s7_pointer p;
for (p = tree; is_pair(p); p = cdr(p))
if (tree_has_definers(sc, car(p)))
return (true);
return ((is_symbol(tree)) && (is_definer(tree)));
}
static s7_pointer make_macro(s7_scheme * sc, opcode_t op, bool named)
{
s7_pointer mac, body, mac_name = NULL;
uint64_t typ;
switch (op) {
case OP_DEFINE_MACRO:
case OP_MACRO:
typ = T_MACRO;
break;
case OP_DEFINE_MACRO_STAR:
case OP_MACRO_STAR:
typ = T_MACRO_STAR;
break;
case OP_DEFINE_BACRO:
case OP_BACRO:
typ = T_BACRO;
break;
case OP_DEFINE_BACRO_STAR:
case OP_BACRO_STAR:
typ = T_BACRO_STAR;
break;
case OP_DEFINE_EXPANSION:
typ = T_MACRO | ((is_let(sc->curlet)) ? 0 : T_EXPANSION);
break; /* local expansions are just normal macros */
case OP_DEFINE_EXPANSION_STAR:
typ = T_MACRO_STAR | ((is_let(sc->curlet)) ? 0 : T_EXPANSION);
break;
default:
if (S7_DEBUGGING)
fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__,
op_names[op]);
typ = T_MACRO;
break;
}
new_cell(sc, mac, typ | T_DONT_EVAL_ARGS);
sc->temp6 = mac;
closure_set_args(mac, (named) ? cdar(sc->code) : car(sc->code));
body = cdr(sc->code);
closure_set_body(mac, body);
closure_set_setter(mac, sc->F);
closure_set_let(mac, sc->curlet);
closure_set_arity(mac, CLOSURE_ARITY_NOT_SET);
sc->capture_let_counter++;
if (named) {
s7_pointer cx;
mac_name = caar(sc->code);
if (((op == OP_DEFINE_EXPANSION)
|| (op == OP_DEFINE_EXPANSION_STAR)) && (!is_let(sc->curlet)))
set_full_type(mac_name,
T_EXPANSION | T_SYMBOL | (full_type(mac_name) &
T_UNHEAP));
/* symbol? macro name has already been checked, find name in let, and define it */
cx = symbol_to_local_slot(sc, mac_name, sc->curlet); /* returns global_slot(symbol) if sc->curlet == nil */
if (is_slot(cx)) {
if ((S7_DEBUGGING) && (sc->curlet == sc->rootlet))
fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__,
__LINE__);
if ((sc->curlet == sc->nil) && (!in_rootlet(cx))) {
#if S7_DEBUGGING
s7_pointer *tmp, *top;
tmp = rootlet_elements(sc->rootlet);
top = (s7_pointer *) (tmp + sc->rootlet_entries);
while (tmp < top)
if (cx == *tmp++)
break;
fprintf(stderr, "add %s%s\n", display(cx),
(tmp < top) ? ", already in rootlet!" : "");
#endif
add_slot_to_rootlet(sc, cx);
}
slot_set_value_with_hook(cx, mac);
} else
s7_make_slot(sc, sc->curlet, mac_name, mac); /* was current but we've checked immutable already */
if (tree_has_definers(sc, body))
set_is_definer(mac_name); /* (list-values 'define ...) aux-13 */
}
/* TODO: we want to ignore arguments here, not (define xyzzy (macro...)) */
if ((!is_either_bacro(mac)) &&
(optimize
(sc, body, 1,
collect_parameters(sc, closure_args(mac), sc->nil)) == OPT_OOPS))
clear_all_optimizations(sc, body);
sc->temp6 = sc->nil;
if (sc->debug > 1) { /* no profile here */
gc_protect_via_stack(sc, mac); /* GC protect func during add_trace */
closure_set_body(mac, add_trace(sc, body));
unstack(sc);
}
if (named) {
set_pair_macro(closure_body(mac), mac_name);
set_has_pair_macro(mac);
if (has_location(car(sc->code))) {
pair_set_location(closure_body(mac),
pair_location(car(sc->code)));
set_has_location(closure_body(mac));
}
}
/* passed to maclet in apply_macro et al, copied in copy_closure */
return (mac);
}
static s7_pointer make_closure_unchecked(s7_scheme * sc, s7_pointer args,
s7_pointer code, uint64_t type,
int32_t arity)
{
s7_pointer x;
new_cell_no_check(sc, x, (type | closure_bits(code)));
closure_set_args(x, args);
closure_set_let(x, sc->curlet);
closure_set_setter(x, sc->F);
closure_set_arity(x, arity);
closure_set_body(x, code);
if (is_pair(cdr(code)))
set_closure_has_multiform(x);
else
set_closure_has_one_form(x);
sc->capture_let_counter++;
return (x);
}
static Inline s7_pointer inline_make_closure(s7_scheme * sc,
s7_pointer args,
s7_pointer code,
uint64_t type, int32_t arity)
{
/* this is called (almost?) every time a lambda form is evaluated, or during letrec, etc */
s7_pointer x;
new_cell(sc, x, (type | closure_bits(code)));
closure_set_args(x, args);
closure_set_let(x, sc->curlet);
closure_set_setter(x, sc->F);
closure_set_arity(x, arity);
closure_set_body(x, code); /* in case add_trace triggers GC, new func (x) needs some legit body for mark_closure */
if (sc->debug_or_profile) {
gc_protect_via_stack(sc, x); /* GC protect func during add_trace */
closure_set_body(x,
(sc->debug > 1) ? add_trace(sc,
code) :
add_profile(sc, code));
set_closure_has_multiform(x);
unstack(sc);
} else if (is_pair(cdr(code)))
set_closure_has_multiform(x);
else
set_closure_has_one_form(x);
sc->capture_let_counter++;
return (x);
}
static s7_pointer make_closure(s7_scheme * sc, s7_pointer args,
s7_pointer code, uint64_t type,
int32_t arity)
{
return (inline_make_closure(sc, args, code, type, arity));
}
static int32_t closure_length(s7_scheme * sc, s7_pointer e)
{
/* we can't use let_length(sc, closure_let(e)) because the closure_let(closure)
* changes. So the open bit is not always on. Besides, the fallbacks need to be for closures, not lets.
*/
s7_pointer length_func;
length_func = find_method(sc, closure_let(e), sc->length_symbol);
if (length_func != sc->undefined)
return ((int32_t)
s7_integer_checked(sc,
call_method(sc, e, length_func,
set_plist_1(sc, e))));
/* there are cases where this should raise a wrong-type-arg error, but for now... */
return (-1);
}
static s7_pointer cons_unchecked_with_type(s7_scheme * sc, s7_pointer p,
s7_pointer a, s7_pointer b);
static s7_pointer copy_tree_with_type(s7_scheme * sc, s7_pointer tree)
{
/* if sc->safety > NO_SAFETY, '(1 2) is set immutable by the reader, but eval (in that safety case) calls
* copy_body on the incoming tree, so we have to preserve T_IMMUTABLE in that case.
* if tree is something like (+ 1 (car '#1=(2 . #1#))), we have to see the quoted list and not copy it.
* Before getting here, we have checked that there is room for the entire tree (in copy_body), or 8192 cells (in list_values) in the free heap.
*/
#if WITH_GCC
#define COPY_TREE_WITH_TYPE(P) ({s7_pointer _p; _p = P; \
cons_unchecked_with_type(sc, _p, (is_unquoted_pair(car(_p))) ? copy_tree_with_type(sc, car(_p)) : car(_p), \
(is_unquoted_pair(cdr(_p))) ? copy_tree_with_type(sc, cdr(_p)) : cdr(_p));})
#else
#define COPY_TREE_WITH_TYPE(P) copy_tree_with_type(sc, P)
#endif
return (cons_unchecked_with_type(sc, tree,
(is_unquoted_pair(car(tree))) ?
COPY_TREE_WITH_TYPE(car(tree)) :
car(tree),
(is_unquoted_pair(cdr(tree))) ?
COPY_TREE_WITH_TYPE(cdr(tree)) :
cdr(tree)));
}
static s7_pointer copy_tree(s7_scheme * sc, s7_pointer tree)
{
#if WITH_GCC
#define COPY_TREE(P) ({s7_pointer _p; _p = P; \
cons_unchecked(sc, (is_unquoted_pair(car(_p))) ? copy_tree(sc, car(_p)) : car(_p), \
(is_pair(cdr(_p))) ? copy_tree(sc, cdr(_p)) : cdr(_p));})
#else
#define COPY_TREE(P) copy_tree(sc, P)
#endif
return (cons_unchecked(sc,
(is_unquoted_pair(car(tree))) ?
COPY_TREE(car(tree)) : car(tree),
(is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) :
cdr(tree)));
}
/* -------------------------------- tree-cyclic? -------------------------------- */
#define TREE_NOT_CYCLIC 0
#define TREE_CYCLIC 1
#define TREE_HAS_PAIRS 2
static int tree_is_cyclic_or_has_pairs(s7_scheme * sc, s7_pointer tree)
{
s7_pointer fast = tree, slow = tree; /* we assume tree is a pair */
bool has_pairs = false;
while (true) {
if (tree_is_collected(fast))
return (TREE_CYCLIC);
if ((!has_pairs) && (is_unquoted_pair(car(fast))))
has_pairs = true;
fast = cdr(fast);
if (!is_pair(fast)) {
if (!has_pairs)
return (TREE_NOT_CYCLIC);
break;
}
if (tree_is_collected(fast))
return (TREE_CYCLIC);
if ((!has_pairs) && (is_unquoted_pair(car(fast))))
has_pairs = true;
fast = cdr(fast);
if (!is_pair(fast)) {
if (!has_pairs)
return (TREE_NOT_CYCLIC);
break;
}
slow = cdr(slow);
if (fast == slow)
return (TREE_CYCLIC);
}
return (TREE_HAS_PAIRS);
}
/* we can't use shared_info here because tree_is_cyclic may be called in the midst of output that depends on sc->circle_info */
static bool tree_is_cyclic_1(s7_scheme * sc, s7_pointer tree)
{
s7_pointer p;
for (p = tree; is_pair(p); p = cdr(p)) {
tree_set_collected(p);
if (sc->tree_pointers_top == sc->tree_pointers_size) {
if (sc->tree_pointers_size == 0) {
sc->tree_pointers_size = 8;
sc->tree_pointers =
(s7_pointer *) Malloc(sc->tree_pointers_size *
sizeof(s7_pointer));
} else {
sc->tree_pointers_size *= 2;
sc->tree_pointers =
(s7_pointer *) Realloc(sc->tree_pointers,
sc->tree_pointers_size *
sizeof(s7_pointer));
}
}
sc->tree_pointers[sc->tree_pointers_top++] = p;
if (is_unquoted_pair(car(p))) {
int32_t i, old_top = sc->tree_pointers_top, result;
result = tree_is_cyclic_or_has_pairs(sc, car(p));
if ((result == TREE_CYCLIC) || (tree_is_cyclic_1(sc, car(p))))
return (true);
for (i = old_top; i < sc->tree_pointers_top; i++)
tree_clear_collected(sc->tree_pointers[i]);
sc->tree_pointers_top = old_top;
}
}
return (false);
}
static bool tree_is_cyclic(s7_scheme * sc, s7_pointer tree)
{
int32_t i, result;
if (!is_pair(tree))
return (false);
result = tree_is_cyclic_or_has_pairs(sc, tree);
if (result == TREE_NOT_CYCLIC)
return (false);
if (result == TREE_CYCLIC)
return (true);
result = tree_is_cyclic_1(sc, tree);
for (i = 0; i < sc->tree_pointers_top; i++)
tree_clear_collected(sc->tree_pointers[i]);
sc->tree_pointers_top = 0;
return (result);
}
static s7_pointer g_tree_is_cyclic(s7_scheme * sc, s7_pointer args)
{
#define H_tree_is_cyclic "(tree-cyclic? tree) returns #t if the tree has a cycle."
#define Q_tree_is_cyclic sc->pl_bt
return (make_boolean(sc, tree_is_cyclic(sc, car(args))));
}
static inline s7_int tree_len(s7_scheme * sc, s7_pointer p);
static s7_pointer copy_body(s7_scheme * sc, s7_pointer p)
{
sc->w = p;
if (tree_is_cyclic(sc, p))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "copy: tree is cyclic: ~S",
24), p));
check_free_heap_size(sc, tree_len(sc, p) * 2);
return ((sc->safety > NO_SAFETY) ? copy_tree_with_type(sc,
p) :
copy_tree(sc, p));
}
static s7_pointer copy_closure(s7_scheme * sc, s7_pointer fnc)
{
/* copy the source tree annotating (for eventual optimization), return a thing of the same type as fnc */
s7_pointer x, body;
body = copy_body(sc, closure_body(fnc));
if ((is_any_macro(fnc)) && (has_pair_macro(fnc))) {
set_pair_macro(body, pair_macro(closure_body(fnc)));
set_has_pair_macro(fnc);
}
new_cell(sc, x, full_type(fnc) & (~T_COLLECTED)); /* I'm paranoid about that is_collected bit */
closure_set_args(x, closure_args(fnc));
closure_set_body(x, body);
closure_set_setter(x, closure_setter(fnc));
closure_set_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? symbol (let (curlet)) ignore-globals) returns #t if symbol has a binding (a value) in the environment let. Only let is searched if ignore-globals is not #f."
#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)
/* if the symbol has a global slot and e is unset or rootlet, this returns #t */
s7_pointer sym = car(args);
if (!is_symbol(sym))
return (method_or_bust
(sc, sym, sc->is_defined_symbol, args, T_SYMBOL, 1));
if (is_pair(cdr(args))) {
s7_pointer e = cadr(args), b, x;
if (!is_let(e))
return (wrong_type_argument_with_type
(sc, sc->is_defined_symbol, 2, e, a_let_string));
if (e == sc->s7_let)
return (make_boolean(sc, symbol_s7_let(sym) != 0));
if (is_pair(cddr(args))) {
b = caddr(args);
if (!s7_is_boolean(b))
return (method_or_bust_with_type
(sc, b, sc->is_defined_symbol, args,
a_boolean_string, 3));
} else
b = sc->F;
if (e == sc->rootlet) { /* we checked (let? e) above */
if (b == sc->F)
return (make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to #<undefined> */
return (sc->F);
}
x = symbol_to_local_slot(sc, sym, e);
if (is_slot(x))
return (sc->T);
return ((b == sc->T) ? sc->F : make_boolean(sc,
is_slot(global_slot
(sym))));
}
return ((is_global(sym)) ? sc->T : make_boolean(sc,
is_slot
(lookup_slot_from
(sym, sc->curlet))));
}
static s7_pointer g_is_defined_in_rootlet(s7_scheme * sc, s7_pointer args)
{
/* here we know arg2=(rootlet), and no arg3, arg1 is a symbol that needs to be looked-up */
s7_pointer sym;
sym = lookup(sc, car(args));
if (!is_symbol(sym))
return (method_or_bust
(sc, sym, sc->is_defined_symbol, args, T_SYMBOL, 1));
return (make_boolean(sc, is_slot(global_slot(sym))));
}
static s7_pointer is_defined_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if (!ops)
return (f);
if ((args == 2) && (is_symbol(cadr(expr)))) {
s7_pointer e = caddr(expr);
if ((is_pair(e)) && (is_null(cdr(e)))
&& (car(e) == sc->rootlet_symbol)) {
set_safe_optimize_op(expr, HOP_SAFE_C_NC);
return (sc->is_defined_in_rootlet);
}
}
return (f);
}
bool s7_is_defined(s7_scheme * sc, const char *name)
{
s7_pointer x;
x = s7_symbol_table_find_name(sc, name);
if (!x)
return (false);
x = lookup_slot_from(x, sc->curlet);
return (is_slot(x));
}
static bool is_defined_b_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_symbol(p))
return (method_or_bust
(sc, p, sc->is_defined_symbol, set_plist_1(sc, p),
T_SYMBOL, 1) != sc->F);
return (is_slot(lookup_slot_from(p, sc->curlet)));
}
static bool is_defined_b_7pp(s7_scheme * sc, s7_pointer p, s7_pointer e)
{
return (g_is_defined(sc, set_plist_2(sc, p, e)) != sc->F);
}
void s7_define(s7_scheme * sc, s7_pointer let, s7_pointer symbol,
s7_pointer value)
{
s7_pointer x;
if ((let == sc->nil) || (let == sc->rootlet))
let = sc->shadow_rootlet;
x = symbol_to_local_slot(sc, symbol, let);
if (is_slot(x))
slot_set_value_with_hook(x, value);
else {
s7_make_slot(sc, let, symbol, value); /* I think this means C code can override "constant" defs */
/* if let is sc->nil or rootlet, s7_make_slot makes a permanent_slot */
if ((let == sc->shadow_rootlet) && (!is_slot(global_slot(symbol)))) {
set_global(symbol); /* is_global => global_slot is usable -- is this a good idea? */
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_set_help(sym, copy_string(help));
add_saved_pointer(sc, symbol_help(sym));
return (sym);
}
s7_pointer s7_define_constant_with_environment(s7_scheme * sc,
s7_pointer envir,
const char *name,
s7_pointer value)
{
s7_pointer sym;
sym = make_symbol(sc, name);
s7_define(sc, envir, sym, value);
set_immutable(sym);
set_possibly_constant(sym);
set_immutable(global_slot(sym));
set_immutable(local_slot(sym));
return (sym);
}
s7_pointer s7_define_constant(s7_scheme * sc, const char *name,
s7_pointer value)
{
return (s7_define_constant_with_environment(sc, sc->nil, name, value));
}
/* (define (func a) (let ((cvar (+ a 1))) cvar)) (define-constant cvar 23) (func 1) -> ;can't bind an immutable object: cvar
* (let ((aaa 1)) (define-constant aaa 32) (set! aaa 3)) -> set!: can't alter immutable object: aaa
*/
s7_pointer s7_define_constant_with_documentation(s7_scheme * sc,
const char *name,
s7_pointer value,
const char *help)
{
s7_pointer sym;
sym = s7_define_constant(sc, name, value);
symbol_set_has_help(sym);
symbol_set_help(sym, copy_string(help));
add_saved_pointer(sc, symbol_help(sym));
return (value); /* inconsistent with variable above, but consistent with define_function? */
}
/* -------------------------------- keyword? -------------------------------- */
bool s7_is_keyword(s7_pointer obj)
{
return (is_keyword(obj));
}
static s7_pointer g_is_keyword(s7_scheme * sc, s7_pointer args)
{
#define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t"
#define Q_is_keyword sc->pl_bt
check_boolean_method(sc, is_keyword, sc->is_keyword_symbol, args);
}
/* -------------------------------- string->keyword -------------------------------- */
s7_pointer s7_make_keyword(s7_scheme * sc, const char *key)
{
s7_pointer sym;
block_t *b;
char *name;
size_t slen;
slen = (size_t) safe_strlen(key);
b = mallocate(sc, slen + 2);
name = (char *) block_data(b);
name[0] = ':';
memcpy((void *) (name + 1), (void *) key, slen);
name[slen + 1] = '\0';
sym = make_symbol_with_length(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */
liberate(sc, b);
return (sym);
}
static s7_pointer g_string_to_keyword(s7_scheme * sc, s7_pointer args)
{
#define H_string_to_keyword "(string->keyword str) prepends ':' to str and defines that as a keyword"
#define Q_string_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_string_symbol)
s7_pointer str = car(args);
if (!is_string(str))
return (method_or_bust_one_arg
(sc, str, sc->string_to_keyword_symbol, args, T_STRING));
if ((string_length(str) == 0) || (string_value(str)[0] == '\0'))
return (s7_error
(sc, sc->out_of_range_symbol,
set_elist_2(sc,
wrap_string(sc,
"string->keyword wants a non-null string: ~S",
43), str)));
return (s7_make_keyword(sc, string_value(str)));
}
/* -------------------------------- keyword->symbol -------------------------------- */
static s7_pointer g_keyword_to_symbol(s7_scheme * sc, s7_pointer args)
{
#define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended colon"
#define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol)
s7_pointer sym = car(args);
if (!is_keyword(sym))
return (method_or_bust_with_type_one_arg
(sc, sym, sc->keyword_to_symbol_symbol, args,
wrap_string(sc, "a keyword", 9)));
return (keyword_symbol(sym));
}
s7_pointer s7_keyword_to_symbol(s7_scheme * sc, s7_pointer key)
{
return (keyword_symbol(key));
}
/* -------------------------------- symbol->keyword -------------------------------- */
#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym))
static s7_pointer g_symbol_to_keyword(s7_scheme * sc, s7_pointer args)
{
#define H_symbol_to_keyword "(symbol->keyword sym) returns a keyword with the same name as sym, but with a colon prepended"
#define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_symbol_symbol)
if (!is_symbol(car(args)))
return (method_or_bust_one_arg
(sc, car(args), sc->symbol_to_keyword_symbol, args,
T_SYMBOL));
return (symbol_to_keyword(sc, car(args)));
}
/* -------------------------------- c-pointer? -------------------------------- */
bool s7_is_c_pointer(s7_pointer arg)
{
return (is_c_pointer(arg));
}
bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type)
{
return ((is_c_pointer(arg)) && (c_pointer_type(arg) == type));
}
static s7_pointer g_is_c_pointer(s7_scheme * sc, s7_pointer args)
{
#define H_is_c_pointer "(c-pointer? obj type) returns #t if obj is a C pointer being held in s7. If type is given, the c_pointer's type is also checked."
#define Q_is_c_pointer s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T)
s7_pointer p = car(args);
if (is_c_pointer(p))
return ((is_pair(cdr(args))) ?
make_boolean(sc, c_pointer_type(p) == cadr(args)) : sc->T);
if (!has_active_methods(sc, p))
return (sc->F);
return (apply_boolean_method(sc, p, sc->is_c_pointer_symbol));
}
/* -------------------------------- c-pointer -------------------------------- */
void *s7_c_pointer(s7_pointer p)
{
return (c_pointer(p));
}
void *s7_c_pointer_with_type(s7_scheme * sc, s7_pointer p,
s7_pointer expected_type, const char *caller,
s7_int argnum)
{
if (!is_c_pointer(p))
return (wrong_type_arg_error_prepackaged
(sc, wrap_string(sc, caller, strlen(caller)),
make_integer(sc, argnum), p, sc->unused,
sc->prepackaged_type_names[T_C_POINTER]));
if ((c_pointer(p) != NULL) && (c_pointer_type(p) != expected_type))
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_5(sc,
wrap_string(sc,
"~S argument ~D got a pointer of type ~S, but expected ~S",
56), wrap_string(sc,
caller,
strlen
(caller)),
make_integer(sc, argnum),
c_pointer_type(p), expected_type)));
return (c_pointer(p));
}
s7_pointer s7_make_c_pointer_with_type(s7_scheme * sc, void *ptr,
s7_pointer type, s7_pointer info)
{
s7_pointer x;
new_cell(sc, x, T_C_POINTER);
c_pointer(x) = ptr;
c_pointer_type(x) = type;
c_pointer_info(x) = info;
c_pointer_weak1(x) = sc->F;
c_pointer_weak2(x) = sc->F;
return (x);
}
s7_pointer s7_make_c_pointer(s7_scheme * sc, void *ptr)
{
return (s7_make_c_pointer_with_type(sc, ptr, sc->F, sc->F));
}
static s7_pointer g_c_pointer(s7_scheme * sc, s7_pointer args)
{
#define H_c_pointer "(c-pointer int type info weak1 weak2) returns a c-pointer object. The type and info args are optional, defaulting to #f."
#define Q_c_pointer s7_make_circular_signature(sc, 2, 3, sc->is_c_pointer_symbol, sc->is_integer_symbol, sc->T)
s7_pointer arg = car(args), type = sc->F, info = sc->F, weak1 =
sc->F, weak2 = sc->F, cp;
intptr_t p;
if (!s7_is_integer(arg))
return (method_or_bust
(sc, arg, sc->c_pointer_symbol, args, T_INTEGER, 1));
p = (intptr_t) s7_integer_checked(sc, arg); /* (c-pointer (bignum "1234")) */
args = cdr(args);
if (is_pair(args)) {
type = car(args);
args = cdr(args);
if (is_pair(args)) {
info = car(args);
args = cdr(args);
if (is_pair(args)) {
weak1 = car(args);
args = cdr(args);
if (is_pair(args))
weak2 = car(args);
}
}
}
cp = s7_make_c_pointer_with_type(sc, (void *) p, type, info);
c_pointer_set_weak1(cp, weak1);
c_pointer_set_weak2(cp, weak2);
if ((weak1 != sc->F) || (weak2 != sc->F))
add_weak_ref(sc, cp);
return (cp);
}
/* -------------------------------- c-pointer-info -------------------------------- */
static s7_pointer c_pointer_info_p_p(s7_scheme * sc, s7_pointer p)
{
if (!is_c_pointer(p))
return (method_or_bust_p
(sc, p, sc->c_pointer_info_symbol, T_C_POINTER));
return (c_pointer_info(p));
}
static s7_pointer g_c_pointer_info(s7_scheme * sc, s7_pointer args)
{
#define H_c_pointer_info "(c-pointer-info obj) returns the c-pointer info field"
#define Q_c_pointer_info s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
return (c_pointer_info_p_p(sc, car(args)));
}
/* -------------------------------- c-pointer-type -------------------------------- */
s7_pointer s7_c_pointer_type(s7_pointer p)
{
return ((is_c_pointer(p)) ? c_pointer_type(p) : NULL);
}
static s7_pointer c_pointer_type_p_p(s7_scheme * sc, s7_pointer p)
{
return ((is_c_pointer(p)) ? c_pointer_type(p) :
method_or_bust_p(sc, p, sc->c_pointer_type_symbol,
T_C_POINTER));
}
static s7_pointer g_c_pointer_type(s7_scheme * sc, s7_pointer args)
{
#define H_c_pointer_type "(c-pointer-type obj) returns the c-pointer type field"
#define Q_c_pointer_type s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
return (c_pointer_type_p_p(sc, car(args)));
}
/* -------------------------------- c-pointer-weak1/2 -------------------------------- */
static s7_pointer c_pointer_weak1_p_p(s7_scheme * sc, s7_pointer p)
{
return ((is_c_pointer(p)) ? c_pointer_weak1(p) :
method_or_bust_p(sc, p, sc->c_pointer_weak1_symbol,
T_C_POINTER));
}
static s7_pointer g_c_pointer_weak1(s7_scheme * sc, s7_pointer args)
{
#define H_c_pointer_weak1 "(c-pointer-weak1 obj) returns the c-pointer weak1 field"
#define Q_c_pointer_weak1 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
return (c_pointer_weak1_p_p(sc, car(args)));
}
static s7_pointer c_pointer_weak2_p_p(s7_scheme * sc, s7_pointer p)
{
return ((is_c_pointer(p)) ? c_pointer_weak2(p) :
method_or_bust_p(sc, p, sc->c_pointer_weak2_symbol,
T_C_POINTER));
}
static s7_pointer g_c_pointer_weak2(s7_scheme * sc, s7_pointer args)
{
#define H_c_pointer_weak2 "(c-pointer-weak2 obj) returns the c-pointer weak2 field"
#define Q_c_pointer_weak2 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
return (c_pointer_weak2_p_p(sc, car(args)));
}
/* -------------------------------- c-pointer->list -------------------------------- */
static s7_pointer g_c_pointer_to_list(s7_scheme * sc, s7_pointer args)
{
#define H_c_pointer_to_list "(c-pointer->list obj) returns the c-pointer data as (list pointer-as-int type info)"
#define Q_c_pointer_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_c_pointer_symbol)
s7_pointer p = car(args);
if (!is_c_pointer(p))
return (method_or_bust
(sc, p, sc->c_pointer_to_list_symbol, args, T_C_POINTER,
1));
return (list_3
(sc, make_integer(sc, (s7_int) ((intptr_t) c_pointer(p))),
c_pointer_type(p), c_pointer_info(p)));
}
/* -------------------------------- continuations and gotos -------------------------------- */
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
};
/* ----------------------- continuation? -------------------------------- */
static s7_pointer g_is_continuation(s7_scheme * sc, s7_pointer args)
{
#define H_is_continuation "(continuation? obj) returns #t if obj is a continuation"
#define Q_is_continuation sc->pl_bt
check_boolean_method(sc, is_continuation, sc->is_continuation_symbol,
args);
/* is this the right thing? It returns #f for call-with-exit ("goto") because
* that form of continuation can't continue (via a jump back to its context).
*/
}
static bool is_continuation_b_p(s7_pointer p)
{
return (is_continuation(p));
}
#if S7_DEBUGGING
static s7_pointer check_wrap_return(s7_pointer lst)
{
s7_pointer fast, slow;
for (fast = lst, slow = lst; is_pair(fast);
slow = cdr(slow), fast = cdr(fast)) {
if (is_matched_pair(fast))
fprintf(stderr, "matched_pair not cleared\n");
fast = cdr(fast);
if (!is_pair(fast))
return (lst);
if (fast == slow)
return (lst);
if (is_matched_pair(fast))
fprintf(stderr, "matched_pair not cleared\n");
}
return (lst);
}
#endif
static s7_pointer copy_any_list(s7_scheme * sc, s7_pointer a)
{
s7_pointer slow, fast, p;
#if S7_DEBUGGING
#define wrap_return(W) do {fast = W; W = sc->nil; return(check_wrap_return(fast));} while (0)
#else
#define wrap_return(W) do {fast = W; W = sc->nil; return(fast);} while (0)
#endif
sc->w = list_1(sc, car(a));
p = sc->w;
slow = cdr(a);
fast = slow;
while (true) {
if (!is_pair(fast)) {
if (is_null(fast))
wrap_return(sc->w);
set_cdr(p, fast);
wrap_return(sc->w);
}
set_cdr(p, list_1(sc, car(fast)));
p = cdr(p);
fast = cdr(fast);
if (!is_pair(fast)) {
if (is_null(fast))
wrap_return(sc->w);
set_cdr(p, fast);
wrap_return(sc->w);
}
/* if unrolled further, it's a lot slower? */
set_cdr(p, list_1_unchecked(sc, car(fast)));
p = cdr(p);
fast = cdr(fast);
slow = cdr(slow);
if (fast == slow) {
/* try to preserve the original cyclic structure */
s7_pointer p1, f1, p2, f2;
set_match_pair(a);
for (p1 = sc->w, f1 = a; !(is_matched_pair(cdr(f1)));
f1 = cdr(f1), p1 = cdr(p1))
set_match_pair(f1);
for (p2 = sc->w, f2 = a; cdr(f1) != f2;
f2 = cdr(f2), p2 = cdr(p2))
clear_match_pair(f2);
for (f1 = f2; is_pair(f1); f1 = cdr(f1), f2 = cdr(f2)) {
clear_match_pair(f1);
f1 = cdr(f1);
clear_match_pair(f1);
if (f1 == f2)
break;
}
clear_match_pair(a);
if (is_null(p1))
set_cdr(p2, p2);
else
set_cdr(p1, p2);
wrap_return(sc->w);
}
}
wrap_return(sc->w);
}
static s7_pointer copy_counter(s7_scheme * sc, s7_pointer obj)
{
s7_pointer nobj;
new_cell(sc, nobj, T_COUNTER);
counter_set_result(nobj, counter_result(obj));
counter_set_list(nobj, counter_list(obj));
counter_set_capture(nobj, counter_capture(obj));
counter_set_let(nobj, counter_let(obj));
counter_set_slots(nobj, counter_slots(obj));
return (nobj);
}
static void copy_stack_list_set_immutable(s7_scheme * sc, s7_pointer pold,
s7_pointer pnew)
{
s7_pointer p1, p2, slow = pold;
for (p1 = pold, p2 = pnew; is_pair(p2); p1 = cdr(p1), p2 = cdr(p2)) {
if (is_immutable(p1))
set_immutable(p2);
if (is_pair(cdr(p1))) {
p1 = cdr(p1);
p2 = cdr(p2);
if (is_immutable(p1))
set_immutable(p2);
if (p1 == slow)
break;
slow = cdr(slow);
}
}
}
static s7_pointer copy_stack(s7_scheme * sc, s7_pointer new_v,
s7_pointer old_v, int64_t top)
{
int64_t i;
bool has_pairs = false;
s7_pointer *nv = stack_elements(new_v), *ov = stack_elements(old_v);
memcpy((void *) nv, (void *) ov, top * sizeof(s7_pointer));
stack_clear_flags(new_v);
s7_gc_on(sc, false);
if (stack_has_counters(old_v)) {
for (i = 2; i < top; i += 4) {
s7_pointer p = ov[i]; /* args */
/* if op_gc_protect, any ov[i] (except op) can be a list, but it isn't the arglist, so it seems to be safe */
if (is_pair(p)) { /* args need not be a list (it can be a port or #f, etc) */
has_pairs = true;
if (is_null(cdr(p)))
nv[i] = cons_unchecked(sc, car(p), sc->nil); /* GC is off -- could uncheck list_2 et al also */
else if ((is_pair(cdr(p))) && (is_null(cddr(p))))
nv[i] = list_2_unchecked(sc, car(p), cadr(p));
else
nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */
/* if op=eval_args4 for example, this has to be a proper list, and in many cases it doesn't need to be copied */
copy_stack_list_set_immutable(sc, p, nv[i]);
}
/* lst can be dotted or circular here. The circular list only happens in a case like:
* (dynamic-wind (lambda () (eq? (let ((lst (cons 1 2))) (set-cdr! lst lst) lst) (call/cc (lambda (k) k)))) (lambda () #f) (lambda () #f))
* proper_list_reverse_in_place(sc->args) is one reason we need to copy, another reuse_as_let
*/
else if (is_counter(p)) { /* these can only occur in this context (not in a list etc) */
stack_set_has_counters(new_v);
nv[i] = copy_counter(sc, p);
}
}
} else
for (i = 2; i < top; i += 4)
if (is_pair(ov[i])) {
s7_pointer p = ov[i];
has_pairs = true;
if (is_null(cdr(p)))
nv[i] = cons_unchecked(sc, car(p), sc->nil);
else if ((is_pair(cdr(p))) && (is_null(cddr(p))))
nv[i] = list_2_unchecked(sc, car(p), cadr(p));
else
nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */
copy_stack_list_set_immutable(sc, p, nv[i]);
}
if (has_pairs)
stack_set_has_pairs(new_v);
s7_gc_on(sc, true);
return (new_v);
}
static s7_pointer copy_op_stack(s7_scheme * sc)
{
s7_pointer nv;
int32_t len;
len = (int32_t) (sc->op_stack_now - sc->op_stack);
nv = make_simple_vector(sc, len); /* not sc->op_stack_size */
if (len > 0) {
int32_t i;
s7_pointer *src, *dst;
src = sc->op_stack;
dst = (s7_pointer *) vector_elements(nv);
for (i = len; i > 0; i--)
*dst++ = *src++;
}
return (nv);
}
/* -------------------------------- with-baffle -------------------------------- */
/* (with-baffle . body) calls body guaranteeing that there can be no jumps into the
* middle of it from outside -- no outer evaluation of a continuation can jump across this
* barrier: The flip-side of call-with-exit.
*/
static bool find_baffle(s7_scheme * sc, s7_int key)
{
/* search backwards through sc->curlet for baffle_let with (continuation_)key as its baffle_key value */
if (sc->baffle_ctr > 0) {
s7_pointer x;
for (x = sc->curlet; is_let(x); x = let_outlet(x))
if ((is_baffle_let(x)) && (let_baffle_key(x) == key))
return (true);
}
return (false);
}
#define NOT_BAFFLED -1
static s7_int find_any_baffle(s7_scheme * sc)
{
/* search backwards through sc->curlet for any sc->baffle_symbol -- called by s7_make_continuation to set continuation_key */
if (sc->baffle_ctr > 0) {
s7_pointer x;
for (x = sc->curlet; is_let(x); x = let_outlet(x))
if (is_baffle_let(x))
return (let_baffle_key(x));
}
return (NOT_BAFFLED);
}
static void check_with_baffle(s7_scheme * sc)
{
if (!s7_is_proper_list(sc, sc->code))
eval_error(sc, "with-baffle: unexpected dot? ~A", 31, sc->code);
pair_set_syntax_op(sc->code, OP_WITH_BAFFLE_UNCHECKED);
}
static bool op_with_baffle_unchecked(s7_scheme * sc)
{
sc->code = cdr(sc->code);
if (is_null(sc->code)) {
sc->value = sc->nil;
return (true);
}
sc->curlet = make_let(sc, sc->curlet);
set_baffle_let(sc->curlet);
set_let_baffle_key(sc->curlet, sc->baffle_ctr++);
return (false);
}
/* -------------------------------- call/cc -------------------------------- */
static void make_room_for_cc_stack(s7_scheme * sc)
{
if ((int64_t) (sc->free_heap_top - sc->free_heap) < (int64_t) (sc->heap_size / 8)) { /* we probably never need this much space -- very often we don't need any */
int64_t freed_heap;
freed_heap = call_gc(sc);
if (freed_heap < (int64_t) (sc->heap_size / 8))
resize_heap(sc);
}
}
s7_pointer s7_make_continuation(s7_scheme * sc)
{
s7_pointer x, stack;
int64_t loc;
block_t *block;
sc->continuation_counter++;
make_room_for_cc_stack(sc);
if (sc->continuation_counter > 2000)
call_gc(sc); /* gc time up, but run time down -- try big cache */
loc = current_stack_top(sc);
stack = make_simple_vector(sc, loc);
set_full_type(stack, T_STACK);
temp_stack_top(stack) = loc;
sc->temp8 = stack;
copy_stack(sc, stack, sc->stack, loc);
new_cell(sc, x, T_CONTINUATION);
block = mallocate_block(sc);
continuation_block(x) = block;
continuation_set_stack(x, stack);
continuation_stack_size(x) = vector_length(continuation_stack(x));
continuation_stack_start(x) = stack_elements(continuation_stack(x));
continuation_stack_end(x) =
(s7_pointer *) (continuation_stack_start(x) + loc);
continuation_op_stack(x) = copy_op_stack(sc);
continuation_op_loc(x) = (int32_t) (sc->op_stack_now - sc->op_stack);
continuation_op_size(x) = sc->op_stack_size;
continuation_key(x) = find_any_baffle(sc);
continuation_name(x) = sc->F;
sc->temp8 = sc->nil;
add_continuation(sc, x);
return (x);
}
static void let_temp_done(s7_scheme * sc, s7_pointer args, s7_pointer code,
s7_pointer let);
static void let_temp_unwind(s7_scheme * sc, s7_pointer slot,
s7_pointer new_value);
static s7_pointer dynamic_unwind(s7_scheme * sc, s7_pointer func,
s7_pointer e);
static s7_pointer eval(s7_scheme * sc, opcode_t first_op);
static bool check_for_dynamic_winds(s7_scheme * sc, s7_pointer c)
{
/* called only from call_with_current_continuation.
* if call/cc jumps into a dynamic-wind, the init/finish funcs are wrapped in with-baffle
* so they'll complain. Otherwise we're supposed to re-run the init func before diving
* into the body. Similarly for let-temporarily. If a call/cc jumps out of a dynamic-wind
* body-func, we're supposed to call the finish-func. The continuation is called at
* current_stack_top(sc); the continuation form is at continuation_stack_top(c).
*/
int64_t i, top1, top2;
opcode_t op;
/* check sc->stack for dynamic-winds we're jumping out of
* we need to check from the current stack top down to where the continuation stack matches the current stack??
* this was (i > 0), but that goes too far back; perhaps s7 should save the position of the call/cc invocation.
* also the two stacks can be different sizes (either can be larger)
*/
top1 = current_stack_top(sc);
top2 = continuation_stack_top(c);
for (i = top1 - 1; (i > 0) && ((i >= top2)
|| (stack_code(sc->stack, i) !=
stack_code(continuation_stack(c),
i))); i -= 4) {
op = stack_op(sc->stack, i);
switch (op) {
case OP_DYNAMIC_WIND:
case OP_LET_TEMP_DONE:
{
s7_pointer x;
int64_t j, s_base = 0;
x = stack_code(sc->stack, i);
for (j = 3; j < top2; j += 4)
if (((stack_op(continuation_stack(c), j) ==
OP_DYNAMIC_WIND)
|| (stack_op(continuation_stack(c), j) ==
OP_LET_TEMP_DONE))
&& (x == stack_code(continuation_stack(c), j))) {
s_base = i;
break;
}
if (s_base == 0) {
if (op == OP_DYNAMIC_WIND) {
if (dynamic_wind_state(x) == DWIND_BODY) {
dynamic_wind_state(x) = DWIND_FINISH;
if (dynamic_wind_out(x) != sc->F) {
push_stack_direct(sc, OP_EVAL_DONE);
sc->args = sc->nil;
sc->code = dynamic_wind_out(x);
eval(sc, OP_APPLY);
}
}
} else
let_temp_done(sc, stack_args(sc->stack, i),
stack_code(sc->stack, i),
stack_let(sc->stack, i));
}
}
break;
case OP_DYNAMIC_UNWIND:
case OP_DYNAMIC_UNWIND_PROFILE:
stack_element(sc->stack, i) = (s7_pointer) OP_GC_PROTECT;
break;
case OP_LET_TEMP_UNWIND:
let_temp_unwind(sc, stack_code(sc->stack, i),
stack_args(sc->stack, i));
break;
case OP_LET_TEMP_S7_UNWIND:
g_s7_let_set_fallback(sc,
set_plist_3(sc, sc->s7_let,
stack_code(sc->stack, i),
stack_args(sc->stack, i)));
break;
case OP_BARRIER:
if (i > top2) /* 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 > top2)
call_exit_active(stack_args(sc->stack, i)) = false;
break;
case OP_UNWIND_INPUT:
if (stack_args(sc->stack, i) != sc->unused)
set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */
break;
case OP_UNWIND_OUTPUT:
if (stack_args(sc->stack, i) != sc->unused)
set_current_output_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */
break;
default:
break;
}
}
/* check continuation-stack for dynamic-winds we're jumping into */
for (i = current_stack_top(sc) - 1; i < top2; i += 4) {
op = stack_op(continuation_stack(c), i);
if (op == OP_DYNAMIC_WIND) {
s7_pointer x;
x = stack_code(continuation_stack(c), i);
if (dynamic_wind_in(x) != sc->F) {
push_stack_direct(sc, OP_EVAL_DONE);
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;
/* not let_temp_done here! */
/* if op == OP_LET_TEMP_DONE, we're jumping back into a let-temporarily. MIT and Chez scheme say they remember the
* let-temp vars (fluid-let or parameters in their terminology) at the point of the call/cc, and restore them
* on re-entry; that strikes me as incoherently complex -- they've wrapped a hidden dynamic-wind around the
* call/cc to restore all let-temp vars! I think let-temp here should be the same as let -- if you jump back
* in, nothing hidden happens. So,
* (let ((x #f) (cc #f)) (let-temporarily ((x 1)) (set! x 2) (call/cc (lambda (r) (set! cc r))) (display x) (unless (= x 2) (newline) (exit)) (set! x 3) (cc)))
* behaves the same (in this regard) if let-temp is replaced with let.
*/
}
return (true);
}
static s7_pointer splice_in_values(s7_scheme * sc, s7_pointer args);
static bool call_with_current_continuation(s7_scheme * sc)
{
s7_pointer c = sc->code;
/* check for (baffle ...) blocking the current attempt to continue */
if ((continuation_key(c) != NOT_BAFFLED) &&
(!(find_baffle(sc, continuation_key(c)))))
return (false);
if (!check_for_dynamic_winds(sc, c))
return (true);
/* make_room_for_cc_stack(sc); *//* 28-May-21 */
/* we push_stack sc->code before calling an embedded eval above, so sc->code should still be c here, etc */
if ((stack_has_pairs(continuation_stack(c))) ||
(stack_has_counters(continuation_stack(c)))) {
make_room_for_cc_stack(sc);
copy_stack(sc, sc->stack, continuation_stack(c),
continuation_stack_top(c));
} else {
s7_pointer *nv = stack_elements(sc->stack), *ov =
stack_elements(continuation_stack(c));
memcpy((void *) nv, (void *) ov,
continuation_stack_top(c) * sizeof(s7_pointer));
}
/* copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); */
sc->stack_end =
(s7_pointer *) (sc->stack_start + continuation_stack_top(c));
{
int32_t i, top = continuation_op_loc(c);
s7_pointer *src, *dst;
sc->op_stack_now = (s7_pointer *) (sc->op_stack + top);
sc->op_stack_size = continuation_op_size(c);
sc->op_stack_end =
(s7_pointer *) (sc->op_stack + sc->op_stack_size);
src = (s7_pointer *) vector_elements(continuation_op_stack(c));
dst = sc->op_stack;
for (i = 0; i < top; i++)
dst[i] = src[i];
}
if (is_null(sc->args))
sc->value = sc->nil;
else
sc->value =
(is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc,
sc->args);
return (true);
}
static s7_pointer g_call_cc(s7_scheme * sc, s7_pointer args)
{
#define H_call_cc "(call-with-current-continuation (lambda (continuer)...)) is always a mistake!"
#define Q_call_cc s7_make_signature(sc, 2, sc->T, sc->is_procedure_symbol)
s7_pointer p = car(args); /* this is the procedure passed to call/cc */
if (!is_t_procedure(p)) { /* this includes continuations */
check_method(sc, p, sc->call_cc_symbol, args);
check_method(sc, p, sc->call_with_current_continuation_symbol,
args);
return (simple_wrong_type_argument_with_type
(sc, sc->call_cc_symbol, p, a_procedure_string));
}
if (((!is_closure(p)) ||
(closure_arity(p) != 1)) && (!s7_is_aritable(sc, p, 1)))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"call/cc procedure, ~A, should take one argument",
47), p)));
sc->w = s7_make_continuation(sc);
if ((is_any_closure(p)) && (is_pair(closure_args(p)))
&& (is_symbol(car(closure_args(p)))))
continuation_name(sc->w) = car(closure_args(p));
push_stack(sc, OP_APPLY, list_1_unchecked(sc, sc->w), p); /* apply function p to continuation sc->w */
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 void apply_continuation(s7_scheme * sc)
{ /* sc->code is the continuation */
if (!call_with_current_continuation(sc))
s7_error(sc, sc->baffled_symbol,
(is_symbol(continuation_name(sc->code))) ?
set_elist_2(sc,
wrap_string(sc,
"continuation ~S can't jump into with-baffle",
43),
continuation_name(sc->code)) : set_elist_1(sc,
wrap_string
(sc,
"continuation can't jump into with-baffle",
40)));
}
static void op_call_cc(s7_scheme * sc)
{
sc->w = s7_make_continuation(sc);
continuation_name(sc->w) = caar(opt2_pair(sc->code)); /* caadadr(sc->code) */
sc->curlet =
make_let_with_slot(sc, sc->curlet, continuation_name(sc->w),
sc->w);
sc->w = sc->nil;
sc->code = cdr(opt2_pair(sc->code)); /* cddadr(sc->code) */
}
static bool op_implicit_continuation_a(s7_scheme * sc)
{
s7_pointer s, code = sc->code; /* dumb-looking code, but it's faster than the pretty version, according to callgrind */
s = lookup_checked(sc, car(code));
if (!is_continuation(s)) {
sc->last_function = s;
return (false);
}
sc->code = s;
sc->args = set_plist_1(sc, fx_call(sc, cdr(code)));
apply_continuation(sc);
return (true);
}
/* -------------------------------- call-with-exit -------------------------------- */
static void pop_input_port(s7_scheme * sc);
static void call_with_exit(s7_scheme * sc)
{
int64_t i, new_stack_top, quit = 0;
if (!call_exit_active(sc->code))
s7_error(sc, sc->invalid_escape_function_symbol,
set_elist_1(sc,
wrap_string(sc,
"call-with-exit escape procedure called outside its block",
56)));
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 */
i = current_stack_top(sc) - 1;
do {
switch (stack_op(sc->stack, i)) { /* avoidable if we group these ops at the end and use 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) {
s7_pointer arg;
/* protect the sc->args value across this call if it is sc->plist_1 -- I can't find a broken case */
arg = (sc->args == sc->plist_1) ? car(sc->plist_1) : sc->unused; /* might also need GC protection here */
push_stack_direct(sc, OP_EVAL_DONE);
sc->args = sc->nil;
sc->code = dynamic_wind_out(lx);
eval(sc, OP_APPLY);
if (arg != sc->unused)
set_plist_1(sc, arg);
}
}
}
break;
case OP_DYNAMIC_UNWIND:
case OP_DYNAMIC_UNWIND_PROFILE:
stack_element(sc->stack, i) = (s7_pointer) OP_GC_PROTECT;
dynamic_unwind(sc, stack_code(sc->stack, i),
stack_args(sc->stack, i));
break;
case OP_EVAL_STRING:
s7_close_input_port(sc, current_input_port(sc));
pop_input_port(sc);
break;
case OP_BARRIER: /* oops -- we almost certainly went too far */
goto SET_VALUE;
case OP_DEACTIVATE_GOTO: /* here we're jumping into an unrelated call-with-exit block */
call_exit_active(stack_args(sc->stack, i)) = false;
break;
case OP_LET_TEMP_DONE:
let_temp_done(sc, stack_args(sc->stack, i),
stack_code(sc->stack, i), stack_let(sc->stack,
i));
break;
case OP_LET_TEMP_UNWIND:
let_temp_unwind(sc, stack_code(sc->stack, i),
stack_args(sc->stack, i));
break;
case OP_LET_TEMP_S7_UNWIND:
g_s7_let_set_fallback(sc,
set_plist_3(sc, sc->s7_let,
stack_code(sc->stack, i),
stack_args(sc->stack, i)));
break;
/* call/cc does not close files, but I think call-with-exit should */
case OP_GET_OUTPUT_STRING:
case OP_UNWIND_OUTPUT:
{
s7_pointer 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 #<unused> */
if (x != sc->unused)
set_current_output_port(sc, x);
}
break;
case OP_UNWIND_INPUT:
s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */
if (stack_args(sc->stack, i) != sc->unused)
set_current_input_port(sc, 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;
}
i -= 4;
} while (i > new_stack_top);
SET_VALUE:
sc->stack_end = (s7_pointer *) (sc->stack_start + new_stack_top);
/* the return value should have an implicit values call, just as in call/cc */
if (is_null(sc->args))
sc->value = sc->nil;
else
sc->value =
(is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc,
sc->args);
if (quit > 0) {
if (sc->longjmp_ok) {
pop_stack(sc);
LongJmp(sc->goto_start, CALL_WITH_EXIT_JUMP);
}
for (i = 0; i < quit; i++)
push_stack_op_let(sc, OP_EVAL_DONE);
}
}
static s7_pointer g_is_goto(s7_scheme * sc, s7_pointer args)
{
#define H_is_goto "(goto? obj) returns #t if obj is a call-with-exit exit function"
#define Q_is_goto sc->pl_bt
return (make_boolean(sc, is_goto(car(args))));
}
static inline s7_pointer make_goto(s7_scheme * sc, s7_pointer name)
{
s7_pointer x;
new_cell(sc, x, T_GOTO);
call_exit_goto_loc(x) = current_stack_top(sc);
call_exit_op_loc(x) = (int32_t) (sc->op_stack_now - sc->op_stack);
call_exit_active(x) = true;
call_exit_name(x) = name;
return (x);
}
static s7_pointer g_call_with_exit(s7_scheme * sc, s7_pointer args)
{ /* (call-with-exit (lambda (return) ...)) */
#define H_call_with_exit "(call-with-exit (lambda (exiter) ...)) is call/cc without the ability to jump back into a previous computation."
#define Q_call_with_exit s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol)
s7_pointer p = car(args), x;
if (is_any_closure(p)) {
x = make_goto(sc,
((is_any_closure(p)) && (is_pair(closure_args(p)))
&& (is_symbol(car(closure_args(p))))) ?
car(closure_args(p)) : sc->F);
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);
return (sc->nil);
}
if (!is_t_procedure(p)) /* this includes continuations */
return (method_or_bust_with_type_one_arg
(sc, p, sc->call_with_exit_symbol, args,
a_procedure_string));
x = make_goto(sc, ((is_any_closure(p)) && (is_pair(closure_args(p)))
&& (is_symbol(car(closure_args(p))))) ?
car(closure_args(p)) : sc->F);
if ((is_any_c_function(p)) && (s7_is_aritable(sc, p, 1))) {
call_exit_active(x) = false;
return ((is_c_function(p)) ?
c_function_call(p) (sc,
set_plist_1(sc,
x)) :
s7_apply_function_star(sc, p, set_plist_1(sc, x)));
}
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);
return (sc->nil);
/* this is why call-with-exit is declared an unsafe_defun: a safe function returns its value, but an unsafe one
* can await a further evaluation (the call-with-exit body). The sc->nil returned value is ignored.
*/
}
static inline void op_call_with_exit(s7_scheme * sc)
{
s7_pointer go, args = opt2_pair(sc->code);
go = make_goto(sc, caar(args));
push_stack_no_let_no_code(sc, OP_DEACTIVATE_GOTO, go); /* was also pushing code */
sc->curlet = make_let_with_slot(sc, sc->curlet, caar(args), go);
sc->code = T_Pair(cdr(args));
}
static void op_call_with_exit_o(s7_scheme * sc)
{
op_call_with_exit(sc);
sc->code = car(sc->code);
}
static bool op_implicit_goto(s7_scheme * sc)
{
s7_pointer g;
g = lookup_checked(sc, car(sc->code));
if (!is_goto(g)) {
sc->last_function = g;
return (false);
}
sc->args = sc->nil;
sc->code = g;
call_with_exit(sc);
return (true);
}
static bool op_implicit_goto_a(s7_scheme * sc)
{
s7_pointer g;
g = lookup_checked(sc, car(sc->code));
if (!is_goto(g)) {
sc->last_function = g;
return (false);
}
sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code)));
sc->code = g;
call_with_exit(sc);
return (true);
}
/* -------------------------------- numbers -------------------------------- */
static block_t *string_to_block(s7_scheme * sc, const char *p, s7_int len)
{
block_t *b;
char *bp;
b = mallocate(sc, len + 1);
bp = (char *) block_data(b);
memcpy((void *) bp, (void *) p, len);
bp[len] = '\0';
return (b);
}
static s7_pointer block_to_string(s7_scheme * sc, block_t * block,
s7_int len)
{
s7_pointer x;
new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE);
string_block(x) = block;
string_value(x) = (char *) block_data(block);
string_length(x) = len;
string_value(x)[len] = '\0';
string_hash(x) = 0;
add_string(sc, x);
return (x);
}
static inline s7_pointer make_simple_ratio(s7_scheme * sc, s7_int num,
s7_int den)
{
s7_pointer x;
if (den == 1)
return (make_integer(sc, num));
if (den == -1)
return (make_integer(sc, -num));
if ((den == S7_INT64_MIN) && ((num & 1) != 0))
return (make_real(sc, (long_double) num / (long_double) den));
new_cell(sc, x, T_RATIO);
if (den < 0) {
numerator(x) = -num;
denominator(x) = -den;
} else {
numerator(x) = num;
denominator(x) = den;
}
return (x);
}
static bool is_zero(s7_scheme * sc, s7_pointer x);
static bool is_positive(s7_scheme * sc, s7_pointer x);
static bool is_negative(s7_scheme * sc, s7_pointer x);
static s7_pointer make_ratio(s7_scheme * sc, s7_int a, s7_int b);
static bool is_NaN(s7_double x)
{
return (x != x);
}
/* callgrind says this is faster than isnan, I think (very confusing data...) */
#if defined(__sun) && defined(__SVR4)
static bool is_inf(s7_double x)
{
return ((x == x) && (is_NaN(x - x)));
} /* there's no isinf in Solaris */
#else
#if (!MS_WINDOWS)
#if __cplusplus
#define is_inf(x) std::isinf(x)
#else
#define is_inf(x) isinf(x)
#endif
#else
static bool is_inf(s7_double x)
{
return ((x == x) && (is_NaN(x - x)));
} /* Another possibility: (x * 0) != 0 */
#if (_MSC_VER < 1700)
/* in MS C, we need to provide inverse hyperbolic trig funcs and cbrt */
static double asinh(double x)
{
return (log(x + sqrt(1.0 + x * x)));
}
static double acosh(double x)
{
return (log(x + sqrt(x * x - 1.0)));
}
/* perhaps less prone to numerical troubles (untested): 2.0 * log(sqrt(0.5 * (x + 1.0)) + sqrt(0.5 * (x - 1.0))) */
static double atanh(double x)
{
return (log((1.0 + x) / (1.0 - x)) / 2.0);
}
static double cbrt(double x)
{
if (x >= 0.0)
return (pow(x, 1.0 / 3.0));
return (-pow(-x, 1.0 / 3.0));
}
#endif
#endif /* windows */
#endif /* not sun */
#if WITH_GMP
static mp_prec_t mpc_precision = DEFAULT_BIGNUM_PRECISION;
static mp_prec_t mpc_set_default_precision(mp_prec_t prec)
{
mpc_precision = prec;
return (prec);
}
#define mpc_init(Z) mpc_init2(Z, mpc_precision)
static bigint *alloc_bigint(s7_scheme * sc)
{
bigint *p;
if (sc->bigints) {
p = sc->bigints;
sc->bigints = p->nxt;
} else {
p = (bigint *) malloc(sizeof(bigint));
/* not permalloc here: gmp must be playing tricky games with realloc or something. permalloc can lead
* to mpz_set_si overwriting adjacent memory (valgrind does not catch this), clobbering at least the
* bigint nxt field. Someday I need to look at the source.
*/
mpz_init(p->n);
}
return (p);
}
static bigrat *alloc_bigrat(s7_scheme * sc)
{
bigrat *p;
if (sc->bigrats) {
p = sc->bigrats;
sc->bigrats = p->nxt;
} else {
p = (bigrat *) malloc(sizeof(bigrat));
mpq_init(p->q);
}
return (p);
}
static bigflt *alloc_bigflt(s7_scheme * sc)
{
bigflt *p;
if (sc->bigflts) {
p = sc->bigflts;
sc->bigflts = p->nxt;
mpfr_set_prec(p->x, sc->bignum_precision);
} else {
p = (bigflt *) malloc(sizeof(bigflt));
mpfr_init2(p->x, sc->bignum_precision);
}
return (p);
}
static bigcmp *alloc_bigcmp(s7_scheme * sc)
{
bigcmp *p;
if (sc->bigcmps) {
p = sc->bigcmps;
sc->bigcmps = p->nxt;
mpc_set_prec(p->z, sc->bignum_precision);
} else {
p = (bigcmp *) malloc(sizeof(bigcmp));
mpc_init(p->z);
}
return (p);
}
static s7_pointer mpz_to_big_integer(s7_scheme * sc, mpz_t val)
{
s7_pointer x;
new_cell(sc, x, T_BIG_INTEGER);
big_integer_bgi(x) = alloc_bigint(sc);
mpz_set(big_integer(x), val);
add_big_integer(sc, x);
return (x);
}
static s7_pointer mpz_to_integer(s7_scheme * sc, mpz_t val)
{
if (mpz_fits_slong_p(val))
return (make_integer(sc, mpz_get_si(val)));
return (mpz_to_big_integer(sc, val));
}
#if (!WITH_PURE_S7)
static s7_pointer mpz_to_big_real(s7_scheme * sc, mpz_t val)
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL);
big_real_bgf(x) = alloc_bigflt(sc);
add_big_real(sc, x);
mpfr_set_z(big_real(x), val, MPFR_RNDN);
return (x);
}
#endif
static s7_pointer mpq_to_big_ratio(s7_scheme * sc, mpq_t val)
{
s7_pointer x;
new_cell(sc, x, T_BIG_RATIO);
big_ratio_bgr(x) = alloc_bigrat(sc);
add_big_ratio(sc, x);
mpq_set(big_ratio(x), val);
return (x);
}
static s7_pointer mpq_to_rational(s7_scheme * sc, mpq_t val)
{
if (mpz_cmp_ui(mpq_denref(val), 1) == 0)
return (mpz_to_integer(sc, mpq_numref(val)));
#if S7_DEBUGGING
mpq_canonicalize(val);
if (mpz_cmp_ui(mpq_denref(val), 1) == 0) {
fprintf(stderr, "mpq_to_rational: missing canonicalize\n");
return (mpz_to_integer(sc, mpq_numref(val)));
}
#endif
if ((mpz_fits_slong_p(mpq_numref(val)))
&& (mpz_fits_slong_p(mpq_denref(val))))
return (make_simple_ratio
(sc, mpz_get_si(mpq_numref(val)),
mpz_get_si(mpq_denref(val))));
return (mpq_to_big_ratio(sc, val));
}
static s7_pointer mpq_to_canonicalized_rational(s7_scheme * sc, mpq_t mpq)
{
mpq_canonicalize(mpq);
return (mpq_to_rational(sc, mpq));
}
static s7_pointer mpz_to_rational(s7_scheme * sc, mpz_t n, mpz_t d)
{ /* mpz_3 and mpz_4 */
if (mpz_cmp_ui(d, 1) == 0)
return (mpz_to_integer(sc, n));
mpq_set_num(sc->mpq_1, n);
mpq_set_den(sc->mpq_1, d);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
}
#if (!WITH_PURE_S7)
static s7_pointer mpq_to_big_real(s7_scheme * sc, mpq_t val)
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL);
big_real_bgf(x) = alloc_bigflt(sc);
add_big_real(sc, x);
mpfr_set_q(big_real(x), val, MPFR_RNDN);
return (x);
}
#endif
static s7_pointer any_rational_to_mpq(s7_scheme * sc, s7_pointer z,
mpq_t bigq)
{
switch (type(z)) {
case T_INTEGER:
mpq_set_si(bigq, integer(z), 1);
break;
case T_BIG_INTEGER:
mpq_set_z(bigq, big_integer(z));
break;
case T_RATIO:
mpq_set_si(bigq, numerator(z), denominator(z));
break;
case T_BIG_RATIO:
mpq_set(bigq, big_ratio(z));
break;
}
return (z);
}
static s7_pointer mpfr_to_integer(s7_scheme * sc, mpfr_t val)
{
mpfr_get_z(sc->mpz_4, val, MPFR_RNDN);
return (mpz_to_integer(sc, sc->mpz_4));
}
static s7_pointer mpfr_to_big_real(s7_scheme * sc, mpfr_t val)
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL);
add_big_real(sc, x);
big_real_bgf(x) = alloc_bigflt(sc);
mpfr_set(big_real(x), val, MPFR_RNDN);
return (x);
}
static s7_pointer mpc_to_number(s7_scheme * sc, mpc_t val)
{
s7_pointer x;
if (mpfr_zero_p(mpc_imagref(val)))
return (mpfr_to_big_real(sc, mpc_realref(val)));
new_cell(sc, x, T_BIG_COMPLEX);
big_complex_bgc(x) = alloc_bigcmp(sc);
add_big_complex(sc, x);
mpc_set(big_complex(x), val, MPC_RNDNN);
return (x);
}
/* s7.h */
mpz_t *s7_big_integer(s7_pointer x)
{
return (&big_integer(x));
}
mpq_t *s7_big_ratio(s7_pointer x)
{
return (&big_ratio(x));
}
mpfr_t *s7_big_real(s7_pointer x)
{
return (&big_real(x));
}
mpc_t *s7_big_complex(s7_pointer x)
{
return (&big_complex(x));
}
bool s7_is_big_integer(s7_pointer x)
{
return (is_t_big_integer(x));
}
bool s7_is_big_ratio(s7_pointer x)
{
return (is_t_big_ratio(x));
}
bool s7_is_big_real(s7_pointer x)
{
return (is_t_big_real(x));
}
bool s7_is_big_complex(s7_pointer x)
{
return (is_t_big_complex(x));
}
s7_pointer s7_make_big_integer(s7_scheme * sc, mpz_t * val)
{
return (mpz_to_integer(sc, *val));
}
s7_pointer s7_make_big_ratio(s7_scheme * sc, mpq_t * val)
{
return (mpq_to_rational(sc, *val));
}
s7_pointer s7_make_big_real(s7_scheme * sc, mpfr_t * val)
{
return (mpfr_to_big_real(sc, *val));
}
s7_pointer s7_make_big_complex(s7_scheme * sc, mpc_t * val)
{
return (mpc_to_number(sc, *val));
}
#if (!WITH_PURE_S7)
static s7_pointer big_integer_to_big_real(s7_scheme * sc, s7_pointer x)
{
return (mpz_to_big_real(sc, big_integer(x)));
}
static s7_pointer big_ratio_to_big_real(s7_scheme * sc, s7_pointer x)
{
return (mpq_to_big_real(sc, big_ratio(x)));
}
#endif
static s7_pointer s7_int_to_big_integer(s7_scheme * sc, s7_int val)
{
s7_pointer x;
new_cell(sc, x, T_BIG_INTEGER);
big_integer_bgi(x) = alloc_bigint(sc);
mpz_set_si(big_integer(x), val);
add_big_integer(sc, x);
return (x);
}
static s7_pointer s7_int_to_big_ratio(s7_scheme * sc, s7_int num,
s7_int den)
{
/* (called only in g_bignum), den here always comes from denominator(x) or some positive constant so it is not negative */
s7_pointer x;
new_cell(sc, x, T_BIG_RATIO);
big_ratio_bgr(x) = alloc_bigrat(sc);
add_big_ratio(sc, x);
mpq_set_si(big_ratio(x), num, den);
return (x);
}
static s7_pointer s7_double_to_big_real(s7_scheme * sc, s7_double rl)
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL);
big_real_bgf(x) = alloc_bigflt(sc);
add_big_real(sc, x);
mpfr_set_d(big_real(x), rl, MPFR_RNDN);
return (x);
}
static s7_pointer s7_double_to_big_complex(s7_scheme * sc, s7_double rl,
s7_double im)
{
s7_pointer x;
new_cell(sc, x, T_BIG_COMPLEX);
add_big_complex(sc, x);
big_complex_bgc(x) = alloc_bigcmp(sc);
mpc_set_d_d(big_complex(x), rl, im, MPC_RNDNN);
return (x);
}
static s7_pointer big_pi(s7_scheme * sc)
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL | T_IMMUTABLE);
big_real_bgf(x) = alloc_bigflt(sc);
add_big_real(sc, x);
mpfr_const_pi(big_real(x), MPFR_RNDN);
return (x);
}
static bool is_integer_via_method(s7_scheme * sc, s7_pointer p)
{
if (s7_is_integer(p))
return (true);
if (has_active_methods(sc, p)) {
s7_pointer f;
f = find_method_with_let(sc, p, sc->is_integer_symbol);
if (f != sc->undefined)
return (is_true
(sc, call_method(sc, p, f, set_plist_1(sc, p))));
}
return (false);
}
#if (!WITH_PURE_S7)
static s7_pointer s7_number_to_big_real(s7_scheme * sc, s7_pointer p)
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL);
big_real_bgf(x) = alloc_bigflt(sc);
add_big_real(sc, x);
switch (type(p)) {
case T_INTEGER:
mpfr_set_si(big_real(x), integer(p), MPFR_RNDN);
break;
case T_RATIO:
/* here we can't use fraction(number(p)) even though that uses long_double division because
* there are lots of int64_t ratios that will still look the same.
* We have to do the actual bignum divide by hand.
*/
mpq_set_si(sc->mpq_1, numerator(p), denominator(p));
mpfr_set_q(big_real(x), sc->mpq_1, MPFR_RNDN);
break;
default:
mpfr_set_d(big_real(x), s7_real(p), MPFR_RNDN);
break;
}
return (x);
}
#endif
static s7_pointer s7_number_to_big_complex(s7_scheme * sc, s7_pointer p)
{
s7_pointer x;
new_cell(sc, x, T_BIG_COMPLEX);
big_complex_bgc(x) = alloc_bigcmp(sc);
add_big_complex(sc, x);
switch (type(p)) {
case T_INTEGER:
mpc_set_si(big_complex(x), integer(p), MPC_RNDNN);
break;
case T_RATIO:
/* can't use fraction here */
mpq_set_si(sc->mpq_1, numerator(p), denominator(p));
mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN);
mpc_set_fr(big_complex(x), sc->mpfr_1, MPC_RNDNN);
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 any_real_to_mpfr(s7_scheme * sc, s7_pointer p,
mpfr_t bigx)
{
switch (type(p)) {
case T_INTEGER:
mpfr_set_si(bigx, integer(p), MPFR_RNDN);
break;
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(p), denominator(p));
mpfr_set_q(bigx, sc->mpq_1, MPFR_RNDN);
break;
case T_REAL:
mpfr_set_d(bigx, real(p), MPFR_RNDN);
if (is_NaN(real(p)))
return (real_NaN);
if (is_inf(real(p)))
return (real_infinity);
break;
case T_BIG_INTEGER:
mpfr_set_z(bigx, big_integer(p), MPFR_RNDN);
break;
case T_BIG_RATIO:
mpfr_set_q(bigx, big_ratio(p), MPFR_RNDN);
break;
case T_BIG_REAL:
mpfr_set(bigx, big_real(p), MPFR_RNDN);
if (mpfr_nan_p(big_real(p)))
return (real_NaN);
if (mpfr_inf_p(big_real(p)))
return (real_infinity);
break;
}
return (NULL);
}
#define mpc_zero_p(z) ((mpfr_zero_p(mpc_realref(z))) && (mpfr_zero_p(mpc_imagref(z))))
static s7_pointer any_number_to_mpc(s7_scheme * sc, s7_pointer p,
mpc_t bigz)
{
switch (type(p)) {
case T_INTEGER:
mpc_set_si(bigz, integer(p), MPC_RNDNN);
break;
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(p), denominator(p));
mpc_set_q(bigz, sc->mpq_1, MPC_RNDNN);
break;
case T_REAL:
if (is_NaN(real(p)))
return (real_NaN);
if (is_inf(real(p)))
return (real_infinity);
mpc_set_d(bigz, real(p), MPC_RNDNN);
break;
case T_COMPLEX:
if (is_NaN(imag_part(p)))
return (complex_NaN);
if (is_NaN(real_part(p)))
return (real_NaN);
mpc_set_d_d(bigz, real_part(p), imag_part(p), MPC_RNDNN);
break;
case T_BIG_INTEGER:
mpc_set_z(bigz, big_integer(p), MPC_RNDNN);
break;
case T_BIG_RATIO:
mpc_set_q(bigz, big_ratio(p), MPC_RNDNN);
break;
case T_BIG_REAL:
mpc_set_fr(bigz, big_real(p), MPC_RNDNN);
if (mpfr_nan_p(big_real(p)))
return (real_NaN);
if (mpfr_inf_p(big_real(p)))
return (real_infinity);
break;
case T_BIG_COMPLEX:
if (mpfr_nan_p(mpc_imagref(big_complex(p))))
return (complex_NaN);
if (mpfr_nan_p(mpc_realref(big_complex(p))))
return (real_NaN);
mpc_set(bigz, big_complex(p), MPC_RNDNN);
break;
}
return (NULL);
}
static s7_pointer make_big_complex(s7_scheme * sc, mpfr_t rl, mpfr_t im)
{
/* there is no mpc_get_str equivalent, so we need to split up str, use make_big_real to get the 2 halves, then mpc_init, then mpc_set_fr_fr */
s7_pointer x;
new_cell(sc, x, T_BIG_COMPLEX);
big_complex_bgc(x) = alloc_bigcmp(sc);
add_big_complex(sc, x);
mpc_set_fr_fr(big_complex(x), rl, im, MPC_RNDNN);
return (x);
}
static block_t *mpfr_to_string(s7_scheme * sc, mpfr_t val, int32_t radix)
{
char *str;
mp_exp_t expptr;
int32_t ep;
s7_int i, len;
block_t *b, *btmp;
if (mpfr_zero_p(val))
return (string_to_block(sc, "0.0", 3));
if (mpfr_nan_p(val))
return (string_to_block(sc, "+nan.0", 6));
if (mpfr_inf_p(val))
return ((mpfr_signbit(val) == 0) ? string_to_block(sc, "+inf.0",
6) :
string_to_block(sc, "-inf.0", 6));
b = callocate(sc, sc->bignum_precision + 32);
#if 1
str =
mpfr_get_str((char *) block_data(b), &expptr, radix, 0, val,
MPFR_RNDN);
ep = (int32_t) 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';
btmp = mallocate(sc, len + 64);
if (str[0] == '-')
snprintf((char *) block_data(btmp), len + 64, "-%c.%s%c%d", str[1],
(char *) (str + 2), (radix <= 10) ? 'E' : '@', ep - 1);
else
snprintf((char *) block_data(btmp), len + 64, "%c.%s%c%d", str[0],
(char *) (str + 1), (radix <= 10) ? 'E' : '@', ep - 1);
liberate(sc, b);
return (btmp);
#else
/* this is dumb */
mpfr_snprintf((char *) block_data(b), sc->bignum_precision + 32, "%.*RE", sc->bignum_precision, val); /* default precision is 1!! */
return (b);
#endif
}
static block_t *mpc_to_string(s7_scheme * sc, mpc_t val, int32_t radix,
use_write_t use_write)
{
block_t *rl, *im, *tmp;
s7_int len;
mpc_real(sc->mpfr_1, val, MPFR_RNDN);
rl = mpfr_to_string(sc, sc->mpfr_1, radix);
mpc_imag(sc->mpfr_2, val, MPFR_RNDN);
im = mpfr_to_string(sc, sc->mpfr_2, radix);
len =
safe_strlen((char *) block_data(rl)) +
safe_strlen((char *) block_data(im)) + 128;
tmp = mallocate(sc, len);
snprintf((char *) block_data(tmp), len, "%s%s%si",
(char *) block_data(rl),
((((char *) block_data(im))[0] == '-')
|| (((char *) block_data(im))[0] == '+')) ? "" : "+",
(char *) block_data(im));
liberate(sc, rl);
liberate(sc, im);
return (tmp);
}
static block_t *big_number_to_string_with_radix(s7_scheme * sc,
s7_pointer p,
int32_t radix,
s7_int width,
s7_int * nlen,
use_write_t use_write)
{
block_t *str;
switch (type(p)) {
case T_BIG_INTEGER:
str = callocate(sc, mpz_sizeinbase(big_integer(p), radix) + 64);
mpz_get_str((char *) block_data(str), radix, big_integer(p));
break;
case T_BIG_RATIO:
mpz_set(sc->mpz_1, mpq_numref(big_ratio(p)));
mpz_set(sc->mpz_2, mpq_denref(big_ratio(p)));
str =
callocate(sc,
mpz_sizeinbase(sc->mpz_1,
radix) + mpz_sizeinbase(sc->mpz_2,
radix) + 64);
mpq_get_str((char *) block_data(str), radix, big_ratio(p));
break;
case T_BIG_REAL:
str = mpfr_to_string(sc, big_real(p), radix);
break;
default:
str = mpc_to_string(sc, big_complex(p), radix, use_write);
break;
}
if (width > 0) {
s7_int len;
len = safe_strlen((char *) block_data(str));
if (width > len) {
int32_t spaces;
block_t *tmp;
tmp = (block_t *) mallocate(sc, width + 1);
spaces = width - len;
((char *) block_data(tmp))[width] = '\0';
memmove((void *) ((char *) block_data(tmp) + spaces),
(void *) block_data(str), len);
memset((void *) block_data(tmp), (int) ' ', spaces);
(*nlen) = width;
liberate(sc, str);
return (tmp);
}
(*nlen) = len;
} else
(*nlen) = safe_strlen((char *) block_data(str));
return (str);
}
static s7_pointer string_to_big_integer(s7_scheme * sc, const char *str,
int32_t radix)
{
mpz_set_str(sc->mpz_4,
(str[0] == '+') ? (const char *) (str + 1) : str, radix);
return (mpz_to_integer(sc, sc->mpz_4));
}
static s7_pointer string_to_big_ratio(s7_scheme * sc, const char *str,
int32_t radix)
{
s7_pointer x;
mpq_set_str(sc->mpq_1, str, radix);
mpq_canonicalize(sc->mpq_1);
if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0)
return (mpz_to_integer(sc, mpq_numref(sc->mpq_1)));
new_cell(sc, x, T_BIG_RATIO);
big_ratio_bgr(x) = alloc_bigrat(sc);
add_big_ratio(sc, x);
mpq_set(big_ratio(x), sc->mpq_1);
return (x);
}
static s7_pointer string_to_big_real(s7_scheme * sc, const char *str,
int32_t radix)
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL);
big_real_bgf(x) = alloc_bigflt(sc);
add_big_real(sc, x);
mpfr_set_str(big_real(x), str, radix, MPFR_RNDN);
return (x);
}
static s7_int string_to_integer(const char *str, int32_t radix,
bool *overflow);
static s7_pointer string_to_either_integer(s7_scheme * sc, const char *str,
int32_t radix)
{
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, int32_t radix)
{
s7_int 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) {
s7_int n;
if (d == 0)
return (real_NaN);
n = string_to_integer(nstr, radix, &overflow);
if (!overflow)
return (make_ratio(sc, n, d));
}
if (nstr[0] == '+')
return (string_to_big_ratio(sc, (const char *) (nstr + 1), radix));
return (string_to_big_ratio(sc, nstr, radix));
}
static s7_double string_to_double_with_radix(const char *ur_str,
int32_t radix,
bool *overflow);
static s7_pointer string_to_either_real(s7_scheme * sc, const char *str,
int32_t 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,
int32_t radix,
s7_double * d_rl)
{
bool overflow = false;
/* there's a real problem here -- we don't want to promote s7_double .1 to a bignum because
* its low order digits are garbage, causing (rationalize .1 0) to return 3602879701896397/36028797018963968
* no matter what the bignum-precision. But we can't just fallback on gmp's reader because (for example)
* it reads 1/2+i or 1+0/0i as 1.0. Also format gets screwed up. And string->number signals an error
* where it should return #f. I wonder what to do.
*/
if ((has_dec_point1) || (ex1)) {
(*d_rl) = string_to_double_with_radix(q, radix, &overflow);
if (overflow)
return (string_to_big_real(sc, q, radix));
} else {
if (slash1) {
s7_int 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));
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,
int32_t radix,
int32_t has_plus_or_minus)
{
/* this can be just about anything involving 2 real/ratio/int portions, +/- in between and 'i' at the end */
double d_rl = 0.0, d_im = 0.0;
s7_pointer p_rl = NULL, p_im = NULL;
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 */
((!p_im) || (is_zero(sc, p_im))))
return ((p_rl) ? p_rl : make_real(sc, d_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)
any_real_to_mpfr(sc, p_rl, sc->mpfr_1);
else
mpfr_set_d(sc->mpfr_1, d_rl, MPFR_RNDN);
if (p_im)
any_real_to_mpfr(sc, p_im, sc->mpfr_2);
else
mpfr_set_d(sc->mpfr_2, d_im, MPFR_RNDN);
if (has_plus_or_minus == -1)
mpfr_neg(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN);
return (make_big_complex(sc, sc->mpfr_1, sc->mpfr_2));
}
static bool big_numbers_are_eqv(s7_scheme * sc, s7_pointer a, s7_pointer b)
{
/* either or both can be big here, but not neither, and types might not match at all */
switch (type(a)) {
case T_INTEGER:
return ((is_t_big_integer(b))
&& (mpz_cmp_si(big_integer(b), integer(a)) == 0));
case T_BIG_INTEGER:
if (is_t_big_integer(b))
return (mpz_cmp(big_integer(a), big_integer(b)) == 0);
return ((is_t_integer(b))
&& (mpz_cmp_si(big_integer(a), integer(b)) == 0));
case T_RATIO:
if (!is_t_big_ratio(b))
return (false);
mpq_set_si(sc->mpq_1, numerator(a), denominator(a));
return (mpq_equal(sc->mpq_1, big_ratio(b)));
case T_BIG_RATIO:
if (is_t_big_ratio(b))
return (mpq_equal(big_ratio(a), big_ratio(b)));
if (!is_t_ratio(b))
return (false);
mpq_set_si(sc->mpq_1, numerator(b), denominator(b));
return (mpq_equal(sc->mpq_1, big_ratio(a)));
case T_REAL:
if (is_NaN(real(a)))
return (false);
return ((is_t_big_real(b)) && (!mpfr_nan_p(big_real(b)))
&& (mpfr_cmp_d(big_real(b), real(a)) == 0));
case T_BIG_REAL:
if (mpfr_nan_p(big_real(a)))
return (false);
if (is_t_big_real(b))
return ((!mpfr_nan_p(big_real(b)))
&& (mpfr_equal_p(big_real(a), big_real(b))));
return ((is_t_real(b)) && (!is_NaN(real(b)))
&& (mpfr_cmp_d(big_real(a), real(b)) == 0));
case T_COMPLEX:
if ((is_NaN(real_part(a))) || (is_NaN(imag_part(a))))
return (false);
if (!is_t_big_complex(b))
return (false);
if ((mpfr_nan_p(mpc_realref(big_complex(b))))
|| (mpfr_nan_p(mpc_imagref(big_complex(b)))))
return (false);
mpc_set_d_d(sc->mpc_1, real_part(a), imag_part(a), MPC_RNDNN);
return (mpc_cmp(sc->mpc_1, big_complex(b)) == 0);
case T_BIG_COMPLEX:
if ((mpfr_nan_p(mpc_realref(big_complex(a))))
|| (mpfr_nan_p(mpc_imagref(big_complex(a)))))
return (false);
if (is_t_big_complex(b)) {
if ((mpfr_nan_p(mpc_realref(big_complex(b))))
|| (mpfr_nan_p(mpc_imagref(big_complex(b)))))
return (false);
return (mpc_cmp(big_complex(a), big_complex(b)) == 0);
}
if (is_t_complex(b)) {
if ((is_NaN(real_part(b))) || (is_NaN(imag_part(b))))
return (false);
mpc_set_d_d(sc->mpc_2, real_part(b), imag_part(b), MPC_RNDNN);
return (mpc_cmp(big_complex(a), sc->mpc_1) == 0);
}
}
return (false);
}
static s7_int big_integer_to_s7_int(s7_scheme * sc, mpz_t n)
{
if (!mpz_fits_slong_p(n))
s7_error(sc, sc->out_of_range_symbol,
set_elist_2(sc,
wrap_string(sc,
"big int does not fit in s7_int: ~S",
34), mpz_to_big_integer(sc, n)));
return (mpz_get_si(n));
}
#endif
#ifndef HAVE_OVERFLOW_CHECKS
#if ((defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) || (defined(__GNUC__) && __GNUC__ >= 5))
#define HAVE_OVERFLOW_CHECKS 1
#else
#define HAVE_OVERFLOW_CHECKS 0
#pragma message("no arithmetic overflow checks in this version of s7")
#endif
#endif
#if (defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4)))
#define subtract_overflow(A, B, C) __builtin_ssubll_overflow((long long)A, (long long)B, (long long *)C)
#define add_overflow(A, B, C) __builtin_saddll_overflow((long long)A, (long long)B, (long long *)C)
#define multiply_overflow(A, B, C) __builtin_smulll_overflow((long long)A, (long long)B, (long long *)C)
/* #define int32_subtract_overflow(A, B, C) __builtin_ssub_overflow(A, B, C) */
#define int32_add_overflow(A, B, C) __builtin_sadd_overflow(A, B, C)
#define int32_multiply_overflow(A, B, C) __builtin_smul_overflow(A, B, C)
#else
#if (defined(__GNUC__) && __GNUC__ >= 5)
#define subtract_overflow(A, B, C) __builtin_sub_overflow(A, B, C)
#define add_overflow(A, B, C) __builtin_add_overflow(A, B, C)
#define multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C)
/* #define int32_subtract_overflow(A, B, C) __builtin_sub_overflow(A, B, C) */
#define int32_add_overflow(A, B, C) __builtin_add_overflow(A, B, C)
#define int32_multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C)
#endif
#endif
#if WITH_GCC
#define s7_int_abs(x) ({s7_int _X_; _X_ = x; _X_ >= 0 ? _X_ : -_X_;})
#else
#define s7_int_abs(x) ((x) >= 0 ? (x) : -(x))
#endif
/* can't use abs even in gcc -- it doesn't work with int64_ts! */
#if (!__NetBSD__)
#define s7_fabsl(X) fabsl(X)
#else
static double s7_fabsl(long_double x)
{
return ((signbit(x)) ? -x : x);
}
#endif
/* for g_log, we also need round. this version is from stackoverflow, see also r5rs_round below */
double s7_round(double number)
{
return ((number < 0.0) ? ceil(number - 0.5) : floor(number + 0.5));
}
#if HAVE_COMPLEX_NUMBERS
#if __cplusplus
#define _Complex_I (complex<s7_double>(0.0, 1.0))
#define creal(x) Real(x)
#define cimag(x) Imag(x)
#define carg(x) arg(x)
#define cabs(x) abs(x)
#define csqrt(x) sqrt(x)
#define cpow(x, y) pow(x, y)
#define clog(x) log(x)
#define cexp(x) exp(x)
#define csin(x) sin(x)
#define ccos(x) cos(x)
#define ctan(x) tan(x)
#define csinh(x) sinh(x)
#define ccosh(x) cosh(x)
#define ctanh(x) tanh(x)
#define casin(x) asin(x)
#define cacos(x) acos(x)
#define catan(x) atan(x)
#define casinh(x) asinh(x)
#define cacosh(x) acosh(x)
#define catanh(x) atanh(x)
#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
#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 12)
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);
}
#endif
#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 9) /* untested -- this orignally looked at __FreeBSD_version which apparently no longer exists */
static s7_complex cexp(s7_complex z)
{
return (exp(creal(z)) * cos(cimag(z)) +
(exp(creal(z)) * sin(cimag(z))) * _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)));
}
#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)
{
return (is_number(p));
}
bool s7_is_complex(s7_pointer p)
{
return (is_number(p));
}
bool s7_is_real(s7_pointer p)
{
return (is_real(p));
}
bool s7_is_rational(s7_pointer p)
{
return (is_rational(p));
}
bool s7_is_integer(s7_pointer p)
{
#if WITH_GMP
return ((is_t_integer(p)) || (is_t_big_integer(p)));
#else
return (is_t_integer(p));
#endif
}
bool s7_is_ratio(s7_pointer p)
{
#if WITH_GMP
return ((is_t_ratio(p)) || (is_t_big_ratio(p)));
#else
return (is_t_ratio(p));
#endif
}
static s7_int c_gcd(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);
/* there are faster gcd algorithms but does it ever matter? */
while (b != 0) {
s7_int temp;
temp = a % b;
a = b;
b = temp;
}
/* if (a < 0) return(-a); *//* why this? */
return (a);
}
#define RATIONALIZE_LIMIT 1.0e12
static bool c_rationalize(s7_double ux, s7_double error, s7_int * numer,
s7_int * denom)
{
/* from CL code in Canny, Donald, Ressler, "A Rational Rotation Method for Robust Geometric Algorithms" */
double x0, x1;
s7_int i, i0, i1, p0, q0, p1, q1;
double e0, e1, e0p, e1p;
int32_t tries = 0;
/* don't use long_double: the loop below will hang */
/* #e1e19 is a killer -- it's bigger than most-positive-fixnum, but if we ceil(ux) below
* it turns into most-negative-fixnum. 1e19 is trouble in many places.
*/
if (fabs(ux) > RATIONALIZE_LIMIT) {
/* (rationalize most-positive-fixnum) should not return most-negative-fixnum
* but any number > 1e14 here is so inaccurate that rationalize is useless
* for example,
* default: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 1185866354261165/4
* gmp: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 9223372036854775807/31111
* can't return false here because that confuses some of the callers!
*/
(*numer) = (s7_int) ux;
(*denom) = 1;
return (true);
}
if (error < 0.0)
error = -error;
x0 = ux - error;
x1 = ux + error;
i = (s7_int) ceil(x0);
if (error >= 1.0) { /* aw good grief! */
if (x0 < 0)
(*numer) = (x1 < 0) ? (s7_int) floor(x1) : 0;
else
(*numer) = i;
(*denom) = 1;
return (true);
}
if (x1 >= i) {
(*numer) = (i >= 0) ? i : (s7_int) floor(x1);
(*denom) = 1;
return (true);
}
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)) {
if ((q0 == s7_int_min) && (p0 == 1)) { /* (rationalize 1.000000004297917e-12) when error is 1e-12 */
(*numer) = 0;
(*denom) = 1;
} else {
(*numer) = p0;
(*denom) = q0;
#if S7_DEBUGGING
if (q0 == 0)
fprintf(stderr, "%f %ld/0\n", ux, p0);
#endif
}
return (true);
}
tries++;
r = (s7_int) floor(e0 / e1);
r1 = (s7_int) ceil(e0p / e1p);
if (r1 < r)
r = r1;
/* do handles all step vars in parallel */
old_p1 = p1;
p1 = p0;
old_q1 = q1;
q1 = q0;
old_e0 = e0;
e0 = e1p;
old_e0p = e0p;
e0p = e1;
old_e1 = e1;
p0 = old_p1 + r * p0;
q0 = old_q1 + r * q0;
e1 = old_e0p - r * e1p;
/* if the error is set too low, we can get e1 = 0 here: (rationalize (/ pi) 1e-17) */
e1p = old_e0 - r * old_e1;
}
return (false);
}
s7_pointer s7_rationalize(s7_scheme * sc, s7_double x, s7_double error)
{
s7_int numer = 0, denom = 1;
if (c_rationalize(x, error, &numer, &denom))
return (make_ratio(sc, numer, denom));
return (make_real(sc, x));
}
s7_pointer s7_make_integer(s7_scheme * sc, s7_int n)
{
s7_pointer x;
if (is_small_int(n))
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 | T_IMMUTABLE);
integer(x) = n;
return (x);
}
static s7_pointer make_permanent_integer(s7_int i)
{
if (is_small_int(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;
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 | T_IMMUTABLE);
set_real(x, n);
return (x);
}
s7_pointer s7_make_complex(s7_scheme * sc, s7_double a, s7_double b)
{
s7_pointer x;
if (b == 0.0) {
new_cell(sc, x, T_REAL);
set_real(x, a);
} else {
new_cell(sc, x, T_COMPLEX);
set_real_part(x, a);
set_imag_part(x, b);
}
return (x);
}
static s7_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 c_complex_to_s7(s7_scheme * sc, s7_complex z)
{
return (make_complex(sc, creal(z), cimag(z)));
}
static s7_pointer division_by_zero_error(s7_scheme * sc, s7_pointer caller,
s7_pointer arg);
static s7_pointer make_ratio(s7_scheme * sc, s7_int a, s7_int b)
{
s7_pointer x;
if (b == s7_int_min) {
/* This should not trigger an error during reading -- we might have the
* ratio on a switch with-bignums or whatever, so its mere occurrence is just an annoyance.
*/
if (a & 1)
return (make_real(sc, (long_double) a / (long_double) b));
a /= 2;
b /= 2;
}
if (b < 0) {
a = -a;
b = -b;
}
if (a == s7_int_min) { /* believe it or not, gcc randomly says a != S7_INT64_MIN here but a == s7_int_min even with explicit types! This has to be a bug */
while (((a & 1) == 0) && ((b & 1) == 0)) {
a /= 2;
b /= 2;
}
} else {
s7_int b1 = b, divisor;
divisor = s7_int_abs(a);
do {
s7_int temp;
temp = divisor % b1;
divisor = b1;
b1 = temp;
} while (b1 != 0);
if (divisor != 1) {
a /= divisor;
b /= divisor;
}
}
if (b == 1)
return (make_integer(sc, a));
new_cell(sc, x, T_RATIO);
numerator(x) = a;
denominator(x) = b;
return (x);
}
s7_pointer s7_make_ratio(s7_scheme * sc, s7_int a, s7_int b)
{
if (b == 0)
return (division_by_zero_error
(sc, wrap_string(sc, "make-ratio", 10),
set_elist_2(sc, wrap_integer1(sc, a), int_zero)));
return (make_ratio(sc, a, b));
}
#define WITH_OVERFLOW_ERROR true
#define WITHOUT_OVERFLOW_ERROR false
#define INT64_TO_DOUBLE_LIMIT (1LL << 53)
#define DOUBLE_TO_INT64_LIMIT (1LL << 53)
#if (!WITH_PURE_S7)
/* 9007199254740991LL is where a truncated double starts to skip integers (expt 2 53) = ca 1e16
* (ceiling (+ 1e16 1)) -> 10000000000000000
* (> 9007199254740993.0 9007199254740992.0) -> #f ; in non-gmp 64-bit doubles
* but we can't fix this except in the gmp case because:
* (integer-decode-float (+ (expt 2.0 62) 100)) -> (4503599627370496 10 1)
* (integer-decode-float (+ (expt 2.0 62) 500)) -> (4503599627370496 10 1)
* (> (+ (expt 2.0 62) 500) (+ (expt 2.0 62) 100)) -> #f ; non-gmp again
* i.e. the bits are identical. We can't even detect when it has happened (without tedious effort), so should
* we just give an error for any floor (or whatever) of an arg>1e16? (sin has a similar problem)?
* I think in the non-gmp case I'll throw an error in these cases because the results are bogus:
* (floor (+ (expt 2.0 62) 512)) -> 4611686018427387904
* (floor (+ (expt 2.0 62) 513)) -> 4611686018427388928
* another case at the edge: (round 9007199254740992.51) -> 9007199254740992
* This spells trouble for normal arithmetic in this range. If no gmp,
* (- (+ (expt 2.0 62) 512) (+ (expt 2.0 62) 513)) = -1024.0 (should be -1.0)
* but we don't currently give an error in this case -- not sure what the right thing is.
*/
static s7_pointer exact_to_inexact(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
#if WITH_GMP
if ((integer(x) > INT64_TO_DOUBLE_LIMIT)
|| (integer(x) < -INT64_TO_DOUBLE_LIMIT))
return (s7_number_to_big_real(sc, x));
#endif
return (make_real(sc, (s7_double) (integer(x))));
case T_RATIO:
#if WITH_GMP
if ((numerator(x) > INT64_TO_DOUBLE_LIMIT) || (numerator(x) < -INT64_TO_DOUBLE_LIMIT) || (denominator(x) > INT64_TO_DOUBLE_LIMIT)) /* just a guess */
return (s7_number_to_big_real(sc, x));
#endif
return (make_real(sc, (s7_double) (fraction(x))));
#if WITH_GMP
case T_BIG_INTEGER:
return (big_integer_to_big_real(sc, x));
case T_BIG_RATIO:
return (big_ratio_to_big_real(sc, x));
#endif
case T_REAL:
case T_BIG_REAL:
case T_COMPLEX:
case T_BIG_COMPLEX:
return (x); /* apparently (exact->inexact 1+i) is not an error */
default:
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->exact_to_inexact_symbol, a_number_string));
}
}
#if WITH_GMP
static s7_pointer big_rationalize(s7_scheme * sc, s7_pointer args);
#endif
static s7_pointer inexact_to_exact(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
case T_BIG_INTEGER:
case T_RATIO:
case T_BIG_RATIO:
return (x);
#if WITH_GMP
case T_BIG_REAL:
return (big_rationalize(sc, set_plist_1(sc, x)));
#endif
case T_REAL:
{
s7_int numer = 0, denom = 1;
s7_double val = real(x);
if ((is_inf(val)) || (is_NaN(val)))
return (simple_wrong_type_argument_with_type
(sc, sc->inexact_to_exact_symbol, x,
a_normal_real_string));
if ((val > DOUBLE_TO_INT64_LIMIT)
|| (val < -(DOUBLE_TO_INT64_LIMIT))) {
#if WITH_GMP
return (big_rationalize(sc, set_plist_1(sc, x))); /* this can handle t_real as well as t_big_real */
#else
return (simple_out_of_range
(sc, sc->inexact_to_exact_symbol, x,
its_too_large_string));
#endif
}
/* c_rationalize limit is RATIONALIZE_LIMIT=1e12 currently so this is a tighter limit than DOUBLE_TO_INT64_LIMIT */
if (c_rationalize
(val, sc->default_rationalize_error, &numer, &denom))
return (make_ratio(sc, numer, denom));
}
default:
return (method_or_bust_one_arg_p
(sc, x, sc->inexact_to_exact_symbol, T_REAL));
}
return (x);
}
#endif
/* this is a mess -- it's too late to clean up s7.h (sigh) */
s7_double s7_number_to_real_with_caller(s7_scheme * sc, s7_pointer x,
const char *caller)
{
if (is_t_real(x))
return (real(x));
switch (type(x)) {
case T_INTEGER:
return ((s7_double) integer(x));
case T_RATIO:
return (fraction(x));
#if WITH_GMP
case T_BIG_INTEGER:
return ((s7_double) big_integer_to_s7_int(sc, big_integer(x)));
case T_BIG_RATIO:
return ((s7_double)
((long_double)
big_integer_to_s7_int(sc,
mpq_numref(big_ratio(x))) /
(long_double) big_integer_to_s7_int(sc,
mpq_denref(big_ratio
(x)))));
case T_BIG_REAL:
return ((s7_double) mpfr_get_d(big_real(x), MPFR_RNDN));
#endif
}
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)
{
if (is_t_integer(x))
return (integer(x));
#if WITH_GMP
if (is_t_big_integer(x))
return (big_integer_to_s7_int(sc, big_integer(x)));
#endif
s7_wrong_type_arg_error(sc, caller, 0, x, "an integer");
return (0);
}
s7_int s7_number_to_integer(s7_scheme * sc, s7_pointer x)
{
return (s7_number_to_integer_with_caller
(sc, x, "s7_number_to_integer"));
}
s7_int s7_numerator(s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (integer(x));
case T_RATIO:
return (numerator(x));
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_get_si(big_integer(x))); /* big_integer_to_s7_int but no sc -- no error if out of range */
case T_BIG_RATIO:
return (mpz_get_si(mpq_numref(big_ratio(x))));
#endif
}
return (0);
}
s7_int s7_denominator(s7_pointer x)
{
if (is_t_ratio(x))
return (denominator(x));
#if WITH_GMP
if (is_t_big_ratio(x))
return (mpz_get_si(mpq_denref(big_ratio(x))));
#endif
return (1);
}
s7_int s7_integer(s7_pointer p)
{
if (is_t_integer(p))
return (integer(p));
#if WITH_GMP
if (is_t_big_integer(p))
return (mpz_get_si(big_integer(p)));
#endif
return (0);
}
s7_double s7_real(s7_pointer x)
{
if (is_t_real(x))
return (real(x));
switch (type(x)) {
case T_RATIO:
return (fraction(x));
case T_INTEGER:
return ((s7_double) integer(x));
#if WITH_GMP
case T_BIG_INTEGER:
return ((s7_double) mpz_get_si(big_integer(x)));
case T_BIG_REAL:
return ((s7_double) mpfr_get_d(big_real(x), MPFR_RNDN));
case T_BIG_RATIO:
{
s7_double result;
mpfr_t bx;
mpfr_init2(bx, DEFAULT_BIGNUM_PRECISION);
mpfr_set_q(bx, big_ratio(x), MPFR_RNDN);
result = mpfr_get_d(bx, MPFR_RNDN);
mpfr_clear(bx);
return (result);
}
#endif
}
return (0.0);
}
static bool is_one(s7_pointer x)
{
return (((is_t_integer(x)) && (integer(x) == 1)) ||
((is_t_real(x)) && (real(x) == 1.0)));
}
/* -------- optimize exponents -------- */
#define MAX_POW 64
static double **pepow = NULL; /* [17][MAX_POW * 2]; */
static void init_pows(void)
{
int32_t i, j;
pepow = (double **) malloc(17 * sizeof(double *));
pepow[0] = NULL;
pepow[1] = NULL;
for (i = 2; i < 17; i++)
pepow[i] = (double *) malloc((MAX_POW * 2) * sizeof(double));
for (i = 2; i < 17; i++) /* radix between 2 and 16 */
for (j = -MAX_POW; j < MAX_POW; j++) /* saved exponent between 0 and +/- MAX_POW */
pepow[i][j + MAX_POW] = pow((double) i, (double) j);
}
static inline double dpow(int32_t x, int32_t y)
{
if ((y >= MAX_POW) || (y < -MAX_POW)) /* this can happen (once in a blue moon) */
return (pow((double) x, (double) y));
return (pepow[x][y + MAX_POW]);
}
/* -------------------------------- number->string -------------------------------- */
#define WITH_DTOA 1
#if WITH_DTOA
/* fpconv, revised to fit the local coding style
The MIT License
Copyright (c) 2013 Andreas Samoljuk
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*/
#define dtoa_npowers 87
#define dtoa_steppowers 8
#define dtoa_firstpower -348 /* 10 ^ -348 */
#define dtoa_expmax -32
#define dtoa_expmin -60
typedef struct dtoa_np {
uint64_t frac;
int exp;
} dtoa_np;
static const dtoa_np dtoa_powers_ten[] = {
{ 18054884314459144840U, -1220 }, { 13451937075301367670U, -1193 },
{ 10022474136428063862U, -1166 }, { 14934650266808366570U, -1140 },
{ 11127181549972568877U, -1113 }, { 16580792590934885855U, -1087 },
{ 12353653155963782858U, -1060 }, { 18408377700990114895U, -1034 },
{ 13715310171984221708U, -1007 }, { 10218702384817765436U, -980 },
{ 15227053142812498563U, -954 }, { 11345038669416679861U, -927 },
{ 16905424996341287883U, -901 }, { 12595523146049147757U, -874 },
{ 9384396036005875287U, -847 }, { 13983839803942852151U, -821 },
{ 10418772551374772303U, -794 }, { 15525180923007089351U, -768 },
{ 11567161174868858868U, -741 }, { 17236413322193710309U, -715 },
{ 12842128665889583758U, -688 }, { 9568131466127621947U, -661 },
{ 14257626930069360058U, -635 }, { 10622759856335341974U, -608 },
{ 15829145694278690180U, -582 }, { 11793632577567316726U, -555 },
{ 17573882009934360870U, -529 }, { 13093562431584567480U, -502 },
{ 9755464219737475723U, -475 }, { 14536774485912137811U, -449 },
{ 10830740992659433045U, -422 }, { 16139061738043178685U, -396 },
{ 12024538023802026127U, -369 }, { 17917957937422433684U, -343 },
{ 13349918974505688015U, -316 }, { 9946464728195732843U, -289 },
{ 14821387422376473014U, -263 }, { 11042794154864902060U, -236 },
{ 16455045573212060422U, -210 }, { 12259964326927110867U, -183 },
{ 18268770466636286478U, -157 }, { 13611294676837538539U, -130 },
{ 10141204801825835212U, -103 }, { 15111572745182864684U, -77 },
{ 11258999068426240000U, -50 }, { 16777216000000000000U, -24 },
{ 12500000000000000000U, 3 }, { 9313225746154785156U, 30 },
{ 13877787807814456755U, 56 }, { 10339757656912845936U, 83 },
{ 15407439555097886824U, 109 }, { 11479437019748901445U, 136 },
{ 17105694144590052135U, 162 }, { 12744735289059618216U, 189 },
{ 9495567745759798747U, 216 }, { 14149498560666738074U, 242 },
{ 10542197943230523224U, 269 }, { 15709099088952724970U, 295 },
{ 11704190886730495818U, 322 }, { 17440603504673385349U, 348 },
{ 12994262207056124023U, 375 }, { 9681479787123295682U, 402 },
{ 14426529090290212157U, 428 }, { 10748601772107342003U, 455 },
{ 16016664761464807395U, 481 }, { 11933345169920330789U, 508 },
{ 17782069995880619868U, 534 }, { 13248674568444952270U, 561 },
{ 9871031767461413346U, 588 }, { 14708983551653345445U, 614 },
{ 10959046745042015199U, 641 }, { 16330252207878254650U, 667 },
{ 12166986024289022870U, 694 }, { 18130221999122236476U, 720 },
{ 13508068024458167312U, 747 }, { 10064294952495520794U, 774 },
{ 14996968138956309548U, 800 }, { 11173611982879273257U, 827 },
{ 16649979327439178909U, 853 }, { 12405201291620119593U, 880 },
{ 9242595204427927429U, 907 }, { 13772540099066387757U, 933 },
{ 10261342003245940623U, 960 }, { 15290591125556738113U, 986 },
{ 11392378155556871081U, 1013 }, { 16975966327722178521U, 1039 },
{ 12648080533535911531U, 1066 }
};
static dtoa_np dtoa_find_cachedpow10(int exp, int *k)
{
int approx, idx;
const double one_log_ten = 0.30102999566398114;
approx = -(exp + dtoa_npowers) * one_log_ten;
idx = (approx - dtoa_firstpower) / dtoa_steppowers;
while (true) {
int current;
current = exp + dtoa_powers_ten[idx].exp + 64;
if (current < dtoa_expmin) {
idx++;
continue;
}
if (current > dtoa_expmax) {
idx--;
continue;
}
*k = (dtoa_firstpower + idx * dtoa_steppowers);
return (dtoa_powers_ten[idx]);
}
}
#define dtoa_fracmask 0x000FFFFFFFFFFFFFU
#define dtoa_expmask 0x7FF0000000000000U
#define dtoa_hiddenbit 0x0010000000000000U
#define dtoa_signmask 0x8000000000000000U
#define dtoa_expbias (1023 + 52)
#define dtoa_absv(n) ((n) < 0 ? -(n) : (n))
#define dtoa_minv(a, b) ((a) < (b) ? (a) : (b))
static uint64_t dtoa_tens[] =
{ 10000000000000000000U, 1000000000000000000U, 100000000000000000U,
10000000000000000U, 1000000000000000U, 100000000000000U,
10000000000000U, 1000000000000U, 100000000000U,
10000000000U, 1000000000U, 100000000U,
10000000U, 1000000U, 100000U,
10000U, 1000U, 100U,
10U, 1U
};
static uint64_t dtoa_get_dbits(double d)
{
union {
double dbl;
uint64_t i;
} dbl_bits = { d };
return (dbl_bits.i);
}
static dtoa_np dtoa_build_np(double d)
{
uint64_t bits;
dtoa_np fp;
bits = dtoa_get_dbits(d);
fp.frac = bits & dtoa_fracmask;
fp.exp = (bits & dtoa_expmask) >> 52;
if (fp.exp) {
fp.frac += dtoa_hiddenbit;
fp.exp -= dtoa_expbias;
} else
fp.exp = -dtoa_expbias + 1;
return (fp);
}
static void dtoa_normalize(dtoa_np * fp)
{
int shift;
while ((fp->frac & dtoa_hiddenbit) == 0) {
fp->frac <<= 1;
fp->exp--;
}
shift = 64 - 52 - 1;
fp->frac <<= shift;
fp->exp -= shift;
}
static void dtoa_get_normalized_boundaries(dtoa_np * fp, dtoa_np * lower,
dtoa_np * upper)
{
int u_shift, l_shift;
upper->frac = (fp->frac << 1) + 1;
upper->exp = fp->exp - 1;
while ((upper->frac & (dtoa_hiddenbit << 1)) == 0) {
upper->frac <<= 1;
upper->exp--;
}
u_shift = 64 - 52 - 2;
upper->frac <<= u_shift;
upper->exp = upper->exp - u_shift;
l_shift = fp->frac == dtoa_hiddenbit ? 2 : 1;
lower->frac = (fp->frac << l_shift) - 1;
lower->exp = fp->exp - l_shift;
lower->frac <<= lower->exp - upper->exp;
lower->exp = upper->exp;
}
static dtoa_np dtoa_multiply(dtoa_np * a, dtoa_np * b)
{
dtoa_np fp;
uint64_t ah_bl, al_bh, al_bl, ah_bh, tmp;
const uint64_t lomask = 0x00000000FFFFFFFF;
ah_bl = (a->frac >> 32) * (b->frac & lomask);
al_bh = (a->frac & lomask) * (b->frac >> 32);
al_bl = (a->frac & lomask) * (b->frac & lomask);
ah_bh = (a->frac >> 32) * (b->frac >> 32);
tmp = (ah_bl & lomask) + (al_bh & lomask) + (al_bl >> 32);
/* round up */
tmp += 1U << 31;
fp.frac = ah_bh + (ah_bl >> 32) + (al_bh >> 32) + (tmp >> 32);
fp.exp = a->exp + b->exp + 64;
return (fp);
}
static void dtoa_round_digit(char *digits, int ndigits, uint64_t delta,
uint64_t rem, uint64_t kappa, uint64_t frac)
{
while ((rem < frac) && (delta - rem >= kappa) &&
((rem + kappa < frac) || (frac - rem > rem + kappa - frac))) {
digits[ndigits - 1]--;
rem += kappa;
}
}
static int dtoa_generate_digits(dtoa_np * fp, dtoa_np * upper,
dtoa_np * lower, char *digits, int *K)
{
uint64_t part1, part2, wfrac, delta;
uint64_t *divp, *unit;
int idx, kappa;
dtoa_np one;
wfrac = upper->frac - fp->frac;
delta = upper->frac - lower->frac;
one.frac = 1ULL << -upper->exp;
one.exp = upper->exp;
part1 = upper->frac >> -one.exp;
part2 = upper->frac & (one.frac - 1);
idx = 0;
kappa = 10;
/* 1000000000 */
for (divp = dtoa_tens + 10; kappa > 0; divp++) {
uint64_t tmp, div;
unsigned digit;
div = *divp;
digit = part1 / div;
if (digit || idx)
digits[idx++] = digit + '0';
part1 -= digit * div;
kappa--;
tmp = (part1 << -one.exp) + part2;
if (tmp <= delta) {
*K += kappa;
dtoa_round_digit(digits, idx, delta, tmp, div << -one.exp,
wfrac);
return (idx);
}
}
/* 10 */
unit = dtoa_tens + 18;
while (true) {
unsigned digit;
part2 *= 10;
delta *= 10;
kappa--;
digit = part2 >> -one.exp;
if (digit || idx)
digits[idx++] = digit + '0';
part2 &= one.frac - 1;
if (part2 < delta) {
*K += kappa;
dtoa_round_digit(digits, idx, delta, part2, one.frac,
wfrac * *unit);
return (idx);
}
unit--;
}
}
static int dtoa_grisu2(double d, char *digits, int *K)
{
int k;
dtoa_np cp, w, lower, upper;
w = dtoa_build_np(d);
dtoa_get_normalized_boundaries(&w, &lower, &upper);
dtoa_normalize(&w);
cp = dtoa_find_cachedpow10(upper.exp, &k);
w = dtoa_multiply(&w, &cp);
upper = dtoa_multiply(&upper, &cp);
lower = dtoa_multiply(&lower, &cp);
lower.frac++;
upper.frac--;
*K = -k;
return (dtoa_generate_digits(&w, &upper, &lower, digits, K));
}
static int dtoa_emit_digits(char *digits, int ndigits, char *dest, int K,
bool neg)
{
int exp, idx, cent;
char sign;
exp = dtoa_absv(K + ndigits - 1);
/* write plain integer */
if ((K >= 0) && (exp < (ndigits + 7))) {
memcpy(dest, digits, ndigits);
memset(dest + ndigits, '0', K);
dest[ndigits + K] = '.';
dest[ndigits + K + 1] = '0';
return (ndigits + K + 2);
}
/* write decimal w/o scientific notation */
if ((K < 0) && (K > -7 || exp < 4)) {
int offset;
offset = ndigits - dtoa_absv(K);
/* fp < 1.0 -> write leading zero */
if (offset <= 0) {
offset = -offset;
dest[0] = '0';
dest[1] = '.';
memset(dest + 2, '0', offset);
memcpy(dest + offset + 2, digits, ndigits);
return (ndigits + 2 + offset);
/* fp > 1.0 */
} else {
memcpy(dest, digits, offset);
dest[offset] = '.';
memcpy(dest + offset + 1, digits + offset, ndigits - offset);
return (ndigits + 1);
}
}
/* write decimal w/ scientific notation */
ndigits = dtoa_minv(ndigits, 18 - neg);
idx = 0;
dest[idx++] = digits[0];
if (ndigits > 1) {
dest[idx++] = '.';
memcpy(dest + idx, digits + 1, ndigits - 1);
idx += ndigits - 1;
}
dest[idx++] = 'e';
sign = K + ndigits - 1 < 0 ? '-' : '+';
dest[idx++] = sign;
cent = 0;
if (exp > 99) {
cent = exp / 100;
dest[idx++] = cent + '0';
exp -= cent * 100;
}
if (exp > 9) {
int dec;
dec = exp / 10;
dest[idx++] = dec + '0';
exp -= dec * 10;
} else if (cent)
dest[idx++] = '0';
dest[idx++] = exp % 10 + '0';
return (idx);
}
static int dtoa_filter_special(double fp, char *dest, bool neg)
{
uint64_t bits;
bool nan;
if (fp == 0.0) {
dest[0] = '0';
dest[1] = '.';
dest[2] = '0';
return (3);
}
bits = dtoa_get_dbits(fp);
nan = (bits & dtoa_expmask) == dtoa_expmask;
if (!nan)
return (0);
if (!neg) {
dest[0] = '+';
dest++;
}
if (bits & dtoa_fracmask) {
dest[0] = 'n';
dest[1] = 'a';
dest[2] = 'n';
dest[3] = '.';
dest[4] = '0';
} else {
dest[0] = 'i';
dest[1] = 'n';
dest[2] = 'f';
dest[3] = '.';
dest[4] = '0';
}
return ((neg) ? 5 : 6);
}
static inline int fpconv_dtoa(double d, char dest[24])
{
char digit[18];
int str_len = 0, spec, K, ndigits;
bool neg = false;
if (dtoa_get_dbits(d) & dtoa_signmask) {
dest[0] = '-';
str_len++;
neg = true;
}
spec = dtoa_filter_special(d, dest + str_len, neg);
if (spec)
return (str_len + spec);
K = 0;
ndigits = dtoa_grisu2(d, digit, &K);
str_len += dtoa_emit_digits(digit, ndigits, dest + str_len, K, neg);
return (str_len);
}
#endif
/* -------------------------------- number->string -------------------------------- */
static const char dignum[] = "0123456789abcdef";
static size_t integer_to_string_any_base(char *p, s7_int n, int32_t radix)
{ /* called by number_to_string_with_radix */
s7_int i, len, end;
bool sign;
s7_int pown;
if ((radix < 2) || (radix > 16))
return (0);
if (n == S7_INT64_MIN) { /* can't negate this, so do it by hand */
static const char *mnfs[17] = { "", "",
"-1000000000000000000000000000000000000000000000000000000000000000",
"-2021110011022210012102010021220101220222",
"-20000000000000000000000000000000",
"-1104332401304422434310311213",
"-1540241003031030222122212",
"-22341010611245052052301", "-1000000000000000000000",
"-67404283172107811828", "-9223372036854775808",
"-1728002635214590698", "-41a792678515120368",
"-10b269549075433c38", "-4340724c6c71dc7a8",
"-160e2ad3246366808", "-8000000000000000"
};
len = safe_strlen(mnfs[radix]);
memcpy((void *) p, (void *) mnfs[radix], len);
p[len] = '\0';
return (len);
}
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 (sign) {
p[0] = '-';
end++;
}
for (i = len; i >= end; i--) {
p[i] = dignum[n % radix];
n /= radix;
}
p[len + 1] = '\0';
return (len + 1);
}
static char *integer_to_string(s7_scheme * sc, s7_int num, s7_int * nlen)
{ /* do not free the returned string */
char *p, *op;
bool sign;
if (num == S7_INT64_MIN) {
(*nlen) = 20;
return ((char *) "-9223372036854775808");
}
p = (char *) (sc->int_to_str1 + 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);
}
static char *integer_to_string_no_length(s7_scheme * sc, s7_int num)
{ /* do not free the returned string */
char *p;
bool sign;
if (num == S7_INT64_MIN)
return ((char *) "-9223372036854775808");
p = (char *) (sc->int_to_str2 + INT_TO_STR_SIZE - 1);
*p-- = '\0';
sign = (num < 0);
if (sign)
num = -num;
do {
*p-- = "0123456789"[num % 10];
num /= 10;
} while (num);
if (sign) {
*p = '-';
return (p);
}
return (++p);
}
static inline char *floatify(char *str, s7_int * nlen)
{
if ((!strchr(str, '.')) && (!strchr(str, 'e'))) { /* faster than (strcspn(str, ".e") >= (size_t)(*nlen)) */
s7_int len = *nlen;
/* snprintf returns "nan" and "inf" but we (stupidly) want "+nan.0" and "+inf.0"; "-nan" and "-inf" will be handled by the normal case */
if (len == 3) {
if (str[0] == 'n') {
str[0] = '+';
str[1] = 'n';
str[2] = 'a';
str[3] = 'n';
len = 4;
}
if (str[0] == 'i') {
str[0] = '+';
str[1] = 'i';
str[2] = 'n';
str[3] = 'f';
len = 4;
}
}
str[len] = '.';
str[len + 1] = '0';
str[len + 2] = '\0';
(*nlen) = len + 2;
}
return (str);
}
static void insert_spaces(s7_scheme * sc, char *src, s7_int width,
s7_int len)
{
s7_int spaces;
if (width >= sc->num_to_str_size) {
sc->num_to_str_size = width + 1;
sc->num_to_str =
(char *) Realloc(sc->num_to_str, sc->num_to_str_size);
}
spaces = width - len;
sc->num_to_str[width] = '\0';
memmove((void *) (sc->num_to_str + spaces), (void *) src, len);
memset((void *) (sc->num_to_str), (int) ' ', spaces);
}
static char *number_to_string_base_10(s7_scheme * sc, s7_pointer obj,
s7_int width, s7_int precision,
char float_choice, s7_int * nlen,
use_write_t choice)
{ /* don't free result */
/* called by number_to_string_with_radix g_number_to_string, number_to_string_p_p number_to_port format_number */
/* the rest of s7 assumes nlen is set to the correct length
* a tricky case: (format #f "~f" 1e308) -- tries to print 308 digits! so 256 as default len is too small.
* but then even worse: (format #f "~F" 1e308+1e308i)!
*/
s7_int len;
len = width + precision;
len = (len > 512) ? (512 + 2 * len) : 1024;
if (len > sc->num_to_str_size) {
sc->num_to_str =
(sc->num_to_str) ? (char *) Realloc(sc->num_to_str,
len) : (char *)
Malloc(len);
sc->num_to_str_size = len;
}
/* bignums can't happen here */
if (is_t_integer(obj)) {
char *p;
if (width == 0) {
if (has_number_name(obj)) {
(*nlen) = number_name_length(obj);
return ((char *) number_name(obj));
}
return (integer_to_string(sc, integer(obj), nlen));
}
p = integer_to_string(sc, integer(obj), &len);
if (width > len) {
insert_spaces(sc, p, width, len);
(*nlen) = width;
return (sc->num_to_str);
}
(*nlen) = len;
return (p);
}
if (is_t_real(obj)) {
if (width == 0) {
#if WITH_DTOA
if ((float_choice == 'g') &&
(precision == WRITE_REAL_PRECISION)) {
/* (number->string 0.0000001) is sensitive to (*s7* 'float-format-precision) and inconsistent: either 1e-7 or 0.0000001
* because fpconv_dtoa has some complicated decision about 'g' vs 'f' -- not sure if this is a bug.
*/
len = fpconv_dtoa(real(obj), sc->num_to_str);
sc->num_to_str[len] = '\0';
(*nlen) = len;
return (sc->num_to_str);
}
#endif
len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, (float_choice == 'g') ? "%.*g" : ((float_choice == 'f') ? "%.*f" : "%.*e"), (int32_t) precision, real(obj)); /* -4 for floatify */
} else
len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, (float_choice == 'g') ? "%*.*g" : ((float_choice == 'f') ? "%*.*f" : "%*.*e"), (int32_t) width, (int32_t) precision, real(obj)); /* -4 for floatify */
(*nlen) = len;
floatify(sc->num_to_str, nlen);
return (sc->num_to_str);
}
if (is_t_complex(obj)) {
char *imag;
sc->num_to_str[0] = '\0';
real(sc->real_wrapper4) = imag_part(obj);
imag =
copy_string(number_to_string_base_10
(sc, sc->real_wrapper4, 0, precision, float_choice,
&len, choice));
sc->num_to_str[0] = '\0';
real(sc->real_wrapper3) = real_part(obj);
number_to_string_base_10(sc, sc->real_wrapper3, 0, precision,
float_choice, &len, choice);
sc->num_to_str[len] = '\0';
len =
catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+')
|| (imag[0] ==
'-')) ? "" :
"+", imag, "i", (char *) NULL);
free(imag);
if (width > len) { /* (format #f "~20g" 1+i) */
insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */
(*nlen) = width;
} else
(*nlen) = len;
return (sc->num_to_str);
}
/* ratio */
len =
catstrs_direct(sc->num_to_str,
integer_to_string_no_length(sc, numerator(obj)),
"/", pos_int_to_str_direct(sc, denominator(obj)),
(const char *) NULL);
if (width > len) {
insert_spaces(sc, sc->num_to_str, width, len);
(*nlen) = width;
} else
(*nlen) = len;
return (sc->num_to_str);
}
static block_t *number_to_string_with_radix(s7_scheme * sc, s7_pointer obj,
int32_t radix, s7_int width,
s7_int precision,
char float_choice,
s7_int * nlen)
{
/* called by s7_number_to_string (char*), g_number_to_string (strp), number_to_string_p_pp (strp), format_number (strp basically) */
/* the rest of s7 assumes nlen is set to the correct length */
block_t *b;
char *p;
s7_int len, str_len;
#if WITH_GMP
if (s7_is_bignum(obj))
return (big_number_to_string_with_radix
(sc, obj, radix, width, nlen, P_WRITE));
/* this ignores precision because it's way too hard to get the mpfr string to look like
* C's output -- we either have to call mpfr_get_str twice (the first time just to
* find out what the exponent is and how long the string actually is), or we have
* to do messy string manipulations. So (format #f "",3F" pi) ignores the "3" and
* prints the full string. And don't even think about mpfr_snprintf!
*/
#endif
if (radix == 10) {
p = number_to_string_base_10(sc, obj, width, precision,
float_choice, nlen, P_WRITE);
return (string_to_block(sc, p, *nlen));
}
switch (type(obj)) {
case T_INTEGER:
{
size_t len1;
b = mallocate(sc, (128 + width));
p = (char *) block_data(b);
len1 = integer_to_string_any_base(p, integer(obj), radix);
if ((size_t) width > len1) {
size_t start;
start = width - len1;
memmove((void *) (p + start), (void *) p, len1);
memset((void *) p, (int) ' ', start);
p[width] = '\0';
*nlen = width;
} else
*nlen = len1;
return (b);
}
case T_RATIO:
{
size_t len1, len2;
str_len = 256 + width;
b = mallocate(sc, str_len);
p = (char *) block_data(b);
len1 = integer_to_string_any_base(p, numerator(obj), radix);
p[len1] = '/';
len2 =
integer_to_string_any_base((char *) (p + len1 + 1),
denominator(obj), radix);
len = len1 + 1 + len2;
p[len] = '\0';
}
break;
case T_REAL:
{
int32_t i;
s7_int int_part, nsize;
s7_double x = real(obj), frac_part, min_frac, base;
bool sign = false;
char n[128], d[256];
if (is_NaN(x))
return (string_to_block(sc, "+nan.0", *nlen = 6));
if (is_inf(x)) {
if (x < 0.0)
return (string_to_block(sc, "-inf.0", *nlen = 6));
return (string_to_block(sc, "+inf.0", *nlen = 6));
}
if (x < 0.0) {
sign = true;
x = -x;
}
if (x > 1.0e18) { /* i.e. close to or greater than most-positive-fixnum (9.22e18), so the code below is unlikely to work, (format #f "~X" 1e19) */
int32_t ep;
block_t *b1;
len = 0;
ep = (int32_t) floor(log(x) / log((double) radix));
real(sc->real_wrapper3) = x / pow((double) radix, (double) ep); /* divide it down to one digit, then the fractional part */
b = number_to_string_with_radix(sc, sc->real_wrapper3,
radix, width, precision,
float_choice, &len);
b1 = mallocate(sc, len + 8);
p = (char *) block_data(b1);
p[0] = '\0';
(*nlen) =
catstrs(p, len + 8, (sign) ? "-" : "",
(char *) block_data(b),
(radix == 16) ? "@" : "e",
integer_to_string_no_length(sc, ep),
(char *) NULL);
liberate(sc, b);
return (b1);
}
int_part = (s7_int) floor(x);
frac_part = x - int_part;
nsize = integer_to_string_any_base(n, int_part, radix);
min_frac = dpow(radix, -precision);
/* doesn't this assume precision < 128/256 and that we can fit in 256 digits (1e308)? */
for (i = 0, base = radix;
(i < precision) && (frac_part > min_frac);
i++, base *= radix) {
s7_int ipart;
ipart = (s7_int) (frac_part * base);
if (ipart >= radix) /* rounding confusion */
ipart = radix - 1;
frac_part -= (ipart / base);
/* d[i] = ((const char *)"0123456789abcdef")[ipart]; */
d[i] = dignum[ipart];
}
if (i == 0)
d[i++] = '0';
d[i] = '\0';
b = mallocate(sc, 256);
p = (char *) block_data(b);
/* much faster than catstrs because we know the string lengths */
{
char *pt = p;
if (sign) {
pt[0] = '-';
pt++;
}
memcpy(pt, n, nsize);
pt += nsize;
pt[0] = '.';
pt++;
memcpy(pt, d, i);
pt[i] = '\0';
/* len = ((sign) ? 1 : 0) + 1 + nsize + i; */
len = pt + i - p;
}
str_len = 256;
}
break;
default:
{
block_t *n, *d;
char *dp, *pt;
s7_int real_len = 0, imag_len = 0;
real(sc->real_wrapper3) = real_part(obj);
n = number_to_string_with_radix(sc, sc->real_wrapper3, radix, 0, precision, float_choice, &real_len); /* include floatify */
real(sc->real_wrapper4) = imag_part(obj);
d = number_to_string_with_radix(sc, sc->real_wrapper4, radix,
0, precision, float_choice,
&imag_len);
dp = (char *) block_data(d);
b = mallocate(sc, 512);
p = (char *) block_data(b);
pt = p;
memcpy(pt, (void *) block_data(n), real_len);
pt += real_len;
if ((dp[0] != '+') && (dp[0] != '-')) {
pt[0] = '+';
pt++;
}
memcpy(pt, dp, imag_len);
pt[imag_len] = 'i';
pt[imag_len + 1] = '\0';
len = pt + imag_len + 1 - p;
str_len = 512;
liberate(sc, n);
liberate(sc, d);
}
break;
}
if (width > len) {
s7_int spaces;
if (width >= str_len) {
str_len = width + 1;
b = reallocate(sc, b, str_len);
p = (char *) block_data(b);
}
spaces = width - len;
p[width] = '\0';
memmove((void *) (p + spaces), (void *) p, len);
memset((void *) p, (int) ' ', spaces);
(*nlen) = width;
} else
(*nlen) = len;
return (b);
}
char *s7_number_to_string(s7_scheme * sc, s7_pointer obj, s7_int radix)
{
s7_int nlen = 0;
block_t *b;
char *str;
b = number_to_string_with_radix(sc, obj, radix, 0, 20, 'g', &nlen); /* (log top 10) so we get all the digits in base 10 (??) */
str = copy_string_with_length((char *) block_data(b), nlen);
liberate(sc, b);
return (str);
}
static s7_pointer g_number_to_string(s7_scheme * sc, s7_pointer args)
{
#define H_number_to_string "(number->string num (radix 10)) converts the number num into a string."
#define Q_number_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_number_symbol, sc->is_integer_symbol)
s7_int nlen = 0, radix; /* ignore cppcheck complaint about radix! */
char *res;
s7_pointer x = car(args);
if (!is_number(x))
return (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 = cadr(args);
if (s7_is_integer(y))
radix = s7_integer_checked(sc, y);
else
return (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, int_two, y,
a_valid_radix_string));
#if (WITH_GMP)
if (!s7_is_bignum(x))
#endif
{
block_t *b;
b = number_to_string_with_radix(sc, x, radix, 0,
sc->float_format_precision,
'g', &nlen);
return (block_to_string(sc, b, nlen));
}
}
#if WITH_GMP
else
radix = 10;
if (s7_is_bignum(x)) {
block_t *b;
b = big_number_to_string_with_radix(sc, x, radix, 0, &nlen,
P_WRITE);
return (block_to_string(sc, b, nlen));
}
res =
number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g',
&nlen, P_WRITE);
#else
if (is_t_integer(x)) {
if (has_number_name(x)) {
nlen = number_name_length(x);
res = (char *) number_name(x);
} else
res = integer_to_string(sc, integer(x), &nlen);
} else
res =
number_to_string_base_10(sc, x, 0, sc->float_format_precision,
'g', &nlen, P_WRITE);
#endif
return (inline_make_string_with_length(sc, res, nlen));
}
static s7_pointer number_to_string_p_p(s7_scheme * sc, s7_pointer p)
{
#if WITH_GMP
return (g_number_to_string(sc, set_plist_1(sc, p)));
#else
s7_int nlen = 0;
char *res;
if (!is_number(p))
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->number_to_string_symbol, a_number_string));
res =
number_to_string_base_10(sc, p, 0, sc->float_format_precision, 'g',
&nlen, P_WRITE);
return (inline_make_string_with_length(sc, res, nlen));
#endif
}
static s7_pointer number_to_string_p_i(s7_scheme * sc, s7_int p)
{
s7_int nlen = 0;
char *res;
res = integer_to_string(sc, p, &nlen);
return (inline_make_string_with_length(sc, res, nlen));
}
/* not number_to_string_p_d! */
static s7_pointer number_to_string_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
#if WITH_GMP
return (g_number_to_string(sc, set_plist_2(sc, p1, p2)));
#else
s7_int nlen = 0, radix;
block_t *b;
if (!is_number(p1))
return (wrong_type_argument_with_type
(sc, sc->number_to_string_symbol, 1, p1, a_number_string));
if (!is_t_integer(p2))
return (wrong_type_argument
(sc, sc->number_to_string_symbol, 2, p2, T_INTEGER));
radix = integer(p2);
if ((radix < 2) || (radix > 16))
return (out_of_range
(sc, sc->number_to_string_symbol, int_two, p2,
a_valid_radix_string));
b = number_to_string_with_radix(sc, p1, radix, 0,
sc->float_format_precision, 'g',
&nlen);
return (block_to_string(sc, b, nlen));
#endif
}
/* -------------------------------------------------------------------------------- */
#define CTABLE_SIZE 256
static bool *exponent_table, *slashify_table, *char_ok_in_a_name,
*white_space, *number_table, *symbol_slashify_table;
static int32_t *digits;
static void init_ctables(void)
{
int32_t 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));
digits = (int32_t *) calloc(CTABLE_SIZE, sizeof(int32_t));
for (i = 0; i < CTABLE_SIZE; i++) {
char_ok_in_a_name[i] = true;
white_space[i] = false;
digits[i] = 256;
number_table[i] = false;
}
char_ok_in_a_name[0] = false;
char_ok_in_a_name[(uint8_t) '('] = false; /* cast for C++ */
char_ok_in_a_name[(uint8_t) ')'] = false;
char_ok_in_a_name[(uint8_t) ';'] = false;
char_ok_in_a_name[(uint8_t) '\t'] = false;
char_ok_in_a_name[(uint8_t) '\n'] = false;
char_ok_in_a_name[(uint8_t) '\r'] = false;
char_ok_in_a_name[(uint8_t) ' '] = false;
char_ok_in_a_name[(uint8_t) '"'] = false;
white_space[(uint8_t) '\t'] = true;
white_space[(uint8_t) '\n'] = true;
white_space[(uint8_t) '\r'] = true;
white_space[(uint8_t) '\f'] = true;
white_space[(uint8_t) '\v'] = true;
white_space[(uint8_t) ' '] = true;
white_space[(uint8_t) '\205'] = true; /* 133 */
white_space[(uint8_t) '\240'] = true; /* 160 */
/* surely only 'e' is needed... */
exponent_table[(uint8_t) 'e'] = true;
exponent_table[(uint8_t) 'E'] = true;
exponent_table[(uint8_t) '@'] = true;
#if WITH_EXTRA_EXPONENT_MARKERS
exponent_table[(uint8_t) 's'] = true;
exponent_table[(uint8_t) 'S'] = true;
exponent_table[(uint8_t) 'f'] = true;
exponent_table[(uint8_t) 'F'] = true;
exponent_table[(uint8_t) 'd'] = true;
exponent_table[(uint8_t) 'D'] = true;
exponent_table[(uint8_t) 'l'] = true;
exponent_table[(uint8_t) 'L'] = true;
#endif
for (i = 0; i < 32; i++)
slashify_table[i] = true;
for (i = 127; i < 160; i++)
slashify_table[i] = true;
slashify_table[(uint8_t) '\\'] = true;
slashify_table[(uint8_t) '"'] = true;
slashify_table[(uint8_t) '\n'] = false;
for (i = 0; i < CTABLE_SIZE; i++)
symbol_slashify_table[i] = ((slashify_table[i]) || (!char_ok_in_a_name[i])); /* force use of (symbol ...) for cases like '(ab) as symbol */
digits[(uint8_t) '0'] = 0;
digits[(uint8_t) '1'] = 1;
digits[(uint8_t) '2'] = 2;
digits[(uint8_t) '3'] = 3;
digits[(uint8_t) '4'] = 4;
digits[(uint8_t) '5'] = 5;
digits[(uint8_t) '6'] = 6;
digits[(uint8_t) '7'] = 7;
digits[(uint8_t) '8'] = 8;
digits[(uint8_t) '9'] = 9;
digits[(uint8_t) 'a'] = 10;
digits[(uint8_t) 'A'] = 10;
digits[(uint8_t) 'b'] = 11;
digits[(uint8_t) 'B'] = 11;
digits[(uint8_t) 'c'] = 12;
digits[(uint8_t) 'C'] = 12;
digits[(uint8_t) 'd'] = 13;
digits[(uint8_t) 'D'] = 13;
digits[(uint8_t) 'e'] = 14;
digits[(uint8_t) 'E'] = 14;
digits[(uint8_t) 'f'] = 15;
digits[(uint8_t) 'F'] = 15;
number_table[(uint8_t) '0'] = true;
number_table[(uint8_t) '1'] = true;
number_table[(uint8_t) '2'] = true;
number_table[(uint8_t) '3'] = true;
number_table[(uint8_t) '4'] = true;
number_table[(uint8_t) '5'] = true;
number_table[(uint8_t) '6'] = true;
number_table[(uint8_t) '7'] = true;
number_table[(uint8_t) '8'] = true;
number_table[(uint8_t) '9'] = true;
number_table[(uint8_t) '.'] = true;
number_table[(uint8_t) '+'] = true;
number_table[(uint8_t) '-'] = true;
number_table[(uint8_t) '#'] = true;
}
#define is_white_space(C) white_space[C]
/* this is much faster than C's isspace, and does not depend on the current locale.
* if c == EOF (-1), it indexes into the empty (0) slot we preallocated below white_space
*/
/* -------------------------------- *#readers* -------------------------------- */
static s7_pointer check_sharp_readers(s7_scheme * sc, const char *name)
{
s7_pointer reader, value = sc->F, args = sc->F;
bool need_loader_port;
/* *#reader* is assumed to be an alist of (char . proc)
* where each proc takes one argument, the string from just beyond the "#" to the next delimiter.
* The procedure can call read-char to read ahead in the current-input-port.
* If it returns anything other than #f, that is the value of the sharp expression.
* Since #f means "nothing found", it is tricky to handle #F:
* (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) ; or ''#f used in lint.scm
* This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback. Added #_ later)
*/
need_loader_port = is_loader_port(current_input_port(sc));
if (need_loader_port)
clear_loader_port(current_input_port(sc));
/* normally read* can't read from current_input_port(sc) if it is in use by the loader, but here we are deliberately making that possible. */
for (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 = set_plist_1(sc, s7_make_string_wrapper(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(current_input_port(sc));
return (value);
}
static s7_pointer g_sharp_readers_set(s7_scheme * sc, s7_pointer args)
{
/* new value must be either () or a proper list of conses (char . func) */
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))) ||
(!is_character(caar(x))) || (!is_procedure(cdar(x))))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"can't set *#readers* to ~S",
26), cadr(args))));
if (is_null(x))
return (cadr(args));
}
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't set *#readers* to ~S", 26),
cadr(args))));
}
static s7_pointer make_undefined(s7_scheme * sc, const char *name)
{
s7_pointer p;
char *newstr;
s7_int len;
new_cell(sc, p, T_UNDEFINED | T_IMMUTABLE);
len = safe_strlen(name);
newstr = (char *) Malloc(len + 2);
newstr[0] = '#';
if (len > 0)
memcpy((void *) (newstr + 1), (void *) name, len);
newstr[len + 1] = '\0';
if (sc->undefined_constant_warnings)
s7_warn(sc, len + 32, "%s is undefined\n", newstr);
undefined_set_name_length(p, len + 1);
undefined_name(p) = newstr;
add_undefined(sc, p);
return (p);
}
static int32_t inchar(s7_pointer pt)
{
int32_t c;
if (is_file_port(pt))
c = fgetc(port_file(pt)); /* not uint8_t! -- could be EOF */
else {
if (port_data_size(pt) <= port_position(pt))
return (EOF);
c = (uint8_t) 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)--;
}
static void resize_strbuf(s7_scheme * sc, s7_int needed_size)
{
s7_int i, old_size = sc->strbuf_size;
while (sc->strbuf_size <= needed_size)
sc->strbuf_size *= 2;
sc->strbuf = (char *) Realloc(sc->strbuf, sc->strbuf_size);
for (i = old_size; i < sc->strbuf_size; i++)
sc->strbuf[i] = '\0';
}
static s7_pointer *chars;
static s7_pointer unknown_sharp_constant(s7_scheme * sc, char *name,
s7_pointer pt)
{
if (hook_has_functions(sc->read_error_hook)) { /* check *read-error-hook* */
s7_pointer result;
bool old_history_enabled;
old_history_enabled = s7_set_history_enabled(sc, false);
/* see sc->error_hook for a more robust way to handle this */
result =
s7_call(sc, sc->read_error_hook,
set_plist_2(sc, sc->T,
s7_make_string_wrapper(sc, name)));
s7_set_history_enabled(sc, old_history_enabled);
if (result != sc->unspecified)
return (result);
}
if (pt) { /* #<"..."> which gets here as name="#<" */
s7_int len;
len = safe_strlen(name);
if ((name[len - 1] != '>') &&
(is_input_port(pt)) && (pt != sc->standard_input)) {
if (s7_peek_char(sc, pt) != chars[(uint8_t) '"']) /* if not #<"...">, just return it */
return (make_undefined(sc, name));
if (is_string_port(pt)) { /* probably unnecessary (see below) */
s7_int added_len, c;
const char *pstart, *p;
char *buf;
s7_pointer res;
c = inchar(pt);
pstart =
(const char *) (port_data(pt) + port_position(pt));
p = strchr(pstart, (int) '"');
if (!p) {
backchar(c, pt);
return (make_undefined(sc, name));
}
p++;
while (char_ok_in_a_name[(uint8_t) (*p)]) {
p++;
}
added_len = (s7_int) (p - pstart); /* p is one past '>' presumably */
/* we can't use strbuf here -- it might be the source of the "name" argument! */
buf = (char *) malloc(len + added_len + 2);
memcpy((void *) buf, (void *) name, len);
buf[len] = '"'; /* from inchar */
memcpy((void *) (buf + len + 1), (void *) pstart,
added_len);
buf[len + added_len + 1] = 0;
port_position(pt) += added_len;
res = make_undefined(sc, (const char *) buf);
free(buf);
return (res);
}
}
}
return (make_undefined(sc, name));
}
static s7_pointer make_atom(s7_scheme * sc, char *q, int32_t radix,
bool want_symbol, bool with_error);
#define SYMBOL_OK true
#define NO_SYMBOLS false
static s7_pointer make_sharp_constant(s7_scheme * sc, char *name,
bool with_error, s7_pointer pt,
bool error_if_bad_number)
{
/* name is the stuff after the '#', return sc->nil if not a recognized #... entity */
/* stupid r7rs special cases */
if ((name[0] == 't') &&
((name[1] == '\0') || (c_strings_are_equal(name, "true"))))
return (sc->T);
if ((name[0] == 'f') &&
((name[1] == '\0') || (c_strings_are_equal(name, "false"))))
return (sc->F);
if (name[0] == '_') {
/* this needs to be unsettable via *#readers*:
* (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1))))))
* (let ((+ -)) (#_+ 1 2)): -1
*/
s7_pointer sym;
sym = make_symbol(sc, (char *) (name + 1));
if ((!is_gensym(sym)) && (is_slot(initial_slot(sym))))
return (initial_value(sym));
/* here we should not necessarily raise an error that *_... is undefined. reader-cond, for example, needs to
* read undefined #_ vals that it will eventually discard.
*/
return (make_undefined(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */
}
if (is_not_null(slot_value(sc->sharp_readers))) {
s7_pointer x;
x = check_sharp_readers(sc, name);
if (x != sc->F)
return (x);
}
if ((name[0] == '\0') || name[1] == '\0')
return (unknown_sharp_constant(sc, name, pt)); /* pt here because #<"..."> comes here as "<" so name[1] is '\0'! */
switch (name[0]) {
/* -------- #< ... > -------- */
case '<':
if (c_strings_are_equal(name, "<unspecified>"))
return (sc->unspecified);
if (c_strings_are_equal(name, "<undefined>"))
return (sc->undefined);
if (c_strings_are_equal(name, "<eof>"))
return (eof_object);
return (unknown_sharp_constant(sc, name, pt));
/* -------- #o #x #b -------- */
case 'o': /* #o (octal) */
case 'x': /* #x (hex) */
case 'b': /* #b (binary) */
{
s7_pointer res;
res =
make_atom(sc, (char *) (name + 1),
(name[0] ==
'o') ? 8 : ((name[0] == 'x') ? 16 : 2),
NO_SYMBOLS, with_error);
if ((error_if_bad_number) && (res == sc->F)) { /* #b32 etc but not if called from string->number */
char buf[256];
size_t len;
len = snprintf(buf, 256, "#%s is not a number", name);
s7_error(sc, sc->read_error_symbol, set_elist_1(sc, s7_make_string_with_length(sc, buf, len))); /* can't use wrap_string here (buf is local) */
}
return (res);
}
/* -------- #\... -------- */
case '\\':
if (name[2] == 0) /* the most common case: #\a */
return (chars[(uint8_t) (name[1])]);
/* not uint32_t here! (uint32_t)255 (as a char) returns -1!! */
switch (name[1]) {
case 'n':
if ((c_strings_are_equal(name + 1, "null")) ||
(c_strings_are_equal(name + 1, "nul")))
return (chars[0]);
if (c_strings_are_equal(name + 1, "newline"))
return (chars[(uint8_t) '\n']);
break;
case 's':
if (c_strings_are_equal(name + 1, "space"))
return (chars[(uint8_t) ' ']);
break;
case 'r':
if (c_strings_are_equal(name + 1, "return"))
return (chars[(uint8_t) '\r']);
break;
case 'l':
if (c_strings_are_equal(name + 1, "linefeed"))
return (chars[(uint8_t) '\n']);
break;
case 't':
if (c_strings_are_equal(name + 1, "tab"))
return (chars[(uint8_t) '\t']);
break;
case 'a':
if (c_strings_are_equal(name + 1, "alarm"))
return (chars[7]);
break;
case 'b':
if (c_strings_are_equal(name + 1, "backspace"))
return (chars[8]);
break;
case 'e':
if (c_strings_are_equal(name + 1, "escape"))
return (chars[0x1b]);
break;
case 'd':
if (c_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, and #\xcebb is lambda? */
{
/* sscanf here misses errors like #\x1.4, but make_atom misses #\x6/3,
* #\x#b0, #\x#e0.0, #\x-0, #\x#e0e100 etc, so we have to do it at an even lower level.
* another problem: #\xbdca2cbec overflows so lval is -593310740 -> segfault unless caught
*/
bool happy = true;
char *tmp = (char *) (name + 2);
int32_t lval = 0;
while ((*tmp) && (happy) && (lval >= 0) && (lval < 256)) {
int32_t dig;
dig = digits[(int32_t) (*tmp++)];
if (dig < 16)
lval = dig + (lval * 16);
else
happy = false;
}
if ((happy) && (lval < 256) && (lval >= 0))
return (chars[lval]);
}
break;
}
}
return (unknown_sharp_constant(sc, name, NULL));
}
static s7_int string_to_integer(const char *str, int32_t radix,
bool *overflow)
{
bool negative = false;
s7_int lval = 0;
int32_t dig;
char *tmp = (char *) str;
#if WITH_GMP
char *tmp1;
#endif
if (str[0] == '+')
tmp++;
else if (str[0] == '-') {
negative = true;
tmp++;
}
while (*tmp == '0') {
tmp++;
};
#if WITH_GMP
tmp1 = tmp;
#endif
if (radix == 10) {
while (true) {
dig = digits[(uint8_t) (*tmp++)];
if (dig > 9)
break;
#if HAVE_OVERFLOW_CHECKS
if ((multiply_overflow(lval, (s7_int) 10, &lval)) ||
(add_overflow(lval, (s7_int) dig, &lval))) {
if ((radix == 10) && (strncmp(str, "-9223372036854775808", 20) == 0) && (digits[(uint8_t) (*tmp++)] > 9)) /* i.e. next thing is not a digit -- "/" for example */
return (S7_INT64_MIN);
*overflow = true;
return ((negative) ? S7_INT64_MIN : S7_INT64_MAX);
break;
}
#else
lval = dig + (lval * 10);
dig = digits[(uint8_t) (*tmp++)];
if (dig > 9)
break;
lval = dig + (lval * 10);
#endif
}
} else
while (true) {
dig = digits[(uint8_t) (*tmp++)];
if (dig >= radix)
break;
#if HAVE_OVERFLOW_CHECKS && (!WITH_GMP)
{
s7_int oval = 0;
if (multiply_overflow(lval, (s7_int) radix, &oval)) {
/* maybe a bad idea! #xffffffffffffffff -> -1??? this is needed for 64-bit number hacks (see s7test.scm bit-reverse) */
if ((radix == 16) &&
(digits[(uint8_t) (*tmp)] >= radix)) {
lval -= 576460752303423488LL; /* turn off sign bit */
lval *= radix;
lval += dig;
lval -= 9223372036854775807LL;
return (lval - 1);
}
lval = oval; /* old case */
if ((lval == S7_INT64_MIN)
&& (digits[(uint8_t) (*tmp++)] > 9))
return (lval);
*overflow = true;
break;
} else
lval = oval;
if (add_overflow(lval, (s7_int) dig, &lval)) {
if (lval == S7_INT64_MIN)
return (lval);
*overflow = true;
break;
}
}
#else
lval = dig + (lval * radix);
dig = digits[(uint8_t) (*tmp++)];
if (dig >= radix)
break;
lval = dig + (lval * radix);
#endif
}
#if WITH_GMP
if (!(*overflow))
(*overflow) = ((lval > S7_INT32_MAX) ||
((tmp - tmp1) > s7_int_digits_by_radix[radix]));
/* this tells the string->number readers to create a bignum. We need to be very conservative here to catch contexts such as (/ 1/524288 19073486328125) */
#endif
return ((negative) ? -lval : lval);
}
/* 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
*/
#if WITH_GMP
static s7_double string_to_double_with_radix(const char *ur_str,
int32_t radix, bool *overflow)
#else
#define string_to_double_with_radix(Str, Rad, Over) string_to_double_with_radix_1(Str, Rad)
static s7_double string_to_double_with_radix_1(const char *ur_str,
int32_t radix)
#endif
{
/* strtod follows LANG which is not what we want (only "." is decimal point in Scheme).
* To overcome LANG in strtod would require screwing around with setlocale which never works.
* So we use our own code -- according to valgrind, this function is much faster than strtod.
* comma as decimal point causes ambiguities: `(+ ,1 2) etc
*/
int32_t i, sign = 1, frac_len, int_len, dig, max_len, exponent = 0;
int64_t int_part = 0, frac_part = 0;
char *str = (char *) ur_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.
* '@' 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];
if (*str == '+')
str++;
else if (*str == '-') {
str++;
sign = -1;
}
while (*str == '0') {
str++;
};
ipart = str;
while (digits[(int32_t) (*str)] < radix)
str++;
int_len = str - ipart;
if (*str == '.')
str++;
fpart = str;
while (digits[(int32_t) (*str)] < radix)
str++;
frac_len = str - fpart;
if ((*str) && (exponent_table[(uint8_t) (*str)])) {
int32_t exp_negative = false;
str++;
if (*str == '+')
str++;
else if (*str == '-') {
str++;
exp_negative = true;
}
while ((dig = digits[(int32_t) (*str++)]) < 10) { /* exponent itself is always base 10 */
#if HAVE_OVERFLOW_CHECKS
if ((int32_multiply_overflow(exponent, 10, &exponent)) ||
(int32_add_overflow(exponent, dig, &exponent))) {
exponent = 1000000; /* see below */
break;
}
#else
exponent = dig + (exponent * 10);
#endif
}
#if (!defined(__GNUC__)) || ((__GNUC__ < 5) && (!defined(__clang__)))
if (exponent < 0) /* we overflowed, so make sure we notice it below (need to check for 0.0e... first) (Brian Damgaard) */
exponent = 1000000; /* see below for examples -- this number needs to be very big but not too big for add */
#endif
if (exp_negative)
exponent = -exponent;
/* 2e12341234123123123123213123123123 -> 0.0
* but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0
* first zero: 2e123412341231231231231
* then: 2e12341234123123123123123123 -> inf
* then: 2e123412341231231231231231231231231231 -> 0.0
* 2e-123412341231231231231 -> inf
* but: 0e123412341231231231231231231231231231
*/
}
#if WITH_GMP
/* 9007199254740995.0 */
if (int_len + frac_len >= max_len) {
(*overflow) = true;
return (0.0);
}
#endif
str = ipart;
if ((int_len + exponent) > max_len) {
/* 12341234.56789e12 12341234567889999872.0 1.234123456789e+19
* -1234567890123456789.0 -1234567890123456768.0 -1.2345678901235e+18
* 12345678901234567890.0 12345678901234567168.0 1.2345678901235e+19
* 123.456e30 123456000000000012741097792995328.0 1.23456e+32
* 12345678901234567890.0e12 12345678901234569054409354903552.0 1.2345678901235e+31
* 1.234567890123456789012e30 1234567890123456849145940148224.0 1.2345678901235e+30
* 1e20 100000000000000000000.0 1e+20
* 1234567890123456789.0 1234567890123456768.0 1.2345678901235e+18
* 123.456e16 1234560000000000000.0 1.23456e+18
* 98765432101234567890987654321.0e-5 987654321012345728401408.0 9.8765432101235e+23
* 98765432101234567890987654321.0e-10 9876543210123456512.0 9.8765432101235e+18
* 0.00000000000000001234e20 1234.0
* 0.000000000000000000000000001234e30 1234.0
* 0.0000000000000000000000000000000000001234e40 1234.0
* 0.000000000012345678909876543210e15 12345.678909877
* 0e1000 0.0
*/
for (i = 0; i < max_len; i++) {
dig = digits[(int32_t) (*str++)];
if (dig < radix)
int_part = dig + (int_part * radix);
else
break;
}
/* if the exponent is huge, check for 0 int_part and frac_part before complaining (0e1000 or 0.0e1000)
*/
if ((int_part == 0) && (exponent > max_len)) {
/* if frac_part is also 0, return 0.0 */
if (frac_len == 0)
return (0.0);
str = fpart;
while ((dig = digits[(int32_t) (*str++)]) < radix)
frac_part = dig + (frac_part * radix);
if (frac_part == 0)
return (0.0);
#if WITH_GMP
(*overflow) = true;
#endif
}
#if WITH_GMP
(*overflow) = ((int_part > 0) || (exponent > 20)); /* .1e310 is a tricky case */
#endif
if (int_part != 0) { /* 0.<310 zeros here>1e310 for example --
* pow (via dpow) thinks it has to be too big, returns Nan,
* then Nan * 0 -> Nan and the NaN propagates
*/
if (int_len <= max_len)
dval = int_part * dpow(radix, exponent);
else
dval =
int_part * dpow(radix, exponent + int_len - max_len);
} else
dval = 0.0;
/* shift by exponent, but if int_len > max_len then we assumed (see below) int_len - max_len 0's on the left */
/* using int_to_int or table lookups here instead of pow did not make any difference in speed */
if (int_len < max_len) {
int32_t k;
str = fpart;
for (k = 0; (frac_len > 0) && (k < exponent); k += max_len) {
int32_t flen;
flen = (frac_len > max_len) ? max_len : frac_len; /* ? */
frac_len -= max_len;
frac_part = 0;
for (i = 0; i < flen; i++)
frac_part =
digits[(int32_t) (*str++)] + (frac_part * radix);
if (frac_part != 0) /* same pow->NaN problem as above can occur here */
dval += frac_part * dpow(radix, exponent - flen - k);
}
} else
/* some of the fraction is in the integer part before the negative exponent shifts it over */
if (int_len > max_len) {
int32_t ilen;
/* 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[(int32_t) (*str++)] + (frac_part * radix);
dval += frac_part * dpow(radix, exponent - ilen);
}
return (sign * dval);
}
/* int_len + exponent <= max_len */
if (int_len <= max_len) {
int32_t int_exponent;
/* 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[(int32_t) (*str++)] + (int_part * radix);
}
dval =
(int_exponent ==
0) ? (s7_double) int_part : int_part * dpow(radix,
int_exponent);
} else {
int32_t len, flen;
int64_t 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[(int32_t) (*str++)] + (int_part * radix);
flen = -exponent;
if (flen > max_len)
flen = max_len;
for (i = 0; i < flen; i++)
frpart = digits[(int32_t) (*str++)] + (frpart * radix);
if (len <= 0)
dval = int_part + frpart * dpow(radix, len - flen);
else
dval = int_part + frpart * dpow(radix, -flen);
}
if (frac_len > 0) {
str = fpart;
if (frac_len <= max_len) {
/* splitting out base 10 case saves very little here */
/* this ignores trailing zeros, so that 0.3 equals 0.300 */
char *fend = (char *) (str + frac_len - 1);
while ((*fend == '0') && (fend != str)) {
fend--;
frac_len--;
} /* (= .6 0.6000) */
if ((frac_len & 1) == 0) {
while (str <= fend) {
frac_part =
digits[(int32_t) (*str++)] + (frac_part * radix);
frac_part =
digits[(int32_t) (*str++)] + (frac_part * radix);
}
} else
while (str <= fend)
frac_part =
digits[(int32_t) (*str++)] + (frac_part * radix);
dval += frac_part * dpow(radix, exponent - frac_len);
/* 0.6: frac: 6, exp: 0.10000000000000000555, val: 0.60000000000000008882
* 0.60: frac: 60, exp: 0.01000000000000000021, val: 0.59999999999999997780
* 0.6000: frac: 6000, exp: 0.00010000000000000000, val: 0.59999999999999997780
* (= 0.6 0.60): #f
* (= #i3/5 0.6): #f
* so (string->number (number->string num)) == num only if both num's are the same text (or you get lucky)
* (= 0.6 6e-1): #t ; but not 60e-2
* to fix the 0.60 case, we need to ignore trailing post-dot zeros.
*/
} else {
if (exponent <= 0) {
for (i = 0; i < max_len; i++)
frac_part =
digits[(int32_t) (*str++)] + (frac_part * radix);
dval += frac_part * dpow(radix, exponent - max_len);
} else {
/* 1.0123456789876543210e1 10.12345678987654373771
* 1.0123456789876543210e10 10123456789.87654304504394531250
* 0.000000010000000000000000e10 100.0
* 0.000000010000000000000000000000000000000000000e10 100.0
* 0.000000012222222222222222222222222222222222222e10 122.22222222222222
* 0.000000012222222222222222222222222222222222222e17 1222222222.222222
*/
int_part = 0;
for (i = 0; i < exponent; i++)
int_part =
digits[(int32_t) (*str++)] + (int_part * radix);
frac_len -= exponent;
if (frac_len > max_len)
frac_len = max_len;
for (i = 0; i < frac_len; i++)
frac_part =
digits[(int32_t) (*str++)] + (frac_part * radix);
dval += int_part + frac_part * dpow(radix, -frac_len);
}
}
}
#if WITH_GMP
if ((int_part == 0) && (frac_part == 0))
return (0.0);
(*overflow) = ((frac_len - exponent) > max_len);
#endif
return (sign * dval);
}
#if (!WITH_GMP)
static s7_pointer make_undefined_bignum(s7_scheme * sc, char *name)
{
block_t *b;
char *buf;
s7_int len;
s7_pointer res;
len = safe_strlen(name) + 16;
b = mallocate(sc, len);
buf = (char *) block_data(b);
snprintf(buf, len, "<bignum: %s>", name);
res = make_undefined(sc, (const char *) buf); /* 123123123123123123123123123123 -> +inf.0 originally, but now #<bignum: 123123...> */
liberate(sc, b);
return (res);
}
#endif
static s7_pointer nan1_or_bust(s7_scheme * sc, s7_double x, char *p,
char *q, int32_t radix, bool want_symbol)
{
s7_int len;
len = safe_strlen(p);
if (p[len - 1] == 'i') { /* +nan.0[+/-]...i */
if (len == 6) /* +nan.0+i */
return (make_complex_not_0i
(sc, x, (p[4] == '+') ? 1.0 : -1.0));
if ((len > 5) && (len < 1024)) { /* make compiler happy */
char *ip;
s7_pointer imag;
ip = copy_string_with_length((const char *) (p + 4), len - 5);
imag =
make_atom(sc, ip, radix, NO_SYMBOLS,
WITHOUT_OVERFLOW_ERROR);
free(ip);
if (is_real(imag))
return (make_complex(sc, x, real_to_double(sc, imag, __func__))); /* +nan.0+2/3i etc */
}
}
return ((want_symbol) ? make_symbol(sc, q) : sc->F);
}
static s7_pointer nan2_or_bust(s7_scheme * sc, s7_double x, char *q,
int32_t radix, bool want_symbol)
{
s7_int len;
len = safe_strlen(q);
if ((len > 7) && (len < 1024)) { /* make compiler happy */
char *ip;
s7_pointer rl;
ip = copy_string_with_length((const char *) q, len - 7);
rl = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR);
free(ip);
if (is_real(rl))
return (make_complex(sc, real_to_double(sc, rl, __func__), x));
}
return ((want_symbol) ? make_symbol(sc, q) : sc->F);
}
static s7_pointer make_atom(s7_scheme * sc, char *q, int32_t radix,
bool want_symbol, bool with_error)
{
/* make symbol or number from string, a number starts with + - . or digit, but so does 1+ for example */
#define IS_DIGIT(Chr, Rad) (digits[(uint8_t)Chr] < Rad)
char c, *p = q;
bool has_dec_point1 = false;
c = *p++;
switch (c) {
case '#':
/* from string->number, (string->number #xc) */
return (make_sharp_constant(sc, p, with_error, NULL, false)); /* make_sharp_constant expects the '#' to be removed */
case '+':
case '-':
c = *p++;
if (c == '.') {
has_dec_point1 = true;
c = *p++;
}
if (!c)
return ((want_symbol) ? make_symbol(sc, q) : sc->F);
if (!IS_DIGIT(c, radix)) {
if (has_dec_point1)
return ((want_symbol) ? make_symbol(sc, q) : sc->F);
if (c == 'n') {
if (local_strcmp(p, "an.0")) /* +nan.0 */
return (real_NaN);
if ((local_strncmp(p, "an.0", 4)) &&
((p[4] == '+') || (p[4] == '-')))
return (nan1_or_bust
(sc, NAN, p, q, radix, want_symbol));
}
if (c == 'i') {
if (local_strcmp(p, "nf.0")) /* +inf.0 */
return ((q[0] ==
'+') ? real_infinity : real_minus_infinity);
if ((local_strncmp(p, "nf.0", 4))
&& ((p[4] == '+') || (p[4] == '-')))
return (nan1_or_bust
(sc, (q[0] == '-') ? -INFINITY : INFINITY, p,
q, radix, want_symbol));
}
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 'n':
return ((want_symbol) ? make_symbol(sc, q) : sc->F);
case 'i':
return ((want_symbol) ? make_symbol(sc, q) : sc->F);
case '0': /* these two are always digits */
case '1':
break;
default:
if (!IS_DIGIT(c, radix))
return ((want_symbol) ? make_symbol(sc, q) : sc->F);
break;
}
/* now it's possibly a number -- the first character(s) could be part of a number in the current radix */
{
char *slash1 = NULL, *slash2 = NULL, *plus = NULL, *ex1 =
NULL, *ex2 = NULL;
bool has_i = false, has_dec_point2 = false;
int32_t has_plus_or_minus = 0, current_radix;
#if (!WITH_GMP)
bool overflow = false; /* for string_to_integer */
#endif
current_radix = radix; /* current_radix is 10 for the exponent portions, but radix for all the rest */
for (; (c = *p) != 0; ++p) {
/* what about embedded null? (string->number (string #\1 (integer->char 0) #\0))
* currently we stop and return 1, but Guile returns #f.
* this also means we can't use substring_uncopied if (string->number (substring...))
*/
if (!IS_DIGIT(c, current_radix)) { /* moving this inside the switch statement was much slower */
current_radix = radix;
switch (c) {
/* -------- decimal point -------- */
case '.':
if ((!IS_DIGIT(p[1], current_radix)) &&
(!IS_DIGIT(p[-1], current_radix)))
return ((want_symbol) ? make_symbol(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) /* see above */
return ((want_symbol) ? make_symbol(sc, q) :
sc->F);
/* fall through -- if '@' used, radices>10 are ok */
case '@':
current_radix = 10;
if (((ex1) || (slash1)) && (has_plus_or_minus == 0)) /* ee */
return ((want_symbol) ? make_symbol(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);
/* now check for nan/inf as imaginary part */
if ((plus[0] == 'n') && (local_strcmp(plus, "nan.0i")))
return (nan2_or_bust
(sc, (c == '+') ? NAN : -NAN, q, radix,
want_symbol));
if ((plus[0] == 'i') && (local_strcmp(plus, "inf.0i")))
return (nan2_or_bust
(sc, (c == '+') ? INFINITY : -INFINITY, q,
radix, want_symbol));
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;
s7_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 */
q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */
(*((char *) (plus - 1))) = '\0';
#if (!WITH_GMP)
if ((has_dec_point1) || (ex1)) /* (string->number "1100.1+0.11i" 2) -- need to split into 2 honest reals before passing to non-base-10 str->dbl */
rl = string_to_double_with_radix(q, radix, ignored);
else { /* no decimal point, no exponent, a ratio (1/2+i for example, but 1+2/3i is handled below) */
if (slash1) {
/* here the overflow could be innocuous if it's in the denominator and the numerator is 0: 0/100000000000000000000000000000000000000 */
s7_int num, den;
num = string_to_integer(q, radix, &overflow);
if (overflow)
return (make_undefined_bignum(sc, q));
den = string_to_integer(slash1, radix, &overflow);
if (den == 0)
rl = NAN; /* real_part if complex */
else {
if (num == 0) {
rl = 0.0;
overflow = false;
} else {
if (overflow)
return (make_undefined_bignum(sc, q)); /* denominator overflow */
rl = (long_double) num / (long_double) den; /* no gmp, so we do what we can */
}
}
} else {
rl = (s7_double) string_to_integer(q, radix,
&overflow);
if (overflow)
return (make_undefined_bignum(sc, q));
}
}
if (rl == -0.0)
rl = 0.0;
if ((has_dec_point2) || (ex2))
im = string_to_double_with_radix(plus, radix, ignored);
else {
if (slash2) { /* complex part I think */
/* same as above: 0-0/100000000000000000000000000000000000000i */
s7_int num, den;
num = string_to_integer(plus, radix, &overflow);
if (overflow)
return (make_undefined_bignum(sc, q));
den = string_to_integer(slash2, radix, &overflow);
if (den == 0)
im = NAN;
else {
if (num == 0) {
im = 0.0;
overflow = false;
} else {
if (overflow)
return (make_undefined_bignum(sc, q)); /* denominator overflow */
im = (long_double) num / (long_double) den;
}
}
} else {
im = (s7_double) string_to_integer(plus, radix,
&overflow);
if (overflow)
return (make_undefined_bignum(sc, q));
}
}
if ((has_plus_or_minus == -1) && (im != 0.0))
im = -im;
result = 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, ignored));
#else
{
char old_e = 0;
if (ex1) {
old_e = (*ex1);
(*ex1) = '@';
}
result = string_to_either_real(sc, q, radix);
if (ex1)
(*ex1) = old_e;
}
#endif
return (result);
}
/* rational */
if (slash1)
#if (!WITH_GMP)
{
s7_int n, d;
n = string_to_integer(q, radix, &overflow);
if (overflow)
return (make_undefined_bignum(sc, q));
d = string_to_integer(slash1, radix, &overflow);
if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */
return (int_zero);
if (d == 0)
return (real_NaN);
if (overflow)
return (make_undefined_bignum(sc, q));
/* it would be neat to return 1 from 10000000000000000000000000000/10000000000000000000000000000
* but q is the entire number ('/' included) and slash1 is the stuff after the '/', and every
* big number comes through here, so there's no clean and safe way to check that q == slash1.
*/
return (make_ratio(sc, n, d));
}
#else
return (string_to_either_ratio(sc, q, slash1, radix));
#endif
/* integer */
#if (!WITH_GMP)
{
s7_int x;
x = string_to_integer(q, radix, &overflow);
if (overflow)
return (make_undefined_bignum(sc, q));
return (make_integer(sc, x));
}
#else
return (string_to_either_integer(sc, q, radix));
#endif
}
}
/* -------------------------------- string->number -------------------------------- */
static s7_pointer string_to_number(s7_scheme * sc, char *str,
int32_t radix)
{
s7_pointer x;
x = make_atom(sc, str, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR);
return ((is_number(x)) ? x : sc->F); /* only needed because str might start with '#' and not be a number (#t for example) */
}
static s7_pointer string_to_number_p_p(s7_scheme * sc, s7_pointer str1)
{
char *str;
if (!is_string(str1))
return (wrong_type_argument
(sc, sc->string_to_number_symbol, 1, str1, T_STRING));
str = (char *) string_value(str1);
return (((!str) || (!(*str))) ? sc->F : string_to_number(sc, str, 10));
}
static s7_pointer string_to_number_p_pp(s7_scheme * sc, s7_pointer str1,
s7_pointer radix1)
{
s7_int radix;
char *str;
if (!is_string(str1))
return (wrong_type_argument
(sc, sc->string_to_number_symbol, 1, str1, T_STRING));
if (!is_t_integer(radix1))
return (wrong_type_argument
(sc, sc->string_to_number_symbol, 2, radix1, T_INTEGER));
radix = integer(radix1);
if ((radix < 2) || (radix > 16))
return (out_of_range
(sc, sc->string_to_number_symbol, int_two, radix1,
a_valid_radix_string));
str = (char *) string_value(str1);
if ((!str) || (!(*str)))
return (sc->F);
return (string_to_number(sc, str, radix));
}
static s7_pointer g_string_to_number_1(s7_scheme * sc, s7_pointer args,
s7_pointer caller)
{
s7_int radix;
char *str;
if (!is_string(car(args)))
return (method_or_bust(sc, car(args), caller, args, T_STRING, 1));
if (is_pair(cdr(args))) {
s7_pointer rad = cadr(args);
if (!s7_is_integer(rad))
return (method_or_bust(sc, rad, caller, args, T_INTEGER, 2));
radix = s7_integer_checked(sc, rad);
if ((radix < 2) || (radix > 16))
return (out_of_range
(sc, caller, int_two, rad, a_valid_radix_string));
} else
radix = 10;
str = (char *) string_value(car(args));
if ((!str) || (!(*str)))
return (sc->F);
return (string_to_number(sc, str, radix));
}
static s7_pointer g_string_to_number(s7_scheme * sc, s7_pointer args)
{
#define H_string_to_number "(string->number str (radix 10)) converts str into a number. \
If str does not represent a number, string->number returns #f. If 'str' has an embedded radix, \
the optional 'radix' argument is ignored: (string->number \"#x11\" 2) -> 17 not 3."
#define Q_string_to_number s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), sc->is_string_symbol, sc->is_integer_symbol)
return (g_string_to_number_1(sc, args, sc->string_to_number_symbol));
}
/* -------------------------------- abs -------------------------------- */
static inline s7_pointer abs_p_p(s7_scheme * sc, s7_pointer x)
{
#if (!WITH_GMP)
if (is_t_integer(x)) {
if (integer(x) >= 0)
return (x);
if (integer(x) > S7_INT64_MIN)
return (make_integer(sc, -integer(x)));
}
if (is_t_real(x)) {
if (is_NaN(real(x))) /* (abs -nan.0) -> +nan.0, not -nan.0 */
return (real_NaN);
return ((signbit(real(x))) ? make_real(sc, -real(x)) : x);
}
#endif
switch (type(x)) {
case T_INTEGER:
if (integer(x) >= 0)
return (x);
#if WITH_GMP
if (integer(x) == S7_INT64_MIN) {
x = s7_int_to_big_integer(sc, integer(x));
mpz_neg(big_integer(x), big_integer(x));
return (x);
}
#else
if (integer(x) == S7_INT64_MIN)
return (simple_out_of_range
(sc, sc->abs_symbol, set_elist_1(sc, x),
result_is_too_large_string));
#endif
return (make_integer(sc, -integer(x)));
case T_RATIO:
if (numerator(x) >= 0)
return (x);
#if WITH_GMP && (!POINTER_32)
if (numerator(x) == S7_INT64_MIN) {
s7_pointer p;
mpz_set_si(sc->mpz_1, S7_INT64_MIN);
mpz_neg(sc->mpz_1, sc->mpz_1);
mpz_set_si(sc->mpz_2, denominator(x));
new_cell(sc, p, T_BIG_RATIO);
big_ratio_bgr(p) = alloc_bigrat(sc);
add_big_ratio(sc, p);
mpq_set_num(big_ratio(p), sc->mpz_1);
mpq_set_den(big_ratio(p), sc->mpz_2);
return (p);
}
#else
if (numerator(x) == S7_INT64_MIN)
return (make_ratio(sc, S7_INT64_MAX, denominator(x)));
#endif
return (make_simple_ratio(sc, -numerator(x), denominator(x)));
case T_REAL:
if (is_NaN(real(x))) /* (abs -nan.0) -> +nan.0, not -nan.0 */
return (real_NaN);
return ((signbit(real(x))) ? make_real(sc, -real(x)) : x); /* (abs -0.0) returns -0.0 -- Shiro Kawai */
#if WITH_GMP
case T_BIG_INTEGER:
mpz_abs(sc->mpz_1, big_integer(x));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
mpq_abs(sc->mpq_1, big_ratio(x));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_abs(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
#endif
default:
return (method_or_bust_one_arg_p(sc, x, sc->abs_symbol, T_REAL));
}
}
static s7_pointer g_abs(s7_scheme * sc, s7_pointer args)
{
#define H_abs "(abs x) returns the absolute value of the real number x"
#define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)
return (abs_p_p(sc, car(args)));
}
static s7_double abs_d_d(s7_double x)
{
return ((signbit(x)) ? (-x) : x);
}
static s7_int abs_i_i(s7_int x)
{
return ((x < 0) ? (-x) : x);
}
/* -------------------------------- 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 magnitude_p_p(s7_scheme * sc, s7_pointer x)
{
if (is_t_complex(x))
return (make_real(sc, my_hypot(imag_part(x), real_part(x))));
switch (type(x)) {
case T_INTEGER:
if (integer(x) == S7_INT64_MIN)
return (mostfix);
/* (magnitude -9223372036854775808) -> -9223372036854775808
* same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808
*/
return ((integer(x) < 0) ? make_integer(sc, -integer(x)) : x);
case T_RATIO:
return ((numerator(x) < 0) ? make_simple_ratio(sc, -numerator(x),
denominator(x)) :
x);
case T_REAL:
if (is_NaN(real(x))) /* (magnitude -nan.0) -> +nan.0, not -nan.0 */
return (real_NaN);
return ((signbit(real(x))) ? make_real(sc, -real(x)) : x);
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
return (abs_p_p(sc, x));
case T_BIG_COMPLEX:
mpc_abs(sc->mpfr_1, big_complex(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->magnitude_symbol, a_number_string));
}
}
static s7_pointer g_magnitude(s7_scheme * sc, s7_pointer args)
{
#define H_magnitude "(magnitude z) returns the magnitude of z"
#define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
return (magnitude_p_p(sc, car(args)));
}
/* -------------------------------- rationalize -------------------------------- */
#if WITH_GMP
static rat_locals_t *init_rat_locals_t(s7_scheme * sc)
{
rat_locals_t *r;
r = (rat_locals_t *) malloc(sizeof(rat_locals_t));
sc->ratloc = r;
mpz_inits(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1,
r->q1, r->old_p1, r->old_q1, NULL);
mpq_init(r->q);
mpfr_inits2(sc->bignum_precision, r->error, r->ux, r->x0, r->x1,
r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1,
r->old_e0p, NULL);
return (r);
}
static void free_rat_locals(s7_scheme * sc)
{
rat_locals_t *r;
r = sc->ratloc;
mpz_clears(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1,
r->q1, r->old_p1, r->old_q1, NULL);
mpq_clear(r->q);
mpfr_clears(r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1,
r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL);
free(r);
}
static s7_pointer big_rationalize(s7_scheme * sc, s7_pointer args)
{
/* can return be non-rational? */
/* currently (rationalize 1/0 1e18) -> 0
* remember to pad with many trailing zeros:
* (rationalize 0.1 0) -> 3602879701896397/36028797018963968
* (rationalize 0.1000000000000000 0) -> 1/10
* perhaps gmp number reader used if gmp -- could this be the trailing zeros problem? (why is the non-gmp case ok?)
* also the bignum function is faking it.
* (rationalize (real-part (bignum "0.1+i")) 0) -> 3602879701896397/36028797018963968
* a confusing case:
* (rationalize 5925563891587147521650777143.74135805596e05) should be 148139097289678688041269428593533951399/250000
* but that requires more than 128 bits of bignum-precision.
*/
s7_pointer pp0 = car(args);
rat_locals_t *r;
if (!sc->ratloc)
r = init_rat_locals_t(sc);
else
r = sc->ratloc;
switch (type(pp0)) {
case T_INTEGER:
mpfr_set_si(r->ux, integer(pp0), MPFR_RNDN);
break;
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(pp0), denominator(pp0));
mpfr_set_q(r->ux, sc->mpq_1, MPFR_RNDN);
break;
case T_REAL:
if (is_NaN(real(pp0)))
return (out_of_range
(sc, sc->rationalize_symbol, int_one, pp0,
its_nan_string));
if (is_inf(real(pp0)))
return (out_of_range
(sc, sc->rationalize_symbol, int_one, pp0,
its_infinite_string));
mpfr_set_d(r->ux, real(pp0), MPFR_RNDN);
break;
case T_BIG_INTEGER:
mpfr_set_z(r->ux, big_integer(pp0), MPFR_RNDN);
break;
case T_BIG_RATIO:
mpfr_set_q(r->ux, big_ratio(pp0), MPFR_RNDN);
break;
case T_BIG_REAL:
if (mpfr_nan_p(big_real(pp0)))
return (out_of_range
(sc, sc->rationalize_symbol, int_one, pp0,
its_nan_string));
if (mpfr_inf_p(big_real(pp0)))
return (out_of_range
(sc, sc->rationalize_symbol, int_one, pp0,
its_infinite_string));
mpfr_set(r->ux, big_real(pp0), MPFR_RNDN);
break;
case T_COMPLEX:
case T_BIG_COMPLEX:
return (wrong_type_argument
(sc, sc->rationalize_symbol, 1, pp0, T_REAL));
default:
return (method_or_bust
(sc, pp0, sc->rationalize_symbol, args, T_REAL, 1));
}
if (is_null(cdr(args)))
mpfr_set_d(r->error, sc->default_rationalize_error, MPFR_RNDN);
else {
s7_pointer pp1 = cadr(args);
switch (type(pp1)) {
case T_INTEGER:
mpfr_set_si(r->error, integer(pp1), MPFR_RNDN);
break;
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(pp1), denominator(pp1));
mpfr_set_q(r->error, sc->mpq_1, MPFR_RNDN);
break;
case T_REAL:
if (is_NaN(real(pp1)))
return (out_of_range
(sc, sc->rationalize_symbol, int_two, pp1,
its_nan_string));
if (is_inf(real(pp1)))
return (int_zero);
mpfr_set_d(r->error, real(pp1), MPFR_RNDN);
break;
case T_BIG_INTEGER:
mpfr_set_z(r->error, big_integer(pp1), MPFR_RNDN);
break;
case T_BIG_RATIO:
mpfr_set_q(r->error, big_ratio(pp1), MPFR_RNDN);
break;
case T_BIG_REAL:
if (mpfr_nan_p(big_real(pp1)))
return (out_of_range
(sc, sc->rationalize_symbol, int_two, pp1,
its_nan_string));
if (mpfr_inf_p(big_real(pp1)))
return (int_zero);
mpfr_set(r->error, big_real(pp1), MPFR_RNDN);
break;
case T_COMPLEX:
case T_BIG_COMPLEX:
return (wrong_type_argument
(sc, sc->rationalize_symbol, 2, pp1, T_REAL));
default:
return (method_or_bust
(sc, pp1, sc->rationalize_symbol, args, T_REAL, 2));
}
mpfr_abs(r->error, r->error, MPFR_RNDN);
}
mpfr_set(r->x0, r->ux, MPFR_RNDN); /* x0 = ux - error */
mpfr_sub(r->x0, r->x0, r->error, MPFR_RNDN);
mpfr_set(r->x1, r->ux, MPFR_RNDN); /* x1 = ux + error */
mpfr_add(r->x1, r->x1, r->error, MPFR_RNDN);
mpfr_get_z(r->i, r->x0, MPFR_RNDU); /* i = ceil(x0) */
if (mpfr_cmp_ui(r->error, 1) >= 0) { /* if (error >= 1.0) */
if (mpfr_cmp_ui(r->x0, 0) < 0) { /* if (x0 < 0) */
if (mpfr_cmp_ui(r->x1, 0) < 0) /* if (x1 < 0) */
mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* num = floor(x1) */
else
mpz_set_ui(r->n, 0); /* else num = 0 */
} else
mpz_set(r->n, r->i); /* else num = i */
return (mpz_to_integer(sc, r->n));
}
if (mpfr_cmp_z(r->x1, r->i) >= 0) { /* if (x1 >= i) */
if (mpz_cmp_ui(r->i, 0) >= 0) /* if (i >= 0) */
mpz_set(r->n, r->i); /* num = i */
else
mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* else num = floor(x1) */
return (mpz_to_integer(sc, r->n));
}
mpfr_get_z(r->i0, r->x0, MPFR_RNDD); /* i0 = floor(x0) */
mpfr_get_z(r->i1, r->x1, MPFR_RNDU); /* i1 = ceil(x1) */
mpz_set(r->p0, r->i0); /* p0 = i0 */
mpz_set_ui(r->q0, 1); /* q0 = 1 */
mpz_set(r->p1, r->i1); /* p1 = i1 */
mpz_set_ui(r->q1, 1); /* q1 = 1 */
mpfr_sub_z(r->e0, r->x0, r->i1, MPFR_RNDN); /* e0 = i1 - x0 */
mpfr_neg(r->e0, r->e0, MPFR_RNDN);
mpfr_sub_z(r->e1, r->x0, r->i0, MPFR_RNDN); /* e1 = x0 - i0 */
mpfr_sub_z(r->e0p, r->x1, r->i1, MPFR_RNDN); /* e0p = i1 - x1 */
mpfr_neg(r->e0p, r->e0p, MPFR_RNDN);
mpfr_sub_z(r->e1p, r->x1, r->i0, MPFR_RNDN); /* e1p = x1 - i0 */
while (true) {
mpfr_set_z(r->val, r->p0, MPFR_RNDN);
mpfr_div_z(r->val, r->val, r->q0, MPFR_RNDN); /* val = p0/q0 */
if (((mpfr_lessequal_p(r->x0, r->val)) && /* if ((x0 <= val) && (val <= x1)) */
(mpfr_lessequal_p(r->val, r->x1))) ||
(mpfr_cmp_ui(r->e1, 0) == 0) || (mpfr_cmp_ui(r->e1p, 0) == 0))
/* these last 2 are probably not needed -- they protect against running out of bits in the non-gmp case above */
{
mpq_set_num(r->q, r->p0); /* return(p0/q0) */
mpq_set_den(r->q, r->q0);
return (mpq_to_rational(sc, r->q));
}
mpfr_div(r->val, r->e0, r->e1, MPFR_RNDN);
mpfr_get_z(r->r, r->val, MPFR_RNDD); /* r = floor(e0/e1) */
mpfr_div(r->val, r->e0p, r->e1p, MPFR_RNDN);
mpfr_get_z(r->r1, r->val, MPFR_RNDU); /* r1 = ceil(e0p/e1p) */
if (mpz_cmp(r->r1, r->r) < 0) /* if (r1 < r) */
mpz_set(r->r, r->r1); /* r = r1 */
mpz_set(r->old_p1, r->p1); /* old_p1 = p1 */
mpz_set(r->p1, r->p0); /* p1 = p0 */
mpz_set(r->old_q1, r->q1); /* old_q1 = q1 */
mpz_set(r->q1, r->q0); /* q1 = q0 */
mpfr_set(r->old_e0, r->e0, MPFR_RNDN); /* old_e0 = e0 */
mpfr_set(r->e0, r->e1p, MPFR_RNDN); /* e0 = e1p */
mpfr_set(r->old_e0p, r->e0p, MPFR_RNDN); /* old_e0p = e0p */
mpfr_set(r->e0p, r->e1, MPFR_RNDN); /* e0p = e1 */
mpfr_set(r->old_e1, r->e1, MPFR_RNDN); /* old_e1 = e1 */
mpz_mul(r->p0, r->p0, r->r); /* p0 = old_p1 + r * p0 */
mpz_add(r->p0, r->p0, r->old_p1);
mpz_mul(r->q0, r->q0, r->r); /* q0 = old_q1 + r * q0 */
mpz_add(r->q0, r->q0, r->old_q1);
mpfr_mul_z(r->e1, r->e1p, r->r, MPFR_RNDN); /* e1 = old_e0p - r * e1p */
mpfr_sub(r->e1, r->old_e0p, r->e1, MPFR_RNDN);
mpfr_mul_z(r->e1p, r->old_e1, r->r, MPFR_RNDN); /* e1p = old_e0 - r * old_e1 */
mpfr_sub(r->e1p, r->old_e0, r->e1p, MPFR_RNDN);
}
}
#endif
static s7_pointer g_rationalize(s7_scheme * sc, s7_pointer args)
{
#define H_rationalize "(rationalize x err) returns the ratio with smallest denominator within err of x"
#define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)
/* I can't find a case where this returns a non-rational result */
s7_double err;
s7_pointer x = car(args);
#if WITH_GMP
if (is_big_number(x))
return (big_rationalize(sc, args));
#endif
if (!is_real(x))
return (method_or_bust
(sc, x, sc->rationalize_symbol, args, T_REAL, 1));
if (is_null(cdr(args)))
err = sc->default_rationalize_error;
else {
s7_pointer ex = cadr(args);
#if WITH_GMP
if (is_big_number(ex))
return (big_rationalize(sc, args));
#endif
if (!is_real(ex))
return (method_or_bust
(sc, ex, sc->rationalize_symbol, args, T_REAL, 2));
err = real_to_double(sc, ex, "rationalize");
if (is_NaN(err))
return (out_of_range
(sc, sc->rationalize_symbol, int_two, cadr(args),
its_nan_string));
if (err < 0.0)
err = -err;
}
switch (type(x)) {
case T_INTEGER:
{
s7_int a, b, pa;
if (err < 1.0)
return (x);
a = integer(x);
if (a < 0)
pa = -a;
else
pa = a;
if (err >= pa)
return (int_zero);
b = (s7_int) err;
pa -= b;
return ((a < 0) ? make_integer(sc, -pa) : make_integer(sc,
pa));
}
case T_RATIO:
if (err == 0.0)
return (x);
case T_REAL:
{
s7_double rat = s7_real(x); /* possible fall through from above */
s7_int numer = 0, denom = 1;
if ((is_NaN(rat)) || (is_inf(rat)))
return (out_of_range
(sc, sc->rationalize_symbol, int_one, x,
a_normal_real_string));
if (err >= fabs(rat))
return (int_zero);
#if WITH_GMP
if (fabs(rat) > RATIONALIZE_LIMIT)
return (big_rationalize
(sc, set_plist_2(sc, x, wrap_real1(sc, err))));
#else
if (fabs(rat) > RATIONALIZE_LIMIT)
return (out_of_range
(sc, sc->rationalize_symbol, int_one, x,
its_too_large_string));
#endif
if ((fabs(rat) + fabs(err)) < 1.0e-18)
err = 1.0e-18;
/* (/ 1.0 most-positive-fixnum) is 1.0842021e-19, so if we let err be less than that,
* (rationalize 1e-19 1e-20) hangs, but this only affects the initial ceiling, I believe.
*/
if (fabs(rat) < fabs(err))
return (int_zero);
return ((c_rationalize(rat, err, &numer, &denom)) ?
make_ratio(sc, numer, denom) : sc->F);
}
}
return (sc->F); /* make compiler happy */
}
static s7_int rationalize_i_i(s7_int x)
{
return (x);
}
static s7_pointer rationalize_p_i(s7_scheme * sc, s7_int x)
{
return (make_integer(sc, x));
}
static s7_pointer rationalize_p_d(s7_scheme * sc, s7_double x)
{
if ((is_NaN(x)) || (is_inf(x)))
return (out_of_range(sc, sc->rationalize_symbol, int_one, wrap_real1(sc, x), a_normal_real_string)); /* was make_real, also below */
if (fabs(x) > RATIONALIZE_LIMIT)
#if WITH_GMP
return (big_rationalize(sc, set_plist_1(sc, wrap_real1(sc, x))));
#else
return (out_of_range
(sc, sc->rationalize_symbol, int_one, wrap_real1(sc, x),
its_too_large_string));
#endif
return (s7_rationalize(sc, x, sc->default_rationalize_error));
}
/* -------------------------------- angle -------------------------------- */
static s7_pointer g_angle(s7_scheme * sc, s7_pointer args)
{
#define H_angle "(angle z) returns the angle of z"
#define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
s7_pointer x = car(args); /* (angle inf+infi) -> 0.78539816339745 ? I think this should be -pi < ang <= pi */
switch (type(x)) {
case T_INTEGER:
return ((integer(x) < 0) ? real_pi : int_zero);
case T_RATIO:
return ((numerator(x) < 0) ? real_pi : int_zero);
case T_COMPLEX:
return (make_real(sc, atan2(imag_part(x), real_part(x))));
case T_REAL:
if (is_NaN(real(x)))
return (x);
return ((real(x) < 0.0) ? real_pi : real_zero);
#if WITH_GMP
case T_BIG_INTEGER:
return ((mpz_cmp_ui(big_integer(x), 0) >=
0) ? int_zero : big_pi(sc));
case T_BIG_RATIO:
return ((mpq_cmp_ui(big_ratio(x), 0, 1) >=
0) ? int_zero : big_pi(sc));
case T_BIG_REAL:
if (mpfr_nan_p(big_real(x)))
return (x);
return ((mpfr_cmp_d(big_real(x), 0.0) >=
0) ? real_zero : big_pi(sc));
case T_BIG_COMPLEX:
{
s7_pointer z;
new_cell(sc, z, T_BIG_REAL);
big_real_bgf(z) = alloc_bigflt(sc);
add_big_real(sc, z);
mpc_arg(big_real(z), big_complex(x), MPFR_RNDN);
return (z);
}
#endif
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->angle_symbol, args, a_number_string));
}
}
/* -------------------------------- complex -------------------------------- */
static s7_pointer g_complex(s7_scheme * sc, s7_pointer args)
{
#define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2"
#define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)
s7_pointer x = car(args), y = cadr(args);
#if WITH_GMP
if ((is_big_number(x)) || (is_big_number(y))) {
s7_pointer p0 = x, p1, p = NULL;
if (!is_real(p0))
return (method_or_bust
(sc, p0, sc->complex_symbol, args, T_REAL, 1));
p1 = y;
if (!is_real(p1))
return (method_or_bust
(sc, p1, sc->complex_symbol, args, T_REAL, 2));
switch (type(p1)) {
case T_INTEGER:
case T_RATIO:
case T_REAL:
{
s7_double iz = s7_real(p1);
if (iz == 0.0) /* imag-part is 0.0 */
return (p0);
new_cell(sc, p, T_BIG_COMPLEX);
big_complex_bgc(p) = alloc_bigcmp(sc);
mpfr_set_d(mpc_imagref(big_complex(p)), iz, MPFR_RNDN);
}
break;
case T_BIG_REAL:
if (mpfr_zero_p(big_real(p1)))
return (p0);
new_cell(sc, p, T_BIG_COMPLEX);
big_complex_bgc(p) = alloc_bigcmp(sc);
mpfr_set(mpc_imagref(big_complex(p)), big_real(p1), MPFR_RNDN);
break;
case T_BIG_RATIO:
new_cell(sc, p, T_BIG_COMPLEX);
big_complex_bgc(p) = alloc_bigcmp(sc);
mpfr_set_q(mpc_imagref(big_complex(p)), big_ratio(p1),
MPFR_RNDN);
break;
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(p1), 0) == 0)
return (p0);
new_cell(sc, p, T_BIG_COMPLEX);
big_complex_bgc(p) = alloc_bigcmp(sc);
mpfr_set_z(mpc_imagref(big_complex(p)), big_integer(p1),
MPFR_RNDN);
break;
}
switch (type(p0)) {
case T_INTEGER:
case T_RATIO:
case T_REAL:
mpfr_set_d(mpc_realref(big_complex(p)), s7_real(p0),
MPFR_RNDN);
break;
case T_BIG_REAL:
mpfr_set(mpc_realref(big_complex(p)), big_real(p0), MPFR_RNDN);
break;
case T_BIG_RATIO:
mpfr_set_q(mpc_realref(big_complex(p)), big_ratio(p0),
MPFR_RNDN);
break;
case T_BIG_INTEGER:
mpfr_set_z(mpc_realref(big_complex(p)), big_integer(p0),
MPFR_RNDN);
break;
}
add_big_complex(sc, p);
return (p);
}
#endif
switch (type(y)) {
case T_INTEGER:
switch (type(x)) {
case T_INTEGER:
return ((integer(y) == 0) ? x : s7_make_complex(sc, (s7_double)
integer(x),
(s7_double)
integer(y)));
/* these int->dbl's are problematic:
* (complex 9223372036854775807 9007199254740995): 9223372036854776000.0+9007199254740996.0i
* should we raise an error?
*/
case T_RATIO:
return ((integer(y) == 0) ? x : s7_make_complex(sc, (s7_double)
fraction(x),
(s7_double)
integer(y)));
case T_REAL:
return ((integer(y) == 0) ? x : s7_make_complex(sc, real(x),
(s7_double)
integer(y)));
default:
return (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))); /* can fraction be 0.0? */
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:
return (method_or_bust
(sc, x, sc->complex_symbol, args, T_REAL, 1));
}
case T_REAL:
switch (type(x)) {
case T_INTEGER:
return ((real(y) == 0.0) ? x : s7_make_complex(sc, (s7_double)
integer(x),
real(y)));
case T_RATIO:
return ((real(y) == 0.0) ? x : s7_make_complex(sc, (s7_double)
fraction(x),
real(y)));
case T_REAL:
return ((real(y) == 0.0) ? x : s7_make_complex(sc, real(x),
real(y)));
default:
return (method_or_bust
(sc, x, sc->complex_symbol, args, T_REAL, 1));
}
default:
return (method_or_bust
(sc, (is_let(x)) ? x : y, sc->complex_symbol, args, T_REAL,
2));
}
}
static s7_pointer complex_p_ii(s7_scheme * sc, s7_int x, s7_int y)
{
return ((y == 0.0) ? make_integer(sc, x) : make_complex_not_0i(sc,
(s7_double)
x,
(s7_double)
y));
}
static s7_pointer complex_p_dd(s7_scheme * sc, s7_double x, s7_double y)
{
return ((y == 0.0) ? make_real(sc, x) : make_complex_not_0i(sc, x, y));
}
/* -------------------------------- bignum -------------------------------- */
static s7_pointer g_bignum(s7_scheme * sc, s7_pointer args)
{
#define H_bignum "(bignum val (radix 10)) returns a multiprecision version of the string 'val'. If the argument is a number \
bignum returns that number as a bignum"
#define Q_bignum s7_make_signature(sc, 3, sc->is_bignum_symbol, s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), sc->is_integer_symbol)
#if WITH_GMP
s7_pointer p = car(args);
if (is_number(p)) {
if (!is_null(cdr(args)))
s7_error(sc, make_symbol(sc, "bignum-error"),
set_elist_2(sc,
wrap_string(sc,
"bignum of a number takes only one argument: ~S",
46), args));
switch (type(p)) {
case T_INTEGER:
return (s7_int_to_big_integer(sc, integer(p)));
case T_RATIO:
return (s7_int_to_big_ratio(sc, numerator(p), denominator(p)));
case T_REAL:
return (s7_double_to_big_real(sc, real(p)));
case T_COMPLEX:
return (s7_double_to_big_complex
(sc, real_part(p), imag_part(p)));
default:
return (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,
wrap_string(sc,
"bignum string argument does not represent a number: ~S",
54), car(args)));
switch (type(p)) {
case T_INTEGER:
return (s7_int_to_big_integer(sc, integer(p)));
case T_RATIO:
return (s7_int_to_big_ratio(sc, numerator(p), denominator(p)));
case T_COMPLEX:
return (s7_number_to_big_complex(sc, p));
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_checked(sc,
cadr(args)) :
10));
default:
return (p);
}
#else
return ((is_number(car(args))) ? car(args) :
g_string_to_number_1(sc, args, sc->bignum_symbol));
#endif
}
/* -------------------------------- exp -------------------------------- */
#if (!HAVE_COMPLEX_NUMBERS)
static s7_pointer no_complex_numbers_string;
#endif
#define EXP_LIMIT 100.0
#if WITH_GMP
static s7_pointer exp_1(s7_scheme * sc, s7_double x)
{
mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN);
mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
static s7_pointer exp_2(s7_scheme * sc, s7_double x, s7_double y)
{
mpc_set_d_d(sc->mpc_1, x, y, MPC_RNDNN);
mpc_exp(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
}
#endif
static s7_pointer exp_p_p(s7_scheme * sc, s7_pointer x)
{
double z;
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 0)
return (int_one); /* (exp 0) -> 1 */
z = (s7_double) integer(x);
#if WITH_GMP
if (fabs(z) > EXP_LIMIT)
return (exp_1(sc, z));
#endif
return (make_real(sc, exp(z)));
case T_RATIO:
z = (s7_double) fraction(x);
#if WITH_GMP
if (fabs(z) > EXP_LIMIT)
return (exp_1(sc, z));
#endif
return (make_real(sc, exp(z)));
case T_REAL:
#if WITH_GMP
if (fabs(real(x)) > EXP_LIMIT)
return (exp_1(sc, real(x)));
#endif
return (make_real(sc, exp(real(x))));
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
#if WITH_GMP
if ((fabs(real_part(x)) > EXP_LIMIT) ||
(fabs(imag_part(x)) > EXP_LIMIT))
return (exp_2(sc, real_part(x), imag_part(x)));
#endif
return (c_complex_to_s7(sc, cexp(to_c_complex(x))));
/* this is inaccurate for large arguments:
* (exp 0+1e20i) -> -0.66491178990701-0.74692189125949i, not 7.639704044417283004001468027378811228331E-1-6.45251285265780844205811711312523007406E-1i
*/
#else
return (out_of_range
(sc, sc->exp_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_exp(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_exp(sc->mpc_1, big_complex(x), MPC_RNDNN);
if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->exp_symbol, set_plist_1(sc, x),
a_number_string));
}
}
static s7_pointer g_exp(s7_scheme * sc, s7_pointer args)
{
#define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459"
#define Q_exp sc->pl_nn
return (exp_p_p(sc, car(args)));
}
#if (!WITH_GMP)
static s7_double exp_d_d(s7_double x)
{
return (exp(x));
}
#endif
/* -------------------------------- log -------------------------------- */
#if __cplusplus
#define LOG_2 1.4426950408889634074
#else
#define LOG_2 1.4426950408889634073599246810018921L /* (/ (log 2.0)) */
#endif
static bool is_nan_b_7p(s7_scheme * sc, s7_pointer x);
#if WITH_GMP
static s7_pointer big_log(s7_scheme * sc, s7_pointer args)
{
s7_pointer p0 = car(args), p1 = NULL, res;
if (!is_number(p0))
return (method_or_bust_with_type
(sc, p0, sc->log_symbol, args, a_number_string, 1));
if (is_pair(cdr(args))) {
p1 = cadr(args);
if (!is_number(p1))
return (method_or_bust_with_type
(sc, p1, sc->log_symbol, args, a_number_string, 2));
}
if (is_real(p0)) {
res = any_real_to_mpfr(sc, p0, sc->mpfr_1);
if (res == real_NaN)
return (res);
if ((is_positive(sc, p0)) &&
((!p1) || ((is_real(p1)) && (is_positive(sc, p1))))) {
if (res)
return (res);
mpfr_log(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
if (p1) {
res = any_real_to_mpfr(sc, p1, sc->mpfr_2);
if (res)
return ((res == real_infinity) ? real_zero : res);
if (mpfr_zero_p(sc->mpfr_2))
return (out_of_range
(sc, sc->log_symbol, int_two, p1,
wrap_string(sc, "can't be zero", 13)));
mpfr_log(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN);
mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
}
if ((mpfr_integer_p(sc->mpfr_1))
&& ((is_rational(p0)) && ((!p1) || (is_rational(p1)))))
return (mpfr_to_integer(sc, sc->mpfr_1));
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
}
if (p1) {
res = any_number_to_mpc(sc, p1, sc->mpc_2);
if (res)
return ((res == real_infinity) ? real_zero : complex_NaN);
if (mpc_zero_p(sc->mpc_2))
return (out_of_range
(sc, sc->log_symbol, int_two, p1,
wrap_string(sc, "can't be zero", 13)));
}
res = any_number_to_mpc(sc, p0, sc->mpc_1);
if (res) {
if ((res == real_infinity) && (p1) && ((is_negative(sc, p0))))
return (make_complex_not_0i(sc, INFINITY, -NAN));
return ((res == real_NaN) ? complex_NaN : res);
}
mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
if (p1) {
mpc_log(sc->mpc_2, sc->mpc_2, MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
}
if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
return (mpc_to_number(sc, sc->mpc_1));
}
#endif
static s7_pointer g_log(s7_scheme * sc, s7_pointer args)
{
#define H_log "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults to e: (log 8 2) = 3"
#define Q_log sc->pcl_n
s7_pointer x = car(args);
if (!is_number(x))
return (method_or_bust_with_type
(sc, x, sc->log_symbol, args, a_number_string, 1));
#if WITH_GMP
if (is_big_number(x))
return (big_log(sc, args));
#endif
if (is_pair(cdr(args))) {
s7_pointer y = cadr(args);
if (!(is_number(y)))
return (method_or_bust_with_type
(sc, y, sc->log_symbol, args, a_number_string, 2));
#if WITH_GMP
if (is_big_number(y))
return (big_log(sc, args));
#endif
if ((is_t_integer(y)) && (integer(y) == 2)) {
/* (define (2^n? x) (and (not (zero? x)) (zero? (logand x (- x 1))))) */
if (is_t_integer(x)) {
s7_int ix;
ix = integer(x);
if (ix > 0) {
s7_double fx;
#if (__ANDROID__) || (MS_WINDOWS) || (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ <= 4)))) && (!defined(__clang__)))
/* 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)))) && (!defined(__clang__)))
return (make_real(sc, fx));
#else
return (((ix & (ix - 1)) == 0) ? make_integer(sc,
(s7_int)
s7_round
(fx)) :
make_real(sc, fx));
#endif
}
}
if ((is_real(x)) && (is_positive(sc, x)))
return (make_real(sc, log(s7_real(x)) * LOG_2));
return (c_complex_to_s7(sc, clog(s7_to_c_complex(x)) * LOG_2));
}
if ((is_t_integer(x)) && (integer(x) == 1) && (is_t_integer(y)) && (integer(y) == 1)) /* (log 1 1) -> 0 (this is NaN in the bignum case) */
return (int_zero);
/* (log 1 0) must be 0 since everyone says (expt 0 0) is 1 */
if (is_zero(sc, y)) {
if ((is_t_integer(y)) && (is_t_integer(x))
&& (integer(x) == 1))
return (y);
return (out_of_range
(sc, sc->log_symbol, int_two, y,
wrap_string(sc, "can't be zero", 13)));
}
if ((is_t_real(x)) && (is_NaN(real(x))))
return (real_NaN);
if (is_one(y)) /* this used to raise an error, but the bignum case is simpler if we return inf */
return ((is_one(x)) ? real_zero : real_infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */
if ((is_real(x)) &&
(is_real(y)) && (is_positive(sc, x)) && (is_positive(sc, y))) {
if ((is_rational(x)) && (is_rational(y))) {
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 */
/* since x and y are rational here, it seems reasonable to try to rationalize the result, but not go overboard?
* what about (expt 16 3/2) -> 64? also 2 as base is handled above and always returns a float.
*/
if (fabs(res) < RATIONALIZE_LIMIT) {
s7_int num, den;
if ((c_rationalize
(res, sc->default_rationalize_error, &num, &den))
&& (s7_int_abs(num) < 100)
&& (s7_int_abs(den) < 100))
return (make_simple_ratio(sc, num, den));
}
return (make_real(sc, res));
}
return (make_real(sc, log(s7_real(x)) / log(s7_real(y))));
}
if ((is_t_real(x)) && (is_NaN(real(x))))
return (real_NaN);
if ((is_t_complex(y))
&& ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))))
return (real_NaN);
return (c_complex_to_s7
(sc, clog(s7_to_c_complex(x)) / clog(s7_to_c_complex(y))));
}
if (!is_real(x))
return (c_complex_to_s7(sc, clog(s7_to_c_complex(x))));
if (is_positive(sc, x))
return (make_real(sc, log(s7_real(x))));
return (make_complex_not_0i(sc, log(-s7_real(x)), M_PI));
}
/* -------------------------------- sin -------------------------------- */
#define SIN_LIMIT 1.0e16
#define SINH_LIMIT 20.0
/* (- (sinh (bignum 30.0)) (sinh 30.0)): -3.718172657214174140191915872003397016115E-4
* (- (sinh (bignum 20.0)) (sinh 20.0)): -7.865629467297586346406367346575835463792E-10, slightly worse (e-8) if imag-part
*/
static s7_pointer sin_p_p(s7_scheme * sc, s7_pointer x)
{
#if (!WITH_GMP)
if (is_t_real(x))
return (make_real(sc, sin(real(x)))); /* range check in gmp case */
#endif
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 0)
return (int_zero); /* (sin 0) -> 0 */
#if WITH_GMP
if (integer(x) > SIN_LIMIT) {
mpz_set_si(sc->mpz_1, integer(x));
mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN);
mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, sin((s7_double) (integer(x)))));
case T_RATIO:
return (make_real(sc, sin((s7_double) (fraction(x)))));
case T_REAL:
{
s7_double y = real(x);
#if WITH_GMP
if (fabs(y) > SIN_LIMIT) {
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, sin(y)));
}
case T_COMPLEX:
#if WITH_GMP
if ((fabs(real_part(x)) > SIN_LIMIT)
|| (fabs(imag_part(x)) > SINH_LIMIT)) {
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_sin(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
}
#endif
#if HAVE_COMPLEX_NUMBERS
return (c_complex_to_s7(sc, csin(to_c_complex(x))));
#else
return (out_of_range
(sc, sc->sin_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_sin(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_sin(sc->mpc_1, big_complex(x), MPC_RNDNN);
if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->sin_symbol, a_number_string));
}
/* sin is inaccurate over about 1e30. There's a way to get true results, but it involves fancy "range reduction" techniques.
* (sin 1e32): 0.5852334864823946
* but it should be 3.901970254333630491697613212893425767786E-1
* (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 !! (it's now a range error)
* it should be 5.263007914620499494429139986095833592117E0
* before comparing imag-part to 0, we need to look for NaN and inf, else:
* (sinh 0+0/0i) -> 0.0 and (sinh (log 0.0)) -> inf.0
*/
}
static s7_pointer g_sin(s7_scheme * sc, s7_pointer args)
{
#define H_sin "(sin z) returns sin(z)"
#define Q_sin sc->pl_nn
return (sin_p_p(sc, car(args)));
}
#if WITH_GMP
static s7_pointer sin_p_d(s7_scheme * sc, s7_double x)
{
if (fabs(x) <= SIN_LIMIT)
return (make_real(sc, sin(x)));
mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN);
mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#else
static s7_pointer sin_p_d(s7_scheme * sc, s7_double x)
{
return (make_real(sc, sin(x)));
}
#endif
static s7_double sin_d_d(s7_double x)
{
return (sin(x));
}
/* -------------------------------- cos -------------------------------- */
static s7_pointer cos_p_p(s7_scheme * sc, s7_pointer x)
{
#if (!WITH_GMP)
if (is_t_real(x))
return (make_real(sc, cos(real(x)))); /* range check in gmp case */
#endif
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 0)
return (int_one); /* (cos 0) -> 1 */
#if WITH_GMP
if (integer(x) > SIN_LIMIT) {
mpz_set_si(sc->mpz_1, integer(x));
mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN);
mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, cos((s7_double) (integer(x)))));
case T_RATIO:
return (make_real(sc, cos((s7_double) (fraction(x)))));
case T_REAL: /* if with_gmp */
{
s7_double y = real(x);
#if WITH_GMP
if (fabs(y) > SIN_LIMIT) {
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, cos(y)));
}
case T_COMPLEX:
#if WITH_GMP
if ((fabs(real_part(x)) > SIN_LIMIT)
|| (fabs(imag_part(x)) > SINH_LIMIT)) {
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_cos(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
}
#endif
#if HAVE_COMPLEX_NUMBERS
return (c_complex_to_s7(sc, ccos(to_c_complex(x))));
#else
return (out_of_range
(sc, sc->cos_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_cos(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_cos(sc->mpc_1, big_complex(x), MPC_RNDNN);
if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->cos_symbol, a_number_string));
}
}
static s7_pointer g_cos(s7_scheme * sc, s7_pointer args)
{
#define H_cos "(cos z) returns cos(z)"
#define Q_cos sc->pl_nn
return (cos_p_p(sc, car(args)));
}
#if WITH_GMP
static s7_pointer cos_p_d(s7_scheme * sc, s7_double x)
{
if (fabs(x) <= SIN_LIMIT)
return (make_real(sc, cos(x)));
mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN);
mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#else
static s7_pointer cos_p_d(s7_scheme * sc, s7_double x)
{
return (make_real(sc, cos(x)));
}
#endif
static s7_double cos_d_d(s7_double x)
{
return (cos(x));
}
/* -------------------------------- tan -------------------------------- */
#define TAN_LIMIT 1.0e18
static s7_pointer tan_p_p(s7_scheme * sc, s7_pointer x)
{
#if (!WITH_GMP)
if (is_t_real(x))
return (make_real(sc, tan(real(x))));
#endif
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 0)
return (int_zero); /* (tan 0) -> 0 */
#if WITH_GMP
if (integer(x) > TAN_LIMIT) {
mpz_set_si(sc->mpz_1, integer(x));
mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN);
mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, tan((s7_double) (integer(x)))));
case T_RATIO:
return (make_real(sc, tan((s7_double) (fraction(x)))));
#if WITH_GMP
case T_REAL:
if (fabs(real(x)) > TAN_LIMIT) {
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, tan(real(x))));
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
if (imag_part(x) > 350.0)
return (make_complex_not_0i(sc, 0.0, 1.0));
return ((imag_part(x) < -350.0) ? s7_make_complex(sc, 0.0,
-1.0) :
c_complex_to_s7(sc, ctan(to_c_complex(x))));
#else
return (out_of_range
(sc, sc->tan_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_tan(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, 350))) > 0)
return (make_complex_not_0i(sc, 0.0, 1.0));
if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, -350))) < 0)
return (make_complex_not_0i(sc, 0.0, -1.0));
mpc_tan(sc->mpc_1, big_complex(x), MPC_RNDNN);
if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->tan_symbol, a_number_string));
}
}
static s7_pointer g_tan(s7_scheme * sc, s7_pointer args)
{
#define H_tan "(tan z) returns tan(z)"
#define Q_tan sc->pl_nn
return (tan_p_p(sc, car(args)));
}
static s7_double tan_d_d(s7_double x)
{
return (tan(x));
}
/* -------------------------------- asin -------------------------------- */
static s7_pointer c_asin(s7_scheme * sc, s7_double x)
{
s7_double absx = fabs(x), recip;
s7_complex result;
if (absx <= 1.0)
return (make_real(sc, asin(x)));
/* otherwise use maxima code: */
recip = 1.0 / absx;
result =
(M_PI / 2.0) -
(_Complex_I *
clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))));
return ((x < 0.0) ? c_complex_to_s7(sc, -result) : c_complex_to_s7(sc,
result));
}
static s7_pointer asin_p_p(s7_scheme * sc, s7_pointer p)
{
if (is_t_real(p))
return (c_asin(sc, real(p)));
switch (type(p)) {
case T_INTEGER:
if (integer(p) == 0)
return (int_zero); /* (asin 0) -> 0 */
/* in netBSD, (asin 2) returns 0.25383842987008+0.25383842987008i according to Peter Bex */
return (c_asin(sc, (s7_double) integer(p)));
case T_RATIO:
return (c_asin(sc, fraction(p)));
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(p)) > 1.0e7) || (fabs(imag_part(p)) > 1.0e7)) {
s7_complex sq1mz, sq1pz, z;
z = to_c_complex(p);
sq1mz = csqrt(1.0 - z);
sq1pz = csqrt(1.0 + z);
return (s7_make_complex
(sc, atan(real_part(p) / creal(sq1mz * sq1pz)),
asinh(cimag(sq1pz * conj(sq1mz)))));
}
return (c_complex_to_s7(sc, casin(to_c_complex(p))));
#else
return (out_of_range
(sc, sc->asin_symbol, int_one, p,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN);
goto ASIN_BIG_REAL;
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN);
goto ASIN_BIG_REAL;
case T_BIG_REAL:
if (mpfr_inf_p(big_real(p))) {
if (mpfr_cmp_ui(big_real(p), 0) < 0)
return (make_complex_not_0i(sc, NAN, INFINITY)); /* match non-bignum choice */
return (make_complex_not_0i(sc, NAN, -INFINITY));
}
mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN);
ASIN_BIG_REAL:
mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN);
if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) {
mpfr_asin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN);
mpc_asin(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_asin(sc->mpc_1, big_complex(p), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->asin_symbol, a_number_string));
}
}
static s7_pointer g_asin(s7_scheme * sc, s7_pointer args)
{
#define H_asin "(asin z) returns asin(z); (sin (asin x)) = x"
#define Q_asin sc->pl_nn
return (asin_p_p(sc, car(args)));
}
/* -------------------------------- acos -------------------------------- */
static s7_pointer c_acos(s7_scheme * sc, s7_double x)
{
s7_double absx = fabs(x), recip;
s7_complex result;
if (absx <= 1.0)
return (make_real(sc, acos(x)));
/* else follow maxima again: */
recip = 1.0 / absx;
if (x > 0.0)
result =
_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 (c_complex_to_s7(sc, result));
}
static s7_pointer acos_p_p(s7_scheme * sc, s7_pointer p)
{
if (is_t_real(p))
return (c_acos(sc, real(p)));
switch (type(p)) {
case T_INTEGER:
return ((integer(p) == 1) ? int_zero : c_acos(sc, (s7_double)
integer(p)));
case T_RATIO:
return (c_acos(sc, fraction(p)));
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(p)) > 1.0e7) || (fabs(imag_part(p)) > 1.0e7)) {
s7_complex sq1mz, sq1pz, z;
z = to_c_complex(p);
sq1mz = csqrt(1.0 - z);
sq1pz = csqrt(1.0 + z); /* creal(sq1pz) can be 0.0 */
if (creal(sq1pz) == 0.0) /* so the atan arg will be inf, so the real part will be pi/2(?) */
return (s7_make_complex
(sc, M_PI / 2.0,
asinh(cimag(sq1mz * conj(sq1pz)))));
return (s7_make_complex
(sc, 2.0 * atan(creal(sq1mz) / creal(sq1pz)),
asinh(cimag(sq1mz * conj(sq1pz)))));
}
return (c_complex_to_s7(sc, cacos(s7_to_c_complex(p))));
#else
return (out_of_range
(sc, sc->acos_symbol, int_one, p,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN);
goto ACOS_BIG_REAL;
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN);
goto ACOS_BIG_REAL;
case T_BIG_REAL:
if (mpfr_inf_p(big_real(p))) {
if (mpfr_cmp_ui(big_real(p), 0) < 0)
return (make_complex_not_0i(sc, -NAN, -INFINITY)); /* match non-bignum choice */
return (make_complex_not_0i(sc, -NAN, INFINITY));
}
mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN);
ACOS_BIG_REAL:
mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN);
if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) {
mpfr_acos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN);
mpc_acos(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_acos(sc->mpc_1, big_complex(p), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->acos_symbol, a_number_string));
}
}
static s7_pointer g_acos(s7_scheme * sc, s7_pointer args)
{
#define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1"
#define Q_acos sc->pl_nn
return (acos_p_p(sc, car(args)));
}
/* -------------------------------- atan -------------------------------- */
static s7_pointer g_atan(s7_scheme * sc, s7_pointer args)
{
#define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)"
#define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)
/* actually if there are two args, both should be real, but how to express that in the signature? */
s7_pointer x = car(args), y;
/* currently (atan inf.0 inf.0) -> 0.78539816339745, and (atan inf.0 -inf.0) -> 2.3561944901923 (etc) */
if (!is_pair(cdr(args))) {
switch (type(x)) {
case T_INTEGER:
return ((integer(x) == 0) ? int_zero : make_real(sc,
atan((double)
integer
(x))));
case T_RATIO:
return (make_real(sc, atan(fraction(x))));
case T_REAL:
return (make_real(sc, atan(real(x))));
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
return (c_complex_to_s7(sc, catan(to_c_complex(x))));
#else
return (out_of_range
(sc, sc->atan_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_atan(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_atan(sc->mpc_1, big_complex(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->atan_symbol, args, a_number_string));
}
}
y = cadr(args);
switch (type(x)) {
case T_INTEGER:
case T_RATIO:
case T_REAL:
if (is_small_real(y))
return (make_real(sc, atan2(s7_real(x), s7_real(y))));
#if WITH_GMP
if (!is_real(y))
return (method_or_bust
(sc, y, sc->atan_symbol, args, T_REAL, 2));
mpfr_set_d(sc->mpfr_1, s7_real(x), MPFR_RNDN);
goto ATAN2_BIG_REAL;
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
goto ATAN2_BIG_REAL;
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
goto ATAN2_BIG_REAL;
case T_BIG_REAL:
mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN);
goto ATAN2_BIG_REAL;
#endif
default:
return (method_or_bust(sc, x, sc->atan_symbol, args, T_REAL, 1));
}
#if WITH_GMP
ATAN2_BIG_REAL:
if (is_small_real(y))
mpfr_set_d(sc->mpfr_2, s7_real(y), MPFR_RNDN);
else if (is_t_big_real(y))
mpfr_set(sc->mpfr_2, big_real(y), MPFR_RNDN);
else if (is_t_big_integer(y))
mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN);
else if (is_t_big_ratio(y))
mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
else
return (method_or_bust(sc, y, sc->atan_symbol, args, T_REAL, 2));
mpfr_atan2(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
#endif
}
static s7_double atan_d_dd(s7_double x, s7_double y)
{
return (atan2(x, y));
}
/* -------------------------------- sinh -------------------------------- */
static s7_pointer g_sinh(s7_scheme * sc, s7_pointer args)
{
#define H_sinh "(sinh z) returns sinh(z)"
#define Q_sinh sc->pl_nn
s7_pointer x = car(args);
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 0)
return (int_zero); /* (sinh 0) -> 0 */
case T_REAL:
case T_RATIO:
{
s7_double y = s7_real(x);
#if WITH_GMP
if (fabs(y) > SINH_LIMIT) {
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, sinh(y)));
}
case T_COMPLEX:
#if WITH_GMP
if ((fabs(real_part(x)) > SINH_LIMIT)
|| (fabs(imag_part(x)) > SINH_LIMIT)) {
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_sinh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
}
#endif
#if HAVE_COMPLEX_NUMBERS
return (c_complex_to_s7(sc, csinh(to_c_complex(x))));
#else
return (out_of_range
(sc, sc->sinh_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_sinh(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_sinh(sc->mpc_1, big_complex(x), MPC_RNDNN);
if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->sinh_symbol, args, a_number_string));
}
}
#if (!WITH_GMP)
static s7_double sinh_d_d(s7_double x)
{
return (sinh(x));
}
#endif
/* -------------------------------- cosh -------------------------------- */
static s7_pointer g_cosh(s7_scheme * sc, s7_pointer args)
{
#define H_cosh "(cosh z) returns cosh(z)"
#define Q_cosh sc->pl_nn
s7_pointer x = car(args);
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 0)
return (int_one); /* (cosh 0) -> 1 */
case T_REAL:
case T_RATIO:
{
s7_double y;
y = s7_real(x);
#if WITH_GMP
if (fabs(y) > SINH_LIMIT) {
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, cosh(y)));
}
case T_COMPLEX:
#if WITH_GMP
if ((fabs(real_part(x)) > SINH_LIMIT)
|| (fabs(imag_part(x)) > SINH_LIMIT)) {
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_cosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
}
#endif
#if HAVE_COMPLEX_NUMBERS
return (c_complex_to_s7(sc, ccosh(to_c_complex(x))));
#else
return (out_of_range
(sc, sc->cosh_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_cosh(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_cosh(sc->mpc_1, big_complex(x), MPC_RNDNN);
if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->cosh_symbol, args, a_number_string));
}
}
#if (!WITH_GMP)
static s7_double cosh_d_d(s7_double x)
{
return (cosh(x));
}
#endif
/* -------------------------------- tanh -------------------------------- */
#define TANH_LIMIT 350.0
static s7_pointer g_tanh(s7_scheme * sc, s7_pointer args)
{
#define H_tanh "(tanh z) returns tanh(z)"
#define Q_tanh sc->pl_nn
s7_pointer x = car(args);
switch (type(x)) {
case T_INTEGER:
return ((integer(x) == 0) ? int_zero : make_real(sc,
tanh((s7_double)
integer
(x))));
case T_RATIO:
return (make_real(sc, tanh(fraction(x))));
case T_REAL:
return (make_real(sc, tanh(real(x))));
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
if (real_part(x) > TANH_LIMIT)
return (real_one); /* closer than 0.0 which is what ctanh is about to return! */
if (real_part(x) < -TANH_LIMIT)
return (make_real(sc, -1.0)); /* closer than ctanh's -0.0 */
return (c_complex_to_s7(sc, ctanh(to_c_complex(x))));
#else
return (out_of_range
(sc, sc->tanh_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
goto BIG_REAL_TANH;
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
goto BIG_REAL_TANH;
case T_BIG_REAL:
if (mpfr_nan_p(big_real(x)))
return (real_NaN);
mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN);
BIG_REAL_TANH:
if (mpfr_cmp_d(sc->mpfr_1, TANH_LIMIT) > 0)
return (real_one);
if (mpfr_cmp_d(sc->mpfr_1, -TANH_LIMIT) < 0)
return (make_real(sc, -1.0));
mpfr_tanh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), TANH_LIMIT, 1))) >
0)
return (real_one);
if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), -TANH_LIMIT, 1))) <
0)
return (make_real(sc, -1.0));
if ((mpfr_nan_p(mpc_imagref(big_complex(x)))) ||
(mpfr_inf_p(mpc_imagref(big_complex(x))))) {
if (mpfr_cmp_ui(mpc_realref(big_complex(x)), 0) == 0)
return (make_complex_not_0i(sc, 0.0, NAN)); /* match non-bignum choice */
return (complex_NaN);
}
mpc_tanh(sc->mpc_1, big_complex(x), MPC_RNDNN);
if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->tanh_symbol, args, a_number_string));
}
}
static s7_double tanh_d_d(s7_double x)
{
return (tanh(x));
}
/* -------------------------------- asinh -------------------------------- */
static s7_pointer g_asinh(s7_scheme * sc, s7_pointer args)
{
#define H_asinh "(asinh z) returns asinh(z)"
#define Q_asinh sc->pl_nn
s7_pointer x = car(args);
switch (type(x)) {
case T_INTEGER:
return ((integer(x) == 0) ? int_zero : make_real(sc,
asinh((s7_double)
integer
(x))));
case T_RATIO:
return (make_real(sc, asinh(fraction(x))));
case T_REAL:
return (make_real(sc, asinh(real(x))));
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
#if (defined(__OpenBSD__)) || (defined(__NetBSD__))
return (c_complex_to_s7(sc, casinh_1(to_c_complex(x))));
#else
return (c_complex_to_s7(sc, casinh(to_c_complex(x))));
#endif
#else
return (out_of_range
(sc, sc->asinh_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_asinh(sc->mpfr_1, big_real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_asinh(sc->mpc_1, big_complex(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->asinh_symbol, a_number_string));
}
}
/* -------------------------------- acosh -------------------------------- */
static s7_pointer g_acosh(s7_scheme * sc, s7_pointer args)
{
#define H_acosh "(acosh z) returns acosh(z)"
#define Q_acosh sc->pl_nn
s7_pointer x = car(args);
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 1)
return (int_zero);
case T_REAL:
case T_RATIO:
{
double x1 = s7_real(x);
if (x1 >= 1.0)
return (make_real(sc, acosh(x1)));
}
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
#ifdef __OpenBSD__
return (c_complex_to_s7(sc, cacosh_1(s7_to_c_complex(x))));
#else
return (c_complex_to_s7(sc, cacosh(s7_to_c_complex(x)))); /* not to_c_complex because x might not be complex */
#endif
#else
/* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */
return (out_of_range
(sc, sc->acosh_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
mpc_set_fr(sc->mpc_1, big_real(x), MPC_RNDNN);
mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_acosh(sc->mpc_1, big_complex(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->acosh_symbol, a_number_string));
}
}
/* -------------------------------- atanh -------------------------------- */
static s7_pointer g_atanh(s7_scheme * sc, s7_pointer args)
{
#define H_atanh "(atanh z) returns atanh(z)"
#define Q_atanh sc->pl_nn
s7_pointer x = car(args);
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 0)
return (int_zero); /* (atanh 0) -> 0 */
case T_REAL:
case T_RATIO:
{
double x1 = s7_real(x);
if (fabs(x1) < 1.0)
return (make_real(sc, atanh(x1)));
}
/* if we can't distinguish x from 1.0 even with long_doubles, we'll get inf.0:
* (atanh 9223372036854775/9223372036854776) -> 18.714973875119
* (atanh 92233720368547758/92233720368547757) -> inf.0
* (atanh (bignum 92233720368547758/92233720368547757)) -> 1.987812468492420421418925013176932317086E1+1.570796326794896619231321691639751442098E0i
* but the imaginary part is unnecessary
*/
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
#if (defined(__OpenBSD__)) || (defined(__NetBSD__))
return (c_complex_to_s7(sc, catanh_1(s7_to_c_complex(x))));
#else
return (c_complex_to_s7(sc, catanh(s7_to_c_complex(x))));
#endif
#else
return (out_of_range
(sc, sc->atanh_symbol, int_one, x,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_2, big_integer(x), MPFR_RNDN);
goto ATANH_BIG_REAL;
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_2, big_ratio(x), MPFR_RNDN);
goto ATANH_BIG_REAL;
case T_BIG_REAL:
mpfr_set(sc->mpfr_2, big_real(x), MPFR_RNDN);
ATANH_BIG_REAL:
mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN);
if (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) < 0) {
mpfr_atanh(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_2));
}
mpc_set_fr(sc->mpc_1, sc->mpfr_2, MPC_RNDNN);
mpc_atanh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_atanh(sc->mpc_1, big_complex(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->atanh_symbol, a_number_string));
}
}
/* -------------------------------- sqrt -------------------------------- */
static s7_pointer sqrt_p_p(s7_scheme * sc, s7_pointer p)
{
switch (type(p)) {
case T_INTEGER:
{
s7_double sqx;
if (integer(p) >= 0) {
s7_int ix;
#if WITH_GMP
mpz_set_si(sc->mpz_1, integer(p));
mpz_sqrtrem(sc->mpz_1, sc->mpz_2, sc->mpz_1);
if (mpz_cmp_ui(sc->mpz_2, 0) == 0)
return (make_integer(sc, mpz_get_si(sc->mpz_1)));
mpfr_set_si(sc->mpfr_1, integer(p), MPFR_RNDN);
mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
#endif
sqx = sqrt((s7_double) integer(p));
ix = (s7_int) sqx;
return (((ix * ix) == integer(p)) ? make_integer(sc,
ix) :
make_real(sc, sqx));
/* Mark Weaver notes that (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t
* but (* 94906265 94906265) -> 9007199136250225 -- oops
* if we use bigfloats, we're ok:
* (* (sqrt 9007199136250226.0) (sqrt 9007199136250226.0)) -> 9.007199136250226000000000000000000000026E15
* at least we return a real here, not an incorrect integer and (sqrt 9007199136250225) -> 94906265
*/
}
#if HAVE_COMPLEX_NUMBERS
#if WITH_GMP
mpc_set_si(sc->mpc_1, integer(p), MPC_RNDNN);
mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
sqx = (s7_double) integer(p); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */
return (s7_make_complex(sc, 0.0, sqrt((s7_double) (-sqx))));
#else
return (out_of_range
(sc, sc->sqrt_symbol, int_one, p,
no_complex_numbers_string));
#endif
}
case T_RATIO:
if (numerator(p) > 0) { /* else it's complex, so it can't be a ratio */
s7_int nm = (s7_int) sqrt(numerator(p));
if (nm * nm == numerator(p)) {
s7_int dn = (s7_int) sqrt(denominator(p));
if (dn * dn == denominator(p))
return (make_ratio(sc, nm, dn));
}
return (make_real(sc, sqrt((s7_double) fraction(p))));
}
#if HAVE_COMPLEX_NUMBERS
return (s7_make_complex
(sc, 0.0, sqrt((s7_double) (-fraction(p)))));
#else
return (out_of_range
(sc, sc->sqrt_symbol, int_one, p,
no_complex_numbers_string));
#endif
case T_REAL:
if (is_NaN(real(p)))
return (real_NaN);
if (real(p) >= 0.0)
return (make_real(sc, sqrt(real(p))));
return (make_complex_not_0i(sc, 0.0, sqrt(-real(p))));
case T_COMPLEX: /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */
#if HAVE_COMPLEX_NUMBERS
return (c_complex_to_s7(sc, csqrt(to_c_complex(p)))); /* sqrt(+inf.0+1.0i) -> +inf.0 */
#else
return (out_of_range
(sc, sc->sqrt_symbol, int_one, p,
no_complex_numbers_string));
#endif
#if WITH_GMP
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(p), 0) >= 0) {
mpz_sqrtrem(sc->mpz_1, sc->mpz_2, big_integer(p));
if (mpz_cmp_ui(sc->mpz_2, 0) == 0)
return (mpz_to_integer(sc, sc->mpz_1));
mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN);
mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
mpc_set_z(sc->mpc_1, big_integer(p), MPC_RNDNN);
mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO: /* if big ratio, check both num and den for squares */
if (mpq_cmp_ui(big_ratio(p), 0, 1) < 0) {
mpc_set_q(sc->mpc_1, big_ratio(p), MPC_RNDNN);
mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
}
mpz_sqrtrem(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(p)));
if (mpz_cmp_ui(sc->mpz_2, 0) == 0) {
mpz_sqrtrem(sc->mpz_3, sc->mpz_2, mpq_denref(big_ratio(p)));
if (mpz_cmp_ui(sc->mpz_2, 0) == 0) {
mpq_set_num(sc->mpq_1, sc->mpz_1);
mpq_set_den(sc->mpq_1, sc->mpz_3);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
}
}
mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN);
mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
if (mpfr_cmp_ui(big_real(p), 0) < 0) {
mpc_set_fr(sc->mpc_1, big_real(p), MPC_RNDNN);
mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
}
mpfr_sqrt(sc->mpfr_1, big_real(p), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_sqrt(sc->mpc_1, big_complex(p), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->sqrt_symbol, a_number_string));
}
}
static s7_pointer g_sqrt(s7_scheme * sc, s7_pointer args)
{
#define H_sqrt "(sqrt z) returns the square root of z"
#define Q_sqrt sc->pl_nn
return (sqrt_p_p(sc, car(args)));
}
/* -------------------------------- expt -------------------------------- */
static s7_int int_to_int(s7_int x, s7_int n)
{
/* from GSL */
s7_int value = 1;
do {
if (n & 1)
value *= x;
n >>= 1;
#if HAVE_OVERFLOW_CHECKS
if (multiply_overflow(x, x, &x))
break;
#else
x *= x;
#endif
} while (n);
return (value);
}
static const int64_t nth_roots[63] = {
S7_INT64_MAX, S7_INT64_MAX, 3037000499LL, 2097151, 55108, 6208, 1448,
511, 234, 127, 78, 52, 38, 28, 22,
18, 15, 13, 11, 9, 8, 7, 7, 6, 6, 5, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3,
3, 3, 3, 2, 2, 2, 2, 2, 2,
2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2
};
static bool int_pow_ok(s7_int x, s7_int y)
{
return ((y < S7_INT_BITS) && (nth_roots[y] >= s7_int_abs(x)));
}
#if WITH_GMP
static s7_pointer real_part_p_p(s7_scheme * sc, s7_pointer p);
static bool lt_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2);
static s7_pointer big_expt(s7_scheme * sc, s7_pointer args)
{
s7_pointer x = car(args), y, res;
if (!is_number(x))
return (method_or_bust_with_type
(sc, x, sc->expt_symbol, args, a_number_string, 1));
y = cadr(args);
if (!is_number(y))
return (method_or_bust_with_type
(sc, y, sc->expt_symbol, args, a_number_string, 2));
if (is_zero(sc, x)) {
if ((s7_is_integer(x)) && (s7_is_integer(y)) && (is_zero(sc, y)))
return (int_one);
if (is_real(y)) {
if (is_negative(sc, y))
return (division_by_zero_error(sc, sc->expt_symbol, args));
} else if (is_negative(sc, real_part_p_p(sc, y))) /* handle big_complex as well as complex */
return (division_by_zero_error(sc, sc->expt_symbol, args));
if ((is_rational(x)) && (is_rational(y)))
return (int_zero);
return (real_zero);
}
if (s7_is_integer(y)) {
s7_int yval;
yval = s7_integer_checked(sc, y);
if (yval == 0)
return ((is_rational(x)) ? int_one : real_one);
if (yval == 1)
return (x);
if ((!is_big_number(x)) && ((is_one(x)) || (is_zero(sc, x))))
return (x);
if ((yval < S7_INT32_MAX) && (yval > S7_INT32_MIN)) {
/* (protect against gmp exception if for example (expt 1/9223372036854775807 -9223372036854775807) */
if (s7_is_integer(x)) {
if (is_t_big_integer(x))
mpz_set(sc->mpz_2, big_integer(x));
else
mpz_set_si(sc->mpz_2, integer(x));
if (yval >= 0) {
mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t) yval);
return (mpz_to_integer(sc, sc->mpz_2));
}
mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t) (-yval));
mpq_set_z(sc->mpq_1, sc->mpz_2);
mpq_inv(sc->mpq_1, sc->mpq_1);
if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0)
return (mpz_to_integer(sc, mpq_numref(sc->mpq_1)));
return (mpq_to_big_ratio(sc, sc->mpq_1));
}
if (s7_is_ratio(x)) { /* here y is an integer */
if (is_t_big_ratio(x)) {
mpz_set(sc->mpz_1, mpq_numref(big_ratio(x)));
mpz_set(sc->mpz_2, mpq_denref(big_ratio(x)));
} else {
mpz_set_si(sc->mpz_1, numerator(x));
mpz_set_si(sc->mpz_2, denominator(x));
}
if (yval >= 0) {
mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t) yval);
mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t) yval);
mpq_set_num(sc->mpq_1, sc->mpz_1);
mpq_set_den(sc->mpq_1, sc->mpz_2);
} else {
yval = -yval;
mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t) yval);
mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t) yval);
mpq_set_num(sc->mpq_1, sc->mpz_2);
mpq_set_den(sc->mpq_1, sc->mpz_1);
mpq_canonicalize(sc->mpq_1);
}
if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0)
return (mpz_to_integer(sc, mpq_numref(sc->mpq_1)));
return (mpq_to_big_ratio(sc, sc->mpq_1));
}
if (is_real(x)) {
if (is_t_big_real(x))
mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN);
else
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_pow_si(sc->mpfr_1, sc->mpfr_1, yval, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
}
}
if ((is_t_ratio(y)) && /* not s7_is_ratio which accepts bignums */
(numerator(y) == 1)) {
if (denominator(y) == 2)
return (sqrt_p_p(sc, x));
if ((is_real(x)) && (denominator(y) == 3)) {
any_real_to_mpfr(sc, x, sc->mpfr_1);
mpfr_cbrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
}
res = any_number_to_mpc(sc, y, sc->mpc_2);
if (res == real_infinity) {
if (is_one(x))
return (int_one);
if (!is_real(x))
return ((is_negative(sc, y)) ? real_zero : complex_NaN);
if (is_zero(sc, x)) {
if (is_negative(sc, y))
return (division_by_zero_error(sc, sc->expt_symbol, args));
return (real_zero);
}
if (lt_b_pi(sc, x, 0)) {
if (lt_b_pi(sc, x, -1))
return ((is_positive(sc, y)) ? real_infinity : real_zero);
return ((is_positive(sc, y)) ? real_zero : real_infinity);
}
if (lt_b_pi(sc, x, 1))
return ((is_positive(sc, y)) ? real_zero : real_infinity);
return ((is_positive(sc, y)) ? real_infinity : real_zero);
}
if (res)
return (complex_NaN);
if ((is_real(x)) && (is_real(y)) && (is_positive(sc, x))) {
res = any_real_to_mpfr(sc, x, sc->mpfr_1);
if (res) {
if (res == real_infinity) {
if (is_negative(sc, y))
return (real_zero);
return ((is_zero(sc, y)) ? real_one : real_infinity);
}
return (complex_NaN);
}
mpfr_pow(sc->mpfr_1, sc->mpfr_1, mpc_realref(sc->mpc_2),
MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
res = any_number_to_mpc(sc, x, sc->mpc_1);
if (res) {
if ((res == real_infinity) && (is_real(y))) {
if (is_negative(sc, y))
return (real_zero);
return ((is_zero(sc, y)) ? real_one : real_infinity);
}
return (complex_NaN);
}
if (mpc_cmp_si_si(sc->mpc_1, 0, 0) == 0)
return (int_zero);
if (mpc_cmp_si_si(sc->mpc_1, 1, 0) == 0)
return (int_one);
mpc_pow(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
if ((!mpfr_nan_p(mpc_imagref(sc->mpc_1))) && (mpfr_cmp_ui(mpc_imagref(sc->mpc_1), 0) == 0)) { /* (expt -inf.0 1/3) -> +inf.0+nan.0i in mpc */
if ((is_rational(car(args))) &&
(is_rational(cadr(args))) &&
(mpfr_integer_p(mpc_realref(sc->mpc_1)) != 0)) {
/* mpfr_integer_p can be confused: (expt 2718/1000 (bignum 617/5)) returns an int32_t if precision=128, float if 512 */
/* so first make sure we're within (say) 31 bits */
mpfr_set_ui(sc->mpfr_1, S7_INT32_MAX, MPFR_RNDN);
if (mpfr_cmpabs(mpc_realref(sc->mpc_1), sc->mpfr_1) < 0) {
mpfr_get_z(sc->mpz_1, mpc_realref(sc->mpc_1), MPFR_RNDN);
return (mpz_to_integer(sc, sc->mpz_1));
}
}
mpfr_set(sc->mpfr_1, mpc_realref(sc->mpc_1), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
return (mpc_to_number(sc, sc->mpc_1));
}
#endif
static s7_pointer g_expt(s7_scheme * sc, s7_pointer args)
{
#define H_expt "(expt z1 z2) returns z1^z2"
#define Q_expt sc->pcl_n
s7_pointer n = car(args), pw;
#if WITH_GMP
return (big_expt(sc, args));
/* big_expt sometimes chooses a different value: g_expt (expt -1 1/3) is -1, but big_expt (expt -1 (bignum 1/3)) is (complex 1/2 (/ (sqrt 3) 2)) */
#endif
if (!is_number(n))
return (method_or_bust_with_type
(sc, n, sc->expt_symbol, args, a_number_string, 1));
pw = cadr(args);
if (!is_number(pw))
return (method_or_bust_with_type
(sc, pw, sc->expt_symbol, args, a_number_string, 2));
if (is_zero(sc, n)) {
if (is_zero(sc, pw)) {
if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* (expt 0 0) -> 1 */
return (int_one);
return (real_zero); /* (expt 0.0 0) -> 0.0 */
}
if (is_real(pw)) {
if (is_negative(sc, pw)) /* (expt 0 -1) */
return (division_by_zero_error(sc, sc->expt_symbol, args));
/* (Clisp gives divide-by-zero error here, Guile returns inf.0) */
if (is_NaN(s7_real(pw))) /* (expt 0 +nan.0) */
return (pw);
} else { /* (expt 0 a+bi) */
if (real_part(pw) < 0.0) /* (expt 0 -1+i) */
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 (int_zero);
return (real_zero); /* (expt 0.0 123123) */
}
if (is_one(pw)) {
if (s7_is_integer(pw)) /* (expt x 1) */
return (n);
if (is_rational(n)) /* (expt ratio 1.0) */
return (make_real(sc, rational_to_double(sc, n)));
return (n);
}
if (is_t_integer(pw)) {
s7_int y = integer(pw);
if (y == 0) {
if (is_rational(n)) /* (expt 3 0) */
return (int_one);
if ((is_NaN(s7_real_part(n))) || /* (expt 1/0 0) -> NaN */
(is_NaN(s7_imag_part(n)))) /* (expt (complex 0 1/0) 0) -> NaN */
return (n);
return (real_one); /* (expt 3.0 0) */
}
switch (type(n)) {
case T_INTEGER:
{
s7_int x;
x = integer(n);
if (x == 1) /* (expt 1 y) */
return (n);
if (x == -1) {
if (y == S7_INT64_MIN) /* (expt -1 most-negative-fixnum) */
return (int_one);
if (s7_int_abs(y) & 1) /* (expt -1 odd-int) */
return (n);
return (int_one); /* (expt -1 even-int) */
}
if (y == S7_INT64_MIN) /* (expt x most-negative-fixnum) */
return (int_zero);
if (x == S7_INT64_MIN) /* (expt most-negative-fixnum y) */
return (make_real(sc, pow((double) x, (double) y)));
if (int_pow_ok(x, s7_int_abs(y))) {
if (y > 0)
return (make_integer(sc, int_to_int(x, y)));
return (make_ratio(sc, 1, int_to_int(x, -y)));
}
}
break;
case T_RATIO:
{
s7_int nm = numerator(n), dn = denominator(n);
if (y == S7_INT64_MIN) {
if (s7_int_abs(nm) > dn)
return (int_zero); /* (expt 4/3 most-negative-fixnum) -> 0? */
return (real_infinity); /* (expt 3/4 most-negative-fixnum) -> inf? */
}
if ((int_pow_ok(nm, s7_int_abs(y))) &&
(int_pow_ok(dn, s7_int_abs(y)))) {
if (y > 0)
return (make_ratio
(sc, int_to_int(nm, y),
int_to_int(dn, y)));
return (s7_make_ratio
(sc, int_to_int(dn, -y), int_to_int(nm, -y)));
}
}
break;
/* occasionally int^rat can be int32_t but it happens so infrequently it's probably not worth checking
* one possibly easy case: (expt 1 1/2) -> 1 (-1?) etc
*/
case T_REAL:
/* (expt -1.0 most-positive-fixnum) should be -1.0
* (expt -1.0 (+ (expt 2 53) 1)) -> -1.0
* (expt -1.0 (- 1 (expt 2 54))) -> -1.0
*/
if (real(n) == -1.0) {
if (y == S7_INT64_MIN)
return (real_one);
return ((s7_int_abs(y) & 1) ? n : real_one);
}
break;
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
if ((s7_real_part(n) == 0.0) &&
((s7_imag_part(n) == 1.0) || (s7_imag_part(n) == -1.0))) {
bool yp, 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 (make_complex_not_0i
(sc, 0.0, (yp == np) ? 1.0 : -1.0));
case 2:
return (make_real(sc, -1.0));
case 3:
return (make_complex_not_0i
(sc, 0.0, (yp == np) ? -1.0 : 1.0));
}
}
#else
return (out_of_range
(sc, sc->expt_symbol, int_two, n,
no_complex_numbers_string));
#endif
break;
}
}
if ((is_real(n)) && (is_real(pw))) {
s7_double x, y;
if ((is_t_ratio(pw)) && (numerator(pw) == 1)) {
if (denominator(pw) == 2)
return (sqrt_p_p(sc, n));
if (denominator(pw) == 3)
return (make_real(sc, cbrt(s7_real(n)))); /* (expt 27 1/3) should be 3, not 3.0... */
/* but: (expt 512/729 1/3) -> 0.88888888888889, and 4 -> sqrt(sqrt...) etc? */
}
x = s7_real(n);
y = s7_real(pw);
if (is_NaN(x))
return (n);
if (is_NaN(y))
return (pw);
if (y == 0.0)
return (real_one);
/* I think pow(rl, inf) is ok */
if (x > 0.0)
return (make_real(sc, pow(x, y))); /* tricky cases abound here: (expt -1 1/9223372036854775807) */
}
/* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ?
* (expt 0+i 1+1/0i) = 0.0 ??
*/
return (c_complex_to_s7
(sc, cpow(s7_to_c_complex(n), s7_to_c_complex(pw))));
}
/* -------------------------------- lcm -------------------------------- */
#if WITH_GMP
static s7_pointer big_lcm(s7_scheme * sc, s7_int num, s7_int den,
s7_pointer args)
{
s7_pointer x;
mpz_set_si(sc->mpz_3, num);
mpz_set_si(sc->mpz_4, den);
for (x = args; is_pair(x); x = cdr(x)) {
s7_pointer rat = car(x);
switch (type(rat)) {
case T_INTEGER:
mpz_set_si(sc->mpz_1, integer(rat));
mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1);
mpz_set_si(sc->mpz_4, 1);
break;
case T_RATIO:
mpz_set_si(sc->mpz_1, numerator(rat));
mpz_set_si(sc->mpz_2, denominator(rat));
mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1);
mpz_gcd(sc->mpz_4, sc->mpz_4, sc->mpz_2);
break;
case T_BIG_INTEGER:
mpz_lcm(sc->mpz_3, sc->mpz_3, big_integer(rat));
mpz_set_si(sc->mpz_4, 1);
break;
case T_BIG_RATIO:
mpz_lcm(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat)));
mpz_gcd(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat)));
break;
case T_REAL:
case T_BIG_REAL:
case T_COMPLEX:
case T_BIG_COMPLEX:
return (wrong_type_argument_with_type
(sc, sc->lcm_symbol, position_of(x, args), rat,
a_rational_string));
default:
return (method_or_bust_with_type(sc, rat, sc->lcm_symbol,
set_ulist_1(sc,
mpz_to_rational
(sc, sc->mpz_3,
sc->mpz_4), x),
a_rational_string,
position_of(x, args)));
}
}
return (mpz_to_rational(sc, sc->mpz_3, sc->mpz_4));
}
#endif
static s7_pointer g_lcm(s7_scheme * sc, s7_pointer args)
{
/* (/ (* m n) (gcd m n)), (lcm a b c) -> (lcm a (lcm b c)) */
#define H_lcm "(lcm ...) returns the least common multiple of its rational arguments"
#define Q_lcm sc->pcl_f
s7_int n = 1, d = 0;
s7_pointer p;
if (!is_pair(args))
return (int_one);
if (!is_pair(cdr(args))) {
if (!is_rational(car(args)))
return (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 = car(p);
s7_int b;
#if HAVE_OVERFLOW_CHECKS
s7_int n1;
#endif
switch (type(x)) {
case T_INTEGER:
d = 1;
if (integer(x) == 0) { /* return 0 unless there's a wrong-type-arg (geez what a mess) */
for (p = cdr(p); is_pair(p); p = cdr(p)) {
s7_pointer x1 = car(p);
if (is_number(x1)) {
if (!is_rational(x1))
return (wrong_type_argument_with_type
(sc, sc->lcm_symbol,
position_of(p, args), x1,
a_rational_string));
} else if (has_active_methods(sc, x1)) {
s7_pointer f;
f = find_method_with_let(sc, x1,
sc->is_rational_symbol);
if ((f == sc->undefined)
||
(is_false
(sc,
call_method(sc, x1, f,
set_plist_1(sc, x1)))))
return (wrong_type_argument_with_type
(sc, sc->lcm_symbol,
position_of(p, args), x1,
a_rational_string));
} else
return (wrong_type_argument_with_type
(sc, sc->lcm_symbol, position_of(p, args),
x1, a_rational_string));
}
return (int_zero);
}
b = integer(x);
if (b < 0) {
if (b == S7_INT64_MIN)
#if WITH_GMP
return (big_lcm(sc, n, d, p));
#else
return (simple_out_of_range
(sc, sc->lcm_symbol, args,
its_too_large_string));
#endif
b = -b;
}
#if HAVE_OVERFLOW_CHECKS
if (multiply_overflow(n / c_gcd(n, b), b, &n1))
#if WITH_GMP
return (big_lcm(sc, n, d, p));
#else
return (simple_out_of_range
(sc, sc->lcm_symbol, args,
result_is_too_large_string));
#endif
n = n1;
#else
n = (n / c_gcd(n, b)) * b;
#endif
break;
case T_RATIO:
b = numerator(x);
if (b < 0) {
if (b == S7_INT64_MIN)
#if WITH_GMP
return (big_lcm(sc, n, d, p));
#else
return (simple_out_of_range
(sc, sc->lcm_symbol, args,
its_too_large_string));
#endif
b = -b;
}
#if HAVE_OVERFLOW_CHECKS
if (multiply_overflow(n / c_gcd(n, b), b, &n1)) /* (lcm 92233720368547758/3 3005/2) */
#if WITH_GMP
return (big_lcm(sc, n, d, p));
#else
return (simple_out_of_range
(sc, sc->lcm_symbol, args,
intermediate_too_large_string));
#endif
n = n1;
#else
n = (n / c_gcd(n, b)) * b;
#endif
if (d == 0)
d = (p == args) ? denominator(x) : 1;
else
d = c_gcd(d, denominator(x));
break;
#if WITH_GMP
case T_BIG_INTEGER:
d = 1;
case T_BIG_RATIO:
return (big_lcm(sc, n, d, p));
#endif
case T_REAL:
case T_BIG_REAL:
case T_COMPLEX:
case T_BIG_COMPLEX:
return (wrong_type_argument_with_type
(sc, sc->lcm_symbol, position_of(p, args), x,
a_rational_string));
default:
return (method_or_bust_with_type(sc, x, sc->lcm_symbol,
set_ulist_1(sc,
(d <=
1) ?
make_integer(sc,
n) :
s7_make_ratio(sc,
n,
d),
p),
a_rational_string,
position_of(p, args)));
}
}
return ((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d));
}
/* -------------------------------- gcd -------------------------------- */
#if WITH_GMP
static s7_pointer big_gcd(s7_scheme * sc, s7_int num, s7_int den,
s7_pointer args)
{
s7_pointer x;
mpz_set_si(sc->mpz_3, num);
mpz_set_si(sc->mpz_4, den);
for (x = args; is_pair(x); x = cdr(x)) {
s7_pointer rat;
rat = car(x);
switch (type(rat)) {
case T_INTEGER:
mpz_set_si(sc->mpz_1, integer(rat));
mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1);
break;
case T_RATIO:
mpz_set_si(sc->mpz_1, numerator(rat));
mpz_set_si(sc->mpz_2, denominator(rat));
mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1);
mpz_lcm(sc->mpz_4, sc->mpz_4, sc->mpz_2);
break;
case T_BIG_INTEGER:
mpz_gcd(sc->mpz_3, sc->mpz_3, big_integer(rat));
break;
case T_BIG_RATIO:
mpz_gcd(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat)));
mpz_lcm(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat)));
break;
case T_REAL:
case T_BIG_REAL:
case T_COMPLEX:
case T_BIG_COMPLEX:
return (wrong_type_argument_with_type
(sc, sc->gcd_symbol, position_of(x, args), rat,
a_rational_string));
default:
return (method_or_bust_with_type(sc, rat, sc->gcd_symbol,
set_ulist_1(sc,
mpz_to_rational
(sc, sc->mpz_3,
sc->mpz_4), x),
a_rational_string,
position_of(x, args)));
}
}
return (mpz_to_rational(sc, sc->mpz_3, sc->mpz_4));
}
#endif
static s7_pointer g_gcd(s7_scheme * sc, s7_pointer args)
{
#define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments"
#define Q_gcd sc->pcl_f
s7_int n = 0, d = 1;
s7_pointer p;
if (!is_pair(args)) /* (gcd) */
return (int_zero);
if (!is_pair(cdr(args))) { /* (gcd 3/4) */
if (!is_rational(car(args)))
return (method_or_bust_with_type
(sc, car(args), sc->gcd_symbol, args,
a_rational_string, 1));
return (abs_p_p(sc, car(args)));
}
for (p = args; is_pair(p); p = cdr(p)) {
s7_pointer x = car(p);
switch (type(x)) {
case T_INTEGER:
if (integer(x) == S7_INT64_MIN)
#if WITH_GMP
return (big_gcd(sc, n, d, p));
#else
return (simple_out_of_range
(sc, sc->lcm_symbol, args, its_too_large_string));
#endif
n = c_gcd(n, integer(x));
break;
case T_RATIO:
{
#if HAVE_OVERFLOW_CHECKS
s7_int dn;
#endif
n = c_gcd(n, numerator(x));
if (d == 1)
d = denominator(x);
else {
s7_int b = denominator(x);
#if HAVE_OVERFLOW_CHECKS
if (multiply_overflow(d / c_gcd(d, b), b, &dn)) /* (gcd 1/92233720368547758 1/3005) */
#if WITH_GMP
return (big_gcd(sc, n, d, x));
#else
return (simple_out_of_range
(sc, sc->gcd_symbol, args,
intermediate_too_large_string));
#endif
d = dn;
#else
d = (d / c_gcd(d, b)) * b;
#endif
}
}
break;
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
return (big_gcd(sc, n, d, p));
#endif
case T_REAL:
case T_BIG_REAL:
case T_COMPLEX:
case T_BIG_COMPLEX:
return (wrong_type_argument_with_type
(sc, sc->gcd_symbol, position_of(p, args), x,
a_rational_string));
default:
return (method_or_bust_with_type(sc, x, sc->gcd_symbol,
set_ulist_1(sc,
(d <=
1) ?
make_integer(sc,
n) :
s7_make_ratio(sc,
n,
d),
p),
a_rational_string,
position_of(p, args)));
}
}
return ((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d));
}
/* -------------------------------- floor -------------------------------- */
static s7_pointer floor_p_p(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (x);
case T_RATIO:
{
s7_int val = numerator(x) / denominator(x);
/* C "/" truncates? -- C spec says "truncation toward 0" */
/* we're avoiding "floor" here because the int->double conversion introduces inaccuracies for big numbers
* but it's used by opt_i_d_c (via s7_number_to_real) so floor_i_7d below can return different results:
* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (floor 3441313796169221281/1720656898084610641)) (newline))) (func)): 1
* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (/ (floor 3441313796169221281/1720656898084610641))) (newline))) (func)): 1/2
*/
return ((numerator(x) < 0) ? make_integer(sc, val - 1) : make_integer(sc, val)); /* not "val" because it might be truncated to 0 */
}
case T_REAL:
{
s7_double z = real(x);
if (is_NaN(z))
return (simple_out_of_range
(sc, sc->floor_symbol, x, its_nan_string));
if (is_inf(z))
return (simple_out_of_range
(sc, sc->floor_symbol, x, its_infinite_string));
#if WITH_GMP
if (fabs(z) > DOUBLE_TO_INT64_LIMIT) {
mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN);
mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD);
return (mpz_to_integer(sc, sc->mpz_1));
}
#else
if (fabs(z) > DOUBLE_TO_INT64_LIMIT)
return (simple_out_of_range
(sc, sc->floor_symbol, x, its_too_large_string));
#endif
return (make_integer(sc, (s7_int) floor(z)));
/* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */
}
#if WITH_GMP
case T_BIG_INTEGER:
return (x);
case T_BIG_RATIO:
mpz_fdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)),
mpq_denref(big_ratio(x)));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_REAL:
if (mpfr_nan_p(big_real(x)))
return (simple_out_of_range
(sc, sc->floor_symbol, x, its_nan_string));
if (mpfr_inf_p(big_real(x)))
return (simple_out_of_range
(sc, sc->floor_symbol, x, its_infinite_string));
mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDD);
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_COMPLEX:
#endif
case T_COMPLEX:
return (s7_wrong_type_arg_error
(sc, "floor", 0, x, "a real number"));
default:
return (method_or_bust_one_arg_p(sc, x, sc->floor_symbol, T_REAL));
}
}
static s7_pointer g_floor(s7_scheme * sc, s7_pointer args)
{
#define H_floor "(floor x) returns the integer closest to x toward -inf"
#define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
return (floor_p_p(sc, car(args)));
}
static s7_int floor_i_i(s7_int i)
{
return (i);
}
#if (!WITH_GMP)
static s7_int floor_i_7d(s7_scheme * sc, s7_double x)
{
if (is_NaN(x))
simple_out_of_range(sc, sc->floor_symbol, wrap_real1(sc, x),
its_nan_string);
if (fabs(x) > DOUBLE_TO_INT64_LIMIT)
simple_out_of_range(sc, sc->floor_symbol, wrap_real1(sc, x),
its_too_large_string);
return ((s7_int) floor(x));
}
static s7_int floor_i_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_integer(p))
return (integer(p));
if (is_t_real(p))
return (floor_i_7d(sc, real(p)));
if (is_t_ratio(p)) { /* for consistency with floor_p_p, don't use floor(fraction(p)) */
s7_int val;
val = numerator(p) / denominator(p);
return ((numerator(p) < 0) ? val - 1 : val);
}
return (s7_integer_checked
(sc, method_or_bust_p(sc, p, sc->floor_symbol, T_REAL)));
}
#endif
/* -------------------------------- ceiling -------------------------------- */
static s7_pointer ceiling_p_p(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (x);
case T_RATIO:
{
s7_int val = numerator(x) / denominator(x);
return ((numerator(x) < 0) ? make_integer(sc,
val) :
make_integer(sc, val + 1));
}
case T_REAL:
{
s7_double z = real(x);
if (is_NaN(z))
return (simple_out_of_range
(sc, sc->ceiling_symbol, x, its_nan_string));
if (is_inf(z))
return (simple_out_of_range
(sc, sc->ceiling_symbol, x, its_infinite_string));
#if WITH_GMP
if (fabs(z) > DOUBLE_TO_INT64_LIMIT) {
mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN);
mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDU);
return (mpz_to_integer(sc, sc->mpz_1));
}
#else
if (fabs(z) > DOUBLE_TO_INT64_LIMIT)
return (simple_out_of_range
(sc, sc->ceiling_symbol, x, its_too_large_string));
#endif
return (make_integer(sc, (s7_int) ceil(real(x))));
}
#if WITH_GMP
case T_BIG_INTEGER:
return (x);
case T_BIG_RATIO:
mpz_cdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)),
mpq_denref(big_ratio(x)));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_REAL:
if (mpfr_nan_p(big_real(x)))
return (simple_out_of_range
(sc, sc->ceiling_symbol, x, its_nan_string));
if (mpfr_inf_p(big_real(x)))
return (simple_out_of_range
(sc, sc->ceiling_symbol, x, its_infinite_string));
mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDU);
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_COMPLEX:
#endif
case T_COMPLEX:
return (s7_wrong_type_arg_error
(sc, "ceiling", 0, x, "a real number"));
default:
return (method_or_bust_one_arg_p
(sc, x, sc->ceiling_symbol, T_REAL));
}
}
static s7_pointer g_ceiling(s7_scheme * sc, s7_pointer args)
{
#define H_ceiling "(ceiling x) returns the integer closest to x toward inf"
#define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
return (ceiling_p_p(sc, car(args)));
}
static s7_int ceiling_i_i(s7_int i)
{
return (i);
}
#if (!WITH_GMP)
static s7_int ceiling_i_7d(s7_scheme * sc, s7_double x)
{
if (is_NaN(x))
simple_out_of_range(sc, sc->ceiling_symbol, wrap_real1(sc, x),
its_nan_string);
if ((is_inf(x)) || (x > DOUBLE_TO_INT64_LIMIT)
|| (x < -DOUBLE_TO_INT64_LIMIT))
simple_out_of_range(sc, sc->ceiling_symbol, wrap_real1(sc, x),
its_too_large_string);
return ((s7_int) ceil(x));
}
static s7_int ceiling_i_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_integer(p))
return (integer(p));
if (is_t_real(p))
return (ceiling_i_7d(sc, real(p)));
if (is_t_ratio(p))
return ((s7_int) (ceil(fraction(p))));
return (s7_integer_checked
(sc, method_or_bust_p(sc, p, sc->ceiling_symbol, T_REAL)));
}
#endif
/* -------------------------------- truncate -------------------------------- */
static s7_pointer truncate_p_p(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (x);
case T_RATIO:
return (make_integer(sc, (s7_int) (numerator(x) / denominator(x)))); /* C "/" already truncates (but this divide is not accurate over e13) */
case T_REAL:
{
s7_double 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));
#if WITH_GMP
if (fabs(z) > DOUBLE_TO_INT64_LIMIT) {
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDZ);
return (mpz_to_integer(sc, sc->mpz_1));
}
#else
if (fabs(z) > DOUBLE_TO_INT64_LIMIT)
return (simple_out_of_range
(sc, sc->truncate_symbol, x,
its_too_large_string));
#endif
return ((z > 0.0) ? make_integer(sc,
(s7_int) floor(z)) :
make_integer(sc, (s7_int) ceil(z)));
}
#if WITH_GMP
case T_BIG_INTEGER:
return (x);
case T_BIG_RATIO:
mpz_tdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)),
mpq_denref(big_ratio(x)));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_REAL:
if (mpfr_nan_p(big_real(x)))
return (simple_out_of_range
(sc, sc->truncate_symbol, x, its_nan_string));
if (mpfr_inf_p(big_real(x)))
return (simple_out_of_range
(sc, sc->truncate_symbol, x, its_infinite_string));
mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDZ);
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_COMPLEX:
#endif
case T_COMPLEX:
return (s7_wrong_type_arg_error
(sc, "truncate", 0, x, "a real number"));
default:
return (method_or_bust_one_arg_p
(sc, x, sc->truncate_symbol, T_REAL));
}
}
static s7_pointer g_truncate(s7_scheme * sc, s7_pointer args)
{
#define H_truncate "(truncate x) returns the integer closest to x toward 0"
#define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
return (truncate_p_p(sc, car(args)));
}
static s7_int truncate_i_i(s7_int i)
{
return (i);
}
#if (!WITH_GMP)
static s7_int truncate_i_7d(s7_scheme * sc, s7_double x)
{
if (is_NaN(x))
simple_out_of_range(sc, sc->truncate_symbol, wrap_real1(sc, x),
its_nan_string);
if (is_inf(x))
simple_out_of_range(sc, sc->truncate_symbol, wrap_real1(sc, x),
its_infinite_string);
if (fabs(x) > DOUBLE_TO_INT64_LIMIT)
simple_out_of_range(sc, sc->truncate_symbol, wrap_real1(sc, x),
its_too_large_string);
return ((x > 0.0) ? (s7_int) floor(x) : (s7_int) ceil(x));
}
#endif
/* -------------------------------- round -------------------------------- */
static s7_double r5rs_round(s7_double x)
{
s7_double fl = floor(x), ce = ceil(x), dfl, dce;
dfl = x - fl;
dce = ce - x;
if (dfl > dce)
return (ce);
if (dfl < dce)
return (fl);
return ((fmod(fl, 2.0) == 0.0) ? fl : ce);
}
static s7_pointer round_p_p(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (x);
case T_RATIO:
{
s7_int truncated = numerator(x) / denominator(x), remains =
numerator(x) % denominator(x);
long_double frac;
frac =
s7_fabsl((long_double) remains /
(long_double) denominator(x));
if ((frac > 0.5) || ((frac == 0.5) && (truncated % 2 != 0)))
return ((numerator(x) < 0) ? make_integer(sc,
truncated -
1) :
make_integer(sc, truncated + 1));
return (make_integer(sc, truncated));
}
case T_REAL:
{
s7_double z = real(x);
if (is_NaN(z))
return (simple_out_of_range
(sc, sc->round_symbol, x, its_nan_string));
if (is_inf(z))
return (simple_out_of_range
(sc, sc->round_symbol, x, its_infinite_string));
#if WITH_GMP
if (fabs(z) > DOUBLE_TO_INT64_LIMIT) {
mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN);
mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); /* mpfr_roundeven in mpfr 4.0.0 */
mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN);
return (mpz_to_integer(sc, sc->mpz_3));
}
#else
if (fabs(z) > DOUBLE_TO_INT64_LIMIT)
return (simple_out_of_range
(sc, sc->round_symbol, x, its_too_large_string));
#endif
return (make_integer(sc, (s7_int) r5rs_round(z)));
}
#if WITH_GMP
case T_BIG_INTEGER:
return (x);
case T_BIG_RATIO:
{
int32_t rnd;
mpz_fdiv_qr(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(x)),
mpq_denref(big_ratio(x)));
mpz_mul_ui(sc->mpz_2, sc->mpz_2, 2);
rnd = mpz_cmpabs(sc->mpz_2, mpq_denref(big_ratio(x)));
mpz_fdiv_q(sc->mpz_2, sc->mpz_2, mpq_denref(big_ratio(x)));
if (rnd > 0)
mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
else if ((rnd == 0) && (mpz_odd_p(sc->mpz_1)))
mpz_add_ui(sc->mpz_1, sc->mpz_1, 1);
return (mpz_to_integer(sc, sc->mpz_1));
}
case T_BIG_REAL:
if (mpfr_nan_p(big_real(x)))
return (simple_out_of_range
(sc, sc->round_symbol, x, its_nan_string));
if (mpfr_inf_p(big_real(x)))
return (simple_out_of_range
(sc, sc->round_symbol, x, its_infinite_string));
mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN);
mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN);
mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN);
return (mpz_to_integer(sc, sc->mpz_3));
case T_BIG_COMPLEX:
#endif
case T_COMPLEX:
return (s7_wrong_type_arg_error
(sc, "round", 0, x, "a real number"));
default:
return (method_or_bust_one_arg_p(sc, x, sc->round_symbol, T_REAL));
}
}
static s7_pointer g_round(s7_scheme * sc, s7_pointer args)
{
#define H_round "(round x) returns the integer closest to x"
#define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
return (round_p_p(sc, car(args)));
}
static s7_int round_i_i(s7_int i)
{
return (i);
}
#if (!WITH_GMP)
static s7_int round_i_7d(s7_scheme * sc, s7_double z)
{
if (is_NaN(z))
simple_out_of_range(sc, sc->round_symbol, wrap_real1(sc, z),
its_nan_string);
if ((is_inf(z)) || (z > DOUBLE_TO_INT64_LIMIT)
|| (z < -DOUBLE_TO_INT64_LIMIT))
simple_out_of_range(sc, sc->round_symbol, wrap_real1(sc, z),
its_too_large_string);
return ((s7_int) r5rs_round(z));
}
#endif
/* ---------------------------------------- add ---------------------------------------- */
static inline s7_pointer add_if_overflow_to_real_or_big_integer(s7_scheme *
sc,
s7_int x,
s7_int y)
{
#if HAVE_OVERFLOW_CHECKS
s7_int val;
if (add_overflow(x, y, &val))
#if WITH_GMP
{
mpz_set_si(sc->mpz_1, x);
mpz_set_si(sc->mpz_2, y);
mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
return (mpz_to_big_integer(sc, sc->mpz_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer add overflow: (+ %" ld64 " %" ld64 ")\n", x,
y);
return (make_real(sc, (long_double) x + (long_double) y));
}
#endif
return (make_integer(sc, val));
#else
return (make_integer(sc, x + y));
#endif
}
static s7_pointer
integer_ratio_add_if_overflow_to_real_or_rational(s7_scheme * sc,
s7_pointer x,
s7_pointer y)
{ /* x: int, y:ratio */
#if HAVE_OVERFLOW_CHECKS
s7_int z;
if ((multiply_overflow(integer(x), denominator(y), &z)) ||
(add_overflow(z, numerator(y), &z)))
#if WITH_GMP
{
mpz_set_si(sc->mpz_1, integer(x));
mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y));
mpz_set_si(sc->mpz_2, numerator(y));
mpz_add(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1);
mpz_set_si(mpq_denref(sc->mpq_1), denominator(y));
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer + ratio overflow: (+ %" ld64 " %" ld64 "/%"
ld64 ")\n", integer(x), numerator(y), denominator(y));
return (make_real(sc, (long_double) integer(x) + fraction(y)));
}
#endif
return (make_ratio(sc, z, denominator(y)));
#else
return (make_ratio
(sc, integer(x) * denominator(y) + numerator(y),
denominator(y)));
#endif
}
#define parcel_out_fractions(X, Y) do {d1 = denominator(x); n1 = numerator(x); d2 = denominator(y); n2 = numerator(y);} while (0)
/* add_out_x|y here (as in lt_out_x|y) gives a small speed-up, say 3-7 callgrind units, about 2% */
static s7_pointer add_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
/* an experiment: try to avoid the switch statement */
/* this wins in most s7 cases, not so much elsewhere? parallel subtract/multiply code is slower */
if (is_t_integer(x)) {
if (is_t_integer(y))
return (add_if_overflow_to_real_or_big_integer
(sc, integer(x), integer(y)));
} else if (is_t_real(x)) {
if (is_t_real(y))
return (make_real(sc, real(x) + real(y)));
} else if ((is_t_complex(x)) && (is_t_complex(y)))
return (make_complex
(sc, real_part(x) + real_part(y),
imag_part(x) + imag_part(y)));
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (add_if_overflow_to_real_or_big_integer
(sc, integer(x), integer(y)));
case T_RATIO:
return (integer_ratio_add_if_overflow_to_real_or_rational
(sc, x, y));
case T_REAL:
#if WITH_GMP
if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) { /* (+ 9223372036854775807 .1), >= needed for (+ 9007199254740992 1.0) */
mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, (long_double) integer(x) + real(y)));
case T_COMPLEX:
return (make_complex_not_0i
(sc,
(long_double) integer(x) + (long_double) real_part(y),
imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpz_set_si(sc->mpz_1, integer(x));
mpz_add(sc->mpz_1, sc->mpz_1, big_integer(y));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, integer(x), 1);
mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_add_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->add_symbol, x, y, a_number_string, 2));
}
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return (integer_ratio_add_if_overflow_to_real_or_rational
(sc, y, x));
case T_RATIO:
{
s7_int d1, d2, n1, n2;
parcel_out_fractions(x, y);
if (d1 == d2) {
#if HAVE_OVERFLOW_CHECKS
s7_int q;
if (add_overflow(n1, n2, &q))
#if WITH_GMP
{
mpq_set_si(sc->mpq_1, n1, d1);
mpq_set_si(sc->mpq_2, n2, d2);
mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio + ratio overflow: (/ (+ %" ld64
" %" ld64 ") %" ld64 ")\n", n1, n2,
d1);
return (make_real
(sc,
((long_double) n1 +
(long_double) n2) / (long_double) d1));
}
#endif
return (s7_make_ratio(sc, q, d1));
#else
return (s7_make_ratio(sc, n1 + n2, d1));
#endif
}
#if HAVE_OVERFLOW_CHECKS
{
s7_int n1d2, n2d1, d1d2, q;
if ((multiply_overflow(d1, d2, &d1d2)) ||
(multiply_overflow(n1, d2, &n1d2)) ||
(multiply_overflow(n2, d1, &n2d1)) ||
(add_overflow(n1d2, n2d1, &q)))
#if WITH_GMP
{
mpq_set_si(sc->mpq_1, n1, d1);
mpq_set_si(sc->mpq_2, n2, d2);
mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio + ratio overflow: (+ %" ld64
"/%" ld64 " %" ld64 "/%" ld64 ")\n",
n1, d1, n2, d2);
return (make_real
(sc,
((long_double) n1 / (long_double) d1) +
((long_double) n2 / (long_double) d2)));
}
#endif
return (s7_make_ratio(sc, q, d1d2));
}
#else
return (s7_make_ratio(sc, n1 * d2 + n2 * d1, d1 * d2));
#endif
}
case T_REAL:
return (make_real(sc, fraction(x) + real(y)));
case T_COMPLEX:
return (make_complex_not_0i
(sc, fraction(x) + real_part(y), imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpq_set_z(sc->mpq_2, big_integer(y));
mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpfr_add_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->add_symbol, x, y, a_number_string, 2));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
#if WITH_GMP
if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) { /* (+ .1 9223372036854775807) */
mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN);
mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, real(x) + (long_double) integer(y)));
case T_RATIO:
return (make_real(sc, real(x) + fraction(y)));
case T_REAL:
return (make_real(sc, real(x) + real(y)));
case T_COMPLEX:
return (make_complex_not_0i
(sc, real(x) + real_part(y), imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_add_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->add_symbol, x, y, a_number_string, 2));
}
case T_COMPLEX:
switch (type(y)) {
case T_INTEGER:
return (make_complex_not_0i
(sc, real_part(x) + integer(y), imag_part(x)));
case T_RATIO:
return (make_complex_not_0i
(sc, real_part(x) + fraction(y), imag_part(x)));
case T_REAL:
return (make_complex_not_0i
(sc, real_part(x) + real(y), imag_part(x)));
case T_COMPLEX:
return (make_complex
(sc, real_part(x) + real_part(y),
imag_part(x) + imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->add_symbol, x, y, a_number_string, 2));
}
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
mpz_set_si(sc->mpz_1, integer(y));
mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1);
return (mpz_to_integer(sc, sc->mpz_1));
case T_RATIO:
mpq_set_z(sc->mpq_2, big_integer(x));
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpq_add(sc->mpq_1, sc->mpq_2, sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN);
mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpz_add(sc->mpz_1, big_integer(x), big_integer(y));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
mpq_set_z(sc->mpq_1, big_integer(x));
mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_add_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->add_symbol, x, y, a_number_string, 2));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
mpq_set_si(sc->mpq_1, integer(y), 1);
mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN);
mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpq_set_z(sc->mpq_1, big_integer(y));
mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_add(sc->mpq_1, big_ratio(x), big_ratio(y));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_add_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->add_symbol, x, y, a_number_string, 2));
}
case T_BIG_REAL:
switch (type(y)) {
case T_INTEGER:
mpfr_add_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpfr_add_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_add_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpfr_add_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_add_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_add(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_add_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->add_symbol, x, y, a_number_string, 2));
}
case T_BIG_COMPLEX:
switch (type(y)) {
case T_INTEGER:
mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN);
mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_REAL:
/* if (is_NaN(real(y))) return(real_NaN); */
mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN);
mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN);
mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN);
mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
mpc_add_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_add(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->add_symbol, x, y, a_number_string, 2));
}
#endif
default:
return (method_or_bust_with_type_pp
(sc, x, sc->add_symbol, x, y, a_number_string, 1));
}
}
static s7_pointer add_p_ppp(s7_scheme * sc, s7_pointer x, s7_pointer y,
s7_pointer z)
{
#if HAVE_OVERFLOW_CHECKS && (!WITH_GMP)
if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) {
s7_int val;
if ((!add_overflow(integer(x), integer(y), &val)) &&
(!add_overflow(val, integer(z), &val)))
return (make_integer(sc, val));
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer add overflow: (+ %" ld64 " %" ld64 " %" ld64
")\n", integer(x), integer(y), integer(z));
return (make_real
(sc,
(long_double) integer(x) + (long_double) integer(y) +
(long_double) integer(z)));
}
#endif
if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z)))
return (make_real(sc, real(x) + real(y) + real(z)));
return (add_p_pp(sc, add_p_pp(sc, x, y), z));
}
static s7_pointer g_add(s7_scheme * sc, s7_pointer args)
{
#define H_add "(+ ...) adds its arguments"
#define Q_add sc->pcl_n
s7_pointer x, p;
if (is_null(args))
return (int_zero);
x = car(args);
p = cdr(args);
if (is_null(p)) {
if (!is_number(x))
return (method_or_bust_with_type_one_arg
(sc, x, sc->add_symbol, args, a_number_string));
return (x);
}
if (is_null(cdr(p)))
return (add_p_pp(sc, x, car(p)));
for (; is_pair(p); p = cdr(p))
x = add_p_pp(sc, x, car(p));
return (x);
}
static s7_pointer g_add_2(s7_scheme * sc, s7_pointer args)
{
return (add_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_add_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer p0 = car(args), p1 = cadr(args), p2 = caddr(args);
if ((is_t_integer(p0)) && (is_t_integer(p1)) && (is_t_integer(p2))) {
#if HAVE_OVERFLOW_CHECKS
s7_int val;
if ((!add_overflow(integer(p0), integer(p1), &val)) &&
(!add_overflow(val, integer(p2), &val)))
return (make_integer(sc, val));
#if WITH_GMP
mpz_set_si(sc->mpz_1, integer(p0));
mpz_set_si(sc->mpz_2, integer(p1));
mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
mpz_set_si(sc->mpz_2, integer(p2));
mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
return (mpz_to_integer(sc, sc->mpz_1));
#else
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer add overflow: (+ %" ld64 " %" ld64 " %" ld64
")\n", integer(p0), integer(p1), integer(p2));
return (make_real
(sc,
(long_double) integer(p0) + (long_double) integer(p1) +
(long_double) integer(p2)));
#endif
#else
return (make_integer(sc, integer(p0) + integer(p1) + integer(p2)));
#endif
}
if ((is_t_real(p0)) && (is_t_real(p1)) && (is_t_real(p2)))
return (make_real(sc, real(p0) + real(p1) + real(p2)));
return (add_p_pp(sc, add_p_pp(sc, p0, p1), p2));
}
/* trade-off in add_3: time saved by using add_p_pp, but it conses up a new number cell, so subsequent gc can overwhelm the gains, and add add_p_pp overhead
* need int wrap as output or reuse-if-known-temp, or perhaps free if not permanent
*/
static s7_pointer g_add_x1_1(s7_scheme * sc, s7_pointer x, int pos)
{
if (is_t_integer(x))
return (add_if_overflow_to_real_or_big_integer(sc, integer(x), 1));
switch (type(x)) {
case T_RATIO:
return (add_p_pp(sc, x, int_one));
case T_REAL:
return (make_real(sc, real(x) + 1.0));
case T_COMPLEX:
return (make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x)));
#if WITH_GMP
case T_BIG_INTEGER:
mpz_set_si(sc->mpz_1, 1);
mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1);
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (add_p_pp(sc, x, int_one));
#endif
default:
return (method_or_bust_with_type(sc, x, sc->add_symbol,
(pos == 1) ? set_plist_2(sc, x,
int_one)
: set_plist_2(sc, int_one, x),
a_number_string, pos));
}
return (x);
}
#if WITH_GMP
static s7_pointer g_add_x1(s7_scheme * sc, s7_pointer args)
{
return (g_add_x1_1(sc, car(args), 1));
}
#else
static s7_pointer g_add_x1(s7_scheme * sc, s7_pointer args)
{
s7_pointer x = car(args);
if (is_t_integer(x))
return (make_integer(sc, integer(x) + 1));
if (is_t_real(x))
return (make_real(sc, real(x) + 1.0));
if (is_t_complex(x))
return (make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x)));
return (add_p_pp(sc, x, int_one));
}
#endif
static s7_pointer g_add_1x(s7_scheme * sc, s7_pointer args)
{
return (g_add_x1_1(sc, cadr(args), 2));
}
static s7_pointer g_add_xi(s7_scheme * sc, s7_pointer x, s7_int y)
{
if (is_t_integer(x))
return (add_if_overflow_to_real_or_big_integer(sc, integer(x), y));
switch (type(x)) {
case T_RATIO:
return (add_p_pp(sc, x, wrap_integer1(sc, y)));
case T_REAL:
return (make_real(sc, real(x) + y));
case T_COMPLEX:
return (make_complex_not_0i(sc, real_part(x) + y, imag_part(x)));
#if WITH_GMP
case T_BIG_INTEGER:
mpz_set_si(sc->mpz_1, y);
mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1);
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (add_p_pp(sc, x, wrap_integer1(sc, y)));
#endif
default:
return (method_or_bust_with_type_pi
(sc, x, sc->add_symbol, x, y, a_number_string));
}
return (x);
}
static s7_pointer g_add_xf(s7_scheme * sc, s7_pointer x, s7_double y)
{
if (is_t_real(x))
return (make_real(sc, real(x) + y));
switch (type(x)) {
case T_INTEGER:
return (make_real(sc, integer(x) + y));
case T_RATIO:
return (make_real(sc, fraction(x) + y));
case T_COMPLEX:
return (make_complex_not_0i(sc, real_part(x) + y, imag_part(x)));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (add_p_pp(sc, x, wrap_real2(sc, y)));
#endif
default:
return (method_or_bust_with_type_pf
(sc, x, sc->add_symbol, x, y, a_number_string));
}
return (x);
}
static s7_pointer g_add_2_ff(s7_scheme * sc, s7_pointer args)
{
#if WITH_GMP
if ((is_t_real(car(args))) && (is_t_real(cadr(args))))
return (make_real(sc, real(car(args)) + real(cadr(args))));
return (add_p_pp(sc, car(args), cadr(args)));
#else
return (make_real(sc, real(car(args)) + real(cadr(args))));
#endif
}
static s7_pointer g_add_2_ii(s7_scheme * sc, s7_pointer args)
{
#if WITH_GMP
if ((is_t_integer(car(args))) && (is_t_integer(cadr(args))))
#endif
return (add_if_overflow_to_real_or_big_integer
(sc, integer(car(args)), integer(cadr(args))));
#if WITH_GMP
return (g_add(sc, args)); /* possibly bigint? */
#endif
}
#if WITH_GMP
static s7_pointer add_2_if(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if ((is_t_integer(x)) && (is_t_real(y))) {
if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) {
mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
return (make_real(sc, integer(x) + real(y)));
}
return (add_p_pp(sc, x, y));
}
static s7_pointer g_add_2_if(s7_scheme * sc, s7_pointer args)
{
return (add_2_if(sc, car(args), cadr(args)));
}
static s7_pointer g_add_2_fi(s7_scheme * sc, s7_pointer args)
{
return (add_2_if(sc, cadr(args), car(args)));
}
static s7_pointer g_add_2_xi(s7_scheme * sc, s7_pointer args)
{
if (is_t_integer(cadr(args)))
return (g_add_xi(sc, car(args), integer(cadr(args))));
return (g_add(sc, args));
}
static s7_pointer g_add_2_ix(s7_scheme * sc, s7_pointer args)
{
if (is_t_integer(car(args)))
return (g_add_xi(sc, cadr(args), integer(car(args))));
return (g_add(sc, args));
}
static s7_pointer g_add_2_xf(s7_scheme * sc, s7_pointer args)
{
if (is_t_real(cadr(args)))
return (g_add_xf(sc, car(args), real(cadr(args))));
return (g_add(sc, args));
}
static s7_pointer g_add_2_fx(s7_scheme * sc, s7_pointer args)
{
if (is_t_real(car(args)))
return (g_add_xf(sc, cadr(args), real(car(args))));
return (g_add(sc, args));
}
#else
static s7_pointer g_add_2_if(s7_scheme * sc, s7_pointer args)
{
return (make_real(sc, integer(car(args)) + real(cadr(args))));
}
static s7_pointer g_add_2_fi(s7_scheme * sc, s7_pointer args)
{
return (make_real(sc, real(car(args)) + integer(cadr(args))));
}
static s7_pointer g_add_2_xi(s7_scheme * sc, s7_pointer args)
{
return (g_add_xi(sc, car(args), integer(cadr(args))));
}
static s7_pointer g_add_2_ix(s7_scheme * sc, s7_pointer args)
{
return (g_add_xi(sc, cadr(args), integer(car(args))));
}
static s7_pointer g_add_2_xf(s7_scheme * sc, s7_pointer args)
{
return (g_add_xf(sc, car(args), real(cadr(args))));
}
static s7_pointer g_add_2_fx(s7_scheme * sc, s7_pointer args)
{
return (g_add_xf(sc, cadr(args), real(car(args))));
}
#endif
static s7_pointer add_p_dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
return (make_real(sc, x1 + x2));
}
/* add_p_ii and add_d_id unhittable apparently -- this (d_id) is due to the order of d_dd_ok and d_id_ok in float_optimize,
* but d_dd is much more often hit, and the int arg (if constant) is turned into a float in d_dd
*/
static s7_double add_d_d(s7_double x)
{
return (x);
}
static s7_double add_d_dd(s7_double x1, s7_double x2)
{
return (x1 + x2);
}
static s7_double add_d_ddd(s7_double x1, s7_double x2, s7_double x3)
{
return (x1 + x2 + x3);
}
static s7_double add_d_dddd(s7_double x1, s7_double x2, s7_double x3,
s7_double x4)
{
return (x1 + x2 + x3 + x4);
}
static s7_int add_i_ii(s7_int i1, s7_int i2)
{
return (i1 + i2);
}
static s7_int add_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
return (i1 + i2 + i3);
}
static s7_pointer argument_type(s7_scheme * sc, s7_pointer arg1)
{
if (is_pair(arg1)) {
if (car(arg1) == sc->quote_symbol)
return ((is_pair(cdr(arg1))) ? s7_type_of(sc, cadr(arg1)) : NULL); /* arg1 = (quote) */
if ((is_h_optimized(arg1)) &&
(is_safe_c_op(optimize_op(arg1))) &&
(is_c_function(opt1_cfunc(arg1)))) {
s7_pointer sig;
sig = c_function_signature(opt1_cfunc(arg1));
if ((sig) && (is_pair(sig)) && (is_symbol(car(sig))))
return (car(sig));
}
/* perhaps add closure sig if we can depend on it (immutable func etc) */
} else if (!is_symbol(arg1))
return (s7_type_of(sc, arg1));
return (NULL);
}
static s7_pointer chooser_check_arg_types(s7_scheme * sc, s7_pointer arg1,
s7_pointer arg2,
s7_pointer fallback,
s7_pointer f_2_ff,
s7_pointer f_2_ii,
s7_pointer f_2_if,
s7_pointer f_2_fi,
s7_pointer f_2_xi,
s7_pointer f_2_ix,
s7_pointer f_2_fx,
s7_pointer f_2_xf)
{
s7_pointer arg1_type, arg2_type;
arg1_type = argument_type(sc, arg1);
arg2_type = argument_type(sc, arg2);
if ((arg1_type) || (arg2_type)) {
if (arg1_type == sc->is_float_symbol) {
if (arg2_type == sc->is_float_symbol)
return (f_2_ff);
return ((arg2_type ==
sc->is_integer_symbol) ? f_2_fi : f_2_fx);
}
if (arg1_type == sc->is_integer_symbol) {
if (arg2_type == sc->is_float_symbol)
return (f_2_if);
return ((arg2_type ==
sc->is_integer_symbol) ? f_2_ii : f_2_ix);
}
if (arg2_type == sc->is_float_symbol)
return (f_2_xf);
if (arg2_type == sc->is_integer_symbol)
return (f_2_xi);
}
return (fallback);
}
static s7_pointer g_random_i(s7_scheme * sc, s7_pointer args);
static s7_pointer add_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
/* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */
if (args == 2) {
if (ops) {
s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
if (arg2 == int_one) /* (+ ... 1) */
return (sc->add_x1);
if ((is_t_integer(arg1))
&& ((is_pair(arg2)) && (is_optimized(arg2))
&& (is_h_safe_c_d(arg2))
&& (fn_proc(arg2) == g_random_i))) {
set_opt3_int(cdr(expr), cadr(arg2));
set_safe_optimize_op(expr, HOP_SAFE_C_NC); /* op if r op? */
return (sc->add_i_random);
}
if (arg1 == int_one)
return (sc->add_1x);
return (chooser_check_arg_types(sc, arg1, arg2, sc->add_2,
sc->add_2_ff, sc->add_2_ii,
sc->add_2_if, sc->add_2_fi,
sc->add_2_xi, sc->add_2_ix,
sc->add_2_fx, sc->add_2_xf));
}
return (sc->add_2);
}
return ((args == 3) ? sc->add_3 : f);
}
/* ---------------------------------------- subtract ---------------------------------------- */
static s7_pointer negate_p_p(s7_scheme * sc, s7_pointer p)
{ /* can't use "negate" because it confuses C++! */
switch (type(p)) {
case T_INTEGER:
if (integer(p) == S7_INT64_MIN)
#if WITH_GMP
{
mpz_set_si(sc->mpz_1, S7_INT64_MIN);
mpz_neg(sc->mpz_1, sc->mpz_1);
return (mpz_to_big_integer(sc, sc->mpz_1));
}
#else
return (simple_out_of_range
(sc, sc->subtract_symbol, p,
wrap_string(sc,
"most-negative-fixnum can't be negated",
37)));
#endif
return (make_integer(sc, -integer(p)));
case T_RATIO:
return (make_simple_ratio(sc, -numerator(p), denominator(p)));
case T_REAL:
return (make_real(sc, -real(p)));
case T_COMPLEX:
return (make_complex_not_0i(sc, -real_part(p), -imag_part(p)));
#if WITH_GMP
case T_BIG_INTEGER:
mpz_neg(sc->mpz_1, big_integer(p));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
mpq_neg(sc->mpq_1, big_ratio(p));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_neg(sc->mpfr_1, big_real(p), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_neg(sc->mpc_1, big_complex(p), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->subtract_symbol, a_number_string));
}
}
static inline s7_pointer
subtract_if_overflow_to_real_or_big_integer(s7_scheme * sc, s7_int x,
s7_int y)
{
#if HAVE_OVERFLOW_CHECKS
s7_int val;
if (subtract_overflow(x, y, &val))
#if WITH_GMP
{
mpz_set_si(sc->mpz_1, x);
mpz_set_si(sc->mpz_2, y);
mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_2);
return (mpz_to_big_integer(sc, sc->mpz_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer subtract overflow: (- %" ld64 " %" ld64 ")\n",
x, y);
return (make_real(sc, (long_double) x - (long_double) y));
}
#endif
return (make_integer(sc, val));
#else
return (make_integer(sc, x - y));
#endif
}
static s7_pointer subtract_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
switch (type(x)) {
case T_INTEGER:
if (integer(x) == 0)
return (negate_p_p(sc, y));
switch (type(y)) {
case T_INTEGER:
return (subtract_if_overflow_to_real_or_big_integer
(sc, integer(x), integer(y)));
case T_RATIO:
{
#if HAVE_OVERFLOW_CHECKS
s7_int z;
if ((multiply_overflow(integer(x), denominator(y), &z)) ||
(subtract_overflow(z, numerator(y), &z)))
#if WITH_GMP
{
mpz_set_si(sc->mpz_1, integer(x));
mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y));
mpz_set_si(sc->mpz_2, numerator(y));
mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_1, sc->mpz_2);
mpz_set_si(mpq_denref(sc->mpq_1), denominator(y));
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer - ratio overflow: (- %" ld64 " %"
ld64 "/%" ld64 ")\n", integer(x),
numerator(y), denominator(y));
return (make_real
(sc, (long_double) integer(x) - fraction(y)));
}
#endif
return (make_ratio(sc, z, denominator(y)));
#else
return (make_ratio
(sc, integer(x) * denominator(y) - numerator(y),
denominator(y)));
#endif
}
case T_REAL:
#if WITH_GMP
if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) { /* (- 9223372036854775807 .1) */
mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, (long_double) integer(x) - real(y)));
case T_COMPLEX:
return (make_complex_not_0i
(sc, (long_double) integer(x) - real_part(y),
-imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpz_set_si(sc->mpz_1, integer(x));
mpz_sub(sc->mpz_1, sc->mpz_1, big_integer(y));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, integer(x), 1);
mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_si_sub(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->subtract_symbol, x, y, a_number_string,
2));
}
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
{
#if HAVE_OVERFLOW_CHECKS
s7_int z;
if ((multiply_overflow(integer(y), denominator(x), &z)) ||
(subtract_overflow(numerator(x), z, &z)))
#if WITH_GMP
{
mpz_set_si(sc->mpz_1, integer(y));
mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(x));
mpz_set_si(sc->mpz_2, numerator(x));
mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1);
mpz_set_si(mpq_denref(sc->mpq_1), denominator(x));
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio - integer overflow: (- %" ld64 "/%"
ld64 " %" ld64 ")\n", numerator(x),
denominator(x), integer(y));
return (make_real
(sc, fraction(x) - (long_double) integer(y)));
}
#endif
return (make_ratio(sc, z, denominator(x)));
#else
return (make_ratio
(sc, numerator(x) - (integer(y) * denominator(x)),
denominator(x)));
#endif
}
case T_RATIO:
{
s7_int d1, d2, n1, n2;
parcel_out_fractions(x, y);
if (d1 == d2) {
#if HAVE_OVERFLOW_CHECKS
s7_int q;
if (subtract_overflow(n1, n2, &q))
#if WITH_GMP
{
mpq_set_si(sc->mpq_1, n1, d1);
mpq_set_si(sc->mpq_2, n2, d2);
mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio - ratio overflow: (- %" ld64
"/%" ld64 " %" ld64 "/%" ld64 ")\n",
n1, d1, n2, d2);
return (make_real
(sc,
((long_double) n1 -
(long_double) n2) / (long_double) d1));
}
#endif
return (s7_make_ratio(sc, q, d1));
#else
return (make_ratio
(sc, numerator(x) - numerator(y),
denominator(x)));
#endif
}
#if HAVE_OVERFLOW_CHECKS
{
s7_int n1d2, n2d1, d1d2, q;
if ((multiply_overflow(d1, d2, &d1d2)) ||
(multiply_overflow(n1, d2, &n1d2)) ||
(multiply_overflow(n2, d1, &n2d1)) ||
(subtract_overflow(n1d2, n2d1, &q)))
#if WITH_GMP
{
mpq_set_si(sc->mpq_1, n1, d1);
mpq_set_si(sc->mpq_2, n2, d2);
mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio - ratio overflow: (- %" ld64
"/%" ld64 " %" ld64 "/%" ld64 ")\n",
n1, d1, n2, d2);
return (make_real
(sc,
((long_double) n1 / (long_double) d1) -
((long_double) n2 / (long_double) d2)));
}
#endif
return (s7_make_ratio(sc, q, d1d2));
}
#else
return (s7_make_ratio(sc, n1 * d2 - n2 * d1, d1 * d2));
#endif
}
case T_REAL:
return (make_real(sc, fraction(x) - real(y)));
case T_COMPLEX:
return (make_complex_not_0i
(sc, fraction(x) - real_part(y), -imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpq_set_z(sc->mpq_2, big_integer(y));
mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN);
mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->subtract_symbol, x, y, a_number_string,
2));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
#if WITH_GMP
if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) { /* (- .1 92233720368547758071) */
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_sub_si(sc->mpfr_1, sc->mpfr_1, integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, real(x) - (long_double) integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */
case T_RATIO:
return (make_real(sc, real(x) - fraction(y)));
case T_REAL:
return (make_real(sc, real(x) - real(y)));
case T_COMPLEX:
return (make_complex_not_0i
(sc, real(x) - real_part(y), -imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_sub_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_sub_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_d_sub(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->subtract_symbol, x, y, a_number_string,
2));
}
case T_COMPLEX:
switch (type(y)) {
case T_INTEGER:
return (make_complex_not_0i
(sc, real_part(x) - integer(y), imag_part(x)));
case T_RATIO:
return (make_complex_not_0i
(sc, real_part(x) - fraction(y), imag_part(x)));
case T_REAL:
return (make_complex_not_0i
(sc, real_part(x) - real(y), imag_part(x)));
case T_COMPLEX:
return (make_complex
(sc, real_part(x) - real_part(y),
imag_part(x) - imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_sub_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->subtract_symbol, x, y, a_number_string,
2));
}
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
mpz_set_si(sc->mpz_1, integer(y));
mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1);
return (mpz_to_integer(sc, sc->mpz_1));
case T_RATIO:
mpq_set_z(sc->mpq_2, big_integer(x));
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpq_sub(sc->mpq_1, sc->mpq_2, sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpz_sub(sc->mpz_1, big_integer(x), big_integer(y));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
mpq_set_z(sc->mpq_1, big_integer(x));
mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->subtract_symbol, x, y, a_number_string,
2));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
mpq_set_si(sc->mpq_1, integer(y), 1);
mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpq_set_z(sc->mpq_1, big_integer(y));
mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_sub(sc->mpq_1, big_ratio(x), big_ratio(y));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->subtract_symbol, x, y, a_number_string,
2));
}
case T_BIG_REAL:
switch (type(y)) {
case T_INTEGER:
mpfr_sub_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpfr_sub_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_sub_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_fr_sub(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpfr_sub_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_sub_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_sub(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_fr_sub(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->subtract_symbol, x, y, a_number_string,
2));
}
case T_BIG_COMPLEX:
switch (type(y)) {
case T_INTEGER:
mpc_set_si(sc->mpc_2, integer(y), MPC_RNDNN);
mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_REAL:
/* if (is_NaN(real(y))) return(real_NaN); */
mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN);
mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN);
mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN);
mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
mpc_sub_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_sub(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->subtract_symbol, x, y, a_number_string,
2));
}
#endif
default:
return (method_or_bust_with_type_pp
(sc, x, sc->subtract_symbol, x, y, a_number_string, 1));
}
}
static s7_pointer g_subtract(s7_scheme * sc, s7_pointer args)
{
#define H_subtract "(- x1 ...) subtracts its trailing arguments from the first, or negates the first if only one it is given"
#define Q_subtract sc->pcl_n
s7_pointer x = car(args), p = cdr(args);
if (is_null(p))
return (negate_p_p(sc, x));
return ((is_null(cddr(args))) ? subtract_p_pp(sc, x, cadr(args)) :
subtract_p_pp(sc, x, g_add(sc, cdr(args))));
}
static s7_pointer g_subtract_1(s7_scheme * sc, s7_pointer args)
{
return (negate_p_p(sc, car(args)));
}
static s7_pointer g_subtract_2(s7_scheme * sc, s7_pointer args)
{
return (subtract_p_pp(sc, car(args), cadr(args)));
}
/* static s7_pointer g_subtract_3(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp(sc, subtract_p_pp(sc, car(args), cadr(args)), caddr(args)));} */
static s7_pointer g_subtract_3(s7_scheme * sc, s7_pointer args)
{
return (subtract_p_pp
(sc, car(args), add_p_pp(sc, cadr(args), caddr(args))));
}
static s7_pointer minus_c1(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (subtract_if_overflow_to_real_or_big_integer
(sc, integer(x), 1));
case T_RATIO:
return (subtract_p_pp(sc, x, int_one));
case T_REAL:
return (make_real(sc, real(x) - 1.0));
case T_COMPLEX:
return (make_complex_not_0i(sc, real_part(x) - 1.0, imag_part(x)));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (subtract_p_pp(sc, x, int_one));
#endif
default:
return (method_or_bust_with_type_pp
(sc, x, sc->subtract_symbol, x, int_one, a_number_string,
1));
}
return (x);
}
static s7_pointer g_subtract_x1(s7_scheme * sc, s7_pointer args)
{
s7_pointer p = car(args);
#if WITH_GMP
return (subtract_p_pp(sc, p, int_one));
#endif
return ((is_t_integer(p)) ? make_integer(sc, integer(p) - 1) :
minus_c1(sc, p));
}
static s7_pointer g_subtract_2f(s7_scheme * sc, s7_pointer args)
{ /* (- x f) */
s7_pointer x = car(args);
s7_double n = real(cadr(args)); /* checked below is_t_real */
if (is_t_real(x))
return (make_real(sc, real(x) - n));
switch (type(x)) {
case T_INTEGER:
return (make_real(sc, integer(x) - n));
case T_RATIO:
return (make_real(sc, fraction(x) - n));
case T_COMPLEX:
return (make_complex_not_0i(sc, real_part(x) - n, imag_part(x)));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (subtract_p_pp(sc, x, cadr(args)));
#endif
default:
return (method_or_bust_with_type
(sc, x, sc->subtract_symbol, args, a_number_string, 1));
}
return (x);
}
static s7_pointer g_subtract_f2(s7_scheme * sc, s7_pointer args)
{ /* (- f x) */
s7_pointer x = cadr(args);
s7_double n = real(car(args)); /* checked below is_t_real */
if (is_t_real(x))
return (make_real(sc, n - real(x)));
switch (type(x)) {
case T_INTEGER:
return (make_real(sc, n - integer(x)));
case T_RATIO:
return (make_real(sc, n - fraction(x)));
case T_COMPLEX:
return (make_complex_not_0i(sc, n - real_part(x), -imag_part(x)));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (subtract_p_pp(sc, car(args), x));
#endif
default:
return (method_or_bust_with_type
(sc, x, sc->subtract_symbol, args, a_number_string, 1));
}
return (x);
}
static s7_int subtract_i_ii(s7_int i1, s7_int i2)
{
return (i1 - i2);
}
static s7_int subtract_i_i(s7_int x)
{
return (-x);
}
static s7_int subtract_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
return (i1 - i2 - i3);
}
static s7_double subtract_d_d(s7_double x)
{
return (-x);
}
static s7_double subtract_d_dd(s7_double x1, s7_double x2)
{
return (x1 - x2);
}
static s7_double subtract_d_ddd(s7_double x1, s7_double x2, s7_double x3)
{
return (x1 - x2 - x3);
}
static s7_double subtract_d_dddd(s7_double x1, s7_double x2, s7_double x3,
s7_double x4)
{
return (x1 - x2 - x3 - x4);
}
static s7_pointer subtract_p_dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
return (make_real(sc, x1 - x2));
}
static s7_pointer subtract_p_ii(s7_scheme * sc, s7_int i1, s7_int i2)
{
return (make_integer(sc, i1 - i2));
}
static s7_pointer g_sub_xi(s7_scheme * sc, s7_pointer x, s7_int y)
{
if (is_t_integer(x))
return (subtract_if_overflow_to_real_or_big_integer
(sc, integer(x), y));
switch (type(x)) {
case T_RATIO:
return (make_ratio
(sc, numerator(x) - (y * denominator(x)), denominator(x)));
case T_REAL:
return (make_real(sc, real(x) - y));
case T_COMPLEX:
return (make_complex_not_0i(sc, real_part(x) - y, imag_part(x)));
#if WITH_GMP
case T_BIG_INTEGER:
mpz_set_si(sc->mpz_1, y);
mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1);
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (subtract_p_pp(sc, x, wrap_integer1(sc, y)));
#endif
default:
return (method_or_bust_with_type_pi
(sc, x, sc->subtract_symbol, x, y, a_number_string));
}
return (x);
}
static s7_pointer subtract_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 1)
return (sc->subtract_1);
if (args == 2) {
if (ops) {
s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
if (arg2 == int_one)
return (sc->subtract_x1);
if (is_t_real(arg1))
return (sc->subtract_f2);
if (is_t_real(arg2))
return (sc->subtract_2f);
}
return (sc->subtract_2);
}
return ((args == 3) ? sc->subtract_3 : f);
}
/* ---------------------------------------- multiply ---------------------------------------- */
#define QUOTIENT_FLOAT_LIMIT 1e13
#define QUOTIENT_INT_LIMIT 10000000000000
/* fraction(x) is not accurate enough if it involves numbers over e18 even when done with long_doubles */
static inline s7_pointer
multiply_if_overflow_to_real_or_big_integer(s7_scheme * sc, s7_int x,
s7_int y)
{
#if HAVE_OVERFLOW_CHECKS
s7_int val;
if (multiply_overflow(x, y, &val))
#if WITH_GMP
{
mpz_set_si(sc->mpz_1, x);
mpz_mul_si(sc->mpz_1, sc->mpz_1, y);
return (mpz_to_big_integer(sc, sc->mpz_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer multiply overflow: (* %" ld64 " %" ld64 ")\n",
x, y);
return (make_real(sc, (double) x * (double) y));
}
#endif
return (make_integer(sc, val));
#else
return (make_integer(sc, x * y));
#endif
}
static s7_pointer
integer_ratio_multiply_if_overflow_to_real_or_ratio(s7_scheme * sc,
s7_int x, s7_pointer y)
{
#if HAVE_OVERFLOW_CHECKS
s7_int z;
if (multiply_overflow(x, numerator(y), &z))
#if WITH_GMP
{
mpz_set_si(sc->mpz_1, x);
mpz_mul_si(sc->mpz_1, sc->mpz_1, numerator(y));
mpq_set_si(sc->mpq_1, 1, denominator(y));
mpq_set_num(sc->mpq_1, sc->mpz_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer * ratio overflow: (* %" ld64 " %" ld64 "/%"
ld64 ")\n", x, numerator(y), denominator(y));
return (make_real(sc, (double) x * fraction(y)));
}
#endif
return (make_ratio(sc, z, denominator(y)));
#else
return (make_ratio(sc, x * numerator(y), denominator(y)));
#endif
}
static s7_pointer multiply_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (multiply_if_overflow_to_real_or_big_integer
(sc, integer(x), integer(y)));
case T_RATIO:
return (integer_ratio_multiply_if_overflow_to_real_or_ratio
(sc, integer(x), y));
case T_REAL:
#if WITH_GMP
if (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT) {
mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN);
mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, (long_double) integer(x) * real(y)));
case T_COMPLEX:
return (s7_make_complex
(sc, (long_double) integer(x) * real_part(y),
(long_double) integer(x) * imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpz_mul_si(sc->mpz_1, big_integer(y), integer(x));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, integer(x), 1);
mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_mul_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_mul_si(sc->mpc_1, big_complex(y), integer(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1)); /* x might be 0 */
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->multiply_symbol, x, y, a_number_string,
2));
}
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return (integer_ratio_multiply_if_overflow_to_real_or_ratio
(sc, integer(y), x));
case T_RATIO:
{
s7_int d1, d2, n1, n2;
parcel_out_fractions(x, y);
#if HAVE_OVERFLOW_CHECKS
{
s7_int n1n2, d1d2;
if ((multiply_overflow(d1, d2, &d1d2)) ||
(multiply_overflow(n1, n2, &n1n2)))
#if WITH_GMP
{
mpq_set_si(sc->mpq_1, n1, d1);
mpq_set_si(sc->mpq_2, n2, d2);
mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_canonicalized_rational
(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio * ratio overflow: (* %" ld64
"/%" ld64 " %" ld64 "/%" ld64 ")\n",
n1, d1, n2, d2);
return (make_real(sc, fraction(x) * fraction(y)));
}
#endif
return (s7_make_ratio(sc, n1n2, d1d2));
}
#else
return (s7_make_ratio(sc, n1 * n2, d1 * d2));
#endif
}
case T_REAL:
#if WITH_GMP
if (numerator(x) > QUOTIENT_INT_LIMIT) {
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN);
mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, fraction(x) * real(y)));
case T_COMPLEX:
return (s7_make_complex
(sc, fraction(x) * real_part(y),
fraction(x) * imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpq_set_z(sc->mpq_2, big_integer(y));
mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpfr_mul_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->multiply_symbol, x, y, a_number_string,
2));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
#if WITH_GMP
if (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT) {
mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN);
mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, real(x) * (long_double) integer(y)));
case T_RATIO:
#if WITH_GMP
if (numerator(y) > QUOTIENT_INT_LIMIT) {
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN);
mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, fraction(y) * real(x)));
case T_REAL:
return (make_real(sc, real(x) * real(y)));
case T_COMPLEX:
return (make_complex
(sc, real(x) * real_part(y), real(x) * imag_part(y)));
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_mul_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1)); /* x might = 0.0 */
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->multiply_symbol, x, y, a_number_string,
2));
}
case T_COMPLEX:
switch (type(y)) {
case T_INTEGER:
return (make_complex
(sc, real_part(x) * integer(y),
imag_part(x) * integer(y)));
case T_RATIO:
return (s7_make_complex
(sc, real_part(x) * fraction(y),
imag_part(x) * fraction(y)));
case T_REAL:
return (make_complex
(sc, real_part(x) * real(y), imag_part(x) * real(y)));
case T_COMPLEX:
{
s7_double r1, r2, i1, i2;
r1 = real_part(x);
r2 = real_part(y);
i1 = imag_part(x);
i2 = imag_part(y);
return (make_complex
(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1));
}
#if WITH_GMP
case T_BIG_INTEGER:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->multiply_symbol, x, y, a_number_string,
2));
}
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
mpz_mul_si(sc->mpz_1, big_integer(x), integer(y));
return (mpz_to_integer(sc, sc->mpz_1));
case T_RATIO:
mpq_set_z(sc->mpq_2, big_integer(x));
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpq_mul(sc->mpq_1, sc->mpq_2, sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN);
mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpz_mul(sc->mpz_1, big_integer(x), big_integer(y));
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
mpq_set_z(sc->mpq_1, big_integer(x));
mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_mul_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->multiply_symbol, x, y, a_number_string,
2));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
mpq_set_si(sc->mpq_1, integer(y), 1);
mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN);
mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpq_set_z(sc->mpq_1, big_integer(y));
mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_mul(sc->mpq_1, big_ratio(x), big_ratio(y));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_mul_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->multiply_symbol, x, y, a_number_string,
2));
}
case T_BIG_REAL:
switch (type(y)) {
case T_INTEGER:
mpfr_mul_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpfr_mul_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
mpfr_mul_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpfr_mul_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_mul_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_mul(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_mul_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1)); /* 0.0? */
default:
return (method_or_bust_with_type_pp
(sc, y, sc->multiply_symbol, x, y, a_number_string,
2));
}
case T_BIG_COMPLEX:
switch (type(y)) {
case T_INTEGER:
mpc_mul_si(sc->mpc_1, big_complex(x), integer(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_REAL:
/* if (is_NaN(real(y))) return(real_NaN); */
mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN);
mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_COMPLEX:
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN);
mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN);
mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
mpc_mul_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
mpc_mul(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->multiply_symbol, x, y, a_number_string,
2));
}
#endif
default:
return (method_or_bust_with_type_pp
(sc, x, sc->multiply_symbol, x, y, a_number_string, 1));
}
}
static s7_pointer multiply_p_ppp(s7_scheme * sc, s7_pointer x,
s7_pointer y, s7_pointer z)
{
return (multiply_p_pp(sc, multiply_p_pp(sc, x, y), z));
}
static s7_pointer multiply_method_or_bust(s7_scheme * sc, s7_pointer obj,
s7_pointer caller,
s7_pointer args, s7_pointer typ,
int32_t num)
{
if (has_active_methods(sc, obj))
return (find_and_apply_method(sc, obj, sc->multiply_symbol, args));
if (num == 0)
return (simple_wrong_type_argument_with_type
(sc, sc->multiply_symbol, obj, typ));
return (wrong_type_argument_with_type
(sc, sc->multiply_symbol, num, obj, typ));
}
static s7_pointer g_multiply(s7_scheme * sc, s7_pointer args)
{
#define H_multiply "(* ...) multiplies its arguments"
#define Q_multiply sc->pcl_n
s7_pointer x, p;
if (is_null(args))
return (int_one);
x = car(args);
p = cdr(args);
if (is_null(p)) {
if (!is_number(x))
return (multiply_method_or_bust
(sc, x, sc->multiply_symbol, args, a_number_string,
0));
return (x);
}
if (is_null(cdr(p)))
return (multiply_p_pp(sc, x, car(p)));
for (; is_pair(p); p = cdr(p))
x = multiply_p_pp(sc, x, car(p));
return (x);
}
static s7_pointer g_multiply_2(s7_scheme * sc, s7_pointer args)
{
return (multiply_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_mul_xi(s7_scheme * sc, s7_pointer x, s7_int n)
{
switch (type(x)) {
case T_INTEGER:
return (multiply_if_overflow_to_real_or_big_integer
(sc, integer(x), n));
case T_RATIO:
return (integer_ratio_multiply_if_overflow_to_real_or_ratio
(sc, n, x));
case T_REAL:
return (make_real(sc, real(x) * n));
case T_COMPLEX:
return (s7_make_complex(sc, real_part(x) * n, imag_part(x) * n));
#if WITH_GMP
case T_BIG_INTEGER:
mpz_mul_si(sc->mpz_1, big_integer(x), n);
return (mpz_to_integer(sc, sc->mpz_1));
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (multiply_p_pp(sc, x, wrap_integer1(sc, n)));
#endif
default:
/* we can get here from mul_2_xi for example so the non-integer argument might not be a symbol */
return (method_or_bust_with_type_pi
(sc, x, sc->multiply_symbol, x, n, a_number_string));
}
return (x);
}
static s7_pointer g_mul_xf(s7_scheme * sc, s7_pointer x, s7_double y)
{
switch (type(x)) {
case T_INTEGER:
return (make_real(sc, integer(x) * y));
case T_RATIO:
return (make_real(sc, numerator(x) * y / denominator(x)));
case T_REAL:
return (make_real(sc, real(x) * y));
case T_COMPLEX:
return (s7_make_complex(sc, real_part(x) * y, imag_part(x) * y));
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
mpfr_mul_d(sc->mpfr_1, big_real(x), y, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
mpc_mul_fr(sc->mpc_1, big_complex(x), sc->mpfr_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pf
(sc, x, sc->multiply_symbol, x, y, a_number_string));
}
return (x);
}
#if WITH_GMP
static s7_pointer g_mul_2_if(s7_scheme * sc, s7_pointer args)
{
if ((is_t_integer(car(args))) && (is_t_real(cadr(args))))
return (make_real(sc, integer(car(args)) * real(cadr(args))));
return (multiply_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_mul_2_fi(s7_scheme * sc, s7_pointer args)
{
if ((is_t_integer(cadr(args))) && (is_t_real(car(args))))
return (make_real(sc, real(car(args)) * integer(cadr(args))));
return (multiply_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_mul_2_xi(s7_scheme * sc, s7_pointer args)
{
if (is_t_integer(cadr(args)))
return (g_mul_xi(sc, car(args), integer(cadr(args))));
return (g_multiply(sc, args));
}
static s7_pointer g_mul_2_ix(s7_scheme * sc, s7_pointer args)
{
if (is_t_integer(car(args)))
return (g_mul_xi(sc, cadr(args), integer(car(args))));
return (g_multiply(sc, args));
}
static s7_pointer g_mul_2_xf(s7_scheme * sc, s7_pointer args)
{
if (is_t_real(cadr(args)))
return (g_mul_xf(sc, car(args), real(cadr(args))));
return (g_multiply(sc, args));
}
static s7_pointer g_mul_2_fx(s7_scheme * sc, s7_pointer args)
{
if (is_t_real(car(args)))
return (g_mul_xf(sc, cadr(args), real(car(args))));
return (g_multiply(sc, args));
}
static s7_pointer g_mul_2_ff(s7_scheme * sc, s7_pointer args)
{
return (multiply_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_mul_2_ii(s7_scheme * sc, s7_pointer args)
{
return (multiply_p_pp(sc, car(args), cadr(args)));
}
#else
static s7_pointer g_mul_2_if(s7_scheme * sc, s7_pointer args)
{
return (make_real(sc, integer(car(args)) * real(cadr(args))));
}
static s7_pointer g_mul_2_fi(s7_scheme * sc, s7_pointer args)
{
return (make_real(sc, real(car(args)) * integer(cadr(args))));
}
static s7_pointer g_mul_2_xi(s7_scheme * sc, s7_pointer args)
{
return (g_mul_xi(sc, car(args), integer(cadr(args))));
}
static s7_pointer g_mul_2_ix(s7_scheme * sc, s7_pointer args)
{
return (g_mul_xi(sc, cadr(args), integer(car(args))));
}
static s7_pointer g_mul_2_xf(s7_scheme * sc, s7_pointer args)
{
return (g_mul_xf(sc, car(args), real(cadr(args))));
}
static s7_pointer g_mul_2_fx(s7_scheme * sc, s7_pointer args)
{
return (g_mul_xf(sc, cadr(args), real(car(args))));
}
static s7_pointer g_mul_2_ff(s7_scheme * sc, s7_pointer args)
{
return (make_real(sc, real(car(args)) * real(cadr(args))));
}
static s7_pointer g_mul_2_ii(s7_scheme * sc, s7_pointer args)
{
#if HAVE_OVERFLOW_CHECKS
s7_int val, x = integer(car(args)), y = integer(cadr(args));
if (multiply_overflow(x, y, &val)) {
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer multiply overflow: (* %" ld64 " %" ld64 ")\n",
x, y);
return (make_real(sc, (double) x * (double) y));
}
return (make_integer(sc, val));
#else
return (make_integer(sc, integer(car(args)) * integer(cadr(args))));
#endif
}
#endif
static s7_int multiply_i_ii(s7_int i1, s7_int i2)
{
#if HAVE_OVERFLOW_CHECKS
s7_int val;
if (multiply_overflow(i1, i2, &val)) {
if (WITH_WARNINGS)
s7_warn(cur_sc, 64,
"integer multiply overflow: (* %" ld64 " %" ld64 ")\n",
i1, i2);
return (S7_INT64_MAX); /* this is inconsistent with other unopt cases where an overflow -> double result */
}
/* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((= j 1)) (even? (* (ash 1 43) (ash 1 43)))))) (define (hi) (func)) (hi)) */
return (val);
#else
return (i1 * i2);
#endif
}
static s7_int multiply_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
#if HAVE_OVERFLOW_CHECKS
s7_int val1, val2;
if ((multiply_overflow(i1, i2, &val1)) ||
(multiply_overflow(val1, i3, &val2))) {
if (WITH_WARNINGS)
s7_warn(cur_sc, 64,
"integer multiply overflow: (* %" ld64 " %" ld64 " %"
ld64 ")\n", i1, i2, i3);
return (S7_INT64_MAX);
}
return (val2);
#else
return (i1 * i2 * i3);
#endif
}
static s7_double multiply_d_d(s7_double x)
{
return (x);
}
static s7_double multiply_d_dd(s7_double x1, s7_double x2)
{
return (x1 * x2);
}
static s7_double multiply_d_ddd(s7_double x1, s7_double x2, s7_double x3)
{
return (x1 * x2 * x3);
}
static s7_double multiply_d_dddd(s7_double x1, s7_double x2, s7_double x3,
s7_double x4)
{
return (x1 * x2 * x3 * x4);
}
static s7_pointer mul_p_dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
return (make_real(sc, x1 * x2));
}
static s7_pointer multiply_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 2) {
if (ops)
return (chooser_check_arg_types
(sc, cadr(expr), caddr(expr), sc->multiply_2,
sc->mul_2_ff, sc->mul_2_ii, sc->mul_2_if,
sc->mul_2_fi, sc->mul_2_xi, sc->mul_2_ix,
sc->mul_2_fx, sc->mul_2_xf));
return (sc->multiply_2);
}
return (f);
}
/* ---------------------------------------- divide ---------------------------------------- */
static s7_pointer complex_invert(s7_scheme * sc, s7_pointer p)
{
s7_double den, r2 = real_part(p), i2 = imag_part(p);
den = (r2 * r2 + i2 * i2);
/* here if p is, for example, -inf.0+i, den is +inf.0 so -i2/den is -0.0 (in gcc anyway), so the imag part is 0.0 */
return (s7_make_complex(sc, r2 / den, -i2 / den));
}
static s7_pointer invert_p_p(s7_scheme * sc, s7_pointer p)
{
#if WITH_GMP
s7_pointer x;
#endif
switch (type(p)) {
case T_INTEGER:
#if WITH_GMP && (!POINTER_32)
if (integer(p) == S7_INT64_MIN) { /* (/ 1 (*s7* 'most-negative-fixnum)) -> -1/9223372036854775808 */
new_cell(sc, x, T_BIG_RATIO);
big_ratio_bgr(x) = alloc_bigrat(sc);
add_big_ratio(sc, x);
mpz_set_si(sc->mpz_1, S7_INT64_MAX);
mpz_set_si(sc->mpz_2, 1);
mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
mpq_set_si(big_ratio(x), -1, 1);
mpq_set_den(big_ratio(x), sc->mpz_1); /* geez... */
return (x);
}
#endif
if (integer(p) == 0)
return (division_by_zero_error(sc, sc->divide_symbol, p));
return (make_simple_ratio(sc, 1, integer(p))); /* this checks for int */
case T_RATIO:
return (make_simple_ratio(sc, denominator(p), numerator(p)));
case T_REAL:
if (real(p) == 0.0)
return (division_by_zero_error(sc, sc->divide_symbol, p));
return (make_real(sc, 1.0 / real(p)));
case T_COMPLEX:
return (complex_invert(sc, p));
#if WITH_GMP
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(p), 0) == 0)
return (division_by_zero_error(sc, sc->divide_symbol, p));
if ((mpz_cmp_ui(big_integer(p), 1) == 0)
|| (mpz_cmp_si(big_integer(p), -1) == 0))
return (p);
new_cell(sc, x, T_BIG_RATIO);
big_ratio_bgr(x) = alloc_bigrat(sc);
add_big_ratio(sc, x);
mpq_set_si(big_ratio(x), 1, 1);
mpq_set_den(big_ratio(x), big_integer(p));
mpq_canonicalize(big_ratio(x));
return (x);
case T_BIG_RATIO:
if (mpz_cmp_ui(mpq_numref(big_ratio(p)), 1) == 0)
return (mpz_to_integer(sc, mpq_denref(big_ratio(p))));
if (mpz_cmp_si(mpq_numref(big_ratio(p)), -1) == 0) {
mpz_neg(sc->mpz_1, mpq_denref(big_ratio(p)));
return (mpz_to_integer(sc, sc->mpz_1));
}
new_cell(sc, x, T_BIG_RATIO);
big_ratio_bgr(x) = alloc_bigrat(sc);
add_big_ratio(sc, x);
mpq_inv(big_ratio(x), big_ratio(p));
mpq_canonicalize(big_ratio(x));
return (x);
case T_BIG_REAL:
if (mpfr_zero_p(big_real(p)))
return (division_by_zero_error(sc, sc->divide_symbol, p));
x = mpfr_to_big_real(sc, big_real(p));
mpfr_ui_div(big_real(x), 1, big_real(x), MPFR_RNDN);
return (x);
case T_BIG_COMPLEX:
if ((!mpfr_number_p(mpc_realref(big_complex(p))))
|| (!mpfr_number_p(mpc_imagref(big_complex(p)))))
return (complex_NaN);
mpc_ui_div(sc->mpc_1, 1, big_complex(p), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1)); /* x might be 0+0i if real-part is inf? */
#endif
default:
check_method(sc, p, sc->divide_symbol, set_plist_1(sc, p));
return (wrong_type_argument_with_type
(sc, sc->divide_symbol, 1, p, a_number_string));
}
}
static s7_pointer divide_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
/* splitting out real/real here saves very little */
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
/* -------- integer x -------- */
case T_INTEGER:
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
if (integer(x) == 1) /* mainly to handle (/ 1 -9223372036854775808) correctly! */
return (invert_p_p(sc, y));
return (make_ratio(sc, integer(x), integer(y)));
case T_RATIO:
#if HAVE_OVERFLOW_CHECKS
{
s7_int dn;
if (multiply_overflow(integer(x), denominator(y), &dn))
#if WITH_GMP
{
mpq_set_si(sc->mpq_1, integer(x), 1);
mpq_set_si(sc->mpq_2, numerator(y), denominator(y));
mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer / ratio overflow: (/ %" ld64 " %"
ld64 "/%" ld64 ")\n", integer(x),
numerator(y), denominator(y));
return (make_real
(sc, integer(x) * inverted_fraction(y)));
}
#endif
return (s7_make_ratio(sc, dn, numerator(y)));
}
#else
return (s7_make_ratio
(sc, integer(x) * denominator(y), numerator(y)));
#endif
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
if (is_inf(real(y)))
return (real_zero);
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
#if WITH_GMP
if ((s7_int_abs(integer(x))) > QUOTIENT_INT_LIMIT) {
mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN);
mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
#endif
return (make_real(sc, (s7_double) (integer(x)) / real(y)));
case T_COMPLEX:
{
s7_double den, r1 = (s7_double) integer(x), r2 =
real_part(y), i2 = imag_part(y);
den = 1.0 / (r2 * r2 + i2 * i2);
/* we could avoid the squaring (see Knuth II p613 16), not a big deal: (/ 1.0e308+1.0e308i 2.0e308+2.0e308i) => nan, (gmp case is ok here) */
return (s7_make_complex
(sc, r1 * r2 * den, -(r1 * i2 * den)));
}
#if WITH_GMP
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(y), 0) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpq_set_si(sc->mpq_1, integer(x), 1);
mpq_set_den(sc->mpq_1, big_integer(y));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, integer(x), 1);
mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_REAL:
if (mpfr_zero_p(big_real(y)))
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_si_div(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
if ((!mpfr_number_p(mpc_realref(big_complex(y))))
|| (!mpfr_number_p(mpc_imagref(big_complex(y)))))
return (complex_NaN);
mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1)); /* x might be 0? */
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->divide_symbol, x, y, a_number_string, 2));
}
break;
/* -------- ratio x -------- */
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
#if HAVE_OVERFLOW_CHECKS
{
s7_int dn;
if (multiply_overflow(denominator(x), integer(y), &dn))
#if WITH_GMP
{
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpq_set_si(sc->mpq_2, integer(y), 1);
mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio / integer overflow: (/ %" ld64 "/%"
ld64 " %" ld64 ")\n", numerator(x),
denominator(x), integer(y));
return (make_real
(sc,
(long_double) numerator(x) /
((long_double) denominator(x) *
(long_double) integer(y))));
}
#endif
return (s7_make_ratio(sc, numerator(x), dn));
}
#else
return (s7_make_ratio
(sc, numerator(x), denominator(x) * integer(y)));
#endif
case T_RATIO:
{
s7_int d1, d2, n1, n2;
parcel_out_fractions(x, y);
if (d1 == d2)
return (s7_make_ratio(sc, n1, n2));
#if HAVE_OVERFLOW_CHECKS
if ((multiply_overflow(n1, d2, &n1)) ||
(multiply_overflow(n2, d1, &d1))) {
#if WITH_GMP
mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); /* not n1 and d1! they are garbage here */
mpq_set_si(sc->mpq_2, n2, d2);
mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
#else
s7_double r1, r2;
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio / ratio overflow: (/ %" ld64 "/%"
ld64 " %" ld64 "/%" ld64 ")\n",
numerator(x), denominator(x), numerator(y),
denominator(y));
r1 = fraction(x);
r2 = inverted_fraction(y);
return (make_real(sc, r1 * r2));
#endif
}
return (s7_make_ratio(sc, n1, d1));
#else
return (s7_make_ratio(sc, n1 * d2, n2 * d1));
#endif
}
case T_REAL:
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
return (make_real(sc, fraction(x) / real(y)));
case T_COMPLEX:
{
s7_double den, rx = fraction(x), r2 = real_part(y), i2 =
imag_part(y);
den = 1.0 / (r2 * r2 + i2 * i2);
return (s7_make_complex(sc, rx * r2 * den, -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */
}
#if WITH_GMP
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(y), 0) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpq_set_z(sc->mpq_1, big_integer(y));
mpq_set_si(sc->mpq_2, numerator(x), denominator(x));
mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
if (mpfr_zero_p(big_real(y)))
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN);
mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
if ((!mpfr_number_p(mpc_realref(big_complex(y))))
|| (!mpfr_number_p(mpc_imagref(big_complex(y)))))
return (complex_NaN);
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->divide_symbol, x, y, a_number_string, 2));
}
/* -------- real x -------- */
case T_REAL:
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
if (is_NaN(real(x)))
return (real_NaN); /* what is (/ +nan.0 0)? */
if (is_inf(real(x)))
return ((real(x) >
0.0) ? ((integer(y) >
0) ? real_infinity : real_minus_infinity)
: ((integer(y) >
0) ? real_minus_infinity : real_infinity));
return (make_real
(sc,
(long_double) real(x) / (long_double) integer(y)));
case T_RATIO:
if (is_NaN(real(x)))
return (real_NaN);
if (is_inf(real(x)))
return ((real(x) >
0) ? ((numerator(y) >
0) ? real_infinity : real_minus_infinity)
: ((numerator(y) >
0) ? real_minus_infinity : real_infinity));
return (make_real(sc, real(x) * inverted_fraction(y)));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
if (is_NaN(real(x)))
return (real_NaN);
if (is_inf(real(y)))
return ((is_inf(real(x))) ? real_NaN : real_zero);
return (make_real(sc, real(x) / real(y)));
case T_COMPLEX:
{
s7_double den, r2, i2;
if (is_NaN(real(x)))
return (complex_NaN);
r2 = real_part(y);
i2 = imag_part(y);
if ((is_NaN(r2)) || (is_inf(r2)))
return (complex_NaN);
if ((is_NaN(i2)) || (is_inf(i2)))
return (complex_NaN);
den = 1.0 / (r2 * r2 + i2 * i2);
return (s7_make_complex
(sc, real(x) * r2 * den, -real(x) * i2 * den));
}
#if WITH_GMP
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(y), 0) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN);
mpfr_d_div(sc->mpfr_1, real(x), sc->mpfr_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_div_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
if (mpfr_zero_p(big_real(y)))
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_d_div(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
if ((is_NaN(real(x)))
|| (!mpfr_number_p(mpc_realref(big_complex(y))))
|| (!mpfr_number_p(mpc_imagref(big_complex(y)))))
return (complex_NaN);
mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->divide_symbol, x, y, a_number_string, 2));
}
/* -------- complex x -------- */
case T_COMPLEX:
switch (type(y)) {
case T_INTEGER:
{
s7_double r1;
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol,
set_elist_2(sc, x, y)));
r1 = (long_double) 1.0 / (long_double) integer(y);
return (s7_make_complex
(sc, real_part(x) * r1, imag_part(x) * r1));
}
case T_RATIO:
{
s7_double frac = inverted_fraction(y);
return (make_complex
(sc, real_part(x) * frac, imag_part(x) * frac));
}
case T_REAL:
{
s7_double r1;
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->divide_symbol,
set_elist_2(sc, x, y)));
r1 = 1.0 / real(y);
return (make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); /* (/ 0.0+1.0i +inf.0) */
}
case T_COMPLEX:
{
s7_double r1, r2, i1, i2, den;
r1 = real_part(x);
if (is_NaN(r1))
return (real_NaN);
i1 = imag_part(x);
if (is_NaN(i1))
return (real_NaN);
r2 = real_part(y);
if (is_NaN(r2))
return (real_NaN);
if (is_inf(r2))
return (complex_NaN);
i2 = imag_part(y);
if (is_NaN(i2))
return (real_NaN);
den = 1.0 / (r2 * r2 + i2 * i2);
return (s7_make_complex
(sc, (r1 * r2 + i1 * i2) * den,
(r2 * i1 - r1 * i2) * den));
}
#if WITH_GMP
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(y), 0) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
if (mpfr_zero_p(big_real(y)))
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_div_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
if ((!mpfr_number_p(mpc_realref(big_complex(y))))
|| (!mpfr_number_p(mpc_imagref(big_complex(y)))))
return (complex_NaN);
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, y, sc->divide_symbol, x, y, a_number_string, 2));
}
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpz_set_si(sc->mpz_1, integer(y));
mpq_set_num(sc->mpq_1, big_integer(x));
mpq_set_den(sc->mpq_1, sc->mpz_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_RATIO:
mpq_set_z(sc->mpq_2, big_integer(x));
mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); /* can't invert here, mpq den=unsigned */
mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) ||
(is_inf(real_part(y))) || (is_inf(imag_part(y))))
return (complex_NaN);
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(y), 0) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpq_set_num(sc->mpq_1, big_integer(x));
mpq_set_den(sc->mpq_1, big_integer(y));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, 0, 1);
mpq_set_num(sc->mpq_1, big_integer(x));
mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y));
return (mpq_to_rational(sc, sc->mpq_1));
case T_BIG_REAL:
if (mpfr_zero_p(big_real(y)))
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
if ((!mpfr_number_p(mpc_realref(big_complex(y))))
|| (!mpfr_number_p(mpc_imagref(big_complex(y)))))
return (complex_NaN);
mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->divide_symbol, x, y, a_number_string, 2));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpq_set_si(sc->mpq_1, integer(y), 1);
mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_rational(sc, sc->mpq_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) ||
(is_inf(real_part(y))) || (is_inf(imag_part(y))))
return (complex_NaN);
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(y), 0) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpq_set_z(sc->mpq_1, big_integer(y));
mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_div(sc->mpq_1, big_ratio(x), big_ratio(y));
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_REAL:
if (mpfr_zero_p(big_real(y)))
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
if ((!mpfr_number_p(mpc_realref(big_complex(y))))
|| (!mpfr_number_p(mpc_imagref(big_complex(y)))))
return (complex_NaN);
mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN);
mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->divide_symbol, x, y, a_number_string, 2));
}
case T_BIG_REAL:
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_div_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpfr_div_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_REAL:
if (is_NaN(real(y)))
return (real_NaN);
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_div_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) ||
(is_inf(real_part(y))) || (is_inf(imag_part(y))))
return (complex_NaN);
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_fr_div(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(y), 0) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_div_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_RATIO:
mpfr_div_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_REAL:
if (mpfr_zero_p(big_real(y)))
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpfr_div(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
if ((!mpfr_number_p(mpc_realref(big_complex(y))))
|| (!mpfr_number_p(mpc_imagref(big_complex(y)))))
return (complex_NaN);
mpc_fr_div(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->divide_symbol, x, y, a_number_string, 2));
}
case T_BIG_COMPLEX:
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN);
mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN);
mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_REAL:
/* if (is_NaN(real(y))) return(real_NaN); */
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN);
mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_COMPLEX:
if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) ||
(is_inf(real_part(y))) || (is_inf(imag_part(y))))
return (complex_NaN);
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_INTEGER:
if (mpz_cmp_ui(big_integer(y), 0) == 0)
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN);
mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_RATIO:
mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN);
mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_REAL:
if (mpfr_zero_p(big_real(y)))
return (division_by_zero_error
(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
mpc_div_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
case T_BIG_COMPLEX:
if ((!mpfr_number_p(mpc_realref(big_complex(y))))
|| (!mpfr_number_p(mpc_imagref(big_complex(y)))))
return (complex_NaN);
mpc_div(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
default:
return (method_or_bust_with_type_pp
(sc, y, sc->divide_symbol, x, y, a_number_string, 2));
}
#endif
default: /* x is not a built-in number */
return (method_or_bust_with_type_pp(sc, x, sc->divide_symbol, x, y, a_number_string, 1)); /* not args here! y = apply * to cdr(args) */
}
return (NULL); /* make the compiler happy */
}
static s7_pointer g_divide(s7_scheme * sc, s7_pointer args)
{
#define H_divide "(/ x1 ...) divides its first argument by the rest, or inverts the first if there is only one argument"
#define Q_divide sc->pcl_n
s7_pointer x = car(args), y, p = cdr(args);
if (is_null(p)) { /* (/ x) */
if (!is_number(x))
return (method_or_bust_with_type_one_arg
(sc, x, sc->divide_symbol, args, a_number_string));
return (invert_p_p(sc, x));
}
if (is_null(cdr(p)))
return (divide_p_pp(sc, x, cadr(args)));
y = g_multiply(sc, p); /* in some schemes (/ 1 0 +nan.0) is not equal to (/ 1 (* 0 +nan.0)), in s7 they're both +nan.0 */
return (divide_p_pp(sc, x, y));
}
static s7_pointer g_invert_1(s7_scheme * sc, s7_pointer args)
{
return (invert_p_p(sc, car(args)));
}
static s7_pointer g_divide_2(s7_scheme * sc, s7_pointer args)
{
return (divide_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_divide_by_2(s7_scheme * sc, s7_pointer args)
{
/* (/ x 2) */
s7_pointer num = car(args);
if (is_t_integer(num)) {
s7_int i = integer(num);
if (i & 1) {
s7_pointer x;
new_cell(sc, x, T_RATIO);
numerator(x) = i;
denominator(x) = 2;
return (x);
}
return (make_integer(sc, i >> 1));
}
switch (type(num)) {
case T_RATIO:
#if HAVE_OVERFLOW_CHECKS
{
s7_int dn;
if (multiply_overflow(denominator(num), 2, &dn)) {
if ((numerator(num) & 1) == 1)
#if WITH_GMP
{
mpq_set_si(sc->mpq_1, numerator(num),
denominator(num));
mpq_set_si(sc->mpq_2, 1, 2);
mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_rational(sc, sc->mpq_1));
}
#else
{
if (WITH_WARNINGS)
s7_warn(sc, 128,
"ratio / 2 overflow: (/ %" ld64 "/%" ld64
" 2)\n", numerator(num), denominator(num));
return (make_real
(sc,
((long_double) numerator(num) * 0.5) /
(long_double) denominator(num)));
}
#endif
return (make_ratio
(sc, numerator(num) / 2, denominator(num)));
}
return (s7_make_ratio(sc, numerator(num), dn));
}
#else
return (make_ratio(sc, numerator(num), denominator(num) * 2));
#endif
case T_REAL:
return (make_real(sc, real(num) * 0.5));
case T_COMPLEX:
return (make_complex_not_0i
(sc, real_part(num) * 0.5, imag_part(num) * 0.5));
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_z(sc->mpq_1, big_integer(num));
mpz_mul_ui(mpq_denref(sc->mpq_1), mpq_denref(sc->mpq_1), 2);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, 2, 1);
mpq_div(sc->mpq_1, big_ratio(num), sc->mpq_1);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
case T_BIG_REAL:
mpfr_div_si(sc->mpfr_1, big_real(num), 2, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_BIG_COMPLEX:
mpc_set_si(sc->mpc_1, 2, MPC_RNDNN);
mpc_div(sc->mpc_1, big_complex(num), sc->mpc_1, MPC_RNDNN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type_pp
(sc, num, sc->divide_symbol, num, int_two, a_number_string,
1));
}
}
static s7_pointer g_invert_x(s7_scheme * sc, s7_pointer args)
{
/* (/ 1.0 x) */
if (is_t_real(cadr(args))) {
s7_double rl = real(cadr(args));
if (rl == 0.0)
return (division_by_zero_error(sc, sc->divide_symbol, args));
return ((is_NaN(rl)) ? real_NaN : make_real(sc, 1.0 / rl));
}
return (g_divide(sc, args));
}
static s7_double divide_d_7d(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 divide_d_7dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
if (x2 == 0.0)
division_by_zero_error(sc, sc->divide_symbol,
set_elist_1(sc, real_zero));
return (x1 / x2);
}
static s7_pointer divide_p_ii(s7_scheme * sc, s7_int x, s7_int y)
{
return (s7_make_ratio(sc, x, y));
} /* s7_make-ratio checks for y==0 */
static s7_pointer divide_p_i(s7_scheme * sc, s7_int x)
{
return (s7_make_ratio(sc, 1, x));
}
static s7_pointer divide_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 1)
return (sc->invert_1);
if ((ops) && (args == 2)) {
s7_pointer arg1 = cadr(expr);
if ((is_t_real(arg1)) && (real(arg1) == 1.0))
return (sc->invert_x);
return (((is_t_integer(caddr(expr)))
&& (integer(caddr(expr)) ==
2)) ? sc->divide_by_2 : sc->divide_2);
}
return (f);
}
/* -------------------------------- quotient -------------------------------- */
static inline s7_int quotient_i_7ii(s7_scheme * sc, s7_int x, s7_int y)
{
if ((y > 0) || (y < -1))
return (x / y);
if (y == 0)
division_by_zero_error(sc, sc->quotient_symbol,
set_elist_2(sc, wrap_integer1(sc, x),
wrap_integer2(sc, y)));
if ((y == -1) && (x == S7_INT64_MIN)) /* (quotient most-negative-fixnum -1) */
simple_out_of_range(sc, sc->quotient_symbol,
set_elist_2(sc, wrap_integer1(sc, x),
wrap_integer2(sc, y)),
its_too_large_string);
return (x / y);
}
#if (!WITH_GMP)
static s7_pointer s7_truncate(s7_scheme * sc, s7_pointer caller,
s7_double xf)
{ /* can't use "truncate" -- it's in unistd.h */
if (fabs(xf) > QUOTIENT_FLOAT_LIMIT)
return (simple_out_of_range
(sc, caller, wrap_real1(sc, xf), its_too_large_string));
return ((xf > 0.0) ? make_integer(sc,
(s7_int) floor(xf)) :
make_integer(sc, (s7_int) ceil(xf)));
}
static s7_int c_quo_dbl(s7_scheme * sc, s7_double x, s7_double y)
{
s7_double xf;
if (y == 0.0)
division_by_zero_error(sc, sc->quotient_symbol,
set_elist_2(sc, wrap_real1(sc, x),
wrap_real2(sc, y)));
if ((is_inf(y)) || (is_NaN(y))) /* here we can't return NAN so I guess we should signal an error */
wrong_type_argument_with_type(sc, sc->quotient_symbol, 2,
wrap_real1(sc, y),
a_normal_real_string);
xf = x / y;
if (fabs(xf) > QUOTIENT_FLOAT_LIMIT)
simple_out_of_range(sc, sc->quotient_symbol, wrap_real1(sc, xf),
its_too_large_string);
return ((xf > 0.0) ? (s7_int) floor(xf) : (s7_int) ceil(xf));
}
#endif
static s7_int quotient_i_ii_unchecked(s7_int i1, s7_int i2)
{
return (i1 / i2);
} /* i2 > 0 */
static s7_pointer quotient_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
#if WITH_GMP
if ((is_real(x)) && (is_real(y))) {
if (is_zero(sc, y))
division_by_zero_error(sc, sc->quotient_symbol,
set_elist_2(sc, x, y));
if ((s7_is_integer(x)) && (s7_is_integer(y))) {
if (is_t_integer(x))
mpz_set_si(sc->mpz_1, integer(x));
else
mpz_set(sc->mpz_1, big_integer(x));
if (is_t_integer(y))
mpz_set_si(sc->mpz_2, integer(y));
else
mpz_set(sc->mpz_2, big_integer(y));
mpz_tdiv_q(sc->mpz_1, sc->mpz_1, sc->mpz_2);
} else if ((!is_rational(x)) || (!is_rational(y))) {
if (any_real_to_mpfr(sc, x, sc->mpfr_1))
return (real_NaN);
if (any_real_to_mpfr(sc, y, sc->mpfr_2))
return (real_NaN);
mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ);
} else {
any_rational_to_mpq(sc, x, sc->mpq_1);
any_rational_to_mpq(sc, y, sc->mpq_2);
mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2);
mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3),
mpq_denref(sc->mpq_3));
}
return (mpz_to_integer(sc, sc->mpz_1));
}
return (method_or_bust_pp
(sc, (is_real(x)) ? y : x, sc->quotient_symbol, x, y, T_REAL,
(is_real(x)) ? 2 : 1));
#else
s7_int d1, d2, n1, n2;
if ((is_t_integer(x)) && (is_t_integer(y)))
return (make_integer
(sc, quotient_i_7ii(sc, integer(x), integer(y))));
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (make_integer
(sc, quotient_i_7ii(sc, integer(x), integer(y))));
case T_RATIO:
n1 = integer(x);
d1 = 1;
n2 = numerator(y);
d2 = denominator(y);
/* (quotient -9223372036854775808 -1/9223372036854775807): arithmetic exception in the no-overflow-checks case */
goto RATIO_QUO_RATIO;
case T_REAL:
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->quotient_symbol, set_elist_2(sc, x, y)));
if ((is_inf(real(y))) || (is_NaN(real(y))))
return (real_NaN);
return (s7_truncate(sc, sc->quotient_symbol, (s7_double) integer(x) / real(y))); /* s7_truncate returns an integer */
default:
return (method_or_bust_pp
(sc, y, sc->quotient_symbol, x, y, 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, set_elist_2(sc, x, y)));
n1 = numerator(x);
d1 = denominator(x);
n2 = integer(y);
d2 = 1;
goto RATIO_QUO_RATIO;
/* this can lose:
* (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1
* (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0
*/
case T_RATIO:
parcel_out_fractions(x, y);
RATIO_QUO_RATIO:
if (d1 == d2)
return (make_integer(sc, n1 / n2)); /* (quotient 3/9223372036854775807 1/9223372036854775807) */
if (n1 == n2)
return (make_integer(sc, d2 / d1)); /* (quotient 9223372036854775807/2 9223372036854775807/8) */
#if HAVE_OVERFLOW_CHECKS
{
s7_int n1d2, n2d1;
if ((multiply_overflow(n1, d2, &n1d2)) ||
(multiply_overflow(n2, d1, &n2d1)))
return (s7_truncate
(sc, sc->quotient_symbol,
((long_double) n1 / (long_double) n2) *
((long_double) d2 / (long_double) d1)));
return (make_integer(sc, n1d2 / n2d1));
}
#else
return (make_integer(sc, (n1 * d2) / (n2 * d1)));
#endif
case T_REAL:
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->quotient_symbol, set_elist_2(sc, x, y)));
if ((is_inf(real(y))) || (is_NaN(real(y))))
return (real_NaN);
return (s7_truncate
(sc, sc->quotient_symbol,
(s7_double) fraction(x) / real(y)));
default:
return (method_or_bust_pp
(sc, y, sc->quotient_symbol, x, y, T_REAL, 2));
}
case T_REAL:
if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y)))
return (real_NaN);
/* 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, set_elist_2(sc, x, y)));
return (s7_truncate
(sc, sc->quotient_symbol,
(long_double) real(x) / (long_double) integer(y)));
case T_RATIO:
return (s7_truncate
(sc, sc->quotient_symbol,
real(x) / (s7_double) fraction(y)));
case T_REAL:
return (make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */
default:
return (method_or_bust_pp
(sc, y, sc->quotient_symbol, x, y, T_REAL, 2));
}
default:
return (method_or_bust_pp
(sc, x, sc->quotient_symbol, x, y, T_REAL, 2));
}
#endif
}
static s7_pointer g_quotient(s7_scheme * sc, s7_pointer args)
{
#define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1"
#define Q_quotient sc->pcl_r
/* sig was '(integer? ...) but quotient can return NaN */
/* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */
return (quotient_p_pp(sc, car(args), cadr(args)));
}
/* -------------------------------- remainder -------------------------------- */
#if WITH_GMP
static s7_pointer big_mod_or_rem(s7_scheme * sc, s7_pointer x,
s7_pointer y, bool use_floor)
{
if ((is_real(x)) && (is_real(y))) {
if ((s7_is_integer(x)) && (s7_is_integer(y))) {
if (is_t_integer(x))
mpz_set_si(sc->mpz_1, integer(x));
else
mpz_set(sc->mpz_1, big_integer(x));
if (is_t_integer(y))
mpz_set_si(sc->mpz_2, integer(y));
else
mpz_set(sc->mpz_2, big_integer(y));
if (use_floor)
mpz_fdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2);
else
mpz_tdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2);
mpz_mul(sc->mpz_3, sc->mpz_3, sc->mpz_2);
mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_3);
return (mpz_to_integer(sc, sc->mpz_1));
}
if ((!is_rational(x)) || (!is_rational(y))) {
any_real_to_mpfr(sc, x, sc->mpfr_1);
any_real_to_mpfr(sc, y, sc->mpfr_2);
mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
if (use_floor)
mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDD);
else
mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ);
mpfr_mul_z(sc->mpfr_2, sc->mpfr_2, sc->mpz_1, MPFR_RNDN);
mpfr_sub(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
}
any_rational_to_mpq(sc, x, sc->mpq_1);
any_rational_to_mpq(sc, y, sc->mpq_2);
mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2);
if (use_floor)
mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3),
mpq_denref(sc->mpq_3));
else
mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3),
mpq_denref(sc->mpq_3));
mpz_mul(mpq_numref(sc->mpq_2), sc->mpz_1, mpq_numref(sc->mpq_2));
mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2);
return (mpq_to_canonicalized_rational(sc, sc->mpq_1));
}
return (method_or_bust_pp
(sc, (is_real(x)) ? y : x,
(use_floor) ? sc->modulo_symbol : sc->remainder_symbol, x, y,
T_REAL, (is_real(x)) ? 2 : 1));
}
#endif
#define REMAINDER_FLOAT_LIMIT 1e13
static inline s7_int remainder_i_7ii(s7_scheme * sc, s7_int x, s7_int y)
{
if ((y > 1) || (y < -1))
return (x % y);
if (y == 0)
division_by_zero_error(sc, sc->remainder_symbol,
set_elist_2(sc, wrap_integer1(sc, x),
wrap_integer2(sc, y)));
return (0);
}
static s7_double c_rem_dbl(s7_scheme * sc, s7_double x, s7_double y)
{
s7_int quo;
s7_double pre_quo;
if ((is_inf(y)) || (is_NaN(y)))
return (NAN);
pre_quo = x / y;
if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT)
simple_out_of_range(sc, sc->remainder_symbol,
set_elist_2(sc, wrap_real1(sc, x),
wrap_real2(sc, y)),
its_too_large_string);
quo =
(pre_quo > 0.0) ? (s7_int) floor(pre_quo) : (s7_int) ceil(pre_quo);
return (x - (y * quo));
}
static s7_int remainder_i_ii_unchecked(s7_int i1, s7_int i2)
{
return (i1 % i2);
} /* i2 > 1 */
static s7_double remainder_d_7dd(s7_scheme * sc, s7_double x1,
s7_double x2)
{
if (x2 == 0.0)
division_by_zero_error(sc, sc->remainder_symbol,
set_elist_2(sc, wrap_real1(sc, x1),
wrap_real2(sc, x2)));
if ((is_inf(x1)) || (is_NaN(x1))) /* match remainder_p_pp */
return (NAN);
return (c_rem_dbl(sc, x1, x2));
}
static s7_pointer remainder_p_pp(s7_scheme * sc, s7_pointer x,
s7_pointer y)
{
#if WITH_GMP
if (is_zero(sc, y))
division_by_zero_error(sc, sc->remainder_symbol,
set_elist_2(sc, x, y));
return (big_mod_or_rem(sc, x, y, false));
#else
s7_int quo, d1, d2, n1, n2;
s7_double pre_quo;
if ((is_t_integer(x)) && (is_t_integer(y)))
return (make_integer
(sc, remainder_i_7ii(sc, integer(x), integer(y))));
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (make_integer
(sc, remainder_i_7ii(sc, integer(x), integer(y))));
case T_RATIO:
n1 = integer(x);
d1 = 1;
n2 = numerator(y);
d2 = denominator(y);
goto RATIO_REM_RATIO;
case T_REAL:
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->remainder_symbol, set_elist_2(sc, x, y)));
if ((is_inf(real(y))) || (is_NaN(real(y))))
return (real_NaN);
pre_quo = (long_double) integer(x) / (long_double) real(y);
if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT)
return (simple_out_of_range
(sc, sc->remainder_symbol, set_elist_2(sc, x, y),
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:
return (method_or_bust_pp
(sc, y, sc->remainder_symbol, x, y, 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, set_elist_2(sc, x, y)));
n1 = numerator(x);
d1 = denominator(x);
d2 = 1;
goto RATIO_REM_RATIO;
case T_RATIO:
parcel_out_fractions(x, y);
RATIO_REM_RATIO:
if (d1 == d2)
quo = (s7_int) (n1 / n2);
else {
if (n1 == n2)
quo = (s7_int) (d2 / d1);
else {
#if HAVE_OVERFLOW_CHECKS
s7_int n1d2, n2d1;
if ((multiply_overflow(n1, d2, &n1d2)) ||
(multiply_overflow(n2, d1, &n2d1))) {
pre_quo =
((long_double) n1 / (long_double) n2) *
((long_double) d2 / (long_double) d1);
if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT)
return (simple_out_of_range
(sc, sc->remainder_symbol,
set_elist_2(sc, x, y),
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
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)
return (s7_make_ratio(sc, n1 - n2 * quo, d1));
return (s7_make_ratio(sc, n1 * d2 - n2 * d1 * quo, d1 * d2));
#endif
return (simple_out_of_range
(sc, sc->remainder_symbol, set_elist_2(sc, x, y),
intermediate_too_large_string));
case T_REAL:
{
s7_double frac;
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->remainder_symbol,
set_elist_2(sc, x, y)));
if ((is_inf(real(y))) || (is_NaN(real(y))))
return (real_NaN);
if (s7_int_abs(numerator(x)) > QUOTIENT_INT_LIMIT)
return (subtract_p_pp
(sc, x,
multiply_p_pp(sc, y,
quotient_p_pp(sc, x, y))));
frac = (s7_double) fraction(x);
pre_quo = frac / real(y);
if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT)
return (simple_out_of_range
(sc, sc->remainder_symbol,
set_elist_2(sc, x, y), 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:
return (method_or_bust_pp
(sc, y, sc->remainder_symbol, x, y, T_REAL, 2));
}
case T_REAL:
if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) {
if (is_zero(sc, y))
return (division_by_zero_error
(sc, sc->remainder_symbol, set_elist_2(sc, x, y)));
return (real_NaN);
}
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (division_by_zero_error
(sc, sc->remainder_symbol, set_elist_2(sc, x, y)));
/* actually here (and elsewhere) if y > INT64_TO_DOUBLE_LIMIT, the result is probably wrong */
pre_quo = (long_double) real(x) / (long_double) integer(y);
if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT)
return (simple_out_of_range
(sc, sc->remainder_symbol, set_elist_2(sc, x, y),
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:
if (s7_int_abs(numerator(y)) > QUOTIENT_INT_LIMIT)
return (subtract_p_pp
(sc, x,
multiply_p_pp(sc, y, quotient_p_pp(sc, x, y))));
{
s7_double frac;
frac = (s7_double) fraction(y);
pre_quo = real(x) / frac;
if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT)
return (simple_out_of_range
(sc, sc->remainder_symbol,
set_elist_2(sc, x, y), 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:
if (real(y) == 0.0)
return (division_by_zero_error
(sc, sc->remainder_symbol, set_elist_2(sc, x, y)));
return (make_real(sc, c_rem_dbl(sc, real(x), real(y))));
/* see under sin -- this calculation is completely bogus if "a" is large
* (quotient 1e22 (* 2 pi)) -> -9223372036854775808 but it should be 1591549430918953357688,
* (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 -- the "remainder" is greater than the original argument!
* Clisp gives 0.0 here, as does sbcl, currently s7 throws an error (out-of-range).
*/
default:
return (method_or_bust_pp
(sc, y, sc->remainder_symbol, x, y, T_REAL, 2));
}
default:
return (method_or_bust_pp
(sc, x, sc->remainder_symbol, x, y, T_REAL, 1));
}
#endif
}
static s7_pointer g_remainder(s7_scheme * sc, s7_pointer args)
{
#define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1"
#define Q_remainder sc->pcl_r
/* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */
s7_pointer x = car(args), y = cadr(args);
if ((is_t_integer(x)) && (is_t_integer(y)))
return (make_integer
(sc, remainder_i_7ii(sc, integer(x), integer(y))));
return (remainder_p_pp(sc, x, y));
}
/* -------------------------------- modulo -------------------------------- */
static s7_int modulo_i_ii(s7_int x, s7_int y)
{
s7_int z;
if (y > 1) {
z = x % y;
return ((z >= 0) ? z : z + y);
}
if (y < -1) {
z = x % y;
return ((z > 0) ? z + y : z);
}
if (y == 0)
return (x); /* else arithmetic exception */
return (0);
}
static s7_int modulo_i_ii_unchecked(s7_int i1, s7_int i2)
{ /* here we know i2 > 1 */
/* i2 > 1 */
s7_int z = i1 % i2;
return ((z < 0) ? (z + i2) : z);
}
static s7_double modulo_d_7dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
s7_double c;
if ((is_NaN(x1)) || (is_NaN(x2)) || (is_inf(x1)) || (is_inf(x2)))
return (NAN);
if (x2 == 0.0)
return (x1);
if (fabs(x1) > 1e17)
simple_out_of_range(sc, sc->modulo_symbol, wrap_real1(sc, x1),
its_too_large_string);
c = x1 / x2;
if ((c > 1e19) || (c < -1e19))
simple_out_of_range(sc, sc->modulo_symbol,
set_elist_3(sc, sc->divide_symbol,
wrap_real1(sc, x1), wrap_real2(sc,
x2)),
intermediate_too_large_string);
return (x1 - x2 * (s7_int) floor(c));
}
static s7_pointer modulo_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
#if WITH_GMP
/* as tricky as expt, so just use bignums; mpz_mod|_ui = mpz_fdiv_r_ui, but sign ignored -- probably not worth the code
* originally subtract_p_pp(sc, x, multiply_p_pp(sc, y, floor_p_p(sc, divide_p_pp(sc, x, y))))
* quotient is truncate_p_p(sc, divide_p_pp(sc, x, y))
* remainder is subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))
*/
if (!is_zero(sc, y))
return (big_mod_or_rem(sc, x, y, true));
if (is_real(x))
return (x);
return (method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, T_REAL, 1));
#else
s7_double a, b;
s7_int n1, n2, d1, d2;
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (make_integer(sc, modulo_i_ii(integer(x), integer(y))));
case T_RATIO:
n1 = integer(x);
d1 = 1;
n2 = numerator(y);
d2 = denominator(y);
if ((n1 == n2) && (d1 > d2))
return (x); /* signs match so this should be ok */
goto RATIO_MOD_RATIO;
case T_REAL:
if ((integer(x) == S7_INT64_MIN)
|| (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT))
return (simple_out_of_range
(sc, sc->modulo_symbol, x, its_too_large_string));
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);
goto REAL_MOD;
default:
return (method_or_bust_pp
(sc, y, sc->modulo_symbol, x, y, T_REAL, 2));
}
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (x);
n1 = numerator(x);
d1 = denominator(x);
n2 = integer(y);
if ((n2 > 0) && (n1 > 0) && (n2 > n1))
return (x);
if ((n2 < 0) && (n1 < 0) && (n2 < n1))
return (x);
if (n2 == S7_INT64_MIN)
return (simple_out_of_range(sc, sc->modulo_symbol,
set_elist_3(sc,
sc->divide_symbol,
x, y),
intermediate_too_large_string));
/* the problem here is that (modulo 3/2 most-negative-fixnum)
* will segfault with signal SIGFPE, Arithmetic exception, so try to trap it.
*/
if ((n1 == n2) && (d1 > 1))
return (x);
d2 = 1;
goto RATIO_MOD_RATIO;
case T_RATIO:
parcel_out_fractions(x, y);
if (d1 == d2)
return (s7_make_ratio(sc, modulo_i_ii(n1, n2), d1));
if ((n1 == n2) && (d1 > d2))
return (x);
RATIO_MOD_RATIO:
#if HAVE_OVERFLOW_CHECKS
{
s7_int n2d1, n1d2, d1d2, fl;
if (!multiply_overflow(n2, d1, &n2d1)) {
if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) */
return (int_zero);
if (!multiply_overflow(n1, d2, &n1d2)) {
fl = (s7_int) (n1d2 / n2d1);
if (((n1 < 0) && (n2 > 0)) ||
((n1 > 0) && (n2 < 0)))
fl -= 1;
if (fl == 0)
return (x);
if ((!multiply_overflow(d1, d2, &d1d2)) &&
(!multiply_overflow(fl, n2d1, &fl)) &&
(!subtract_overflow(n1d2, fl, &fl)))
return (s7_make_ratio(sc, fl, d1d2));
}
}
}
#else
{
s7_int n1d2, n2d1, fl;
n1d2 = n1 * d2;
n2d1 = n2 * d1;
if (n2d1 == 1)
return (int_zero);
/* can't use "floor" here (float->int ruins everything) */
fl = (s7_int) (n1d2 / n2d1);
if (((n1 < 0) && (n2 > 0)) || ((n1 > 0) && (n2 < 0)))
fl -= 1;
if (fl == 0)
return (x);
return (s7_make_ratio(sc, n1d2 - (n2d1 * fl), d1 * d2));
}
#endif
return (simple_out_of_range(sc, sc->modulo_symbol,
set_elist_3(sc, sc->divide_symbol,
x, y),
intermediate_too_large_string));
case T_REAL:
b = real(y);
if (is_inf(b))
return (real_NaN);
if (fabs(b) > 1e17)
return (simple_out_of_range
(sc, sc->modulo_symbol, y, its_too_large_string));
if (b == 0.0)
return (x);
if (is_NaN(b))
return (y);
a = fraction(x);
return (make_real(sc, a - b * (s7_int) floor(a / b)));
default:
return (method_or_bust_pp
(sc, y, sc->modulo_symbol, x, y, T_REAL, 2));
}
case T_REAL:
{
s7_double c;
a = real(x);
if (!is_real(y))
return (method_or_bust_pp
(sc, y, sc->modulo_symbol, x, y, T_REAL, 2));
if (is_NaN(a))
return (x);
if (is_inf(a))
return (real_NaN); /* not b */
if (fabs(a) > 1e17)
return (simple_out_of_range
(sc, sc->modulo_symbol, x, its_too_large_string));
switch (type(y)) {
case T_INTEGER:
if (integer(y) == 0)
return (x);
if ((integer(y) == S7_INT64_MIN)
|| (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT))
return (simple_out_of_range
(sc, sc->modulo_symbol, y,
its_too_large_string));
b = (s7_double) integer(y);
goto REAL_MOD;
case T_RATIO:
b = fraction(y);
goto REAL_MOD;
case T_REAL:
b = real(y);
if (b == 0.0)
return (x);
if (is_NaN(b))
return (y);
if (is_inf(b))
return (real_NaN);
REAL_MOD:
c = a / b;
if (fabs(c) > 1e19)
return (simple_out_of_range(sc, sc->modulo_symbol,
set_elist_3(sc,
sc->divide_symbol,
x, y),
intermediate_too_large_string));
return (make_real(sc, a - b * (s7_int) floor(c)));
default:
return (method_or_bust_pp
(sc, y, sc->modulo_symbol, x, y, T_REAL, 2));
}
}
default:
return (method_or_bust_pp
(sc, x, sc->modulo_symbol, x, y, T_REAL, 1));
}
#endif
}
static s7_pointer g_modulo(s7_scheme * sc, s7_pointer args)
{
#define H_modulo "(modulo x1 x2) returns x1 mod x2; (modulo 4 3) = 1. The arguments can be real numbers."
#define Q_modulo sc->pcl_r
/* (define (mod x1 x2) (- x1 (* x2 (floor (/ x1 x2))))) from slib
* (mod x 0) = x according to "Concrete Mathematics"
*/
return (modulo_p_pp(sc, car(args), cadr(args)));
}
/* ---------------------------------------- max ---------------------------------------- */
static bool is_real_via_method_1(s7_scheme * sc, s7_pointer p)
{
s7_pointer f;
f = find_method_with_let(sc, p, sc->is_real_symbol);
if (f != sc->undefined)
return (is_true(sc, call_method(sc, p, f, set_plist_1(sc, p))));
return (false);
}
#define is_real_via_method(sc, p) ((is_real(p)) || ((has_active_methods(sc, p)) && (is_real_via_method_1(sc, p))))
#define max_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->max_symbol, X, Y, T_REAL, 1)
#define max_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->max_symbol, X, Y, T_REAL, 2)
static s7_pointer max_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
/* same basic code as lt_b_7_pp (or any relop) but max returns NaN if NaN encountered, and methods for < and max return
* different results, so it seems simpler to repeat the other code.
*/
if (type(x) == type(y)) {
if (is_t_integer(x))
return ((integer(x) < integer(y)) ? y : x);
if (is_t_real(x))
return (((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y);
if (is_t_ratio(x))
return ((fraction(x) < fraction(y)) ? y : x);
#if WITH_GMP
if (is_t_big_integer(x))
return ((mpz_cmp(big_integer(x), big_integer(y)) < 0) ? y : x);
if (is_t_big_ratio(x))
return ((mpq_cmp(big_ratio(x), big_ratio(y)) < 0) ? y : x);
if (is_t_big_real(x))
return (((mpfr_nan_p(big_real(x)) != 0) || (mpfr_greaterequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */
#endif
}
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_RATIO:
return ((integer(x) < fraction(y)) ? y : x);
case T_REAL:
if (is_NaN(real(y)))
return (y);
return ((integer(x) < real(y)) ? y : x);
#if WITH_GMP
case T_BIG_INTEGER:
return ((mpz_cmp_si(big_integer(y), integer(x)) < 0) ? x : y);
case T_BIG_RATIO:
return ((mpq_cmp_si(big_ratio(y), integer(x), 1) < 0) ? x : y);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (y);
return ((mpfr_cmp_si(big_real(y), integer(x)) < 0) ? x : y);
#endif
default:
return (max_out_y(sc, x, y));
}
break;
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return ((fraction(x) < integer(y)) ? y : x);
case T_REAL:
if (is_NaN(real(y)))
return (y);
return ((fraction(x) < real(y)) ? y : x);
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return ((mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0) ? y : x);
case T_BIG_RATIO:
return ((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x))
< 0) ? x : y);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (y);
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return ((mpfr_cmp_q(big_real(y), sc->mpq_1) < 0) ? x : y);
#endif
default:
return (max_out_y(sc, x, y));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
if (is_NaN(real(x)))
return (x);
return ((real(x) < integer(y)) ? y : x);
case T_RATIO:
return ((real(x) < fraction(y)) ? y : x);
#if WITH_GMP
case T_BIG_INTEGER:
if (is_NaN(real(x)))
return (x);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return ((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0) ? y : x);
case T_BIG_RATIO:
if (is_NaN(real(x)))
return (x);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return ((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0) ? y : x);
case T_BIG_REAL:
if (is_NaN(real(x)))
return (x);
if (mpfr_nan_p(big_real(y)))
return (y);
return ((mpfr_cmp_d(big_real(y), real(x)) < 0) ? x : y);
#endif
default:
return (max_out_y(sc, x, y));
}
break;
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
return ((mpz_cmp_si(big_integer(x), integer(y)) < 0) ? y : x);
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return ((mpq_cmp_z(sc->mpq_1, big_integer(x)) < 0) ? x : y);
case T_REAL:
if (is_NaN(real(y)))
return (y);
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
return ((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x);
case T_BIG_RATIO:
return ((mpq_cmp_z(big_ratio(y), big_integer(x)) < 0) ? x : y);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (y);
return ((mpfr_cmp_z(big_real(y), big_integer(x)) < 0) ? x : y);
default:
return (max_out_y(sc, x, y));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
return ((mpq_cmp_si(big_ratio(x), integer(y), 1) < 0) ? y : x);
case T_RATIO:
return ((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y))
< 0) ? y : x);
case T_REAL:
if (is_NaN(real(y)))
return (y);
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return ((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x);
case T_BIG_INTEGER:
return ((mpq_cmp_z(big_ratio(x), big_integer(y)) < 0) ? y : x);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (y);
return ((mpfr_cmp_q(big_real(y), big_ratio(x)) < 0) ? x : y);
default:
return (max_out_y(sc, x, y));
}
case T_BIG_REAL:
switch (type(y)) {
case T_INTEGER:
if (mpfr_nan_p(big_real(x)))
return (x);
return ((mpfr_cmp_si(big_real(x), integer(y)) < 0) ? y : x);
case T_RATIO:
if (mpfr_nan_p(big_real(x)))
return (x);
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return ((mpfr_cmp_q(big_real(x), sc->mpq_1) < 0) ? y : x);
case T_REAL:
if (mpfr_nan_p(big_real(x)))
return (x);
if (is_NaN(real(y)))
return (y);
return ((mpfr_cmp_d(big_real(x), real(y)) < 0) ? y : x);
case T_BIG_INTEGER:
if (mpfr_nan_p(big_real(x)))
return (x);
return ((mpfr_cmp_z(big_real(x), big_integer(y)) < 0) ? y : x);
case T_BIG_RATIO:
if (mpfr_nan_p(big_real(x)))
return (x);
return ((mpfr_cmp_q(big_real(x), big_ratio(y)) < 0) ? y : x);
default:
return (max_out_y(sc, x, y));
}
#endif
default:
return (max_out_x(sc, x, y));
}
return (x);
}
static s7_pointer g_max(s7_scheme * sc, s7_pointer args)
{
#define H_max "(max ...) returns the maximum of its arguments"
#define Q_max sc->pcl_r
s7_pointer x = car(args), p;
if (is_null(cdr(args))) {
if (is_real(x))
return (x);
return (method_or_bust_p(sc, x, sc->max_symbol, T_REAL));
}
for (p = cdr(args); is_pair(p); p = cdr(p))
x = max_p_pp(sc, x, car(p));
return (x);
}
static s7_pointer g_max_2(s7_scheme * sc, s7_pointer args)
{
return (max_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_max_3(s7_scheme * sc, s7_pointer args)
{
return (max_p_pp
(sc, max_p_pp(sc, car(args), cadr(args)), caddr(args)));
}
static s7_pointer max_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
return ((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : f));
}
static s7_int max_i_ii(s7_int i1, s7_int i2)
{
return ((i1 > i2) ? i1 : i2);
}
static s7_int max_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
return ((i1 > i2) ? ((i1 > i3) ? i1 : i3) : ((i2 > i3) ? i2 : i3));
}
static s7_double max_d_dd(s7_double x1, s7_double x2)
{
if (is_NaN(x1))
return (x1);
return ((x1 > x2) ? x1 : x2);
}
static s7_double max_d_ddd(s7_double x1, s7_double x2, s7_double x3)
{
return (max_d_dd(x1, max_d_dd(x2, x3)));
}
static s7_double max_d_dddd(s7_double x1, s7_double x2, s7_double x3,
s7_double x4)
{
return (max_d_dd(x1, max_d_ddd(x2, x3, x4)));
}
/* ---------------------------------------- min ---------------------------------------- */
#define min_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->min_symbol, X, Y, T_REAL, 1)
#define min_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->min_symbol, X, Y, T_REAL, 2)
static s7_pointer min_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (type(x) == type(y)) {
if (is_t_integer(x))
return ((integer(x) > integer(y)) ? y : x);
if (is_t_real(x))
return (((is_NaN(real(x))) || (real(x) <= real(y))) ? x : y);
if (is_t_ratio(x))
return ((fraction(x) > fraction(y)) ? y : x);
#if WITH_GMP
if (is_t_big_integer(x))
return ((mpz_cmp(big_integer(x), big_integer(y)) > 0) ? y : x);
if (is_t_big_ratio(x))
return ((mpq_cmp(big_ratio(x), big_ratio(y)) > 0) ? y : x);
if (is_t_big_real(x))
return (((mpfr_nan_p(big_real(x)) != 0) || (mpfr_lessequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */
#endif
}
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_RATIO:
return ((integer(x) > fraction(y)) ? y : x);
case T_REAL:
if (is_NaN(real(y)))
return (y);
return ((integer(x) > real(y)) ? y : x);
#if WITH_GMP
case T_BIG_INTEGER:
return ((mpz_cmp_si(big_integer(y), integer(x)) > 0) ? x : y);
case T_BIG_RATIO:
return ((mpq_cmp_si(big_ratio(y), integer(x), 1) > 0) ? x : y);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (y);
return ((mpfr_cmp_si(big_real(y), integer(x)) > 0) ? x : y);
#endif
default:
return (min_out_y(sc, x, y));
}
break;
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return ((fraction(x) > integer(y)) ? y : x);
case T_REAL:
if (is_NaN(real(y)))
return (y);
return ((fraction(x) > real(y)) ? y : x);
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return ((mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0) ? y : x);
case T_BIG_RATIO:
return ((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x))
> 0) ? x : y);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (y);
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return ((mpfr_cmp_q(big_real(y), sc->mpq_1) > 0) ? x : y);
#endif
default:
return (min_out_y(sc, x, y));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
if (is_NaN(real(x)))
return (x);
return ((real(x) > integer(y)) ? y : x);
case T_RATIO:
return ((real(x) > fraction(y)) ? y : x);
#if WITH_GMP
case T_BIG_INTEGER:
if (is_NaN(real(x)))
return (x);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return ((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0) ? y : x);
case T_BIG_RATIO:
if (is_NaN(real(x)))
return (x);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return ((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0) ? y : x);
case T_BIG_REAL:
if (is_NaN(real(x)))
return (x);
if (mpfr_nan_p(big_real(y)))
return (y);
return ((mpfr_cmp_d(big_real(y), real(x)) > 0) ? x : y);
#endif
default:
return (min_out_y(sc, x, y));
}
break;
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
return ((mpz_cmp_si(big_integer(x), integer(y)) > 0) ? y : x);
case T_RATIO:
mpq_set_z(sc->mpq_1, big_integer(x));
return ((mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >
0) ? y : x);
case T_REAL:
if (is_NaN(real(y)))
return (y);
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
return ((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x);
case T_BIG_RATIO:
return ((mpq_cmp_z(big_ratio(y), big_integer(x)) > 0) ? x : y);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (y);
return ((mpfr_cmp_z(big_real(y), big_integer(x)) > 0) ? x : y);
default:
return (min_out_y(sc, x, y));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
return ((mpq_cmp_si(big_ratio(x), integer(y), 1) > 0) ? y : x);
case T_RATIO:
return ((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y))
> 0) ? y : x);
case T_REAL:
if (is_NaN(real(y)))
return (y);
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return ((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x);
case T_BIG_INTEGER:
return ((mpq_cmp_z(big_ratio(x), big_integer(y)) > 0) ? y : x);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (y);
return ((mpfr_cmp_q(big_real(y), big_ratio(x)) > 0) ? x : y);
default:
return (min_out_y(sc, x, y));
}
case T_BIG_REAL:
switch (type(y)) {
case T_INTEGER:
if (mpfr_nan_p(big_real(x)))
return (x);
return ((mpfr_cmp_si(big_real(x), integer(y)) > 0) ? y : x);
case T_RATIO:
if (mpfr_nan_p(big_real(x)))
return (x);
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return ((mpfr_cmp_q(big_real(x), sc->mpq_1) > 0) ? y : x);
case T_REAL:
if (mpfr_nan_p(big_real(x)))
return (x);
if (is_NaN(real(y)))
return (y);
return ((mpfr_cmp_d(big_real(x), real(y)) > 0) ? y : x);
case T_BIG_INTEGER:
if (mpfr_nan_p(big_real(x)))
return (x);
return ((mpfr_cmp_z(big_real(x), big_integer(y)) > 0) ? y : x);
case T_BIG_RATIO:
if (mpfr_nan_p(big_real(x)))
return (x);
return ((mpfr_cmp_q(big_real(x), big_ratio(y)) > 0) ? y : x);
default:
return (min_out_y(sc, x, y));
}
#endif
default:
return (min_out_x(sc, x, y));
}
return (x);
}
static s7_pointer g_min(s7_scheme * sc, s7_pointer args)
{
#define H_min "(min ...) returns the minimum of its arguments"
#define Q_min sc->pcl_r
s7_pointer x = car(args), p;
if (is_null(cdr(args))) {
if (is_real(x))
return (x);
return (method_or_bust_p(sc, x, sc->min_symbol, T_REAL));
}
for (p = cdr(args); is_pair(p); p = cdr(p))
x = min_p_pp(sc, x, car(p));
return (x);
}
static s7_pointer g_min_2(s7_scheme * sc, s7_pointer args)
{
return (min_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_min_3(s7_scheme * sc, s7_pointer args)
{
return (min_p_pp
(sc, min_p_pp(sc, car(args), cadr(args)), caddr(args)));
}
static s7_pointer min_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
return ((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : f));
}
static s7_int min_i_ii(s7_int i1, s7_int i2)
{
return ((i1 < i2) ? i1 : i2);
}
static s7_int min_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
return ((i1 < i2) ? ((i1 < i3) ? i1 : i3) : ((i2 < i3) ? i2 : i3));
}
static s7_double min_d_dd(s7_double x1, s7_double x2)
{
if (is_NaN(x1))
return (x1);
return ((x1 < x2) ? x1 : x2);
}
static s7_double min_d_ddd(s7_double x1, s7_double x2, s7_double x3)
{
return (min_d_dd(x1, min_d_dd(x2, x3)));
}
static s7_double min_d_dddd(s7_double x1, s7_double x2, s7_double x3,
s7_double x4)
{
return (min_d_dd(x1, min_d_ddd(x2, x3, x4)));
}
/* ---------------------------------------- = ---------------------------------------- */
static bool eq_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, x))
return (find_and_apply_method
(sc, x, sc->num_eq_symbol,
set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument_with_type(sc, sc->num_eq_symbol, 1, x,
a_number_string);
return (false);
}
static bool eq_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, y))
return (find_and_apply_method
(sc, y, sc->num_eq_symbol,
set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument_with_type(sc, sc->num_eq_symbol, 2, y,
a_number_string);
return (false);
}
static bool num_eq_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (type(x) == type(y)) {
if (is_t_integer(x))
return (integer(x) == integer(y));
if (is_t_real(x))
return (real(x) == real(y));
if (is_t_complex(x))
return ((real_part(x) == real_part(y))
&& (imag_part(x) == imag_part(y)));
if (is_t_ratio(x))
return ((numerator(x) == numerator(y))
&& (denominator(x) == denominator(y)));
#if WITH_GMP
if (is_t_big_integer(x))
return (mpz_cmp(big_integer(x), big_integer(y)) == 0);
if (is_t_big_ratio(x))
return (mpq_equal(big_ratio(x), big_ratio(y)));
if (is_t_big_real(x))
return (mpfr_equal_p(big_real(x), big_real(y)));
if (is_t_big_complex(x)) { /* mpc_cmp can't handle NaN */
if ((mpfr_nan_p(mpc_realref(big_complex(x))))
|| (mpfr_nan_p(mpc_imagref(big_complex(x))))
|| (mpfr_nan_p(mpc_realref(big_complex(y))))
|| (mpfr_nan_p(mpc_imagref(big_complex(y)))))
return (false);
return (mpc_cmp(big_complex(x), big_complex(y)) == 0);
}
#endif
}
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_RATIO:
return (false);
case T_REAL:
#if WITH_GMP
if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) {
if (is_NaN(real(y)))
return (false);
mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_cmp_si(sc->mpfr_1, integer(x)) == 0);
}
#endif
return (integer(x) == real(y));
case T_COMPLEX:
return (false);
#if WITH_GMP
case T_BIG_INTEGER:
return ((mpz_fits_slong_p(big_integer(y)))
&& (integer(x) == mpz_get_si(big_integer(y))));
case T_BIG_RATIO:
return (false);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_si(big_real(y), integer(x)) == 0));
case T_BIG_COMPLEX:
return (false);
#endif
default:
return (eq_out_y(sc, x, y));
}
break;
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return (false);
case T_REAL:
return (fraction(x) == real(y));
case T_COMPLEX:
return (false);
#if WITH_GMP
case T_BIG_INTEGER:
return (false);
case T_BIG_RATIO:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpq_equal(sc->mpq_1, big_ratio(y)));
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (false);
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpfr_cmp_q(big_real(y), sc->mpq_1) == 0);
case T_BIG_COMPLEX:
return (false);
#endif
default:
return (eq_out_y(sc, x, y));
}
break;
case T_REAL:
switch (type(y)) {
case T_INTEGER:
return (real(x) == integer(y));
case T_RATIO:
return (real(x) == fraction(y));
case T_COMPLEX:
return (false);
#if WITH_GMP
case T_BIG_INTEGER:
if (is_NaN(real(x)))
return (false);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) == 0);
case T_BIG_RATIO:
if (is_NaN(real(x)))
return (false);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) == 0);
case T_BIG_REAL:
if (is_NaN(real(x)))
return (false);
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_d(big_real(y), real(x)) == 0));
case T_BIG_COMPLEX:
return (false);
#endif
default:
return (eq_out_y(sc, x, y));
}
break;
case T_COMPLEX:
if (is_real(y))
return (false);
#if WITH_GMP
if (is_t_big_complex(y)) {
if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) ||
(mpfr_nan_p(mpc_realref(big_complex(y))))
|| (mpfr_nan_p(mpc_imagref(big_complex(y)))))
return (false);
mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN);
return (mpc_cmp(big_complex(y), sc->mpc_1) == 0);
}
#endif
return (eq_out_y(sc, x, y));
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
return ((mpz_fits_slong_p(big_integer(x)))
&& (integer(y) == mpz_get_si(big_integer(x))));
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_cmp_z(sc->mpfr_1, big_integer(x)) == 0);
case T_RATIO:
case T_COMPLEX:
case T_BIG_RATIO:
case T_BIG_COMPLEX:
return (false);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_z(big_real(y), big_integer(x)) == 0));
default:
return (eq_out_y(sc, x, y));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return (mpq_equal(sc->mpq_1, big_ratio(x)));
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN);
return (mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) == 0);
case T_INTEGER:
case T_BIG_INTEGER:
case T_COMPLEX:
case T_BIG_COMPLEX:
return (false);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_q(big_real(y), big_ratio(x)) == 0));
default:
return (eq_out_y(sc, x, y));
}
case T_BIG_REAL:
if ((is_number(y)) && (mpfr_nan_p(big_real(x))))
return (false);
switch (type(y)) {
case T_INTEGER:
return (mpfr_cmp_si(big_real(x), integer(y)) == 0);
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return (mpfr_cmp_q(big_real(x), sc->mpq_1) == 0);
case T_REAL:
return ((!is_NaN(real(y)))
&& (mpfr_cmp_d(big_real(x), real(y)) == 0));
case T_BIG_INTEGER:
return (mpfr_cmp_z(big_real(x), big_integer(y)) == 0);
case T_BIG_RATIO:
return (mpfr_cmp_q(big_real(x), big_ratio(y)) == 0);
case T_COMPLEX:
case T_BIG_COMPLEX:
return (false);
default:
return (eq_out_y(sc, x, y));
}
case T_BIG_COMPLEX:
switch (type(y)) {
case T_RATIO:
case T_REAL:
case T_INTEGER:
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
return (false);
case T_COMPLEX:
if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) ||
(mpfr_nan_p(mpc_realref(big_complex(x))))
|| (mpfr_nan_p(mpc_imagref(big_complex(x)))))
return (false);
mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN);
return (mpc_cmp(big_complex(x), sc->mpc_1) == 0); /* NaN's not allowed! */
default:
return (eq_out_y(sc, x, y));
}
#endif
default:
return (eq_out_x(sc, x, y));
}
return (false);
}
static bool is_number_via_method(s7_scheme * sc, s7_pointer p)
{
if (is_number(p))
return (true);
if (has_active_methods(sc, p)) {
s7_pointer f;
f = find_method_with_let(sc, p, sc->is_number_symbol);
if (f != sc->undefined)
return (is_true
(sc, call_method(sc, p, f, set_plist_1(sc, p))));
}
return (false);
}
static s7_pointer g_num_eq(s7_scheme * sc, s7_pointer args)
{
#define H_num_eq "(= z1 ...) returns #t if all its arguments are equal"
#define Q_num_eq s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol)
s7_pointer x = car(args), p = cdr(args);
if (is_null(cdr(p)))
return (make_boolean(sc, num_eq_b_7pp(sc, x, car(p))));
for (; is_pair(p); p = cdr(p))
if (!num_eq_b_7pp(sc, x, car(p))) {
for (p = cdr(p); is_pair(p); p = cdr(p))
if (!is_number_via_method(sc, car(p)))
return (wrong_type_argument_with_type
(sc, sc->num_eq_symbol, position_of(p, args),
car(p), a_number_string));
return (sc->F);
}
return (sc->T);
}
static bool num_eq_b_ii(s7_int i1, s7_int i2)
{
return (i1 == i2);
}
static bool num_eq_b_dd(s7_double i1, s7_double i2)
{
return (i1 == i2);
}
static s7_pointer num_eq_p_dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
return (make_boolean(sc, x1 == x2));
}
static s7_pointer num_eq_p_ii(s7_scheme * sc, s7_int x1, s7_int x2)
{
return (make_boolean(sc, x1 == x2));
}
static s7_pointer num_eq_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
return (make_boolean(sc, num_eq_b_7pp(sc, x, y)));
}
static s7_pointer num_eq_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
if (is_t_integer(p1))
return ((integer(p1) == p2) ? sc->T : sc->F);
if (is_t_real(p1))
return ((real(p1) == p2) ? sc->T : sc->F);
#if WITH_GMP
if (is_t_big_integer(p1))
return (((mpz_fits_slong_p(big_integer(p1)))
&& (p2 == mpz_get_si(big_integer(p1)))) ? sc->T : sc->F);
if (is_t_big_real(p1))
return ((mpfr_cmp_si(big_real(p1), p2) == 0) ? sc->T : sc->F);
#endif
return ((is_number(p1)) ? sc->F :
make_boolean(sc, eq_out_x(sc, p1, make_integer(sc, p2))));
}
static bool num_eq_b_pi(s7_scheme * sc, s7_pointer x, s7_int y)
{
if (is_t_integer(x))
return (integer(x) == y);
if (is_t_real(x))
return (real(x) == y);
#if WITH_GMP
if (is_t_big_integer(x))
return ((mpz_fits_slong_p(big_integer(x)))
&& (y == mpz_get_si(big_integer(x))));
if (is_t_big_real(x))
return (mpfr_cmp_si(big_real(x), y) == 0);
#endif
if (!is_number(x)) /* complex/ratio */
simple_wrong_type_argument_with_type(sc, sc->num_eq_symbol, x,
a_number_string);
/* return(eq_out_x(sc, x, make_integer(sc, y))); *//* much slower? see thash */
return (false);
}
static s7_pointer g_num_eq_2(s7_scheme * sc, s7_pointer args)
{
s7_pointer x = car(args), y = cadr(args);
if ((is_t_integer(x)) && (is_t_integer(y))) /* this is by far the most common case (ratios aren't used much, and = with floats is frowned upon) */
return (make_boolean(sc, integer(x) == integer(y)));
return (make_boolean(sc, num_eq_b_7pp(sc, x, y)));
}
static inline s7_pointer num_eq_xx(s7_scheme * sc, s7_pointer x,
s7_pointer y)
{
if (is_t_integer(x))
return (make_boolean(sc, integer(x) == integer(y)));
if (is_t_real(x))
return ((is_NaN(real(x))) ? sc->F :
make_boolean(sc, real(x) == integer(y)));
if (!is_number(x))
return (make_boolean(sc, eq_out_x(sc, x, y)));
#if WITH_GMP
if (is_t_big_integer(x))
return (make_boolean
(sc, mpz_cmp_si(big_integer(x), integer(y)) == 0));
if (is_t_big_real(x)) {
if (mpfr_nan_p(big_real(x)))
return (sc->F);
return (make_boolean
(sc, mpfr_cmp_si(big_real(x), integer(y)) == 0));
}
if (is_t_big_ratio(x))
return (make_boolean
(sc, mpq_cmp_si(big_ratio(x), integer(y), 1) == 0));
#endif
return (sc->F);
}
static s7_pointer g_num_eq_xi(s7_scheme * sc, s7_pointer args)
{
return (num_eq_xx(sc, car(args), cadr(args)));
}
static s7_pointer g_num_eq_ix(s7_scheme * sc, s7_pointer args)
{
return (num_eq_xx(sc, cadr(args), car(args)));
}
static s7_pointer num_eq_chooser(s7_scheme * sc, s7_pointer ur_f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 2) {
if ((ops) && (is_t_integer(caddr(expr))))
return (sc->num_eq_xi);
return (((ops)
&& (is_t_integer(cadr(expr)))) ? sc->
num_eq_ix : sc->num_eq_2);
}
return (ur_f);
}
/* ---------------------------------------- < ---------------------------------------- */
static bool lt_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, x))
return (find_and_apply_method
(sc, x, sc->lt_symbol, set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument(sc, sc->lt_symbol, 1, x, T_REAL);
return (false);
}
static bool lt_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, y))
return (find_and_apply_method
(sc, y, sc->lt_symbol, set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument(sc, sc->lt_symbol, 2, y, T_REAL);
return (false);
}
static bool lt_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (type(x) == type(y)) {
if (is_t_integer(x))
return (integer(x) < integer(y));
if (is_t_real(x))
return (real(x) < real(y));
if (is_t_ratio(x))
return (fraction(x) < fraction(y));
#if WITH_GMP
if (is_t_big_integer(x))
return (mpz_cmp(big_integer(x), big_integer(y)) < 0);
if (is_t_big_ratio(x))
return (mpq_cmp(big_ratio(x), big_ratio(y)) < 0);
if (is_t_big_real(x))
return (mpfr_less_p(big_real(x), big_real(y)));
#endif
}
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_RATIO:
return (integer(x) < fraction(y)); /* ?? */
case T_REAL:
return (integer(x) < real(y));
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_cmp_si(big_integer(y), integer(x)) > 0);
case T_BIG_RATIO:
return (mpq_cmp_si(big_ratio(y), integer(x), 1) > 0);
case T_BIG_REAL:
return (mpfr_cmp_si(big_real(y), integer(x)) > 0);
#endif
default:
return (lt_out_y(sc, x, y));
}
break;
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return (fraction(x) < integer(y));
case T_REAL:
return (fraction(x) < real(y));
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0);
case T_BIG_RATIO:
return (mpq_cmp_si(big_ratio(y), numerator(x), denominator(x))
> 0);
case T_BIG_REAL:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpfr_cmp_q(big_real(y), sc->mpq_1) > 0);
#endif
default:
return (lt_out_y(sc, x, y));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
return (real(x) < integer(y));
case T_RATIO:
return (real(x) < fraction(y));
#if WITH_GMP
case T_BIG_INTEGER:
if (is_NaN(real(x)))
return (false);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0);
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0);
case T_BIG_REAL:
return (mpfr_cmp_d(big_real(y), real(x)) > 0);
#endif
default:
return (lt_out_y(sc, x, y));
}
break;
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (mpz_cmp_si(big_integer(x), integer(y)) < 0);
case T_RATIO:
mpq_set_z(sc->mpq_1, big_integer(x));
return (mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) <
0);
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_1, real(y)) < 0);
case T_BIG_RATIO:
return (mpq_cmp_z(big_ratio(y), big_integer(x)) > 0);
case T_BIG_REAL:
return (mpfr_cmp_z(big_real(y), big_integer(x)) > 0);
default:
return (lt_out_y(sc, x, y));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
return (mpq_cmp_si(big_ratio(x), integer(y), 1) < 0);
case T_RATIO:
return (mpq_cmp_si(big_ratio(x), numerator(y), denominator(y))
< 0);
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_1, real(y)) < 0);
case T_BIG_INTEGER:
return (mpq_cmp_z(big_ratio(x), big_integer(y)) < 0);
case T_BIG_REAL:
return (mpfr_cmp_q(big_real(y), big_ratio(x)) > 0);
default:
return (lt_out_y(sc, x, y));
}
case T_BIG_REAL:
switch (type(y)) {
case T_INTEGER:
return (mpfr_cmp_si(big_real(x), integer(y)) < 0);
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return (mpfr_cmp_q(big_real(x), sc->mpq_1) < 0);
case T_REAL:
return (mpfr_cmp_d(big_real(x), real(y)) < 0);
case T_BIG_INTEGER:
return (mpfr_cmp_z(big_real(x), big_integer(y)) < 0);
case T_BIG_RATIO:
return (mpfr_cmp_q(big_real(x), big_ratio(y)) < 0);
default:
return (lt_out_y(sc, x, y));
}
#endif
default:
return (lt_out_x(sc, x, y));
}
return (true);
}
static s7_pointer g_less(s7_scheme * sc, s7_pointer args)
{
#define H_less "(< x1 ...) returns #t if its arguments are in increasing order"
#define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
s7_pointer x = car(args), p = cdr(args);
if (is_null(cdr(p)))
return (make_boolean(sc, lt_b_7pp(sc, x, car(p))));
for (; is_pair(p); p = cdr(p)) {
if (!lt_b_7pp(sc, x, car(p))) {
for (p = cdr(p); is_pair(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
return (wrong_type_argument
(sc, sc->lt_symbol, position_of(p, args),
car(p), T_REAL));
return (sc->F);
}
x = car(p);
}
return (sc->T);
}
static bool ratio_lt_pi(s7_pointer x, s7_int y)
{
if ((y >= 0) && (numerator(x) < 0))
return (true);
if ((y <= 0) && (numerator(x) > 0))
return (false);
if (denominator(x) < S7_INT32_MAX)
return (numerator(x) < (y * denominator(x)));
return (fraction(x) < y);
}
static s7_pointer g_less_x0(s7_scheme * sc, s7_pointer args)
{
s7_pointer x = car(args);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) < 0));
if (is_small_real(x))
return (make_boolean(sc, is_negative(sc, x)));
#if WITH_GMP
if (is_t_big_integer(x))
return (make_boolean(sc, mpz_cmp_si(big_integer(x), 0) < 0));
if (is_t_big_real(x))
return (make_boolean(sc, mpfr_cmp_si(big_real(x), 0) < 0));
if (is_t_big_ratio(x))
return (make_boolean(sc, mpq_cmp_si(big_ratio(x), 0, 1) < 0));
#endif
return (method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1));
}
static s7_pointer g_less_xi(s7_scheme * sc, s7_pointer args)
{
s7_int y = integer(cadr(args));
s7_pointer x = car(args);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) < y));
if (is_t_real(x))
return (make_boolean(sc, real(x) < y));
if (is_t_ratio(x))
return (make_boolean(sc, ratio_lt_pi(x, y)));
#if WITH_GMP
if (is_t_big_integer(x))
return (make_boolean(sc, mpz_cmp_si(big_integer(x), y) < 0));
if (is_t_big_real(x))
return (make_boolean(sc, mpfr_cmp_si(big_real(x), y) < 0));
if (is_t_big_ratio(x))
return (make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) < 0));
#endif
return (method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1));
}
static s7_pointer g_less_xf(s7_scheme * sc, s7_pointer args)
{
s7_double y = real(cadr(args)); /* chooser below checks is_t_real(y) */
s7_pointer x = car(args);
if (is_t_real(x))
return (make_boolean(sc, real(x) < y));
if (is_t_integer(x))
return (make_boolean(sc, integer(x) < y));
if (is_t_ratio(x))
return (make_boolean(sc, fraction(x) < y));
#if WITH_GMP
if (is_t_big_real(x))
return (make_boolean(sc, mpfr_cmp_d(big_real(x), y) < 0));
if (is_t_big_integer(x)) {
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
return (make_boolean
(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) > 0));
}
if (is_t_big_ratio(x)) {
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
return (make_boolean
(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) > 0));
}
#endif
return (method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1));
}
static inline s7_pointer lt_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
return (make_boolean(sc, lt_b_7pp(sc, p1, p2)));
}
static bool lt_b_ii(s7_int i1, s7_int i2)
{
return (i1 < i2);
}
static bool lt_b_dd(s7_double i1, s7_double i2)
{
return (i1 < i2);
}
static s7_pointer lt_p_dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
return (make_boolean(sc, x1 < x2));
}
static s7_pointer lt_p_ii(s7_scheme * sc, s7_int x1, s7_int x2)
{
return (make_boolean(sc, x1 < x2));
}
static bool lt_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
if (is_t_integer(p1))
return (integer(p1) < p2);
if (is_t_real(p1))
return (real(p1) < p2);
if (is_t_ratio(p1))
return (ratio_lt_pi(p1, p2));
#if WITH_GMP
if (is_t_big_integer(p1))
return (mpz_cmp_si(big_integer(p1), p2) < 0);
if (is_t_big_real(p1))
return (mpfr_cmp_si(big_real(p1), p2) < 0);
if (is_t_big_ratio(p1))
return (mpq_cmp_si(big_ratio(p1), p2, 1) < 0);
#endif
return (lt_out_x(sc, p1, make_integer(sc, p2)));
}
static s7_pointer g_less_2(s7_scheme * sc, s7_pointer args)
{
return (lt_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer lt_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
return (make_boolean(sc, lt_b_pi(sc, p1, p2)));
}
static s7_pointer less_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
if (args == 2) {
if (ops) {
s7_pointer arg2 = caddr(expr);
if (is_t_integer(arg2)) {
if (integer(arg2) == 0)
return (sc->less_x0);
if ((integer(arg2) < S7_INT32_MAX) &&
(integer(arg2) > S7_INT32_MIN))
return (sc->less_xi);
}
if (is_t_real(arg2))
return (sc->less_xf);
}
return (sc->less_2);
}
return (f);
}
/* ---------------------------------------- <= ---------------------------------------- */
static bool leq_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, x))
return (find_and_apply_method
(sc, x, sc->leq_symbol, set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument(sc, sc->leq_symbol, 1, x, T_REAL);
return (false);
}
static bool leq_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, y))
return (find_and_apply_method
(sc, y, sc->leq_symbol, set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument(sc, sc->leq_symbol, 2, y, T_REAL);
return (false);
}
static bool leq_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (type(x) == type(y)) {
if (is_t_integer(x))
return (integer(x) <= integer(y));
if (is_t_real(x))
return (real(x) <= real(y));
if (is_t_ratio(x))
return (fraction(x) <= fraction(y));
#if WITH_GMP
if (is_t_big_integer(x))
return (mpz_cmp(big_integer(x), big_integer(y)) <= 0);
if (is_t_big_ratio(x))
return (mpq_cmp(big_ratio(x), big_ratio(y)) <= 0);
if (is_t_big_real(x))
return (mpfr_lessequal_p(big_real(x), big_real(y)));
#endif
}
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_RATIO:
return (integer(x) <= fraction(y)); /* ?? */
case T_REAL:
return (integer(x) <= real(y));
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_cmp_si(big_integer(y), integer(x)) >= 0);
case T_BIG_RATIO:
return (mpq_cmp_si(big_ratio(y), integer(x), 1) >= 0);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_si(big_real(y), integer(x)) >= 0));
#endif
default:
return (leq_out_y(sc, x, y));
}
break;
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return (fraction(x) <= integer(y));
case T_REAL:
return (fraction(x) <= real(y));
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpq_cmp_z(sc->mpq_1, big_integer(y)) <= 0);
case T_BIG_RATIO:
return (mpq_cmp_si(big_ratio(y), numerator(x), denominator(x))
>= 0);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (false);
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpfr_cmp_q(big_real(y), sc->mpq_1) >= 0);
#endif
default:
return (leq_out_y(sc, x, y));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
return (real(x) <= integer(y));
case T_RATIO:
return (real(x) <= fraction(y));
#if WITH_GMP
case T_BIG_INTEGER:
if (is_NaN(real(x)))
return (false);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) <= 0);
case T_BIG_RATIO:
if (is_NaN(real(x)))
return (false);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) <= 0);
case T_BIG_REAL:
if (is_NaN(real(x)))
return (false);
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_d(big_real(y), real(x)) >= 0));
#endif
default:
return (leq_out_y(sc, x, y));
}
break;
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (mpz_cmp_si(big_integer(x), integer(y)) <= 0);
case T_RATIO:
mpq_set_z(sc->mpq_1, big_integer(x));
return (mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) <=
0);
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0);
case T_BIG_RATIO:
return (mpq_cmp_z(big_ratio(y), big_integer(x)) >= 0);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_z(big_real(y), big_integer(x)) >= 0));
default:
return (leq_out_y(sc, x, y));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
return (mpq_cmp_si(big_ratio(x), integer(y), 1) <= 0);
case T_RATIO:
return (mpq_cmp_si(big_ratio(x), numerator(y), denominator(y))
<= 0);
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0);
case T_BIG_INTEGER:
return (mpq_cmp_z(big_ratio(x), big_integer(y)) <= 0);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_q(big_real(y), big_ratio(x)) >= 0));
default:
return (leq_out_y(sc, x, y));
}
case T_BIG_REAL:
if ((is_real(y)) && (mpfr_nan_p(big_real(x))))
return (false);
switch (type(y)) {
case T_INTEGER:
return (mpfr_cmp_si(big_real(x), integer(y)) <= 0);
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return (mpfr_cmp_q(big_real(x), sc->mpq_1) <= 0);
case T_REAL:
return ((!is_NaN(real(y)))
&& (mpfr_cmp_d(big_real(x), real(y)) <= 0));
case T_BIG_INTEGER:
return (mpfr_cmp_z(big_real(x), big_integer(y)) <= 0);
case T_BIG_RATIO:
return (mpfr_cmp_q(big_real(x), big_ratio(y)) <= 0);
default:
return (leq_out_y(sc, x, y));
}
#endif
default:
return (leq_out_x(sc, x, y));
}
return (true);
}
static s7_pointer g_less_or_equal(s7_scheme * sc, s7_pointer args)
{
#define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in non-decreasing order"
#define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
s7_pointer x = car(args), p = cdr(args);
if (is_null(cdr(p)))
return (make_boolean(sc, leq_b_7pp(sc, x, car(p))));
for (; is_pair(p); x = car(p), p = cdr(p))
if (!leq_b_7pp(sc, x, car(p))) {
for (p = cdr(p); is_pair(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
return (wrong_type_argument
(sc, sc->leq_symbol, position_of(p, args),
car(p), T_REAL));
return (sc->F);
}
return (sc->T);
}
static inline s7_pointer leq_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
return (make_boolean(sc, leq_b_7pp(sc, p1, p2)));
}
static bool leq_b_ii(s7_int i1, s7_int i2)
{
return (i1 <= i2);
}
static bool leq_b_dd(s7_double i1, s7_double i2)
{
return (i1 <= i2);
}
static s7_pointer leq_p_dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
return (make_boolean(sc, x1 <= x2));
}
static s7_pointer leq_p_ii(s7_scheme * sc, s7_int x1, s7_int x2)
{
return (make_boolean(sc, x1 <= x2));
}
static bool ratio_leq_pi(s7_pointer x, s7_int y)
{
if ((y >= 0) && (numerator(x) <= 0))
return (true);
if ((y <= 0) && (numerator(x) > 0))
return (false);
if (denominator(x) < S7_INT32_MAX)
return (numerator(x) <= (y * denominator(x)));
return (fraction(x) <= y);
}
static s7_pointer g_leq_xi(s7_scheme * sc, s7_pointer args)
{
s7_int y = integer(cadr(args));
s7_pointer x = car(args);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) <= y));
if (is_t_real(x))
return (make_boolean(sc, real(x) <= y));
if (is_t_ratio(x))
return (make_boolean(sc, ratio_leq_pi(x, y)));
#if WITH_GMP
if (is_t_big_integer(x))
return (make_boolean(sc, mpz_cmp_si(big_integer(x), y) <= 0));
if (is_t_big_real(x)) {
if (mpfr_nan_p(big_real(x)))
return (sc->F);
return (make_boolean(sc, mpfr_cmp_si(big_real(x), y) <= 0));
}
if (is_t_big_ratio(x))
return (make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) <= 0));
#endif
return (method_or_bust(sc, x, sc->leq_symbol, args, T_REAL, 1));
}
static bool leq_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
if (is_t_integer(p1))
return (integer(p1) <= p2);
if (is_t_real(p1))
return (real(p1) <= p2);
if (is_t_ratio(p1))
return (ratio_leq_pi(p1, p2));
#if WITH_GMP
if (is_t_big_integer(p1))
return (mpz_cmp_si(big_integer(p1), p2) <= 0);
if (is_t_big_real(p1))
return (mpfr_cmp_si(big_real(p1), p2) <= 0);
if (is_t_big_ratio(p1))
return (mpq_cmp_si(big_ratio(p1), p2, 1) <= 0);
#endif
return (leq_out_x(sc, p1, make_integer(sc, p2)));
}
static s7_pointer leq_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
return (make_boolean(sc, leq_b_pi(sc, p1, p2)));
}
static s7_pointer g_leq_2(s7_scheme * sc, s7_pointer args)
{
return (make_boolean(sc, leq_b_7pp(sc, car(args), cadr(args))));
}
static s7_pointer g_leq_ixx(s7_scheme * sc, s7_pointer args)
{
s7_pointer p = cdr(args);
if (is_t_integer(car(p))) {
if (integer(car(args)) > integer(car(p))) {
if (!is_real_via_method(sc, cadr(p)))
return (wrong_type_argument
(sc, sc->leq_symbol, 3, cadr(p), T_REAL));
return (sc->F);
}
if (is_t_integer(cadr(p)))
return ((integer(car(p)) > integer(cadr(p))) ? sc->F : sc->T);
}
return (g_less_or_equal(sc, args));
}
static s7_pointer leq_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
if (args == 2) {
if (ops) {
s7_pointer arg2 = caddr(expr);
if ((is_t_integer(arg2)) &&
(integer(arg2) < S7_INT32_MAX) &&
(integer(arg2) > S7_INT32_MIN))
return (sc->leq_xi);
}
return (sc->leq_2);
}
if ((args == 3) && (is_t_integer(cadr(expr))))
return (sc->leq_ixx);
return (f);
}
/* ---------------------------------------- > ---------------------------------------- */
static bool gt_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, x))
return (find_and_apply_method
(sc, x, sc->gt_symbol, set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument(sc, sc->gt_symbol, 1, x, T_REAL);
return (false);
}
static bool gt_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, y))
return (find_and_apply_method
(sc, y, sc->gt_symbol, set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument(sc, sc->gt_symbol, 2, y, T_REAL);
return (false);
}
static bool gt_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (type(x) == type(y)) {
if (is_t_integer(x))
return (integer(x) > integer(y));
if (is_t_real(x))
return (real(x) > real(y));
if (is_t_ratio(x))
return (fraction(x) > fraction(y));
#if WITH_GMP
if (is_t_big_integer(x))
return (mpz_cmp(big_integer(x), big_integer(y)) > 0);
if (is_t_big_ratio(x))
return (mpq_cmp(big_ratio(x), big_ratio(y)) > 0);
if (is_t_big_real(x))
return (mpfr_greater_p(big_real(x), big_real(y)));
#endif
}
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_RATIO:
return (integer(x) > fraction(y)); /* ?? */
case T_REAL:
return (integer(x) > real(y));
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_cmp_si(big_integer(y), integer(x)) < 0);
case T_BIG_RATIO:
return (mpq_cmp_si(big_ratio(y), integer(x), 1) < 0);
case T_BIG_REAL:
return (mpfr_cmp_si(big_real(y), integer(x)) < 0);
#endif
default:
return (gt_out_y(sc, x, y));
}
break;
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return (fraction(x) > integer(y));
case T_REAL:
return (fraction(x) > real(y));
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0);
case T_BIG_RATIO:
return (mpq_cmp_si(big_ratio(y), numerator(x), denominator(x))
< 0);
case T_BIG_REAL:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpfr_cmp_q(big_real(y), sc->mpq_1) < 0);
#endif
default:
return (gt_out_y(sc, x, y));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
return (real(x) > integer(y));
case T_RATIO:
return (real(x) > fraction(y));
#if WITH_GMP
case T_BIG_INTEGER:
if (is_NaN(real(x)))
return (false);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0);
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0);
case T_BIG_REAL:
return (mpfr_cmp_d(big_real(y), real(x)) < 0);
#endif
default:
return (gt_out_y(sc, x, y));
}
break;
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (mpz_cmp_si(big_integer(x), integer(y)) > 0);
case T_RATIO:
mpq_set_z(sc->mpq_1, big_integer(x));
return (mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >
0);
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_1, real(y)) > 0);
case T_BIG_RATIO:
return (mpq_cmp_z(big_ratio(y), big_integer(x)) < 0);
case T_BIG_REAL:
return (mpfr_cmp_z(big_real(y), big_integer(x)) < 0);
default:
return (gt_out_y(sc, x, y));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
return (mpq_cmp_si(big_ratio(x), integer(y), 1) > 0);
case T_RATIO:
return (mpq_cmp_si(big_ratio(x), numerator(y), denominator(y))
> 0);
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_1, real(y)) > 0);
case T_BIG_INTEGER:
return (mpq_cmp_z(big_ratio(x), big_integer(y)) > 0);
case T_BIG_REAL:
return (mpfr_cmp_q(big_real(y), big_ratio(x)) < 0);
default:
return (gt_out_y(sc, x, y));
}
case T_BIG_REAL:
switch (type(y)) {
case T_INTEGER:
return (mpfr_cmp_si(big_real(x), integer(y)) > 0);
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return (mpfr_cmp_q(big_real(x), sc->mpq_1) > 0);
case T_REAL:
return (mpfr_cmp_d(big_real(x), real(y)) > 0);
case T_BIG_INTEGER:
return (mpfr_cmp_z(big_real(x), big_integer(y)) > 0);
case T_BIG_RATIO:
return (mpfr_cmp_q(big_real(x), big_ratio(y)) > 0);
default:
return (gt_out_y(sc, x, y));
}
#endif
default:
return (gt_out_x(sc, x, y));
}
return (true);
}
static s7_pointer g_greater(s7_scheme * sc, s7_pointer args)
{
#define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order"
#define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
s7_pointer x = car(args), p = cdr(args);
if (is_null(cdr(p)))
return (make_boolean(sc, gt_b_7pp(sc, x, car(p))));
for (; is_pair(p); x = car(p), p = cdr(p))
if (!gt_b_7pp(sc, x, car(p))) {
for (p = cdr(p); is_pair(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
return (wrong_type_argument
(sc, sc->gt_symbol, position_of(p, args),
car(p), T_REAL));
return (sc->F);
}
return (sc->T);
}
static s7_pointer g_greater_xi(s7_scheme * sc, s7_pointer args)
{
s7_int y = integer(cadr(args));
s7_pointer x = car(args);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) > y));
if (is_t_real(x))
return (make_boolean(sc, real(x) > y));
if (is_t_ratio(x))
return (make_boolean(sc, !ratio_leq_pi(x, y)));
#if WITH_GMP
if (is_t_big_integer(x))
return (make_boolean(sc, mpz_cmp_si(big_integer(x), y) > 0));
if (is_t_big_real(x))
return (make_boolean(sc, mpfr_cmp_si(big_real(x), y) > 0));
if (is_t_big_ratio(x))
return (make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) > 0));
#endif
return (method_or_bust_with_type
(sc, x, sc->gt_symbol, args, a_number_string, 1));
}
static s7_pointer g_greater_xf(s7_scheme * sc, s7_pointer args)
{
s7_double y = real(cadr(args));
s7_pointer x = car(args);
if (is_t_real(x))
return (make_boolean(sc, real(x) > y));
switch (type(x)) {
case T_INTEGER:
return (make_boolean(sc, integer(x) > y));
case T_RATIO:
/* (> 9223372036854775807/9223372036854775806 1.0) */
if (denominator(x) < S7_INT32_MAX) /* y range check was handled in greater_chooser */
return (make_boolean
(sc, (numerator(x) > (y * denominator(x)))));
return (make_boolean(sc, fraction(x) > y));
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
return (make_boolean
(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) < 0));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
return (make_boolean
(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) < 0));
case T_BIG_REAL:
return (make_boolean(sc, mpfr_cmp_d(big_real(x), y) > 0));
#endif
default:
return (method_or_bust_with_type
(sc, x, sc->gt_symbol, args, a_number_string, 1));
}
return (sc->T);
}
static inline s7_pointer gt_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
return (make_boolean(sc, gt_b_7pp(sc, p1, p2)));
}
static bool gt_b_ii(s7_int i1, s7_int i2)
{
return (i1 > i2);
}
static bool gt_b_dd(s7_double i1, s7_double i2)
{
return (i1 > i2);
}
static s7_pointer gt_p_dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
return (make_boolean(sc, x1 > x2));
}
static s7_pointer gt_p_ii(s7_scheme * sc, s7_int x1, s7_int x2)
{
return (make_boolean(sc, x1 > x2));
}
static bool gt_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
if (is_t_integer(p1))
return (integer(p1) > p2);
if (is_t_real(p1))
return (real(p1) > p2);
if (is_t_ratio(p1))
return (!ratio_leq_pi(p1, p2));
#if WITH_GMP
if (is_t_big_integer(p1))
return (mpz_cmp_si(big_integer(p1), p2) > 0);
if (is_t_big_real(p1))
return (mpfr_cmp_si(big_real(p1), p2) > 0);
if (is_t_big_ratio(p1))
return (mpq_cmp_si(big_ratio(p1), p2, 1) > 0);
#endif
return (gt_out_x(sc, p1, make_integer(sc, p2)));
}
static s7_pointer gt_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
return (make_boolean(sc, gt_b_pi(sc, p1, p2)));
}
static s7_pointer g_greater_2(s7_scheme * sc, s7_pointer args)
{
/* ridiculous repetition, but overheads are killing this poor thing */
s7_pointer x = car(args), y = cadr(args);
if (type(x) == type(y)) {
if (is_t_integer(x))
return (make_boolean(sc, integer(x) > integer(y)));
if (is_t_real(x))
return (make_boolean(sc, real(x) > real(y)));
if (is_t_ratio(x))
return (make_boolean(sc, fraction(x) > fraction(y)));
}
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_RATIO:
return (gt_p_pp(sc, x, y));
case T_REAL:
return (make_boolean(sc, integer(x) > real(y)));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
return (gt_p_pp(sc, x, y));
#endif
default:
return (make_boolean(sc, gt_out_y(sc, x, y)));
}
break;
case T_RATIO:
return (gt_p_pp(sc, x, y));
case T_REAL:
switch (type(y)) {
case T_INTEGER:
return (make_boolean(sc, real(x) > integer(y)));
case T_RATIO:
return (make_boolean(sc, real(x) > fraction(y)));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
return (gt_p_pp(sc, x, y));
#endif
default:
return (make_boolean(sc, gt_out_y(sc, x, y)));
}
break;
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
return (gt_p_pp(sc, x, y));
#endif
default:
return (make_boolean(sc, gt_out_x(sc, x, y)));
}
return (sc->T);
}
static s7_pointer greater_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 2) {
if (ops) {
s7_pointer arg2 = caddr(expr);
if ((is_t_integer(arg2)) &&
(integer(arg2) < S7_INT32_MAX) &&
(integer(arg2) > S7_INT32_MIN))
return (sc->greater_xi);
if ((is_t_real(arg2)) &&
(real(arg2) < S7_INT32_MAX) && (real(arg2) > S7_INT32_MIN))
return (sc->greater_xf);
}
return (sc->greater_2);
}
return (f);
}
/* ---------------------------------------- >= ---------------------------------------- */
static bool geq_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, x))
return (find_and_apply_method
(sc, x, sc->geq_symbol, set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument(sc, sc->geq_symbol, 1, x, T_REAL);
return (false);
}
static bool geq_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (has_active_methods(sc, y))
return (find_and_apply_method
(sc, y, sc->geq_symbol, set_plist_2(sc, x, y)) != sc->F);
wrong_type_argument(sc, sc->geq_symbol, 2, y, T_REAL);
return (false);
}
static bool geq_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
if (type(x) == type(y)) {
if (is_t_integer(x))
return (integer(x) >= integer(y));
if (is_t_real(x))
return (real(x) >= real(y));
if (is_t_ratio(x))
return (fraction(x) >= fraction(y));
#if WITH_GMP
if (is_t_big_integer(x))
return (mpz_cmp(big_integer(x), big_integer(y)) >= 0);
if (is_t_big_ratio(x))
return (mpq_cmp(big_ratio(x), big_ratio(y)) >= 0);
if (is_t_big_real(x))
return (mpfr_greaterequal_p(big_real(x), big_real(y)));
#endif
}
switch (type(x)) {
case T_INTEGER:
switch (type(y)) {
case T_RATIO:
return (integer(x) >= fraction(y)); /* ?? */
case T_REAL:
return (integer(x) >= real(y));
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_cmp_si(big_integer(y), integer(x)) <= 0);
case T_BIG_RATIO:
return (mpq_cmp_si(big_ratio(y), integer(x), 1) <= 0);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_si(big_real(y), integer(x)) <= 0));
#endif
default:
return (geq_out_y(sc, x, y));
}
break;
case T_RATIO:
switch (type(y)) {
case T_INTEGER:
return (fraction(x) >= integer(y));
case T_REAL:
return (fraction(x) >= real(y));
#if WITH_GMP
case T_BIG_INTEGER:
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpq_cmp_z(sc->mpq_1, big_integer(y)) >= 0);
case T_BIG_RATIO:
return (mpq_cmp_si(big_ratio(y), numerator(x), denominator(x))
<= 0);
case T_BIG_REAL:
if (mpfr_nan_p(big_real(y)))
return (false);
mpq_set_si(sc->mpq_1, numerator(x), denominator(x));
return (mpfr_cmp_q(big_real(y), sc->mpq_1) <= 0);
#endif
default:
return (geq_out_y(sc, x, y));
}
case T_REAL:
switch (type(y)) {
case T_INTEGER:
return (real(x) >= integer(y));
case T_RATIO:
return (real(x) >= fraction(y));
#if WITH_GMP
case T_BIG_INTEGER:
if (is_NaN(real(x)))
return (false);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) >= 0);
case T_BIG_RATIO:
if (is_NaN(real(x)))
return (false);
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) >= 0);
case T_BIG_REAL:
if (is_NaN(real(x)))
return (false);
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_d(big_real(y), real(x)) <= 0));
#endif
default:
return (geq_out_y(sc, x, y));
}
break;
#if WITH_GMP
case T_BIG_INTEGER:
switch (type(y)) {
case T_INTEGER:
return (mpz_cmp_si(big_integer(x), integer(y)) >= 0);
case T_RATIO:
mpq_set_z(sc->mpq_1, big_integer(x));
return (mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >=
0);
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0);
case T_BIG_RATIO:
return (mpq_cmp_z(big_ratio(y), big_integer(x)) <= 0);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_z(big_real(y), big_integer(x)) <= 0));
default:
return (geq_out_y(sc, x, y));
}
case T_BIG_RATIO:
switch (type(y)) {
case T_INTEGER:
return (mpq_cmp_si(big_ratio(x), integer(y), 1) >= 0);
case T_RATIO:
return (mpq_cmp_si(big_ratio(x), numerator(y), denominator(y))
>= 0);
case T_REAL:
if (is_NaN(real(y)))
return (false);
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0);
case T_BIG_INTEGER:
return (mpq_cmp_z(big_ratio(x), big_integer(y)) >= 0);
case T_BIG_REAL:
return ((!mpfr_nan_p(big_real(y)))
&& (mpfr_cmp_q(big_real(y), big_ratio(x)) <= 0));
default:
return (geq_out_y(sc, x, y));
}
case T_BIG_REAL:
if ((is_real(y)) && (mpfr_nan_p(big_real(x))))
return (false);
switch (type(y)) {
case T_INTEGER:
return (mpfr_cmp_si(big_real(x), integer(y)) >= 0);
case T_RATIO:
mpq_set_si(sc->mpq_1, numerator(y), denominator(y));
return (mpfr_cmp_q(big_real(x), sc->mpq_1) >= 0);
case T_REAL:
return ((!is_NaN(real(y)))
&& (mpfr_cmp_d(big_real(x), real(y)) >= 0));
case T_BIG_INTEGER:
return (mpfr_cmp_z(big_real(x), big_integer(y)) >= 0);
case T_BIG_RATIO:
return (mpfr_cmp_q(big_real(x), big_ratio(y)) >= 0);
default:
return (geq_out_y(sc, x, y));
}
#endif
default:
return (geq_out_x(sc, x, y));
}
return (true);
}
static s7_pointer g_greater_or_equal(s7_scheme * sc, s7_pointer args)
{
#define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in non-increasing order"
#define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
s7_pointer x = car(args), p = cdr(args);
if (is_null(cdr(p)))
return (make_boolean(sc, geq_b_7pp(sc, x, car(p))));
for (; is_pair(p); x = car(p), p = cdr(p))
if (!geq_b_7pp(sc, x, car(p))) {
for (p = cdr(p); is_pair(p); p = cdr(p))
if (!is_real_via_method(sc, car(p)))
return (wrong_type_argument
(sc, sc->geq_symbol, position_of(p, args),
car(p), T_REAL));
return (sc->F);
}
return (sc->T);
}
static inline s7_pointer geq_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
return (make_boolean(sc, geq_b_7pp(sc, p1, p2)));
}
static bool geq_b_ii(s7_int i1, s7_int i2)
{
return (i1 >= i2);
}
static bool geq_b_dd(s7_double i1, s7_double i2)
{
return (i1 >= i2);
}
static s7_pointer geq_p_dd(s7_scheme * sc, s7_double x1, s7_double x2)
{
return (make_boolean(sc, x1 >= x2));
}
static s7_pointer geq_p_ii(s7_scheme * sc, s7_int x1, s7_int x2)
{
return (make_boolean(sc, x1 >= x2));
}
static s7_pointer g_geq_2(s7_scheme * sc, s7_pointer args)
{
return (make_boolean(sc, geq_b_7pp(sc, car(args), cadr(args))));
}
static s7_pointer g_geq_xf(s7_scheme * sc, s7_pointer args)
{
s7_double y = real(cadr(args));
s7_pointer x = car(args);
return (make_boolean
(sc,
((is_t_real(x)) ? (real(x) >= y) :
geq_b_7pp(sc, car(args), cadr(args)))));
}
static s7_pointer g_geq_xi(s7_scheme * sc, s7_pointer args)
{
s7_int y = integer(cadr(args));
s7_pointer x = car(args);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) >= y));
if (is_t_real(x))
return (make_boolean(sc, real(x) >= y));
if (is_t_ratio(x))
return (make_boolean(sc, !ratio_lt_pi(x, y)));
#if WITH_GMP
if (is_t_big_integer(x))
return (make_boolean(sc, mpz_cmp_si(big_integer(x), y) >= 0));
if (is_t_big_real(x)) {
if (mpfr_nan_p(big_real(x)))
return (sc->F);
return (make_boolean(sc, mpfr_cmp_si(big_real(x), y) >= 0));
}
if (is_t_big_ratio(x))
return (make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) >= 0));
#endif
return (method_or_bust(sc, x, sc->geq_symbol, args, T_REAL, 1));
}
static bool geq_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
if (is_t_integer(p1))
return (integer(p1) >= p2);
if (is_t_real(p1))
return (real(p1) >= p2);
if (is_t_ratio(p1))
return (!ratio_lt_pi(p1, p2));
#if WITH_GMP
if (is_t_big_integer(p1))
return (mpz_cmp_si(big_integer(p1), p2) >= 0);
if (is_t_big_real(p1))
return ((!mpfr_nan_p(big_real(p1)))
&& (mpfr_cmp_si(big_real(p1), p2) >= 0));
if (is_t_big_ratio(p1))
return (mpq_cmp_si(big_ratio(p1), p2, 1) >= 0);
#endif
return (geq_out_x(sc, p1, make_integer(sc, p2)));
}
static s7_pointer geq_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2)
{
return (make_boolean(sc, geq_b_pi(sc, p1, p2)));
}
static s7_pointer geq_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
if (args == 2) {
if (ops) {
s7_pointer arg2 = caddr(expr);
if ((is_t_integer(arg2)) &&
(integer(arg2) < S7_INT32_MAX) &&
(integer(arg2) > S7_INT32_MIN))
return (sc->geq_xi);
if ((is_t_real(arg2)) &&
(real(arg2) < S7_INT32_MAX) && (real(arg2) > S7_INT32_MIN))
return (sc->geq_xf);
}
return (sc->geq_2);
}
return (f);
}
/* ---------------------------------------- real-part ---------------------------------------- */
s7_double s7_real_part(s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return ((s7_double) integer(x));
case T_RATIO:
return (fraction(x));
case T_REAL:
return (real(x));
case T_COMPLEX:
return (real_part(x));
#if WITH_GMP
case T_BIG_INTEGER:
return ((s7_double) mpz_get_si(big_integer(x)));
case T_BIG_RATIO:
return ((s7_double)
((long_double) mpz_get_si(mpq_numref(big_ratio(x))) /
(long_double) mpz_get_si(mpq_denref(big_ratio(x)))));
case T_BIG_REAL:
return ((s7_double) mpfr_get_d(big_real(x), MPFR_RNDN));
case T_BIG_COMPLEX:
return ((s7_double)
mpfr_get_d(mpc_realref(big_complex(x)), MPFR_RNDN));
#endif
}
return (0.0);
}
static s7_pointer real_part_p_p(s7_scheme * sc, s7_pointer p)
{
if (is_t_complex(p))
return (make_real(sc, real_part(p)));
switch (type(p)) {
case T_INTEGER:
case T_RATIO:
case T_REAL:
return (p);
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
return (p);
case T_BIG_COMPLEX:
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL);
big_real_bgf(x) = alloc_bigflt(sc);
add_big_real(sc, x);
mpc_real(big_real(x), big_complex(p), MPFR_RNDN);
return (x);
}
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->real_part_symbol, a_number_string));
}
}
static s7_pointer g_real_part(s7_scheme * sc, s7_pointer args)
{
#define H_real_part "(real-part num) returns the real part of num"
#define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
return (real_part_p_p(sc, car(args)));
}
/* ---------------------------------------- imag-part ---------------------------------------- */
s7_double s7_imag_part(s7_pointer x)
{
if (is_t_complex(x))
return (imag_part(x));
#if WITH_GMP
if (is_t_big_complex(x))
return ((s7_double)
mpfr_get_d(mpc_imagref(big_complex(x)), MPFR_RNDN));
#endif
return (0.0);
}
static s7_pointer imag_part_p_p(s7_scheme * sc, s7_pointer p)
{
if (is_t_complex(p))
return (make_real(sc, imag_part(p)));
switch (type(p)) {
case T_INTEGER:
case T_RATIO:
return (int_zero);
case T_REAL:
return (real_zero);
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
return (int_zero);
case T_BIG_REAL:
return (real_zero);
case T_BIG_COMPLEX:
{
s7_pointer x;
new_cell(sc, x, T_BIG_REAL);
big_real_bgf(x) = alloc_bigflt(sc);
add_big_real(sc, x);
mpc_imag(big_real(x), big_complex(p), MPFR_RNDN);
return (x);
}
#endif
default:
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->imag_part_symbol, a_number_string));
}
}
static s7_pointer g_imag_part(s7_scheme * sc, s7_pointer args)
{
#define H_imag_part "(imag-part num) returns the imaginary part of num"
#define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
/* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */
return (imag_part_p_p(sc, car(args)));
}
/* ---------------------------------------- numerator denominator ---------------------------------------- */
static s7_int numerator_i_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_ratio(p))
return (numerator(p));
if (is_t_integer(p))
return (integer(p));
#if WITH_GMP
if (is_t_big_ratio(p))
return (mpz_get_si(mpq_numref(big_ratio(p))));
if (is_t_big_integer(p))
return (mpz_get_si(big_integer(p)));
#endif
return (integer
(method_or_bust_with_type_one_arg_p
(sc, p, sc->numerator_symbol, a_rational_string)));
}
static s7_pointer g_numerator(s7_scheme * sc, s7_pointer args)
{
#define H_numerator "(numerator rat) returns the numerator of the rational number rat"
#define Q_numerator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)
s7_pointer x = car(args);
switch (type(x)) {
case T_RATIO:
return (make_integer(sc, numerator(x)));
case T_INTEGER:
return (x);
#if WITH_GMP
case T_BIG_INTEGER:
return (x);
case T_BIG_RATIO:
return (mpz_to_integer(sc, mpq_numref(big_ratio(x))));
#endif
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->numerator_symbol, args, a_rational_string));
}
}
static s7_pointer g_denominator(s7_scheme * sc, s7_pointer args)
{
#define H_denominator "(denominator rat) returns the denominator of the rational number rat"
#define Q_denominator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)
s7_pointer x = car(args);
switch (type(x)) {
case T_RATIO:
return (make_integer(sc, denominator(x)));
case T_INTEGER:
return (int_one);
#if WITH_GMP
case T_BIG_INTEGER:
return (int_one);
case T_BIG_RATIO:
return (mpz_to_integer(sc, mpq_denref(big_ratio(x))));
#endif
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->denominator_symbol, args, a_rational_string));
}
}
static s7_int denominator_i_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_ratio(p))
return (denominator(p));
if (is_t_integer(p))
return (1);
#if WITH_GMP
if (is_t_big_ratio(p))
return (mpz_get_si(mpq_denref(big_ratio(p))));
if (is_t_big_integer(p))
return (1);
#endif
return (integer
(method_or_bust_with_type_one_arg_p
(sc, p, sc->denominator_symbol, a_rational_string)));
}
/* ---------------------------------------- number? bignum? complex? integer? byte? rational? real? ---------------------------------------- */
static s7_pointer g_is_number(s7_scheme * sc, s7_pointer args)
{
#define H_is_number "(number? obj) returns #t if obj is a number"
#define Q_is_number sc->pl_bt
check_boolean_method(sc, is_number, sc->is_number_symbol, args);
}
bool s7_is_bignum(s7_pointer obj)
{
return (is_big_number(obj));
}
static s7_pointer g_is_bignum(s7_scheme * sc, s7_pointer args)
{
#define H_is_bignum "(bignum? obj) returns #t if obj is a multiprecision number."
#define Q_is_bignum sc->pl_bt
return (s7_make_boolean(sc, is_big_number(car(args))));
}
static s7_pointer g_is_integer(s7_scheme * sc, s7_pointer args)
{
#define H_is_integer "(integer? obj) returns #t if obj is an integer"
#define Q_is_integer sc->pl_bt
check_boolean_method(sc, s7_is_integer, sc->is_integer_symbol, args);
}
static bool is_byte(s7_pointer p)
{
return ((s7_is_integer(p)) && (s7_integer(p) >= 0)
&& (s7_integer(p) < 256));
}
static s7_pointer g_is_byte(s7_scheme * sc, s7_pointer args)
{
#define H_is_byte "(byte? obj) returns #t if obj is a byte (an integer between 0 and 255)"
#define Q_is_byte sc->pl_bt
check_boolean_method(sc, is_byte, sc->is_byte_symbol, args);
}
static s7_pointer g_is_real(s7_scheme * sc, s7_pointer args)
{
#define H_is_real "(real? obj) returns #t if obj is a real number"
#define Q_is_real sc->pl_bt
check_boolean_method(sc, is_real, sc->is_real_symbol, args);
}
static s7_pointer g_is_complex(s7_scheme * sc, s7_pointer args)
{
#define H_is_complex "(complex? obj) returns #t if obj is a number"
#define Q_is_complex sc->pl_bt
check_boolean_method(sc, is_number, sc->is_complex_symbol, args);
}
static s7_pointer g_is_rational(s7_scheme * sc, s7_pointer args)
{
#define H_is_rational "(rational? obj) returns #t if obj is a rational number (either an integer or a ratio)"
#define Q_is_rational sc->pl_bt
check_boolean_method(sc, is_rational, sc->is_rational_symbol, args);
/* in the non-gmp case, (rational? 455702434782048082459/86885567283849955830) -> #f, not #t, and similarly for exact? etc. */
}
static s7_pointer g_is_float(s7_scheme * sc, s7_pointer args)
{
#define H_is_float "(float? x) returns #t is x is real and not rational."
#define Q_is_float sc->pl_bt
s7_pointer p = car(args);
#if WITH_GMP
return (make_boolean(sc, (is_t_real(p)) || (is_t_big_real(p)))); /* (float? pi) */
#else
return (make_boolean(sc, is_t_real(p)));
#endif
}
#if WITH_GMP
static bool is_float_b(s7_pointer p)
{
return ((is_t_real(p)) || (is_t_big_real(p)));
}
#else
static bool is_float_b(s7_pointer p)
{
return (is_t_real(p));
}
#endif
/* ---------------------------------------- nan? ---------------------------------------- */
static bool is_nan_b_7p(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
case T_RATIO:
return (false);
case T_REAL:
return (is_NaN(real(x)));
case T_COMPLEX:
return ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
return (false);
case T_BIG_REAL:
return (mpfr_nan_p(big_real(x)) != 0);
case T_BIG_COMPLEX:
return ((mpfr_nan_p(mpc_realref(big_complex(x))) != 0)
|| (mpfr_nan_p(mpc_imagref(big_complex(x))) != 0));
#endif
default:
if (is_number(x))
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->is_nan_symbol, a_number_string) != sc->F);
}
return (false);
}
static s7_pointer g_is_nan(s7_scheme * sc, s7_pointer args)
{
#define H_is_nan "(nan? obj) returns #t if obj is a NaN"
#define Q_is_nan sc->pl_bt
return (make_boolean(sc, is_nan_b_7p(sc, car(args))));
}
/* ---------------------------------------- infinite? ---------------------------------------- */
static bool is_infinite_b_7p(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
case T_RATIO:
return (false);
case T_REAL:
return (is_inf(real(x)));
case T_COMPLEX:
return ((is_inf(real_part(x))) || (is_inf(imag_part(x))));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
return (false);
case T_BIG_REAL:
return (mpfr_inf_p(big_real(x)) != 0);
case T_BIG_COMPLEX:
return ((mpfr_inf_p(mpc_realref(big_complex(x))) != 0) ||
(mpfr_inf_p(mpc_imagref(big_complex(x))) != 0));
#endif
default:
if (is_number(x))
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->is_infinite_symbol,
a_number_string) != sc->F);
}
return (false);
}
static s7_pointer g_is_infinite(s7_scheme * sc, s7_pointer args)
{
#define H_is_infinite "(infinite? obj) returns #t if obj is an infinite real"
#define Q_is_infinite sc->pl_bt
return (make_boolean(sc, is_infinite_b_7p(sc, car(args))));
}
/* ---------------------------------------- even? odd?---------------------------------------- */
static bool is_even_b_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_integer(p))
return ((integer(p) & 1) == 0);
#if WITH_GMP
if (is_t_big_integer(p))
return (mpz_even_p(big_integer(p)));
#endif
return (method_or_bust_one_arg_p(sc, p, sc->is_even_symbol, T_INTEGER)
!= sc->F);
}
static bool is_even_i(s7_int i1)
{
return ((i1 & 1) == 0);
}
static s7_pointer g_is_even(s7_scheme * sc, s7_pointer args)
{
#define H_is_even "(even? int) returns #t if the integer int32_t is even"
#define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
return (make_boolean(sc, is_even_b_7p(sc, car(args))));
}
static bool is_odd_b_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_integer(p))
return ((integer(p) & 1) == 1);
#if WITH_GMP
if (is_t_big_integer(p))
return (mpz_odd_p(big_integer(p)));
#endif
return (method_or_bust_one_arg_p(sc, p, sc->is_odd_symbol, T_INTEGER)
!= sc->F);
}
static bool is_odd_i(s7_int i1)
{
return ((i1 & 1) == 1);
}
static s7_pointer g_is_odd(s7_scheme * sc, s7_pointer args)
{
#define H_is_odd "(odd? int) returns #t if the integer int32_t is odd"
#define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
return (make_boolean(sc, is_odd_b_7p(sc, car(args))));
}
/* ---------------------------------------- zero? ---------------------------------------- */
static bool is_zero(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (integer(x) == 0);
case T_REAL:
return (real(x) == 0.0);
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_cmp_ui(big_integer(x), 0) == 0);
case T_BIG_REAL:
return (mpfr_zero_p(big_real(x)));
#endif
default:
return (false); /* ratios and complex numbers here are already collapsed into integers and reals */
}
}
static bool is_zero_b_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_integer(p))
return (integer(p) == 0);
if (is_t_real(p))
return (real(p) == 0.0);
if (is_number(p))
return (is_zero(sc, p));
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->is_zero_symbol, a_number_string) != sc->F);
}
static s7_pointer g_is_zero(s7_scheme * sc, s7_pointer args)
{
#define H_is_zero "(zero? num) returns #t if the number num is zero"
#define Q_is_zero sc->pl_bn
return (make_boolean(sc, is_zero_b_7p(sc, car(args))));
}
static s7_pointer is_zero_p_p(s7_scheme * sc, s7_pointer p)
{
return (make_boolean(sc, is_zero_b_7p(sc, p)));
}
static bool is_zero_i(s7_int p)
{
return (p == 0);
}
static bool is_zero_d(s7_double p)
{
return (p == 0.0);
}
/* -------------------------------- positive? -------------------------------- */
static bool is_positive(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (integer(x) > 0);
case T_RATIO:
return (numerator(x) > 0);
case T_REAL:
return (real(x) > 0.0);
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_cmp_ui(big_integer(x), 0) > 0);
case T_BIG_RATIO:
return (mpq_cmp_ui(big_ratio(x), 0, 1) > 0);
case T_BIG_REAL:
return (mpfr_cmp_ui(big_real(x), 0) > 0);
#endif
default:
return (simple_wrong_type_argument
(sc, sc->is_positive_symbol, x, T_REAL));
}
}
static bool is_positive_b_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_integer(p))
return (integer(p) > 0);
if (is_t_real(p))
return (real(p) > 0.0);
if (is_number(p))
return (is_positive(sc, p));
return (method_or_bust_one_arg_p(sc, p, sc->is_positive_symbol, T_REAL)
!= sc->F);
}
static s7_pointer g_is_positive(s7_scheme * sc, s7_pointer args)
{
#define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)"
#define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)
return (make_boolean(sc, is_positive_b_7p(sc, car(args))));
}
static s7_pointer is_positive_p_p(s7_scheme * sc, s7_pointer p)
{
return (make_boolean(sc, is_positive_b_7p(sc, p)));
}
static bool is_positive_i(s7_int p)
{
return (p > 0);
}
static bool is_positive_d(s7_double p)
{
return (p > 0.0);
}
/* -------------------------------- negative? -------------------------------- */
static bool is_negative(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_INTEGER:
return (integer(x) < 0);
case T_RATIO:
return (numerator(x) < 0);
case T_REAL:
return (real(x) < 0.0);
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_cmp_ui(big_integer(x), 0) < 0);
case T_BIG_RATIO:
return (mpq_cmp_ui(big_ratio(x), 0, 1) < 0);
case T_BIG_REAL:
return (mpfr_cmp_ui(big_real(x), 0) < 0);
#endif
default:
return (simple_wrong_type_argument
(sc, sc->is_negative_symbol, x, T_REAL));
}
}
static bool is_negative_b_7p(s7_scheme * sc, s7_pointer p)
{
if (is_t_integer(p))
return (integer(p) < 0);
if (is_t_real(p))
return (real(p) < 0.0);
if (is_number(p))
return (is_negative(sc, p));
return (method_or_bust_one_arg_p(sc, p, sc->is_negative_symbol, T_REAL)
!= sc->F);
}
static s7_pointer g_is_negative(s7_scheme * sc, s7_pointer args)
{
#define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)"
#define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)
return (make_boolean(sc, is_negative_b_7p(sc, car(args))));
}
static s7_pointer is_negative_p_p(s7_scheme * sc, s7_pointer p)
{
return (make_boolean(sc, is_negative_b_7p(sc, p)));
}
static bool is_negative_i(s7_int p)
{
return (p < 0);
}
static bool is_negative_d(s7_double p)
{
return (p < 0.0);
}
#if (!WITH_PURE_S7)
/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */
static s7_pointer g_exact_to_inexact(s7_scheme * sc, s7_pointer args)
{
#define H_exact_to_inexact "(exact->inexact num) converts num to an inexact number; (exact->inexact 3/2) = 1.5"
#define Q_exact_to_inexact s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol)
/* arg can be complex -> itself! */
return (exact_to_inexact(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_real_symbol, sc->is_real_symbol)
return (inexact_to_exact(sc, car(args)));
}
static s7_pointer g_is_exact(s7_scheme * sc, s7_pointer args)
{
#define H_is_exact "(exact? num) returns #t if num is exact (an integer or a ratio)"
#define Q_is_exact sc->pl_bn
s7_pointer x = car(args);
switch (type(x)) {
case T_INTEGER:
case T_BIG_INTEGER:
case T_RATIO:
case T_BIG_RATIO:
return (sc->T);
case T_REAL:
case T_BIG_REAL:
case T_COMPLEX:
case T_BIG_COMPLEX:
return (sc->F);
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->is_exact_symbol, args, a_number_string));
}
}
static bool is_exact_b_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_number(p))
return (method_or_bust_with_type_one_arg
(sc, p, sc->is_exact_symbol, set_plist_1(sc, p),
a_number_string) != sc->F);
return (is_rational(p));
}
static s7_pointer g_is_inexact(s7_scheme * sc, s7_pointer args)
{
#define H_is_inexact "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)"
#define Q_is_inexact sc->pl_bn
s7_pointer x = car(args);
switch (type(x)) {
case T_INTEGER:
case T_BIG_INTEGER:
case T_RATIO:
case T_BIG_RATIO:
return (sc->F);
case T_REAL:
case T_BIG_REAL:
case T_COMPLEX:
case T_BIG_COMPLEX:
return (sc->T);
default:
return (method_or_bust_with_type_one_arg
(sc, x, sc->is_inexact_symbol, args, a_number_string));
}
}
static bool is_inexact_b_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_number(p))
return (method_or_bust_with_type_one_arg
(sc, p, sc->is_inexact_symbol, set_plist_1(sc, p),
a_number_string) != sc->F);
return (!is_rational(p));
}
/* ---------------------------------------- integer-length ---------------------------------------- */
static int32_t integer_length(s7_int a)
{
if (a < 0) {
if (a == S7_INT64_MIN)
return (63);
a = -a;
}
if (a < 256LL)
return (intlen_bits[a]); /* in gmp, sbcl and clisp (integer-length 0) is 0 */
if (a < 65536LL)
return (8 + intlen_bits[a >> 8]);
if (a < 16777216LL)
return (16 + intlen_bits[a >> 16]);
if (a < 4294967296LL)
return (24 + intlen_bits[a >> 24]);
if (a < 1099511627776LL)
return (32 + intlen_bits[a >> 32]);
if (a < 281474976710656LL)
return (40 + intlen_bits[a >> 40]);
if (a < 72057594037927936LL)
return (48 + intlen_bits[a >> 48]);
return (56 + intlen_bits[a >> 56]);
}
static s7_pointer g_integer_length(s7_scheme * sc, s7_pointer args)
{
#define H_integer_length "(integer-length arg) returns the number of bits required to represent the integer 'arg': (ceiling (log (if (< arg 0) (- arg) (+ arg 1)) 2))"
#define Q_integer_length sc->pcl_i
s7_pointer p = car(args);
if (is_t_integer(p)) {
s7_int x;
x = integer(p);
return ((x <
0) ? small_int(integer_length(-(x + 1))) :
small_int(integer_length(x)));
}
#if WITH_GMP
if (is_t_big_integer(p))
return (make_integer(sc, mpz_sizeinbase(big_integer(p), 2)));
#endif
return (method_or_bust_one_arg
(sc, p, sc->integer_length_symbol, args, T_INTEGER));
}
static s7_int integer_length_i_i(s7_int x)
{
return ((x < 0) ? integer_length(-(x + 1)) : integer_length(x));
}
#endif /* !pure s7 */
/* ---------------------------------------- integer-decode-float ---------------------------------------- */
static s7_pointer g_integer_decode_float(s7_scheme * sc, s7_pointer args)
{
#define H_integer_decode_float "(integer-decode-float x) returns a list containing the significand, exponent, and \
sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)"
#define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol)
typedef union {
int64_t ix;
double fx;
} decode_float_t;
decode_float_t num;
s7_pointer x = car(args);
if (is_t_real(x)) {
if (real(x) == 0.0)
return (list_3(sc, int_zero, int_zero, int_one));
num.fx = (double) real(x);
return (list_3(sc,
make_integer(sc,
(s7_int) ((num.ix & 0xfffffffffffffLL)
| 0x10000000000000LL)),
make_integer(sc,
(s7_int) (((num.ix &
0x7fffffffffffffffLL)
>> 52) - 1023 - 52)),
((num.ix & 0x8000000000000000LL) !=
0) ? minus_one : int_one));
}
#if WITH_GMP
if (is_t_big_real(x)) {
mp_exp_t exp_n;
bool neg;
exp_n = mpfr_get_z_exp(sc->mpz_1, big_real(x));
neg = (mpz_cmp_ui(sc->mpz_1, 0) < 0);
if (neg)
mpz_abs(sc->mpz_1, sc->mpz_1);
return (list_3
(sc, mpz_to_integer(sc, sc->mpz_1),
make_integer(sc, exp_n), (neg) ? minus_one : int_one));
/* not gmp: (integer-decode-float +nan.0): (6755399441055744 972 1), gmp: (integer-decode-float (bignum +nan.0)): (0 -1073741823 1) */
}
#endif
return (method_or_bust_with_type_one_arg
(sc, x, sc->integer_decode_float_symbol, args,
wrap_string(sc, "a non-rational real", 19)));
}
/* -------------------------------- logior -------------------------------- */
#if WITH_GMP
static s7_pointer big_logior(s7_scheme * sc, s7_int start, s7_pointer args)
{
s7_pointer x;
mpz_set_si(sc->mpz_1, start);
for (x = args; is_not_null(x); x = cdr(x)) {
s7_pointer i = car(x);
switch (type(i)) {
case T_BIG_INTEGER:
mpz_ior(sc->mpz_1, sc->mpz_1, big_integer(i));
break;
case T_INTEGER:
mpz_set_si(sc->mpz_2, integer(i));
mpz_ior(sc->mpz_1, sc->mpz_1, sc->mpz_2);
break;
default:
if (!is_integer_via_method(sc, i))
return (wrong_type_argument
(sc, sc->logior_symbol, position_of(x, args), i,
T_INTEGER));
return (method_or_bust
(sc, i, sc->logior_symbol,
set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x),
T_INTEGER, position_of(x, args)));
}
}
return (mpz_to_integer(sc, sc->mpz_1));
}
#endif
static s7_pointer g_logior(s7_scheme * sc, s7_pointer args)
{
#define H_logior "(logior int32_t ...) returns the OR of its integer arguments (the bits that are on in any of the arguments)"
#define Q_logior sc->pcl_i
s7_int result = 0;
s7_pointer x;
for (x = args; is_not_null(x); x = cdr(x)) {
#if WITH_GMP
if (is_t_big_integer(car(x)))
return (big_logior(sc, result, x));
#endif
if (!is_t_integer(car(x)))
return (method_or_bust(sc, car(x), sc->logior_symbol,
(result == 0) ? x : set_ulist_1(sc,
make_integer
(sc,
result),
x),
T_INTEGER, position_of(x, args)));
result |= integer(car(x));
}
return (make_integer(sc, result));
}
static s7_int logior_i_ii(s7_int i1, s7_int i2)
{
return (i1 | i2);
}
static s7_int logior_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
return (i1 | i2 | i3);
}
/* -------------------------------- logxor -------------------------------- */
#if WITH_GMP
static s7_pointer big_logxor(s7_scheme * sc, s7_int start, s7_pointer args)
{
s7_pointer x;
mpz_set_si(sc->mpz_1, start);
for (x = args; is_not_null(x); x = cdr(x)) {
s7_pointer i = car(x);
switch (type(i)) {
case T_BIG_INTEGER:
mpz_xor(sc->mpz_1, sc->mpz_1, big_integer(i));
break;
case T_INTEGER:
mpz_set_si(sc->mpz_2, integer(i));
mpz_xor(sc->mpz_1, sc->mpz_1, sc->mpz_2);
break;
default:
if (!is_integer_via_method(sc, i))
return (wrong_type_argument
(sc, sc->logxor_symbol, position_of(x, args), i,
T_INTEGER));
return (method_or_bust
(sc, i, sc->logxor_symbol,
set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x),
T_INTEGER, position_of(x, args)));
}
}
return (mpz_to_integer(sc, sc->mpz_1));
}
#endif
static s7_pointer g_logxor(s7_scheme * sc, s7_pointer args)
{
#define H_logxor "(logxor int32_t ...) returns the XOR of its integer arguments (the bits that are on in an odd number of the arguments)"
#define Q_logxor sc->pcl_i
s7_int result = 0;
s7_pointer x;
for (x = args; is_not_null(x); x = cdr(x)) {
#if WITH_GMP
if (is_t_big_integer(car(x)))
return (big_logxor(sc, result, x));
#endif
if (!is_t_integer(car(x)))
return (method_or_bust(sc, car(x), sc->logxor_symbol,
(result == 0) ? x : set_ulist_1(sc,
make_integer
(sc,
result),
x),
T_INTEGER, position_of(x, args)));
result ^= integer(car(x));
}
return (make_integer(sc, result));
}
static s7_int logxor_i_ii(s7_int i1, s7_int i2)
{
return (i1 ^ i2);
}
static s7_int logxor_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
return (i1 ^ i2 ^ i3);
}
/* -------------------------------- logand -------------------------------- */
#if WITH_GMP
static s7_pointer big_logand(s7_scheme * sc, s7_int start, s7_pointer args)
{
s7_pointer x;
mpz_set_si(sc->mpz_1, start);
for (x = args; is_not_null(x); x = cdr(x)) {
s7_pointer i = car(x);
switch (type(i)) {
case T_BIG_INTEGER:
mpz_and(sc->mpz_1, sc->mpz_1, big_integer(i));
break;
case T_INTEGER:
mpz_set_si(sc->mpz_2, integer(i));
mpz_and(sc->mpz_1, sc->mpz_1, sc->mpz_2);
break;
default:
if (!is_integer_via_method(sc, i))
return (wrong_type_argument
(sc, sc->logand_symbol, position_of(x, args), i,
T_INTEGER));
return (method_or_bust
(sc, i, sc->logand_symbol,
set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x),
T_INTEGER, position_of(x, args)));
}
}
return (mpz_to_integer(sc, sc->mpz_1));
}
#endif
static s7_pointer g_logand(s7_scheme * sc, s7_pointer args)
{
#define H_logand "(logand int32_t ...) returns the AND of its integer arguments (the bits that are on in every argument)"
#define Q_logand sc->pcl_i
s7_int result = -1;
s7_pointer x;
for (x = args; is_not_null(x); x = cdr(x)) {
#if WITH_GMP
if (is_t_big_integer(car(x)))
return (big_logand(sc, result, x));
#endif
if (!is_t_integer(car(x)))
return (method_or_bust(sc, car(x), sc->logand_symbol,
(result == -1) ? x : set_ulist_1(sc,
make_integer
(sc,
result),
x),
T_INTEGER, position_of(x, args)));
result &= integer(car(x));
}
return (make_integer(sc, result));
}
static s7_int logand_i_ii(s7_int i1, s7_int i2)
{
return (i1 & i2);
}
static s7_int logand_i_iii(s7_int i1, s7_int i2, s7_int i3)
{
return (i1 & i2 & i3);
}
/* -------------------------------- lognot -------------------------------- */
static s7_pointer g_lognot(s7_scheme * sc, s7_pointer args)
{
#define H_lognot "(lognot num) returns the negation of num (its complement, the bits that are not on): (lognot 0) -> -1"
#define Q_lognot sc->pcl_i
s7_pointer x = car(args);
if (is_t_integer(x))
return (make_integer(sc, ~integer(x)));
#if WITH_GMP
if (is_t_big_integer(x)) {
mpz_com(sc->mpz_1, big_integer(x));
return (mpz_to_integer(sc, sc->mpz_1));
}
#endif
return (method_or_bust_one_arg
(sc, x, sc->lognot_symbol, args, T_INTEGER));
}
static s7_int lognot_i_i(s7_int i1)
{
return (~i1);
}
/* -------------------------------- logbit? -------------------------------- */
/* logbit? CL is (logbitp index int) using 2^index, but that order strikes me as backwards
* at least gmp got the arg order right!
*/
static s7_pointer g_logbit(s7_scheme * sc, s7_pointer args)
{
#define H_logbit "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f. The argument \
order here follows gmp, and is the opposite of the CL convention. (logbit? int bit) is the same as (not (zero? (logand int (ash 1 bit))))."
#define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
s7_pointer x = car(args), y = cadr(args);
s7_int index; /* index in gmp is mp_bitcnt which is an unsigned long int */
if (!s7_is_integer(x))
return (method_or_bust
(sc, x, sc->logbit_symbol, args, T_INTEGER, 1));
if (!s7_is_integer(y))
return (method_or_bust
(sc, y, sc->logbit_symbol, args, T_INTEGER, 2));
index = s7_integer_checked(sc, y);
if (index < 0)
return (out_of_range
(sc, sc->logbit_symbol, int_two, 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 int64_ts are necessary, else C turns it into an int, gets confused about signs etc */
return (make_boolean
(sc,
((((int64_t) (1LL << (int64_t) index)) & (int64_t) integer(x))
!= 0)));
}
static bool logbit_b_7ii(s7_scheme * sc, s7_int i1, s7_int i2)
{
if (i2 < 0) {
out_of_range(sc, sc->logbit_symbol, int_two, wrap_integer1(sc, i1),
its_negative_string);
return (false);
}
if (i2 >= S7_INT_BITS)
return (i1 < 0);
return ((((int64_t) (1LL << (int64_t) i2)) & (int64_t) i1) != 0);
}
static bool logbit_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
if (is_t_integer(p1)) {
if (is_t_integer(p2))
return (logbit_b_7ii(sc, integer(p1), integer(p2)));
return (method_or_bust
(sc, p2, sc->logbit_symbol, set_plist_2(sc, p1, p2),
T_INTEGER, 2) != sc->F);
}
#if WITH_GMP
return (g_logbit(sc, set_plist_2(sc, p1, p2)));
#else
return (method_or_bust
(sc, p1, sc->logbit_symbol, set_plist_2(sc, p1, p2), T_INTEGER,
1) != sc->F);
#endif
}
/* -------------------------------- 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) {
if ((arg1 == -1) && (arg2 == 63)) /* (ash -1 63): most-negative-fixnum */
return (S7_INT64_MIN);
out_of_range(sc, sc->ash_symbol, int_two, wrap_integer1(sc, arg2),
its_too_large_string);
}
if (arg2 < -S7_INT_BITS)
return ((arg1 < 0) ? -1 : 0); /* (ash -31 -100) */
/* I can't see any point in protecting this: (ash 9223372036854775807 1) -> -2, but anyone using ash must know something about bits */
if (arg2 < 0)
return (arg1 >> -arg2);
if (arg1 < 0) {
uint64_t z = (uint64_t) arg1;
return ((s7_int) (z << 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 sc->pcl_i
#if WITH_GMP
/* here, as in expt, there are cases like (ash 1 63) which need to be handled as bignums */
s7_pointer 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 easy 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))) {
s7_int shift;
bool p0_is_big = is_big_number(p0);
int32_t p0_compared_to_zero = 0;
if (p0_is_big)
p0_compared_to_zero = mpz_cmp_ui(big_integer(p0), 0);
else if (integer(p0) > 0)
p0_compared_to_zero = 1;
else
p0_compared_to_zero = (integer(p0) < 0) ? -1 : 0;
if (p0_compared_to_zero == 0)
return (int_zero);
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, int_two, p1,
its_too_large_string));
/* here if p0 is negative, we need to return -1 */
return ((p0_compared_to_zero == 1) ? int_zero : minus_one);
}
shift = mpz_get_si(big_integer(p1));
} else {
shift = integer(p1);
if (shift < S7_INT32_MIN)
return ((p0_compared_to_zero == 1) ? int_zero : minus_one);
}
if (shift > S7_INT32_MAX)
return (out_of_range(sc, sc->ash_symbol, int_two, p1, its_too_large_string)); /* gmp calls abort if overflow here */
if (is_t_big_integer(p0))
mpz_set(sc->mpz_1, big_integer(p0));
else
mpz_set_si(sc->mpz_1, integer(p0));
if (shift > 0) /* left */
mpz_mul_2exp(sc->mpz_1, sc->mpz_1, shift);
else if (shift < 0) /* right */
mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t) (-shift));
return (mpz_to_integer(sc, sc->mpz_1));
}
/* else fall through */
#endif
s7_pointer x = car(args), y;
if (!s7_is_integer(x))
return (method_or_bust(sc, x, sc->ash_symbol, args, T_INTEGER, 1));
y = cadr(args);
if (!s7_is_integer(y))
return (method_or_bust(sc, y, sc->ash_symbol, args, T_INTEGER, 2));
return (make_integer
(sc,
c_ash(sc, s7_integer_checked(sc, x),
s7_integer_checked(sc, y))));
}
#if (!WITH_GMP)
static s7_int ash_i_7ii(s7_scheme * sc, s7_int i1, s7_int i2)
{
return (c_ash(sc, i1, i2));
}
#endif
static s7_int lsh_i_ii_unchecked(s7_int i1, s7_int i2)
{
return (i1 << i2);
} /* this may need gmp special handling, and out-of-range as in c_ash */
static s7_int rsh_i_ii_unchecked(s7_int i1, s7_int i2)
{
return (i1 >> (-i2));
}
static s7_int rsh_i_i2_direct(s7_int i1, s7_int i2)
{
return (i1 >> 1);
}
/* -------------------------------- random-state -------------------------------- */
/* random numbers. The simple version used in clm.c is probably adequate, but here I'll use Marsaglia's MWC algorithm.
* (random num) -> a number (0..num), if num == 0 return 0, use global default state
* (random num state) -> same but use this state
* (random-state seed) -> make a new state
* to save the current seed, use copy, to save it across load, random-state->list and list->random-state.
* random-state? returns #t if its arg is one of these guys
*/
s7_pointer s7_random_state(s7_scheme * sc, s7_pointer args)
{
#define H_random_state "(random-state seed (carry plausible-default)) returns a new random number state initialized with 'seed'. \
Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\
(let ((seed (random-state 1234))) (random 1.0 seed))"
#define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol)
#if WITH_GMP
s7_pointer r, seed = car(args);
if (!s7_is_integer(seed))
return (method_or_bust_one_arg
(sc, seed, sc->random_state_symbol, args, T_INTEGER));
if (is_t_integer(seed))
seed = s7_int_to_big_integer(sc, integer(seed));
new_cell(sc, r, T_RANDOM_STATE);
gmp_randinit_default(random_gmp_state(r)); /* Mersenne twister */
gmp_randseed(random_gmp_state(r), big_integer(seed)); /* this is ridiculously slow! */
add_big_random_state(sc, r);
return (r);
#else
s7_pointer r1 = car(args), r2, p;
s7_int i1, i2;
if (!s7_is_integer(r1))
return (method_or_bust
(sc, r1, sc->random_state_symbol, args, T_INTEGER, 1));
i1 = integer(r1);
if (i1 < 0)
return (out_of_range
(sc, sc->random_state_symbol, int_one, r1,
its_negative_string));
if (is_null(cdr(args))) {
new_cell(sc, p, T_RANDOM_STATE);
random_seed(p) = (uint64_t) i1;
random_carry(p) = 1675393560; /* should this be dependent on the seed? */
return (p);
}
r2 = cadr(args);
if (!s7_is_integer(r2))
return (method_or_bust
(sc, r2, sc->random_state_symbol, args, T_INTEGER, 2));
i2 = integer(r2);
if (i2 < 0)
return (out_of_range
(sc, sc->random_state_symbol, int_two, r2,
its_negative_string));
new_cell(sc, p, T_RANDOM_STATE);
random_seed(p) = (uint64_t) i1;
random_carry(p) = (uint64_t) i2;
return (p);
#endif
}
#define g_random_state s7_random_state
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 new_r, obj = car(args);
if (!is_random_state(obj))
return (sc->F);
new_cell(sc, new_r, T_RANDOM_STATE);
random_seed(new_r) = random_seed(obj);
random_carry(new_r) = random_carry(obj);
return (new_r);
#endif
}
/* -------------------------------- random-state? -------------------------------- */
static s7_pointer g_is_random_state(s7_scheme * sc, s7_pointer args)
{
#define H_is_random_state "(random-state? obj) returns #t if obj is a random-state object (from random-state)."
#define Q_is_random_state sc->pl_bt
check_boolean_method(sc, is_random_state, sc->is_random_state_symbol,
args);
}
bool s7_is_random_state(s7_pointer p)
{
return (type(p) == T_RANDOM_STATE);
}
/* -------------------------------- random-state->list -------------------------------- */
s7_pointer s7_random_state_to_list(s7_scheme * sc, s7_pointer args)
{
#define H_random_state_to_list "(random-state->list r) returns the random state object as a list.\
You can later apply random-state to this list to continue a random number sequence from any point."
#define Q_random_state_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_random_state_symbol)
#if WITH_GMP
if ((is_pair(args)) && (!is_random_state(car(args))))
return (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))
return (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
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) = (uint64_t) seed;
random_carry(p) = (uint64_t) carry;
sc->default_rng = p;
#endif
}
/* -------------------------------- random -------------------------------- */
#if WITH_GMP
static double next_random(s7_scheme * sc)
#else
static double next_random(s7_pointer r)
#endif
{
#if (!WITH_GMP)
/* The multiply-with-carry generator for 32-bit integers:
* x(n)=a*x(n-1) + carry mod 2^32
* Choose multiplier a from this list:
* 1791398085 1929682203 1683268614 1965537969 1675393560 1967773755 1517746329 1447497129 1655692410 1606218150
* 2051013963 1075433238 1557985959 1781943330 1893513180 1631296680 2131995753 2083801278 1873196400 1554115554
* ( or any 'a' for which both a*2^32-1 and a*2^31-1 are prime)
*/
double result;
uint64_t 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) ((uint32_t) (random_seed(r))) / 4294967295.5;
/* divisor was 2^32-1 = 4294967295.0, but somehow this can round up once in a billion tries?
* do we want the double just less than 2^32?
* can the multiply-add+logand above return 0? I'm getting 0's from (random (expt 2 62))
*/
/* (let ((mx 0) (mn 1000)) (do ((i 0 (+ i 1))) ((= i 10000)) (let ((val (random 123))) (set! mx (max mx val)) (set! mn (min mn val)))) (list mn mx)) */
return (result);
#else
mpfr_urandomb(sc->mpfr_1, random_gmp_state(sc->default_rng));
return (mpfr_get_d(sc->mpfr_1, MPFR_RNDN));
#endif
}
static s7_pointer g_random(s7_scheme * sc, s7_pointer args)
{
#define H_random "(random num (state #f)) returns a random number of the same type as num between zero and num, equalling num only if num is zero"
#define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol)
s7_pointer r, num;
/* if we disallow (random 0) the programmer has to protect every call on random with (if (eqv? x 0) 0 (random x)). If
* we claim we're using a half-open interval, then we should also disallow (random 0.0); otherwise the following
* must be true: (let* ((x 0.0) (y (random x))) (and (>= y 0.0) (< y x))). The definition above is consistent
* with (random 0) -> 0, simpler to use in practice, and certainly no worse than (/ 0 0) -> 1.
*/
if (is_null(cdr(args)))
r = sc->default_rng;
else {
r = cadr(args);
if (!is_random_state(r))
return (method_or_bust_with_type
(sc, r, sc->random_symbol, args,
a_random_state_object_string, 2));
}
num = car(args);
switch (type(num)) {
#if (!WITH_GMP)
case T_INTEGER:
return (make_integer
(sc, (s7_int) (integer(num) * next_random(r))));
case T_RATIO:
{
s7_double x = fraction(num), error;
s7_int numer = 0, denom = 1;
/* the error here needs to take the size of the fraction into account. Otherwise, if
* error is (say) 1e-6 and the fraction is (say) 9000000/9223372036854775807,
* c_rationalize will always return 0. But even that isn't foolproof:
* (random 1/562949953421312) -> 1/376367230475000
*/
if ((x < 1.0e-10) && (x > -1.0e-10)) {
/* 1e-12 is not tight enough:
* (random 1/2251799813685248) -> 1/2250240579436280
* (random -1/4503599627370496) -> -1/4492889778435526
* (random 1/140737488355328) -> 1/140730223985746
* (random -1/35184372088832) -> -1/35183145492420
* (random -1/70368744177664) -> -1/70366866392738
* (random 1/4398046511104) -> 1/4398033095756
* (random 1/137438953472) -> 1/137438941127
*/
if (numerator(num) < -10)
numer =
-(s7_int) (floor
(-numerator(num) * next_random(r)));
else if (numerator(num) > 10)
numer =
(s7_int) floor(numerator(num) * next_random(r));
else {
int64_t diff;
numer = numerator(num);
diff = S7_INT64_MAX - denominator(num);
if (diff < 100)
return (make_ratio(sc, numer, denominator(num)));
denom =
denominator(num) +
(s7_int) floor(diff * next_random(r));
return (s7_make_ratio(sc, numer, denom));
}
return (make_ratio(sc, numer, denominator(num)));
}
error = ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12;
c_rationalize(x * next_random(r), error, &numer, &denom);
return (make_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)));
#else
case T_INTEGER:
if (integer(num) == 0)
return (int_zero);
mpz_set_si(sc->mpz_1, integer(num));
mpz_urandomm(sc->mpz_1, random_gmp_state(r), sc->mpz_1);
if (integer(num) < 0)
mpz_neg(sc->mpz_1, sc->mpz_1);
return (make_integer(sc, mpz_get_si(sc->mpz_1)));
case T_BIG_INTEGER:
if (mpz_cmp_si(big_integer(num), 0) == 0)
return (int_zero);
mpz_urandomm(sc->mpz_1, random_gmp_state(r), big_integer(num));
/* this does not work if num is a negative number -- you get positive results. so check num for sign, and negate result if necessary. */
if (mpz_cmp_ui(big_integer(num), 0) < 0)
mpz_neg(sc->mpz_1, sc->mpz_1);
return (mpz_to_integer(sc, sc->mpz_1));
case T_RATIO:
mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, sc->mpq_1, MPFR_RNDN);
mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error,
MPFR_RNDN);
return (big_rationalize
(sc,
set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1),
mpfr_to_big_real(sc, sc->mpfr_2))));
case T_BIG_RATIO:
mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(num), MPFR_RNDN);
mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error,
MPFR_RNDN);
return (big_rationalize
(sc,
set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1),
mpfr_to_big_real(sc, sc->mpfr_2))));
case T_REAL:
mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(num), MPFR_RNDN);
return (make_real(sc, mpfr_get_d(sc->mpfr_1, MPFR_RNDN)));
case T_BIG_REAL:
mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
mpfr_mul(sc->mpfr_1, sc->mpfr_1, big_real(num), MPFR_RNDN);
return (mpfr_to_big_real(sc, sc->mpfr_1));
case T_COMPLEX:
mpc_urandom(sc->mpc_1, random_gmp_state(r));
mpfr_mul_d(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1),
real_part(num), MPFR_RNDN);
mpfr_mul_d(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1),
imag_part(num), MPFR_RNDN);
return (s7_make_complex
(sc, mpfr_get_d(mpc_realref(sc->mpc_1), MPFR_RNDN),
mpfr_get_d(mpc_imagref(sc->mpc_1), MPFR_RNDN)));
case T_BIG_COMPLEX:
mpc_urandom(sc->mpc_1, random_gmp_state(r));
mpfr_mul(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1),
mpc_realref(big_complex(num)), MPFR_RNDN);
mpfr_mul(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1),
mpc_imagref(big_complex(num)), MPFR_RNDN);
return (mpc_to_number(sc, sc->mpc_1));
#endif
default:
return (method_or_bust_with_type
(sc, num, sc->random_symbol, args, a_number_string, 1));
}
return (sc->F);
}
s7_double s7_random(s7_scheme * sc, s7_pointer state)
{
#if WITH_GMP
mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN);
mpfr_urandomb(sc->mpfr_1,
random_gmp_state((state) ? state : sc->default_rng));
return ((s7_double) mpfr_get_d(sc->mpfr_1, MPFR_RNDN));
#else
return (next_random((state) ? state : sc->default_rng));
#endif
}
static s7_double random_d_7d(s7_scheme * sc, s7_double x)
{
#if WITH_GMP
return (real(g_random(sc, set_plist_1(sc, wrap_real2(sc, x)))));
#else
return (x * next_random(sc->default_rng));
#endif
}
static s7_int random_i_7i(s7_scheme * sc, s7_int i)
{
#if WITH_GMP
return (integer(g_random(sc, set_plist_1(sc, wrap_integer1(sc, i)))));
#else
return ((s7_int) (i * next_random(sc->default_rng)));
#endif
}
static s7_pointer g_random_i(s7_scheme * sc, s7_pointer args)
{
#if WITH_GMP
return (g_random(sc, args));
#else
return (make_integer
(sc,
(s7_int) (integer(car(args)) *
next_random(sc->default_rng))));
#endif
}
static s7_pointer g_random_f(s7_scheme * sc, s7_pointer args)
{
#if WITH_GMP
return (g_random(sc, args));
#else
return (make_real(sc, real(car(args)) * next_random(sc->default_rng)));
#endif
}
static s7_pointer g_random_1(s7_scheme * sc, s7_pointer args)
{
#if (!WITH_GMP)
s7_pointer num = car(args), r = sc->default_rng;
if (is_t_integer(num))
return (make_integer
(sc, (s7_int) (integer(num) * next_random(r))));
if (is_t_real(num))
return (make_real(sc, real(num) * next_random(r)));
#endif
return (g_random(sc, args));
}
static s7_pointer random_p_p(s7_scheme * sc, s7_pointer num)
{
#if (!WITH_GMP)
if (is_t_integer(num))
return (make_integer
(sc,
(s7_int) (integer(num) * next_random(sc->default_rng))));
if (is_t_real(num))
return (make_real(sc, real(num) * next_random(sc->default_rng)));
#endif
return (g_random(sc, set_plist_1(sc, num)));
}
static s7_pointer random_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if ((ops) && (args == 1)) {
s7_pointer arg1 = cadr(expr);
if (is_t_integer(arg1))
return (sc->random_i);
return ((is_t_real(arg1)) ? sc->random_f : sc->random_1);
}
return (f);
}
static s7_pointer g_add_i_random(s7_scheme * sc, s7_pointer args)
{
#if WITH_GMP
return (add_p_pp(sc, car(args), random_p_p(sc, cadadr(args))));
#else
s7_int x = integer(car(args)), y = integer(opt3_int(args)); /* cadadr */
return (make_integer(sc, x + (s7_int) (y * next_random(sc->default_rng)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */
#endif
}
/* -------------------------------- characters -------------------------------- */
/* -------------------------------- char<->integer -------------------------------- */
static s7_pointer g_char_to_integer(s7_scheme * sc, s7_pointer args)
{
#define H_char_to_integer "(char->integer c) converts the character c to an integer"
#define Q_char_to_integer s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol)
if (!is_character(car(args)))
return (method_or_bust_one_arg
(sc, car(args), sc->char_to_integer_symbol, args,
T_CHARACTER));
return (small_int(character(car(args))));
}
static s7_int char_to_integer_i_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_character(p))
return (integer
(method_or_bust_one_arg_p
(sc, p, sc->char_to_integer_symbol, T_CHARACTER)));
return (character(p));
}
static s7_pointer char_to_integer_p_p(s7_scheme * sc, s7_pointer p)
{
if (!is_character(p))
return (method_or_bust_one_arg_p
(sc, p, sc->char_to_integer_symbol, T_CHARACTER));
return (make_integer(sc, character(p)));
}
static s7_pointer integer_to_char_p_p(s7_scheme * sc, s7_pointer x)
{
s7_int ind;
if (!s7_is_integer(x))
return (method_or_bust_one_arg_p
(sc, x, sc->integer_to_char_symbol, T_INTEGER));
ind = s7_integer_checked(sc, x);
if ((ind >= 0) && (ind < NUM_CHARS))
return (chars[(uint8_t) ind]);
return (s7_out_of_range_error
(sc, "integer->char", 1, x,
"it doen't fit in an unsigned byte"));
}
static s7_pointer g_integer_to_char(s7_scheme * sc, s7_pointer args)
{
#define H_integer_to_char "(integer->char i) converts the non-negative integer i to a character"
#define Q_integer_to_char s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol)
return (integer_to_char_p_p(sc, car(args)));
}
static s7_pointer integer_to_char_p_i(s7_scheme * sc, s7_int ind)
{
if ((ind >= 0) && (ind < NUM_CHARS))
return (chars[(uint8_t) ind]);
return (s7_out_of_range_error(sc, "integer->char", 1, wrap_integer2(sc, ind), "it doen't fit in an unsigned byte")); /* int2 s7_out... uses 1 */
}
static uint8_t uppers[256], lowers[256];
static void init_uppers(void)
{
int32_t i;
for (i = 0; i < 256; i++) {
uppers[i] = (uint8_t) toupper(i);
lowers[i] = (uint8_t) tolower(i);
}
}
static void init_chars(void)
{
s7_cell *cells;
int32_t i;
chars = (s7_pointer *) malloc((NUM_CHARS + 1) * sizeof(s7_pointer)); /* chars is declared far above */
cells = (s7_cell *) calloc(NUM_CHARS + 1, sizeof(s7_cell));
chars[0] = &cells[0];
eof_object = chars[0];
set_full_type(eof_object, T_EOF | T_IMMUTABLE | T_UNHEAP);
eof_name_length(eof_object) = 6;
eof_name(eof_object) = "#<eof>";
chars++; /* now chars[EOF] == chars[-1] == #<eof> */
cells++;
for (i = 0; i < NUM_CHARS; i++) {
s7_pointer cp = &cells[i];
uint8_t c = (uint8_t) i;
set_type_bit(cp, T_IMMUTABLE | T_CHARACTER | T_UNHEAP);
set_optimize_op(cp, OP_CON);
character(cp) = c;
upper_character(cp) = (uint8_t) 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(S) memcpy((void *)(&(character_name(cp))), (const void *)(S), character_name_length(cp) = strlen(S))
switch (c) {
case ' ':
make_character_name("#\\space");
break;
case '\n':
make_character_name("#\\newline");
break;
case '\r':
make_character_name("#\\return");
break;
case '\t':
make_character_name("#\\tab");
break;
case '\0':
make_character_name("#\\null");
break;
case (char) 0x1b:
make_character_name("#\\escape");
break;
case (char) 0x7f:
make_character_name("#\\delete");
break;
case (char) 7:
make_character_name("#\\alarm");
break;
case (char) 8:
make_character_name("#\\backspace");
break;
default:
{
#define P_SIZE 12
int32_t 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;
}
}
}
}
/* -------------------------------- char-upcase, char-downcase ----------------------- */
static s7_pointer char_upcase_p_p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
return (method_or_bust_one_arg_p
(sc, c, sc->char_upcase_symbol, T_CHARACTER));
return (chars[upper_character(c)]);
}
static s7_pointer char_upcase_p_p_unchecked(s7_scheme * sc, s7_pointer c)
{
return (chars[upper_character(c)]);
}
static s7_pointer g_char_upcase(s7_scheme * sc, s7_pointer args)
{
#define H_char_upcase "(char-upcase c) converts the character c to upper case"
#define Q_char_upcase sc->pcl_c
return (char_upcase_p_p(sc, car(args)));
}
static s7_pointer g_char_downcase(s7_scheme * sc, s7_pointer args)
{
#define H_char_downcase "(char-downcase c) converts the character c to lower case"
#define Q_char_downcase sc->pcl_c
if (!is_character(car(args)))
return (method_or_bust_one_arg
(sc, car(args), sc->char_downcase_symbol, args,
T_CHARACTER));
return (chars[lowers[character(car(args))]]);
}
/* -------------------------------- char-alphabetic? char-numeric? char-whitespace? -------------------------------- */
static s7_pointer g_is_char_alphabetic(s7_scheme * sc, s7_pointer args)
{
#define H_is_char_alphabetic "(char-alphabetic? c) returns #t if the character c is alphabetic"
#define Q_is_char_alphabetic sc->pl_bc
if (!is_character(car(args)))
return (method_or_bust_one_arg
(sc, car(args), sc->is_char_alphabetic_symbol, args,
T_CHARACTER));
return (make_boolean(sc, is_char_alphabetic(car(args))));
/* isalpha returns #t for (integer->char 226) and others in that range */
}
static bool is_char_alphabetic_b_7p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
simple_wrong_type_argument(sc, sc->is_char_alphabetic_symbol, c,
T_CHARACTER);
/* return(method_or_bust_one_arg(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), T_CHARACTER) != sc->F); *//* slower? see tmisc */
return (is_char_alphabetic(c));
}
static s7_pointer is_char_alphabetic_p_p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
return (method_or_bust_one_arg
(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c),
T_CHARACTER));
return (make_boolean(sc, is_char_alphabetic(c)));
}
static s7_pointer g_is_char_numeric(s7_scheme * sc, s7_pointer args)
{
#define H_is_char_numeric "(char-numeric? c) returns #t if the character c is a digit"
#define Q_is_char_numeric sc->pl_bc
s7_pointer arg = car(args);
if (!is_character(arg))
return (method_or_bust_one_arg
(sc, arg, sc->is_char_numeric_symbol, args, T_CHARACTER));
return (make_boolean(sc, is_char_numeric(arg)));
}
static bool is_char_numeric_b_7p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
simple_wrong_type_argument(sc, sc->is_char_numeric_symbol, c,
T_CHARACTER);
/* return(method_or_bust_one_arg(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), T_CHARACTER) != sc->F); *//* as above */
return (is_char_numeric(c));
}
static s7_pointer is_char_numeric_p_p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
return (method_or_bust_one_arg
(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c),
T_CHARACTER));
return (make_boolean(sc, is_char_numeric(c)));
}
static s7_pointer g_is_char_whitespace(s7_scheme * sc, s7_pointer args)
{
#define H_is_char_whitespace "(char-whitespace? c) returns #t if the character c is non-printing character"
#define Q_is_char_whitespace sc->pl_bc
s7_pointer arg = car(args);
if (!is_character(arg))
return (method_or_bust_one_arg
(sc, arg, sc->is_char_whitespace_symbol, args,
T_CHARACTER));
return (make_boolean(sc, is_char_whitespace(arg)));
}
static bool is_char_whitespace_b_7p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
simple_wrong_type_argument(sc, sc->is_char_whitespace_symbol, c,
T_CHARACTER);
return (is_char_whitespace(c));
}
static s7_pointer is_char_whitespace_p_p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
return (method_or_bust_one_arg
(sc, c, sc->is_char_whitespace_symbol, set_plist_1(sc, c),
T_CHARACTER));
return (make_boolean(sc, is_char_whitespace(c)));
}
static s7_pointer is_char_whitespace_p_p_unchecked(s7_scheme * sc,
s7_pointer c)
{
return (make_boolean(sc, is_char_whitespace(c)));
}
/* -------------------------------- char-upper-case? char-lower-case? -------------------------------- */
static s7_pointer g_is_char_upper_case(s7_scheme * sc, s7_pointer args)
{
#define H_is_char_upper_case "(char-upper-case? c) returns #t if the character c is in upper case"
#define Q_is_char_upper_case sc->pl_bc
s7_pointer arg = car(args);
if (!is_character(arg))
return (method_or_bust_one_arg
(sc, arg, sc->is_char_upper_case_symbol, args,
T_CHARACTER));
return (make_boolean(sc, is_char_uppercase(arg)));
}
static bool is_char_upper_case_b_7p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
return (method_or_bust_one_arg
(sc, c, sc->is_char_upper_case_symbol, set_plist_1(sc, c),
T_CHARACTER) != sc->F);
return (is_char_uppercase(c));
}
static s7_pointer g_is_char_lower_case(s7_scheme * sc, s7_pointer args)
{
#define H_is_char_lower_case "(char-lower-case? c) returns #t if the character c is in lower case"
#define Q_is_char_lower_case sc->pl_bc
s7_pointer arg = car(args);
if (!is_character(arg))
return (method_or_bust_one_arg
(sc, arg, sc->is_char_lower_case_symbol, args,
T_CHARACTER));
return (make_boolean(sc, is_char_lowercase(arg)));
}
static bool is_char_lower_case_b_7p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
return (method_or_bust_one_arg
(sc, c, sc->is_char_lower_case_symbol, set_plist_1(sc, c),
T_CHARACTER) != sc->F);
return (is_char_lowercase(c));
}
/* -------------------------------- char? -------------------------------- */
static s7_pointer g_is_char(s7_scheme * sc, s7_pointer args)
{
#define H_is_char "(char? obj) returns #t if obj is a character"
#define Q_is_char sc->pl_bt
check_boolean_method(sc, is_character, sc->is_char_symbol, args);
}
static s7_pointer is_char_p_p(s7_scheme * sc, s7_pointer p)
{
return ((is_character(p)) ? sc->T : sc->F);
}
s7_pointer s7_make_character(s7_scheme * sc, uint8_t c)
{
return (chars[c]);
}
bool s7_is_character(s7_pointer p)
{
return (is_character(p));
}
uint8_t s7_character(s7_pointer p)
{
return (character(p));
}
/* -------------------------------- char<? char<=? char>? char>=? char=? -------------------------------- */
static int32_t charcmp(uint8_t c1, uint8_t c2)
{
return ((c1 == c2) ? 0 : (c1 < c2) ? -1 : 1);
/* not tolower here -- the single case is apparently supposed to be upper case
* this matters in a case like (char-ci<? #\_ #\e) which Guile and Gauche say is #f
* although (char<? #\_ #\e) is #t -- the spec does not say how to interpret this!
*/
}
static bool is_character_via_method(s7_scheme * sc, s7_pointer p)
{
if (is_character(p))
return (true);
if (has_active_methods(sc, p)) {
s7_pointer f;
f = find_method_with_let(sc, p, sc->is_char_symbol);
if (f != sc->undefined)
return (is_true
(sc, call_method(sc, p, f, set_plist_1(sc, p))));
}
return (false);
}
static s7_pointer char_with_error_check(s7_scheme * sc, s7_pointer x,
s7_pointer args, s7_pointer caller)
{
s7_pointer y;
for (y = cdr(x); is_pair(y); y = cdr(y)) /* before returning #f, check for bad trailing arguments */
if (!is_character_via_method(sc, car(y)))
return (wrong_type_argument
(sc, caller, position_of(y, args), car(y),
T_CHARACTER));
return (sc->F);
}
static s7_pointer g_char_cmp(s7_scheme * sc, s7_pointer args, int32_t val,
s7_pointer sym)
{
s7_pointer x, y = car(args);
if (!is_character(y))
return (method_or_bust(sc, y, sym, args, T_CHARACTER, 1));
for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) {
if (!is_character(car(x)))
return (method_or_bust
(sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER,
position_of(x, args)));
if (charcmp(character(y), character(car(x))) != val)
return (char_with_error_check(sc, x, args, sym));
}
return (sc->T);
}
static s7_pointer g_char_cmp_not(s7_scheme * sc, s7_pointer args,
int32_t val, s7_pointer sym)
{
s7_pointer x, y = car(args);
if (!is_character(y))
return (method_or_bust(sc, y, sym, args, T_CHARACTER, 1));
for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) {
if (!is_character(car(x)))
return (method_or_bust
(sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER,
position_of(x, args)));
if (charcmp(character(y), character(car(x))) == val)
return (char_with_error_check(sc, x, args, sym));
}
return (sc->T);
}
static s7_pointer g_chars_are_equal(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_equal "(char=? char ...) returns #t if all the character arguments are equal"
#define Q_chars_are_equal sc->pcl_bc
s7_pointer x, y = car(args);
if (!is_character(y))
return (method_or_bust
(sc, y, sc->char_eq_symbol, args, T_CHARACTER, 1));
for (x = cdr(args); is_pair(x); x = cdr(x)) {
if (!is_character(car(x)))
return (method_or_bust
(sc, car(x), sc->char_eq_symbol, set_ulist_1(sc, y, x),
T_CHARACTER, position_of(x, args)));
if (car(x) != y)
return (char_with_error_check
(sc, x, args, sc->char_eq_symbol));
}
return (sc->T);
}
static s7_pointer g_chars_are_less(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_less "(char<? char ...) returns #t if all the character arguments are increasing"
#define Q_chars_are_less sc->pcl_bc
return (g_char_cmp(sc, args, -1, sc->char_lt_symbol));
}
static s7_pointer g_chars_are_greater(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_greater "(char>? char ...) returns #t if all the character arguments are decreasing"
#define Q_chars_are_greater sc->pcl_bc
return (g_char_cmp(sc, args, 1, sc->char_gt_symbol));
}
static s7_pointer g_chars_are_geq(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_geq "(char>=? char ...) returns #t if all the character arguments are equal or decreasing"
#define Q_chars_are_geq sc->pcl_bc
return (g_char_cmp_not(sc, args, -1, sc->char_geq_symbol));
}
static s7_pointer g_chars_are_leq(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_leq "(char<=? char ...) returns #t if all the character arguments are equal or increasing"
#define Q_chars_are_leq sc->pcl_bc
return (g_char_cmp_not(sc, args, 1, sc->char_leq_symbol));
}
static s7_pointer g_simple_char_eq(s7_scheme * sc, s7_pointer args)
{
return (make_boolean(sc, car(args) == cadr(args)));
} /* chooser checks types */
#define check_char2_args(Sc, Caller, P1, P2) \
do { \
if (!is_character(P1)) return(method_or_bust(Sc, P1, Caller, set_plist_2(Sc, P1, P2), T_CHARACTER, 1) != sc->F); \
if (!is_character(P2)) return(method_or_bust(Sc, P2, Caller, set_plist_2(Sc, P1, P2), T_CHARACTER, 2) != sc->F); \
} while (0)
static bool char_lt_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (p1 < p2);
}
static bool char_lt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_lt_symbol, p1, p2);
return (p1 < p2);
}
static bool char_leq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (p1 <= p2);
}
static bool char_leq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_leq_symbol, p1, p2);
return (p1 <= p2);
}
static bool char_gt_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (p1 > p2);
}
static bool char_gt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_gt_symbol, p1, p2);
return (p1 > p2);
}
static bool char_geq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (p1 >= p2);
}
static bool char_geq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_geq_symbol, p1, p2);
return (p1 >= p2);
}
static bool char_eq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (p1 == p2);
}
static bool char_eq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
if (!is_character(p1))
return (method_or_bust
(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2),
T_CHARACTER, 1) != sc->F);
if (p1 == p2)
return (true);
if (!is_character(p2))
return (method_or_bust
(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2),
T_CHARACTER, 2) != sc->F);
return (false);
}
static s7_pointer char_eq_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
if (!is_character(p1))
return (method_or_bust
(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2),
T_CHARACTER, 1));
if (p1 == p2)
return (sc->T);
if (!is_character(p2))
return (method_or_bust
(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2),
T_CHARACTER, 2));
return (sc->F);
}
static s7_pointer g_char_equal_2(s7_scheme * sc, s7_pointer args)
{
if (!is_character(car(args)))
return (method_or_bust
(sc, car(args), sc->char_eq_symbol, args, T_CHARACTER, 1));
if (car(args) == cadr(args))
return (sc->T);
if (!is_character(cadr(args)))
return (method_or_bust
(sc, cadr(args), sc->char_eq_symbol, args, T_CHARACTER,
2));
return (sc->F);
}
static s7_pointer g_char_less_2(s7_scheme * sc, s7_pointer args)
{
if (!is_character(car(args)))
return (method_or_bust
(sc, car(args), sc->char_lt_symbol, args, T_CHARACTER, 1));
if (!is_character(cadr(args)))
return (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 g_char_greater_2(s7_scheme * sc, s7_pointer args)
{
if (!is_character(car(args)))
return (method_or_bust
(sc, car(args), sc->char_gt_symbol, args, T_CHARACTER, 1));
if (!is_character(cadr(args)))
return (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 bool returns_char(s7_scheme * sc, s7_pointer arg)
{
return (argument_type(sc, arg) == sc->is_char_symbol);
}
static s7_pointer char_equal_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if (args == 2) {
if (ops) {
s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
if ((returns_char(sc, arg1)) && (returns_char(sc, arg2)))
return (sc->simple_char_eq);
}
return (sc->char_equal_2);
}
return (f);
}
static s7_pointer char_less_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 2) ? sc->char_less_2 : f);
}
static s7_pointer char_greater_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 2) ? sc->char_greater_2 : f);
}
/* -------------------------------- char-ci<? char-ci<=? char-ci>? char-ci>=? char-ci=? -------------------------------- */
#if (!WITH_PURE_S7)
static s7_pointer g_char_cmp_ci(s7_scheme * sc, s7_pointer args,
int32_t val, s7_pointer sym)
{
s7_pointer x, y = car(args);
if (!is_character(y))
return (method_or_bust(sc, y, sym, args, T_CHARACTER, 1));
for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) {
if (!is_character(car(x)))
return (method_or_bust
(sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER,
position_of(x, args)));
if (charcmp(upper_character(y), upper_character(car(x))) != val)
return (char_with_error_check(sc, x, args, sym));
}
return (sc->T);
}
static s7_pointer g_char_cmp_ci_not(s7_scheme * sc, s7_pointer args,
int32_t val, s7_pointer sym)
{
s7_pointer x, y = car(args);
if (!is_character(y))
return (method_or_bust(sc, y, sym, args, T_CHARACTER, 1));
for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) {
if (!is_character(car(x)))
return (method_or_bust
(sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER,
position_of(x, args)));
if (charcmp(upper_character(y), upper_character(car(x))) == val)
return (char_with_error_check(sc, x, args, sym));
}
return (sc->T);
}
static s7_pointer g_chars_are_ci_equal(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_ci_equal "(char-ci=? char ...) returns #t if all the character arguments are equal, ignoring case"
#define Q_chars_are_ci_equal sc->pcl_bc
return (g_char_cmp_ci(sc, args, 0, sc->char_ci_eq_symbol));
}
static s7_pointer g_chars_are_ci_less(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_ci_less "(char-ci<? char ...) returns #t if all the character arguments are increasing, ignoring case"
#define Q_chars_are_ci_less sc->pcl_bc
return (g_char_cmp_ci(sc, args, -1, sc->char_ci_lt_symbol));
}
static s7_pointer g_chars_are_ci_greater(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_ci_greater "(char-ci>? char ...) returns #t if all the character arguments are decreasing, ignoring case"
#define Q_chars_are_ci_greater sc->pcl_bc
return (g_char_cmp_ci(sc, args, 1, sc->char_ci_gt_symbol));
}
static s7_pointer g_chars_are_ci_geq(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_ci_geq "(char-ci>=? char ...) returns #t if all the character arguments are equal or decreasing, ignoring case"
#define Q_chars_are_ci_geq sc->pcl_bc
return (g_char_cmp_ci_not(sc, args, -1, sc->char_ci_geq_symbol));
}
static s7_pointer g_chars_are_ci_leq(s7_scheme * sc, s7_pointer args)
{
#define H_chars_are_ci_leq "(char-ci<=? char ...) returns #t if all the character arguments are equal or increasing, ignoring case"
#define Q_chars_are_ci_leq sc->pcl_bc
return (g_char_cmp_ci_not(sc, args, 1, sc->char_ci_leq_symbol));
}
static bool char_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (upper_character(p1) < upper_character(p2));
}
static bool char_ci_lt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_ci_lt_symbol, p1, p2);
return (upper_character(p1) < upper_character(p2));
}
static bool char_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (upper_character(p1) <= upper_character(p2));
}
static bool char_ci_leq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_ci_leq_symbol, p1, p2);
return (upper_character(p1) <= upper_character(p2));
}
static bool char_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (upper_character(p1) > upper_character(p2));
}
static bool char_ci_gt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_ci_gt_symbol, p1, p2);
return (upper_character(p1) > upper_character(p2));
}
static bool char_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (upper_character(p1) >= upper_character(p2));
}
static bool char_ci_geq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_ci_geq_symbol, p1, p2);
return (upper_character(p1) >= upper_character(p2));
}
static bool char_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (upper_character(p1) == upper_character(p2));
}
static bool char_ci_eq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_char2_args(sc, sc->char_ci_eq_symbol, p1, p2);
return (upper_character(p1) == upper_character(p2));
}
#endif /* not pure s7 */
/* -------------------------------- char-position -------------------------------- */
static s7_pointer g_char_position(s7_scheme * sc, s7_pointer args)
{
#define H_char_position "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f"
#define Q_char_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_integer_symbol)
const char *porig, *pset;
s7_int start, pos, len; /* not "int" because start arg might be most-negative-fixnum */
s7_pointer arg1 = car(args), arg2;
if ((!is_character(arg1)) && (!is_string(arg1)))
return (method_or_bust
(sc, arg1, sc->char_position_symbol, args, T_CHARACTER,
1));
arg2 = cadr(args);
if (!is_string(arg2))
return (method_or_bust
(sc, arg2, sc->char_position_symbol, args, T_STRING, 2));
if (is_pair(cddr(args))) {
s7_pointer arg3 = caddr(args);
if (!s7_is_integer(arg3))
return (method_or_bust
(sc, arg3, sc->char_position_symbol, args, T_INTEGER,
3));
start = s7_integer_checked(sc, 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;
porig = string_value(arg2);
len = string_length(arg2);
if (start >= len)
return (sc->F);
if (is_character(arg1)) {
char c = character(arg1);
const char *p;
p = strchr((const char *) (porig + start), (int) c); /* use strchrnul in Gnu C to catch embedded null case */
return ((p) ? make_integer(sc, p - porig) : sc->F);
}
if (string_length(arg1) == 0)
return (sc->F);
pset = string_value(arg1);
pos = strcspn((const char *) (porig + start), (const char *) pset);
if ((pos + start) < len)
return (make_integer(sc, pos + start));
/* if the string has an embedded null, we can get erroneous results here --
* perhaps check for null at pos+start? What about a searched-for string that also has embedded nulls?
*/
return (sc->F);
}
static s7_pointer char_position_p_ppi(s7_scheme * sc, s7_pointer p1,
s7_pointer p2, s7_int start)
{
/* p1 is char, p2 is string */
const char *porig, *p;
s7_int len;
char c;
if (!is_string(p2))
simple_wrong_type_argument(sc, sc->char_position_symbol, p2,
T_STRING);
if (start < 0)
wrong_type_argument_with_type(sc, sc->char_position_symbol, 3,
make_integer(sc, start),
a_non_negative_integer_string);
c = character(p1);
len = string_length(p2);
porig = string_value(p2);
if (start >= len)
return (sc->F);
p = strchr((const char *) (porig + start), (int) c);
if (p)
return (make_integer(sc, p - porig));
return (sc->F);
}
static s7_pointer g_char_position_csi(s7_scheme * sc, s7_pointer args)
{
/* assume char arg1, no end */
const char *porig, *p;
char c = character(car(args));
s7_pointer arg2 = cadr(args);
s7_int start, len;
if (!is_string(arg2))
return (g_char_position(sc, args));
len = string_length(arg2); /* can't return #f here if len==0 -- need start error check first */
porig = string_value(arg2);
if (is_pair(cddr(args))) {
s7_pointer arg3 = caddr(args);
if (!s7_is_integer(arg3))
return (g_char_position(sc, args));
start = s7_integer_checked(sc, 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);
return ((p) ? make_integer(sc, p - porig) : sc->F);
}
static s7_pointer char_position_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if (!ops)
return (f);
if ((is_character(cadr(expr))) && ((args == 2) || (args == 3)))
return (sc->char_position_csi);
return (f);
}
/* -------------------------------- string-position -------------------------------- */
static s7_pointer g_string_position(s7_scheme * sc, s7_pointer args)
{
#define H_string_position "(string-position str1 str2 (start 0)) returns the starting position of str1 in str2 or #f"
#define Q_string_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)
const char *s1, *s2, *p2;
s7_int start = 0;
s7_pointer s1p = car(args), s2p;
if (!is_string(s1p))
return (method_or_bust
(sc, s1p, sc->string_position_symbol, args, T_STRING, 1));
s2p = cadr(args);
if (!is_string(s2p))
return (method_or_bust
(sc, s2p, sc->string_position_symbol, args, T_STRING, 2));
if (is_pair(cddr(args))) {
s7_pointer arg3 = caddr(args);
if (!s7_is_integer(arg3))
return (method_or_bust
(sc, arg3, sc->string_position_symbol, args, T_INTEGER,
3));
start = s7_integer_checked(sc, arg3);
if (start < 0)
return (wrong_type_argument_with_type
(sc, sc->string_position_symbol, 3, caddr(args),
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);
return ((p2) ? make_integer(sc, p2 - s2) : sc->F);
}
/* -------------------------------- strings -------------------------------- */
static s7_pointer nil_string; /* permanent "" */
bool s7_is_string(s7_pointer p)
{
return (is_string(p));
}
const char *s7_string(s7_pointer p)
{
return (string_value(p));
}
s7_int s7_string_length(s7_pointer str)
{
return (string_length(str));
}
s7_pointer s7_make_string_with_length(s7_scheme * sc, const char *str,
s7_int len)
{
return (make_string_with_length(sc, str, len));
}
#define NUM_STRING_WRAPPERS 8 /* should be a power of 2 */
static s7_pointer wrap_string(s7_scheme * sc, const char *str, s7_int len)
{
s7_pointer x;
x = sc->string_wrappers[sc->string_wrapper_pos];
sc->string_wrapper_pos = (sc->string_wrapper_pos + 1) & (NUM_STRING_WRAPPERS - 1); /* i.e. next is pos+1 modulo len */
string_value(x) = (char *) str;
string_length(x) = len;
return (x);
}
s7_pointer s7_make_string_wrapper(s7_scheme * sc, const char *str)
{
return (wrap_string(sc, str, safe_strlen(str)));
}
static Inline s7_pointer inline_make_empty_string(s7_scheme * sc,
s7_int len, char fill)
{
s7_pointer x;
block_t *b;
if (len == 0)
return (nil_string);
new_cell(sc, x, T_STRING);
b = mallocate(sc, len + 1);
string_block(x) = b;
string_value(x) = (char *) block_data(b);
if (fill != '\0')
local_memset((void *) (string_value(x)), fill, len);
string_value(x)[len] = 0;
string_hash(x) = 0;
string_length(x) = len;
add_string(sc, x);
return (x);
}
static s7_pointer make_empty_string(s7_scheme * sc, s7_int len, char fill)
{
return (inline_make_empty_string(sc, len, fill));
}
s7_pointer s7_make_string(s7_scheme * sc, const char *str)
{
return ((str) ? make_string_with_length(sc, str, safe_strlen(str)) :
nil_string);
}
static char *make_permanent_c_string(s7_scheme * sc, const char *str)
{
char *x;
s7_int len;
len = safe_strlen(str);
x = (char *) permalloc(sc, len + 1);
memcpy((void *) x, (void *) str, len);
x[len] = 0;
return (x);
}
s7_pointer s7_make_permanent_string(s7_scheme * sc, const char *str)
{
/* for the symbol table which is never GC'd */
s7_pointer x;
s7_int len;
if (!str)
return (nil_string);
x = alloc_pointer(sc);
set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP);
set_optimize_op(x, OP_CON);
len = safe_strlen(str);
string_length(x) = len;
string_block(x) = NULL;
string_value(x) = (char *) permalloc(sc, len + 1);
memcpy((void *) string_value(x), (void *) str, len);
string_value(x)[len] = 0;
string_hash(x) = 0;
return (x);
}
static s7_pointer g_is_string(s7_scheme * sc, s7_pointer args)
{
#define H_is_string "(string? obj) returns #t if obj is a string"
#define Q_is_string sc->pl_bt
check_boolean_method(sc, is_string, sc->is_string_symbol, args);
}
static s7_pointer make_permanent_string(const char *str)
{
s7_pointer x;
s7_int len;
x = (s7_pointer) calloc(1, sizeof(s7_cell));
set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP);
set_optimize_op(x, OP_CON);
len = safe_strlen(str);
string_length(x) = len;
string_block(x) = NULL;
string_value(x) = (char *) str;
string_hash(x) = 0;
return (x);
}
static void init_strings(void)
{
nil_string = make_permanent_string("");
nil_string->tf.flag = T_STRING | T_UNHEAP;
set_optimize_op(nil_string, OP_CON);
car_a_list_string =
make_permanent_string("a pair whose car is also a pair");
cdr_a_list_string =
make_permanent_string("a pair whose cdr is also a pair");
caar_a_list_string =
make_permanent_string("a pair whose caar is also a pair");
cadr_a_list_string =
make_permanent_string("a pair whose cadr is also a pair");
cdar_a_list_string =
make_permanent_string("a pair whose cdar is also a pair");
cddr_a_list_string =
make_permanent_string("a pair whose cddr is also a pair");
caaar_a_list_string =
make_permanent_string("a pair whose caaar is also a pair");
caadr_a_list_string =
make_permanent_string("a pair whose caadr is also a pair");
cadar_a_list_string =
make_permanent_string("a pair whose cadar is also a pair");
caddr_a_list_string =
make_permanent_string("a pair whose caddr is also a pair");
cdaar_a_list_string =
make_permanent_string("a pair whose cdaar is also a pair");
cdadr_a_list_string =
make_permanent_string("a pair whose cdadr is also a pair");
cddar_a_list_string =
make_permanent_string("a pair whose cddar is also a pair");
cdddr_a_list_string =
make_permanent_string("a pair whose cdddr is also a pair");
a_list_string = make_permanent_string("a list");
an_eq_func_string =
make_permanent_string("a procedure that can take 2 arguments");
an_association_list_string =
make_permanent_string("an association list");
a_normal_real_string = make_permanent_string("a normal real");
a_rational_string = make_permanent_string("an integer or a ratio");
a_number_string = make_permanent_string("a number");
a_procedure_string = make_permanent_string("a procedure");
a_procedure_or_a_macro_string =
make_permanent_string("a procedure or a macro");
a_normal_procedure_string =
make_permanent_string("a normal procedure");
a_let_string = make_permanent_string("a let (environment)");
a_proper_list_string = make_permanent_string("a proper list");
a_boolean_string = make_permanent_string("a boolean");
a_byte_vector_string = make_permanent_string("a byte-vector");
an_input_port_string = make_permanent_string("an input port");
an_open_port_string = make_permanent_string("an open port");
an_output_port_string = make_permanent_string("an output port");
an_input_string_port_string =
make_permanent_string("an input string port");
an_input_file_port_string =
make_permanent_string("an input file port");
an_output_string_port_string =
make_permanent_string("an output string port");
an_output_file_port_string =
make_permanent_string("an output file port");
a_thunk_string = make_permanent_string("a thunk");
a_symbol_string = make_permanent_string("a symbol");
a_non_negative_integer_string =
make_permanent_string("a non-negative integer");
an_unsigned_byte_string = make_permanent_string("an unsigned byte");
something_applicable_string =
make_permanent_string("a procedure or something applicable");
a_random_state_object_string =
make_permanent_string("a random-state object");
a_format_port_string =
make_permanent_string("#f, #t, (), or an open output port");
a_non_constant_symbol_string =
make_permanent_string("a non-constant symbol");
a_sequence_string = make_permanent_string("a sequence");
a_valid_radix_string =
make_permanent_string("should be between 2 and 16");
result_is_too_large_string =
make_permanent_string("result is too large");
its_too_large_string = make_permanent_string("it is too large");
its_too_small_string =
make_permanent_string("it is less than the start position");
its_negative_string = make_permanent_string("it is negative");
its_nan_string =
make_permanent_string("NaN usually indicates a numerical error");
its_infinite_string = make_permanent_string("it is infinite");
too_many_indices_string = make_permanent_string("too many indices");
value_is_missing_string = make_permanent_string("~A argument ~S's value is missing"); /* not '~A because it's normally a keyword */
parameter_set_twice_string =
make_permanent_string("parameter set twice, ~S in ~S");
immutable_error_string =
make_permanent_string("can't ~S ~S (it is immutable)");
no_setter_string =
make_permanent_string("~A (~A) does not have a setter");
cant_bind_immutable_string =
make_permanent_string("can't bind an immutable object: ~S");
intermediate_too_large_string =
make_permanent_string("intermediate result is too large");
#if (!HAVE_COMPLEX_NUMBERS)
no_complex_numbers_string =
make_permanent_string
("this version of s7 does not support complex numbers");
#endif
format_string_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A");
format_string_2 = make_permanent_string("format: ~S: ~A");
format_string_3 =
make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A");
format_string_4 = make_permanent_string("format: ~S~&~NT^: ~A");
too_many_arguments_string =
make_permanent_string("~S: too many arguments: ~A");
not_enough_arguments_string =
make_permanent_string("~S: not enough arguments: ~A");
missing_method_string =
make_permanent_string("missing ~S method in ~S");
}
/* -------------------------------- 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 = car(args);
s7_int len;
char fill;
if (!s7_is_integer(n)) {
check_method(sc, n, sc->make_string_symbol, args);
return (wrong_type_argument
(sc, sc->make_string_symbol, 1, n, T_INTEGER));
}
len = s7_integer_checked(sc, n);
if (len == 0)
return (nil_string);
if ((len < 0) || (len > sc->max_string_length))
return (out_of_range
(sc, sc->make_string_symbol, int_one, n,
(len < 0) ? its_negative_string : its_too_large_string));
if (is_null(cdr(args)))
return (make_empty_string(sc, len, '\0')); /* #\null here means "don't fill/clear" */
if (!is_character(cadr(args)))
return (method_or_bust
(sc, cadr(args), sc->make_string_symbol, args, T_CHARACTER,
2));
fill = s7_character(cadr(args));
n = make_empty_string(sc, len, fill);
if (fill == '\0')
memclr((void *) string_value(n), (size_t) len);
return (n);
}
static s7_pointer make_string_p_i(s7_scheme * sc, s7_int len)
{
if (len == 0)
return (nil_string);
if ((len < 0) || (len > sc->max_string_length))
return (out_of_range
(sc, sc->make_string_symbol, int_one,
wrap_integer1(sc, len),
(len < 0) ? its_negative_string : its_too_large_string));
return (make_empty_string(sc, len, '\0'));
}
#if (!WITH_PURE_S7)
/* -------------------------------- string-length -------------------------------- */
static s7_pointer g_string_length(s7_scheme * sc, s7_pointer args)
{
#define H_string_length "(string-length str) returns the length of the string str"
#define Q_string_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
s7_pointer p = car(args);
if (!is_string(p))
return (method_or_bust_one_arg
(sc, p, sc->string_length_symbol, args, T_STRING));
return (make_integer(sc, string_length(p)));
}
static s7_int string_length_i_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_string(p))
return (integer
(method_or_bust_one_arg_p
(sc, p, sc->string_length_symbol, T_STRING)));
return (string_length(p));
}
#endif
/* -------------------------------- string-up|downcase -------------------------------- */
static s7_pointer g_string_downcase(s7_scheme * sc, s7_pointer args)
{
#define H_string_downcase "(string-downcase str) returns the lower case version of str."
#define Q_string_downcase sc->pcl_s
s7_pointer p = car(args), newstr;
s7_int i, len;
uint8_t *nstr, *ostr;
if (!is_string(p))
return (method_or_bust_one_arg_p
(sc, p, sc->string_downcase_symbol, T_STRING));
len = string_length(p);
newstr = make_empty_string(sc, len, 0);
ostr = (uint8_t *) string_value(p);
nstr = (uint8_t *) string_value(newstr);
if (len >= 128) {
i = len - 1;
while (i >= 8)
LOOP_8(nstr[i] = lowers[(uint8_t) ostr[i]]; i--);
while (i >= 0) {
nstr[i] = lowers[(uint8_t) ostr[i]];
i--;
}
} else
for (i = 0; i < len; i++)
nstr[i] = lowers[(uint8_t) ostr[i]];
return (newstr);
}
static s7_pointer g_string_upcase(s7_scheme * sc, s7_pointer args)
{
#define H_string_upcase "(string-upcase str) returns the upper case version of str."
#define Q_string_upcase sc->pcl_s
s7_pointer p = car(args), newstr;
s7_int i, len;
uint8_t *nstr, *ostr;
if (!is_string(p))
return (method_or_bust_one_arg_p
(sc, p, sc->string_upcase_symbol, T_STRING));
len = string_length(p);
newstr = make_empty_string(sc, len, 0);
ostr = (uint8_t *) string_value(p);
nstr = (uint8_t *) string_value(newstr);
if (len >= 128) {
i = len - 1;
while (i >= 8)
LOOP_8(nstr[i] = uppers[(uint8_t) ostr[i]]; i--);
while (i >= 0) {
nstr[i] = uppers[(uint8_t) ostr[i]];
i--;
}
} else
for (i = 0; i < len; i++)
nstr[i] = uppers[(uint8_t) ostr[i]];
return (newstr);
}
/* -------------------------------- string-ref -------------------------------- */
static s7_pointer string_ref_1(s7_scheme * sc, s7_pointer strng,
s7_pointer index)
{
char *str;
s7_int ind;
if (!s7_is_integer(index))
return (method_or_bust_pp
(sc, index, sc->string_ref_symbol, strng, index, T_INTEGER,
2));
ind = s7_integer_checked(sc, index);
if (ind < 0)
return (out_of_range
(sc, sc->string_ref_symbol, int_two, index,
a_non_negative_integer_string));
if (ind >= string_length(strng))
return (out_of_range
(sc, sc->string_ref_symbol, int_two, index,
its_too_large_string));
str = string_value(strng);
return (chars[((uint8_t *) str)[ind]]);
}
static s7_pointer g_string_ref(s7_scheme * sc, s7_pointer args)
{
#define H_string_ref "(string-ref str index) returns the character at the index-th element of the string str"
#define Q_string_ref s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol)
s7_pointer strng = car(args);
if (!is_string(strng))
return (method_or_bust
(sc, strng, sc->string_ref_symbol, args, T_STRING, 1));
return (string_ref_1(sc, strng, cadr(args)));
}
static s7_pointer string_ref_p_pi(s7_scheme * sc, s7_pointer p1, s7_int i1)
{
if (!is_string(p1))
return (method_or_bust
(sc, p1, sc->string_ref_symbol,
set_plist_2(sc, p1, make_integer(sc, i1)), T_STRING, 1));
if ((i1 >= 0) && (i1 < string_length(p1)))
return (chars[((uint8_t *) string_value(p1))[i1]]);
out_of_range(sc, sc->string_ref_symbol, int_two, wrap_integer1(sc, i1),
(i1 < 0) ? its_negative_string : its_too_large_string);
return (p1);
}
static s7_pointer string_ref_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer i1)
{
if (!is_string(p1))
return (method_or_bust_pp
(sc, p1, sc->string_ref_symbol, p1, i1, T_STRING, 1));
return (string_ref_1(sc, p1, i1));
}
static s7_pointer string_ref_p_p0(s7_scheme * sc, s7_pointer p1,
s7_pointer i1)
{ /* i1 can be NULL */
if (!is_string(p1))
return (method_or_bust_pp
(sc, p1, sc->string_ref_symbol, p1, int_zero, T_STRING,
1));
if (string_length(p1) > 0)
return (chars[((uint8_t *) string_value(p1))[0]]);
out_of_range(sc, sc->string_ref_symbol, int_two, int_zero,
its_too_large_string);
return (p1);
}
static s7_pointer string_plast_via_method(s7_scheme * sc, s7_pointer p1)
{
s7_pointer len;
len = method_or_bust_one_arg_p(sc, p1, sc->length_symbol, T_STRING);
return (method_or_bust_with_type_pi
(sc, p1, sc->string_ref_symbol, p1, integer(len) - 1,
sc->prepackaged_type_names[T_STRING]));
}
static s7_pointer string_ref_p_plast(s7_scheme * sc, s7_pointer p1,
s7_pointer i1)
{
if (!is_string(p1))
return (string_plast_via_method(sc, p1));
if (string_length(p1) > 0)
return (chars
[((uint8_t *) string_value(p1))[string_length(p1) - 1]]);
out_of_range(sc, sc->string_ref_symbol, int_two,
wrap_integer1(sc, string_length(p1) - 1),
its_too_large_string);
return (p1);
}
static s7_pointer string_ref_p_pi_unchecked(s7_scheme * sc, s7_pointer p1,
s7_int i1)
{
if ((i1 >= 0) && (i1 < string_length(p1)))
return (chars[((uint8_t *) string_value(p1))[i1]]);
out_of_range(sc, sc->string_ref_symbol, int_two, wrap_integer1(sc, i1),
(i1 < 0) ? its_negative_string : its_too_large_string);
return (p1);
}
static s7_pointer string_ref_unchecked(s7_scheme * sc, s7_pointer p1,
s7_int i1)
{
return (chars[((uint8_t *) string_value(p1))[i1]]);
}
/* -------------------------------- 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 strng = car(args), c, index;
char *str;
s7_int ind;
if (!is_mutable_string(strng))
return (mutable_method_or_bust
(sc, strng, sc->string_set_symbol, args, T_STRING, 1));
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->string_set_symbol, args, T_INTEGER, 2));
ind = s7_integer_checked(sc, index);
if (ind < 0)
return (out_of_range
(sc, sc->string_set_symbol, int_two, index,
a_non_negative_integer_string));
if (ind >= string_length(strng))
return (out_of_range
(sc, sc->string_set_symbol, int_two, index,
its_too_large_string));
str = string_value(strng);
c = caddr(args);
if (!is_character(c))
return (method_or_bust
(sc, c, sc->string_set_symbol, args, T_CHARACTER, 3));
str[ind] = (char) s7_character(c);
return (c);
}
static s7_pointer string_set_p_pip(s7_scheme * sc, s7_pointer p1,
s7_int i1, s7_pointer p2)
{
if (!is_string(p1))
simple_wrong_type_argument(sc, sc->string_set_symbol, p1,
T_STRING);
if (!is_character(p2))
simple_wrong_type_argument(sc, sc->string_set_symbol, p2,
T_CHARACTER);
if ((i1 >= 0) && (i1 < string_length(p1)))
string_value(p1)[i1] = s7_character(p2);
else
out_of_range(sc, sc->string_set_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
return (p2);
}
static s7_pointer string_set_p_pip_unchecked(s7_scheme * sc, s7_pointer p1,
s7_int i1, s7_pointer p2)
{
if ((i1 >= 0) && (i1 < string_length(p1)))
string_value(p1)[i1] = s7_character(p2);
else
out_of_range(sc, sc->string_set_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
return (p2);
}
static s7_pointer string_set_unchecked(s7_scheme * sc, s7_pointer p1,
s7_int i1, s7_pointer p2)
{
string_value(p1)[i1] = s7_character(p2);
return (p2);
}
/* -------------------------------- string-append -------------------------------- */
static s7_pointer g_string_append_1(s7_scheme * sc, s7_pointer args,
s7_pointer caller)
{
#define H_string_append "(string-append str1 ...) appends all its string arguments into one string"
#define Q_string_append sc->pcl_s
s7_int len = 0;
s7_pointer x, newstr;
char *pos;
if (is_null(args))
return (nil_string);
s7_gc_protect_via_stack(sc, args);
/* 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_active_methods(sc, p)) {
s7_pointer func;
func = find_method_with_let(sc, p, caller);
if (func != sc->undefined) {
s7_pointer y;
if (len == 0) {
unstack(sc);
return (call_method(sc, p, func, x)); /* not args (string-append "" "" ...) */
}
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)));
unstack(sc);
return (call_method
(sc, p, func, set_ulist_1(sc, newstr, x)));
}
}
unstack(sc);
return (wrong_type_argument
(sc, caller, position_of(x, args), p, T_STRING));
}
len += string_length(p);
}
if (len == 0) {
unstack(sc);
return (nil_string);
}
if (len > sc->max_string_length) {
unstack(sc);
return (s7_error(sc, sc->out_of_range_symbol,
set_elist_4(sc,
wrap_string(sc,
"~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D",
70), caller,
wrap_integer1(sc, len),
wrap_integer2(sc,
sc->max_string_length))));
}
newstr = inline_make_empty_string(sc, len, 0);
for (pos = string_value(newstr), x = args; is_not_null(x); x = cdr(x)) {
len = string_length(car(x));
if (len > 0) {
memcpy(pos, string_value(car(x)), len);
pos += len;
}
}
unstack(sc);
return (newstr);
}
static s7_pointer g_string_append(s7_scheme * sc, s7_pointer args)
{
return (g_string_append_1(sc, args, sc->string_append_symbol));
}
static inline s7_pointer string_append_1(s7_scheme * sc, s7_pointer s1,
s7_pointer s2)
{
if ((is_string(s1)) && (is_string(s2))) {
s7_int len, pos = string_length(s1);
s7_pointer newstr;
if (pos == 0)
return (make_string_with_length
(sc, string_value(s2), string_length(s2)));
len = pos + string_length(s2);
if (len == pos)
return (make_string_with_length
(sc, string_value(s1), string_length(s1)));
if (len > sc->max_string_length)
return (s7_error(sc, sc->out_of_range_symbol,
set_elist_4(sc,
wrap_string(sc,
"~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D",
70),
sc->string_append_symbol,
wrap_integer1(sc, len),
wrap_integer2(sc,
sc->max_string_length))));
newstr = make_empty_string(sc, len, 0); /* len+1 0-terminated */
memcpy(string_value(newstr), string_value(s1), pos);
memcpy((char *) (string_value(newstr) + pos), string_value(s2),
string_length(s2));
return (newstr);
}
return (g_string_append_1
(sc, list_2(sc, s1, s2), sc->string_append_symbol));
}
static s7_pointer string_append_p_pp(s7_scheme * sc, s7_pointer s1,
s7_pointer s2)
{
return (string_append_1(sc, s1, s2));
}
static s7_pointer g_string_append_2(s7_scheme * sc, s7_pointer args)
{
return (string_append_1(sc, car(args), cadr(args)));
}
static void check_for_substring_temp(s7_scheme * sc, s7_pointer expr);
static s7_pointer string_append_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
check_for_substring_temp(sc, expr);
return ((args == 2) ? sc->string_append_2 : f);
}
/* -------------------------------- substring -------------------------------- */
static s7_pointer start_and_end(s7_scheme * sc, s7_pointer caller,
s7_pointer args, int32_t position,
s7_pointer index_args, s7_int * start,
s7_int * end)
{
/* we assume that *start=0 and *end=length, that end is "exclusive", return true if the start/end points are not changed */
s7_pointer pstart = car(index_args);
s7_int index;
if (!s7_is_integer(pstart))
return (method_or_bust
(sc, pstart, caller, args, T_INTEGER, position));
index = s7_integer_checked(sc, 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_pair(cdr(index_args))) {
s7_pointer pend = cadr(index_args);
if (!s7_is_integer(pend))
return (method_or_bust
(sc, pend, caller, args, T_INTEGER, position + 1));
index = s7_integer_checked(sc, 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->unused);
}
static s7_pointer g_substring(s7_scheme * sc, s7_pointer args)
{
#define H_substring "(substring str start (end (length str))) returns the portion of the string str between start and \
end: (substring \"01234\" 1 2) -> \"1\""
#define Q_substring s7_make_circular_signature(sc, 2, 3, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)
s7_pointer x, str = car(args);
s7_int start = 0, end, len;
char *s;
if (!is_string(str))
return (method_or_bust
(sc, str, sc->substring_symbol, args, T_STRING, 1));
end = string_length(str);
if (!is_null(cdr(args))) {
x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args),
&start, &end);
if (x != sc->unused)
return (x);
}
s = string_value(str);
len = end - start;
if (len == 0)
return (nil_string);
x = inline_make_string_with_length(sc, (char *) (s + start), len);
string_value(x)[len] = 0;
return (x);
}
static s7_pointer g_substring_uncopied(s7_scheme * sc, s7_pointer args)
{
s7_pointer str = car(args);
s7_int start = 0, end;
if (!is_string(str))
return (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, args, 2, cdr(args),
&start, &end);
if (x != sc->unused)
return (x);
}
return (wrap_string
(sc, (char *) (string_value(str) + start), end - start));
}
static s7_pointer substring_uncopied_p_pii(s7_scheme * sc, s7_pointer str,
s7_int start, s7_int end)
{
if (!is_string(str))
return (method_or_bust
(sc, str, sc->substring_symbol,
set_plist_3(sc, str, make_integer(sc, start),
make_integer(sc, end)), T_STRING, 1));
if ((end < start) || (end > string_length(str)))
return (out_of_range
(sc, sc->substring_symbol, int_three,
wrap_integer1(sc, end),
(end <
start) ? its_too_small_string : its_too_large_string));
if ((start < 0) || (start > end))
return (out_of_range
(sc, sc->substring_symbol, int_two,
wrap_integer1(sc, start),
(start <
0) ? its_negative_string : its_too_large_string));
return (wrap_string
(sc, (char *) (string_value(str) + start), end - start));
}
static s7_pointer g_get_output_string(s7_scheme * sc, s7_pointer args);
static void check_for_substring_temp(s7_scheme * sc, s7_pointer expr)
{
s7_pointer nps[NUM_STRING_WRAPPERS];
s7_pointer p, arg;
int32_t substrs = 0, i;
/* don't use substring_uncopied for arg if arg is returned: (reverse! (write-string (substring x ...))) */
for (p = cdr(expr); is_pair(p); p = cdr(p)) {
arg = car(p);
if ((is_pair(arg)) &&
(is_symbol(car(arg))) &&
(is_safely_optimized(arg)) && (has_fn(arg))) {
if (fn_proc(arg) == g_substring) {
if (substrs < NUM_STRING_WRAPPERS)
nps[substrs++] = arg;
} else if (fn_proc(arg) == g_symbol_to_string)
set_c_function(arg, sc->symbol_to_string_uncopied);
else if ((fn_proc(arg) == g_get_output_string)
&& (is_null(cddr(arg))))
set_c_function(arg, sc->get_output_string_uncopied);
}
}
for (i = 0; i < substrs; i++)
set_c_function(nps[i], sc->substring_uncopied);
}
static s7_pointer string_substring_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
/* used by several string functions */
check_for_substring_temp(sc, expr);
return (f);
}
/* -------------------------------- string-copy -------------------------------- */
static s7_pointer g_string_copy(s7_scheme * sc, s7_pointer args)
{
#define H_string_copy "(string-copy str dest-str (dest-start 0) dest-end) returns a copy of its string argument. If dest-str is given, \
string-copy copies its first argument into the second, starting at dest-start in the second string and returns dest-str"
#define Q_string_copy s7_make_signature(sc, 5, sc->is_string_symbol, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol)
s7_pointer source = car(args), p, dest;
s7_int start, end;
if (!is_string(source))
return (method_or_bust
(sc, source, sc->string_copy_symbol, args, T_STRING, 1));
if (is_null(cdr(args)))
return (make_string_with_length
(sc, string_value(source), string_length(source)));
dest = cadr(args);
if (!is_string(dest))
return (wrong_type_argument
(sc, sc->string_copy_symbol, 2, dest, T_STRING));
if (is_immutable(dest))
return (immutable_object_error
(sc,
set_elist_2(sc,
wrap_string(sc,
"can't string-copy to ~S; it is immutable",
40), dest)));
end = string_length(dest);
p = cddr(args);
if (is_null(p))
start = 0;
else {
if (!s7_is_integer(car(p)))
return (wrong_type_argument
(sc, sc->string_copy_symbol, 3, car(p), T_INTEGER));
start = s7_integer_checked(sc, car(p));
if (start < 0)
start = 0;
p = cdr(p);
if (is_null(p))
end = start + string_length(source);
else {
if (!s7_is_integer(car(p)))
return (wrong_type_argument
(sc, sc->string_copy_symbol, 4, car(p),
T_INTEGER));
end = s7_integer_checked(sc, car(p));
if (end < 0)
end = start;
}
}
if (end > string_length(dest))
end = string_length(dest);
if (end <= start)
return (dest);
if ((end - start) > string_length(source))
end = start + string_length(source);
memcpy((void *) (string_value(dest) + start),
(void *) (string_value(source)), end - start);
return (dest);
}
static s7_pointer string_copy_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if (args == 1)
check_for_substring_temp(sc, expr);
return (f);
}
/* -------------------------------- string comparisons -------------------------------- */
static int32_t scheme_strcmp(s7_pointer s1, s7_pointer s2)
{
/* tricky here because str[i] must be treated as unsigned: (string<? (string (integer->char #xf0)) (string (integer->char #x70)))
* and null or lack thereof does not say anything about the string end
*/
size_t i, len, len1 = (size_t) string_length(s1), len2 =
(size_t) string_length(s2);
char *str1 = string_value(s1), *str2 = string_value(s2);
len = (len1 > len2) ? len2 : len1;
if (len < sizeof(size_t)) {
for (i = 0; i < len; i++) {
if ((uint8_t) (str1[i]) < (uint8_t) (str2[i]))
return (-1);
if ((uint8_t) (str1[i]) > (uint8_t) (str2[i]))
return (1);
}
} else {
/* this algorithm from stackoverflow(?), with various changes (original did not work for large strings, etc) */
size_t last, pos;
size_t *ptr1, *ptr2;
last = len / sizeof(size_t);
for (ptr1 = (size_t *) str1, ptr2 = (size_t *) str2, i = 0;
i < last; i++)
if (ptr1[i] != ptr2[i])
break;
for (pos = i * sizeof(size_t); pos < len; pos++) {
if ((uint8_t) str1[pos] < (uint8_t) str2[pos])
return (-1);
if ((uint8_t) str1[pos] > (uint8_t) str2[pos])
return (1);
}
}
if (len1 < len2)
return (-1);
return ((len1 > len2) ? 1 : 0);
}
static bool is_string_via_method(s7_scheme * sc, s7_pointer p)
{
if (s7_is_string(p))
return (true);
if (has_active_methods(sc, p)) {
s7_pointer f;
f = find_method_with_let(sc, p, sc->is_string_symbol);
if (f != sc->undefined)
return (is_true
(sc, call_method(sc, p, f, set_plist_1(sc, p))));
}
return (false);
}
static s7_pointer g_string_cmp(s7_scheme * sc, s7_pointer args,
int32_t val, s7_pointer sym)
{
s7_pointer x, y = car(args);
if (!is_string(y))
return (method_or_bust(sc, y, sym, args, T_STRING, 1));
for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) {
if (!is_string(car(x)))
return (method_or_bust
(sc, car(x), sym, set_ulist_1(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);
}
}
return (sc->T);
}
static s7_pointer g_string_cmp_not(s7_scheme * sc, s7_pointer args,
int32_t val, s7_pointer sym)
{
s7_pointer x, y = car(args);
if (!is_string(y))
return (method_or_bust(sc, y, sym, args, T_STRING, 1));
for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) {
if (!is_string(car(x)))
return (method_or_bust
(sc, car(x), sym, set_ulist_1(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);
}
}
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 sc->pcl_bs
/* C-based check stops at null, but we can have embedded nulls.
* (let ((s1 "1234") (s2 "1245")) (string-set! s1 1 #\null) (string-set! s2 1 #\null) (string=? s1 s2))
*/
s7_pointer x, y = car(args);
bool happy = true;
if (!is_string(y))
return (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 = car(x);
if (y != p) {
if (!is_string(p))
return (method_or_bust
(sc, p, sc->string_eq_symbol,
set_ulist_1(sc, y, x), T_STRING, position_of(x,
args)));
if (happy)
happy = scheme_strings_are_equal(p, y);
}
}
return ((happy) ? sc->T : sc->F);
}
static s7_pointer g_strings_are_less(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_less "(string<? str ...) returns #t if all the string arguments are increasing"
#define Q_strings_are_less sc->pcl_bs
return (g_string_cmp(sc, args, -1, sc->string_lt_symbol));
}
static s7_pointer g_strings_are_greater(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing"
#define Q_strings_are_greater sc->pcl_bs
return (g_string_cmp(sc, args, 1, sc->string_gt_symbol));
}
static s7_pointer g_strings_are_geq(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_geq "(string>=? str ...) returns #t if all the string arguments are equal or decreasing"
#define Q_strings_are_geq sc->pcl_bs
return (g_string_cmp_not(sc, args, -1, sc->string_geq_symbol));
}
static s7_pointer g_strings_are_leq(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_leq "(string<=? str ...) returns #t if all the string arguments are equal or increasing"
#define Q_strings_are_leq sc->pcl_bs
return (g_string_cmp_not(sc, args, 1, sc->string_leq_symbol));
}
static s7_pointer g_string_equal_2(s7_scheme * sc, s7_pointer args)
{
if (!is_string(car(args)))
return (method_or_bust
(sc, car(args), sc->string_eq_symbol, args, T_STRING, 1));
if (!is_string(cadr(args)))
return (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 g_string_equal_2c(s7_scheme * sc, s7_pointer args)
{
if (!is_string(car(args)))
return (method_or_bust
(sc, car(args), sc->string_eq_symbol, args, T_STRING, 1));
return (make_boolean
(sc, scheme_strings_are_equal(car(args), cadr(args))));
}
static s7_pointer g_string_less_2(s7_scheme * sc, s7_pointer args)
{
if (!is_string(car(args)))
return (method_or_bust
(sc, car(args), sc->string_lt_symbol, args, T_STRING, 1));
if (!is_string(cadr(args)))
return (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 g_string_greater_2(s7_scheme * sc, s7_pointer args)
{
if (!is_string(car(args)))
return (method_or_bust
(sc, car(args), sc->string_gt_symbol, args, T_STRING, 1));
if (!is_string(cadr(args)))
return (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));
}
#define check_string2_args(Sc, Caller, P1, P2) \
do { \
if (!is_string(p1)) return(method_or_bust(sc, P1, Caller, set_plist_2(Sc, P1, P2), T_STRING, 1) != Sc->F); \
if (!is_string(p2)) return(method_or_bust(sc, P2, Caller, set_plist_2(Sc, P1, P2), T_STRING, 2) != Sc->F); \
} while (0)
static bool string_lt_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcmp(p1, p2) == -1);
}
static bool string_lt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_string2_args(sc, sc->string_lt_symbol, p1, p2);
return (scheme_strcmp(p1, p2) == -1);
}
static bool string_leq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcmp(p1, p2) != 1);
}
static bool string_leq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_string2_args(sc, sc->string_leq_symbol, p1, p2);
return (scheme_strcmp(p1, p2) != 1);
}
static bool string_gt_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcmp(p1, p2) == 1);
}
static bool string_gt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_string2_args(sc, sc->string_gt_symbol, p1, p2);
return (scheme_strcmp(p1, p2) == 1);
}
static bool string_geq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcmp(p1, p2) != -1);
}
static bool string_geq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_string2_args(sc, sc->string_geq_symbol, p1, p2);
return (scheme_strcmp(p1, p2) != -1);
}
static bool string_eq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strings_are_equal(p1, p2));
}
static bool string_eq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
check_string2_args(sc, sc->string_eq_symbol, p1, p2);
return (scheme_strings_are_equal(p1, p2));
}
static s7_pointer string_equal_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
check_for_substring_temp(sc, expr);
return ((args ==
2) ? ((is_string(caddr(expr))) ? sc->
string_equal_2c : sc->string_equal_2) : f);
}
static s7_pointer string_less_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
check_for_substring_temp(sc, expr);
return ((args == 2) ? sc->string_less_2 : f);
}
static s7_pointer string_greater_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
check_for_substring_temp(sc, expr);
return ((args == 2) ? sc->string_greater_2 : f);
}
#if (!WITH_PURE_S7)
static int32_t scheme_strcasecmp(s7_pointer s1, s7_pointer s2)
{
/* same as scheme_strcmp -- watch out for unwanted sign! and lack of trailing null (length sets string end).
*/
s7_int i, len, len1 = string_length(s1), len2 = string_length(s2);
uint8_t *str1 = (uint8_t *) string_value(s1), *str2 =
(uint8_t *) string_value(s2);
len = (len1 > len2) ? len2 : len1;
for (i = 0; i < len; i++) {
if (uppers[(int32_t) str1[i]] < uppers[(int32_t) str2[i]])
return (-1);
if (uppers[(int32_t) str1[i]] > uppers[(int32_t) str2[i]])
return (1);
}
if (len1 < len2)
return (-1);
return ((len1 > len2) ? 1 : 0);
}
static bool scheme_strequal_ci(s7_pointer s1, s7_pointer s2)
{
/* same as scheme_strcmp -- watch out for unwanted sign! */
s7_int i, len = string_length(s1), len2 = string_length(s2);
uint8_t *str1, *str2;
if (len != len2)
return (false);
str1 = (uint8_t *) string_value(s1);
str2 = (uint8_t *) string_value(s2);
for (i = 0; i < len; i++)
if (uppers[(int32_t) str1[i]] != uppers[(int32_t) str2[i]])
return (false);
return (true);
}
static s7_pointer string_check_method(s7_scheme * sc, s7_pointer sym,
s7_pointer x, s7_pointer y,
s7_pointer args)
{
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);
}
static s7_pointer g_string_ci_cmp(s7_scheme * sc, s7_pointer args,
int32_t val, s7_pointer sym)
{
s7_pointer x, y = car(args);
if (!is_string(y))
return (method_or_bust(sc, y, sym, args, T_STRING, 1));
for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) {
if (!is_string(car(x)))
return (method_or_bust
(sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING,
position_of(x, args)));
if (val == 0) {
if (!scheme_strequal_ci(y, car(x)))
return (string_check_method(sc, sym, x, y, args));
} else if (scheme_strcasecmp(y, car(x)) != val)
return (string_check_method(sc, sym, x, y, args));
}
return (sc->T);
}
static s7_pointer g_string_ci_cmp_not(s7_scheme * sc, s7_pointer args,
int32_t val, s7_pointer sym)
{
s7_pointer x, y = car(args);
if (!is_string(y))
return (method_or_bust(sc, y, sym, args, T_STRING, 1));
for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) {
if (!is_string(car(x)))
return (method_or_bust
(sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING,
position_of(x, args)));
if (scheme_strcasecmp(y, car(x)) == val)
return (string_check_method(sc, sym, x, y, args));
}
return (sc->T);
}
static s7_pointer g_strings_are_ci_equal(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_ci_equal "(string-ci=? str ...) returns #t if all the string arguments are equal, ignoring case"
#define Q_strings_are_ci_equal sc->pcl_bs
return (g_string_ci_cmp(sc, args, 0, sc->string_ci_eq_symbol));
}
static s7_pointer g_strings_are_ci_less(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_ci_less "(string-ci<? str ...) returns #t if all the string arguments are increasing, ignoring case"
#define Q_strings_are_ci_less sc->pcl_bs
return (g_string_ci_cmp(sc, args, -1, sc->string_ci_lt_symbol));
}
static s7_pointer g_strings_are_ci_greater(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_ci_greater "(string-ci>? str ...) returns #t if all the string arguments are decreasing, ignoring case"
#define Q_strings_are_ci_greater sc->pcl_bs
return (g_string_ci_cmp(sc, args, 1, sc->string_ci_gt_symbol));
}
static s7_pointer g_strings_are_ci_geq(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_ci_geq "(string-ci>=? str ...) returns #t if all the string arguments are equal or decreasing, ignoring case"
#define Q_strings_are_ci_geq sc->pcl_bs
return (g_string_ci_cmp_not(sc, args, -1, sc->string_ci_geq_symbol));
}
static s7_pointer g_strings_are_ci_leq(s7_scheme * sc, s7_pointer args)
{
#define H_strings_are_ci_leq "(string-ci<=? str ...) returns #t if all the string arguments are equal or increasing, ignoring case"
#define Q_strings_are_ci_leq sc->pcl_bs
return (g_string_ci_cmp_not(sc, args, 1, sc->string_ci_leq_symbol));
}
static bool string_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcasecmp(p1, p2) == -1);
}
static bool string_ci_lt_b_7pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
check_string2_args(sc, sc->string_ci_lt_symbol, p1, p2);
return (scheme_strcasecmp(p1, p2) == -1);
}
static bool string_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcasecmp(p1, p2) != 1);
}
static bool string_ci_leq_b_7pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
check_string2_args(sc, sc->string_ci_leq_symbol, p1, p2);
return (scheme_strcasecmp(p1, p2) != 1);
}
static bool string_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcasecmp(p1, p2) == 1);
}
static bool string_ci_gt_b_7pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
check_string2_args(sc, sc->string_ci_gt_symbol, p1, p2);
return (scheme_strcasecmp(p1, p2) == 1);
}
static bool string_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcasecmp(p1, p2) != -1);
}
static bool string_ci_geq_b_7pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
check_string2_args(sc, sc->string_ci_geq_symbol, p1, p2);
return (scheme_strcasecmp(p1, p2) != -1);
}
static bool string_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2)
{
return (scheme_strcasecmp(p1, p2) == 0);
}
static bool string_ci_eq_b_7pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
check_string2_args(sc, sc->string_ci_eq_symbol, p1, p2);
return (scheme_strcasecmp(p1, p2) == 0);
}
#endif /* pure s7 */
static s7_pointer g_string_fill_1(s7_scheme * sc, s7_pointer caller,
s7_pointer args)
{
s7_pointer x = car(args), chr;
s7_int start = 0, end;
if (!is_string(x))
return (method_or_bust(sc, x, caller, args, T_STRING, 1)); /* not two methods here */
if (is_immutable_string(x))
return (immutable_object_error
(sc, set_elist_3(sc, immutable_error_string, caller, x)));
chr = cadr(args);
if (!is_character(chr))
return (method_or_bust(sc, chr, caller, args, T_CHARACTER, 2));
end = string_length(x);
if (!is_null(cddr(args))) {
s7_pointer p;
p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end);
if (p != sc->unused)
return (p);
if (start == end)
return (chr);
}
if (end == 0)
return (chr);
local_memset((void *) (string_value(x) + start), (int32_t) character(chr), end - start); /* not memclr even if chr=#\null! */
return (chr);
}
#if (!WITH_PURE_S7)
/* -------------------------------- string-fill! -------------------------------- */
static s7_pointer g_string_fill(s7_scheme * sc, s7_pointer args)
{
#define H_string_fill "(string-fill! str chr start end) fills the string str with the character chr"
#define Q_string_fill s7_make_signature(sc, 5, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol), sc->is_string_symbol, sc->is_char_symbol, sc->is_integer_symbol, sc->is_integer_symbol)
return (g_string_fill_1(sc, sc->string_fill_symbol, args));
}
#endif
/* -------------------------------- string -------------------------------- */
static s7_pointer g_string_1(s7_scheme * sc, s7_pointer args,
s7_pointer sym)
{
int32_t i, len;
s7_pointer x, newstr;
char *str;
if (is_null(args))
return (nil_string);
/* 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 = car(x);
if (!is_character(p)) {
if (has_active_methods(sc, p)) {
s7_pointer func;
func = find_method_with_let(sc, p, sym);
if (func != sc->undefined) {
s7_pointer y;
if (len == 0)
return (call_method(sc, p, 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_1
(sc,
set_plist_2(sc, newstr,
call_method(sc, p, func, x)),
sym));
}
}
return (wrong_type_argument
(sc, sym, len + 1, car(x), T_CHARACTER));
}
}
newstr = inline_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)
return ((is_null(args)) ? nil_string :
g_string_1(sc, args, sc->string_symbol));
}
static s7_pointer g_string_c1(s7_scheme * sc, s7_pointer args)
{
s7_pointer c = car(args), str;
/* no multiple values here because no pairs below */
if (!is_character(c))
return (method_or_bust
(sc, c, sc->string_symbol, args, T_CHARACTER, 1));
str = inline_make_empty_string(sc, 1, 0); /* can't put character(c) here because null is handled specially */
string_value(str)[0] = character(c);
return (str);
}
static s7_pointer string_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
return (((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : f);
}
static s7_pointer string_p_p(s7_scheme * sc, s7_pointer p)
{
s7_pointer str;
if (!is_character(p))
return (g_string_1(sc, set_plist_1(sc, p), sc->string_symbol));
str = inline_make_empty_string(sc, 1, 0);
string_value(str)[0] = character(p);
return (str);
}
/* -------------------------------- list->string -------------------------------- */
#if (!WITH_PURE_S7)
static s7_pointer g_list_to_string(s7_scheme * sc, s7_pointer args)
{
#define H_list_to_string "(list->string lst) appends all the list's characters into one string; (apply string lst)"
#define Q_list_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_proper_list_symbol)
if (is_null(car(args)))
return (nil_string);
if (!s7_is_proper_list(sc, car(args)))
return (method_or_bust_with_type_one_arg
(sc, car(args), sc->list_to_string_symbol, args,
wrap_string(sc,
"a (proper, non-circular) list of characters",
43)));
return (g_string_1(sc, car(args), sc->list_to_string_symbol));
}
#endif
/* -------------------------------- string->list -------------------------------- */
static s7_pointer string_to_list(s7_scheme * sc, const char *str,
s7_int len)
{
s7_int i;
s7_pointer result;
if (len == 0)
return (sc->nil);
check_free_heap_size(sc, len);
sc->v = sc->nil;
for (i = len - 1; i >= 0; i--)
sc->v = cons_unchecked(sc, chars[((uint8_t) 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 = car(args);
if (!is_string(str))
return (method_or_bust_one_arg
(sc, str, sc->string_to_list_symbol, args, T_STRING));
end = string_length(str);
if (!is_null(cdr(args))) {
p = start_and_end(sc, sc->string_to_list_symbol, args, 2,
cdr(args), &start, &end);
if (p != sc->unused)
return (p);
if (start == end)
return (sc->nil);
} else if (end == 0)
return (sc->nil);
if ((end - start) > sc->max_list_length)
return (out_of_range
(sc, sc->string_to_list_symbol, int_one, car(args),
its_too_large_string));
sc->w = sc->nil;
check_free_heap_size(sc, end - start);
for (i = end - 1; i >= start; i--)
sc->w =
cons_unchecked(sc, chars[((uint8_t) string_value(str)[i])],
sc->w);
p = sc->w;
sc->w = sc->nil;
return (p);
}
static s7_pointer string_to_list_p_p(s7_scheme * sc, s7_pointer str)
{
s7_int i, len;
s7_pointer p;
const uint8_t *val;
if (!is_string(str))
return (method_or_bust_one_arg
(sc, str, sc->string_to_list_symbol, set_plist_1(sc, str),
T_STRING));
len = string_length(str);
if (len == 0)
return (sc->nil);
check_free_heap_size(sc, len);
val = (const uint8_t *) string_value(str);
for (p = sc->nil, i = len - 1; i >= 0; i--)
p = cons_unchecked(sc, chars[val[i]], p);
return (p);
}
#endif
/* -------------------------------- port-closed? -------------------------------- */
static s7_pointer g_is_port_closed(s7_scheme * sc, s7_pointer args)
{
#define H_is_port_closed "(port-closed? p) returns #t if the port p is closed."
#define Q_is_port_closed s7_make_signature(sc, 2, sc->is_boolean_symbol, s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_output_port_symbol, sc->not_symbol))
s7_pointer x = car(args);
if ((is_input_port(x)) || (is_output_port(x)))
return (make_boolean(sc, port_is_closed(x)));
if ((x == current_output_port(sc)) && (x == sc->F))
return (sc->F);
return (method_or_bust_with_type_one_arg
(sc, x, sc->is_port_closed_symbol, args,
wrap_string(sc, "a port", 6)));
}
static bool is_port_closed_b_7p(s7_scheme * sc, s7_pointer x)
{
if ((is_input_port(x)) || (is_output_port(x)))
return (port_is_closed(x));
if ((x == current_output_port(sc)) && (x == sc->F))
return (false);
return (method_or_bust_with_type_one_arg
(sc, x, sc->is_port_closed_symbol, set_plist_1(sc, x),
wrap_string(sc, "a port", 6)) != sc->F);
}
/* -------------------------------- port-position -------------------------------- */
static s7_pointer g_port_position(s7_scheme * sc, s7_pointer args)
{
#define H_port_position "(port-position input-port) returns the current location (in bytes) in the port's data where the next read will take place."
#define Q_port_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol)
s7_pointer port = car(args);
if (!(is_input_port(port)))
return (simple_wrong_type_argument
(sc, sc->port_position_symbol, port, T_INPUT_PORT));
if (port_is_closed(port))
return (s7_wrong_type_arg_error
(sc, "port-position", 0, port, "an open input port"));
if (is_string_port(port))
return (make_integer(sc, port_position(port)));
#if (!MS_WINDOWS)
if (is_file_port(port))
return (make_integer(sc, ftell(port_file(port))));
#endif
return (int_zero);
}
static s7_pointer g_set_port_position(s7_scheme * sc, s7_pointer args)
{
s7_pointer port = car(args), pos;
s7_int position;
if (!(is_input_port(port)))
return (s7_wrong_type_arg_error
(sc, "set! port-position", 1, port, "an input port"));
if (port_is_closed(port))
return (s7_wrong_type_arg_error
(sc, "set! port-position", 1, port, "an open input port"));
pos = cadr(args);
if (!is_t_integer(pos))
return (s7_wrong_type_arg_error
(sc, "set! port-position", 2, pos, "an integer"));
position = s7_integer_checked(sc, pos);
if (position < 0)
return (out_of_range
(sc, sc->port_position_symbol, int_two, pos,
its_negative_string));
if (is_string_port(port))
port_position(port) = position;
#if (!MS_WINDOWS)
else if (is_file_port(port)) {
rewind(port_file(port));
fseek(port_file(port), (long) position, SEEK_SET);
}
#endif
return (pos);
}
/* -------------------------------- port-file -------------------------------- */
static s7_pointer g_port_file(s7_scheme * sc, s7_pointer args)
{
#define H_port_file "(port-file port) returns the FILE* pointer associated with the port, wrapped in a c-pointer object"
#define Q_port_file s7_make_signature(sc, 2, sc->is_c_pointer_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol))
s7_pointer port = car(args);
if ((!is_input_port(port)) && (!is_output_port(port)))
return (s7_wrong_type_arg_error
(sc, "port-file", 0, port, "a port"));
if (port_is_closed(port))
return (s7_wrong_type_arg_error
(sc, "port-file", 0, port, "an open port"));
#if (!MS_WINDOWS)
if (is_file_port(port))
return (s7_make_c_pointer_with_type
(sc, (void *) (port_file(port)), sc->file__symbol, sc->F));
#endif
return (s7_make_c_pointer(sc, NULL));
}
/* -------------------------------- port-line-number -------------------------------- */
static s7_pointer port_line_number_p_p(s7_scheme * sc, s7_pointer x)
{
if ((!(is_input_port(x))) || (port_is_closed(x)))
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->port_line_number_symbol,
an_input_port_string));
return (make_integer(sc, port_line_number(x)));
}
static s7_pointer g_port_line_number(s7_scheme * sc, s7_pointer args)
{
#define H_port_line_number "(port-line-number input-file-port) returns the current read line number of port"
#define Q_port_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol)
return (port_line_number_p_p
(sc, (is_null(args)) ? current_input_port(sc) : car(args)));
}
s7_int s7_port_line_number(s7_scheme * sc, s7_pointer p)
{
if (!(is_input_port(p)))
simple_wrong_type_argument(sc, sc->port_line_number_symbol, p,
T_INPUT_PORT);
return (port_line_number(p));
}
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_t_integer(car(args)))))
p = current_input_port(sc);
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_t_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);
}
/* -------------------------------- port-filename -------------------------------- */
const char *s7_port_filename(s7_scheme * sc, 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 port_filename_p_p(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_with_length(sc, port_filename(x), port_filename_length(x))); /* not wrapper here! */
return (nil_string);
/* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */
}
return (method_or_bust_with_type_one_arg_p
(sc, x, sc->port_filename_symbol, an_open_port_string));
}
static s7_pointer g_port_filename(s7_scheme * sc, s7_pointer args)
{
#define H_port_filename "(port-filename file-port) returns the filename associated with port"
#define Q_port_filename s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol))
return (port_filename_p_p
(sc, (is_null(args)) ? current_input_port(sc) : car(args)));
}
/* -------------------------------- pair-line-number -------------------------------- */
static s7_pointer pair_line_number_p_p(s7_scheme * sc, s7_pointer p)
{
if (!is_pair(p))
return (method_or_bust_one_arg_p
(sc, p, sc->pair_line_number_symbol, T_PAIR));
return ((has_location(p)) ? make_integer(sc, pair_line_number(p)) :
sc->F);
}
static s7_pointer g_pair_line_number(s7_scheme * sc, s7_pointer args)
{
#define H_pair_line_number "(pair-line-number pair) returns the line number at which it read 'pair', or #f if no such number is available"
#define Q_pair_line_number s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), sc->is_pair_symbol)
return (pair_line_number_p_p(sc, car(args)));
}
/* -------------------------------- pair-filename -------------------------------- */
static s7_pointer g_pair_filename(s7_scheme * sc, s7_pointer args)
{
#define H_pair_filename "(pair-filename pair) returns the name of the file containing 'pair'"
#define Q_pair_filename s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_pair_symbol)
s7_pointer p = car(args);
if (is_pair(p))
return ((has_location(p)) ? sc->file_names[pair_file_number(p)] : sc->F); /* maybe also pair_file_number(p) > 0 */
check_method(sc, p, sc->pair_filename_symbol, args);
return (simple_wrong_type_argument
(sc, sc->pair_filename_symbol, p, T_PAIR));
}
/* -------------------------------- input-port? -------------------------------- */
bool s7_is_input_port(s7_scheme * sc, s7_pointer p)
{
return (is_input_port(p));
}
static bool is_input_port_b(s7_pointer p)
{
return (is_input_port(p));
}
static s7_pointer g_is_input_port(s7_scheme * sc, s7_pointer args)
{
#define H_is_input_port "(input-port? p) returns #t if p is an input port"
#define Q_is_input_port sc->pl_bt
check_boolean_method(sc, is_input_port, sc->is_input_port_symbol,
args);
}
/* -------------------------------- output-port? -------------------------------- */
bool s7_is_output_port(s7_scheme * sc, s7_pointer p)
{
return (is_output_port(p));
}
static bool is_output_port_b(s7_pointer p)
{
return (is_output_port(p));
}
static s7_pointer g_is_output_port(s7_scheme * sc, s7_pointer args)
{
#define H_is_output_port "(output-port? p) returns #t if p is an output port"
#define Q_is_output_port sc->pl_bt
check_boolean_method(sc, is_output_port, sc->is_output_port_symbol,
args);
}
/* -------------------------------- current-input-port -------------------------------- */
s7_pointer s7_current_input_port(s7_scheme * sc)
{
return (current_input_port(sc));
}
static s7_pointer g_current_input_port(s7_scheme * sc, s7_pointer args)
{
#define H_current_input_port "(current-input-port) returns the current input port"
#define Q_current_input_port s7_make_signature(sc, 1, sc->is_input_port_symbol)
return (current_input_port(sc));
}
static s7_pointer g_set_current_input_port(s7_scheme * sc, s7_pointer args)
{
#define H_set_current_input_port "(set-current-input-port port) sets the current-input port to port and returns the previous value of the input port"
#define Q_set_current_input_port s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_input_port_symbol)
s7_pointer port = car(args), old_port = current_input_port(sc);
if ((is_input_port(port)) && (!port_is_closed(port)))
set_current_input_port(sc, port);
else {
check_method(sc, port, sc->set_current_input_port_symbol, args);
return (s7_wrong_type_arg_error
(sc, "set-current-input-port", 0, port,
"an open input port"));
}
return (old_port);
}
s7_pointer s7_set_current_input_port(s7_scheme * sc, s7_pointer port)
{
s7_pointer old_port = current_input_port(sc);
set_current_input_port(sc, port);
return (old_port);
}
/* -------------------------------- current-output-port -------------------------------- */
s7_pointer s7_current_output_port(s7_scheme * sc)
{
return (current_output_port(sc));
}
s7_pointer s7_set_current_output_port(s7_scheme * sc, s7_pointer port)
{
s7_pointer old_port = current_output_port(sc);
set_current_output_port(sc, port);
return (old_port);
}
static s7_pointer g_current_output_port(s7_scheme * sc, s7_pointer args)
{
#define H_current_output_port "(current-output-port) returns the current output port"
#define Q_current_output_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
return (current_output_port(sc));
}
static s7_pointer g_set_current_output_port(s7_scheme * sc,
s7_pointer args)
{
#define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port"
#define Q_set_current_output_port s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
s7_pointer port = car(args), old_port = current_output_port(sc);
if (((is_output_port(port)) &&
(!port_is_closed(port))) || (port == sc->F))
set_current_output_port(sc, port);
else {
check_method(sc, port, sc->set_current_output_port_symbol, args);
return (s7_wrong_type_arg_error
(sc, "set-current-output-port", 0, port,
"an open output port"));
}
return (old_port);
}
/* -------------------------------- current-error-port -------------------------------- */
s7_pointer s7_current_error_port(s7_scheme * sc)
{
return (sc->error_port);
}
s7_pointer s7_set_current_error_port(s7_scheme * sc, s7_pointer port)
{
s7_pointer old_port = 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, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_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, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
s7_pointer port = car(args), old_port = sc->error_port;
if (((is_output_port(port)) &&
(!port_is_closed(port))) || (port == sc->F))
sc->error_port = port;
else {
check_method(sc, port, sc->set_current_error_port_symbol, args);
return (s7_wrong_type_arg_error
(sc, "set-current-error-port", 0, port,
"an open output port"));
}
return (old_port);
}
/* -------------------------------- char-ready? -------------------------------- */
#if (!WITH_PURE_S7)
static s7_pointer g_is_char_ready(s7_scheme * sc, s7_pointer args)
{
#define H_is_char_ready "(char-ready? (port (current-input-port))) returns #t if a character is ready for input on the given port"
#define Q_is_char_ready s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_input_port_symbol)
s7_pointer pt, res;
if (is_null(args))
return (make_boolean(sc, (is_input_port(current_input_port(sc)))
&& (is_string_port(current_input_port(sc)))));
pt = car(args);
if (!is_input_port(pt))
return (method_or_bust_with_type_one_arg
(sc, pt, sc->is_char_ready_symbol, args,
an_input_port_string));
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 (make_boolean(sc, is_string_port(pt)));
res = (*(port_input_function(pt))) (sc, S7_IS_CHAR_READY, pt);
if (is_multiple_value(res)) { /* can only happen if more than one value in res */
clear_multiple_value(res);
s7_error(sc, sc->bad_result_symbol,
set_elist_2(sc,
wrap_string(sc,
"input-function-port char-ready? returned: ~S",
44), res));
}
return (make_boolean(sc, (res != sc->F))); /* char-ready? returns a boolean */
}
#endif
/* -------- ports -------- */
static int32_t closed_port_read_char(s7_scheme * sc, s7_pointer port);
static s7_pointer closed_port_read_line(s7_scheme * sc, s7_pointer port,
bool with_eol);
static void closed_port_write_char(s7_scheme * sc, uint8_t c,
s7_pointer port);
static void closed_port_write_string(s7_scheme * sc, const char *str,
s7_int len, s7_pointer port);
static void closed_port_display(s7_scheme * sc, const char *s,
s7_pointer port);
static void close_closed_port(s7_scheme * sc, s7_pointer port)
{
return;
}
static port_functions_t closed_port_functions =
{ closed_port_read_char, closed_port_write_char,
closed_port_write_string, NULL, NULL, NULL, NULL,
closed_port_read_line, closed_port_display, close_closed_port
};
static void close_input_file(s7_scheme * sc, s7_pointer p)
{
if (port_filename(p)) {
/* for string ports, this is the original input file name */
liberate(sc, port_filename_block(p));
port_filename(p) = NULL;
}
if (port_file(p)) {
fclose(port_file(p));
port_file(p) = NULL;
}
if (port_needs_free(p))
free_port_data(sc, p);
port_port(p)->pf = &closed_port_functions;
port_set_closed(p, true);
port_position(p) = 0;
}
static void close_input_string(s7_scheme * sc, s7_pointer p)
{
if (port_filename(p)) {
/* for string ports, this is the original input file name */
liberate(sc, port_filename_block(p));
port_filename(p) = NULL;
}
if (port_needs_free(p))
free_port_data(sc, p);
port_port(p)->pf = &closed_port_functions;
port_set_closed(p, true);
port_position(p) = 0;
}
static void close_simple_input_string(s7_scheme * sc, s7_pointer p)
{
#if S7_DEBUGGING
if (port_filename(p))
fprintf(stderr, "%s: port has a filename\n", __func__);
if (port_needs_free(p))
fprintf(stderr, "%s: port needs free\n", __func__);
#endif
port_port(p)->pf = &closed_port_functions;
port_set_closed(p, true);
port_position(p) = 0;
}
void s7_close_input_port(s7_scheme * sc, s7_pointer p)
{
port_close(p) (sc, p);
}
/* -------------------------------- close-input-port -------------------------------- */
static s7_pointer g_close_input_port(s7_scheme * sc, s7_pointer args)
{
#define H_close_input_port "(close-input-port port) closes the port"
#define Q_close_input_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, sc->is_input_port_symbol)
s7_pointer pt = car(args);
if (!is_input_port(pt))
return (method_or_bust_with_type_one_arg_p
(sc, pt, sc->close_input_port_symbol,
an_input_port_string));
if ((!is_immutable_port(pt)) && /* (close-input-port *stdin*) */
(!is_loader_port(pt))) /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */
s7_close_input_port(sc, pt);
return (sc->unspecified);
}
/* -------------------------------- flush-output-port -------------------------------- */
bool s7_flush_output_port(s7_scheme * sc, s7_pointer p)
{
bool result = true;
if ((is_output_port(p)) && /* type=T_OUTPUT_PORT, so this excludes #f */
(is_file_port(p)) && (!port_is_closed(p)) && (port_file(p))) {
if (port_position(p) > 0) {
result =
(fwrite
((void *) (port_data(p)), 1, port_position(p),
port_file(p)) == (size_t) port_position(p));
port_position(p) = 0;
}
fflush(port_file(p));
}
return (result);
}
static s7_pointer g_flush_output_port(s7_scheme * sc, s7_pointer args)
{
#define H_flush_output_port "(flush-output-port port) flushes the file port (that is, it writes any accumulated output to the output file)"
#define Q_flush_output_port s7_make_signature(sc, 2, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
s7_pointer pt;
pt = (is_null(args)) ? current_output_port(sc) : car(args);
if (!is_output_port(pt)) {
if (pt == sc->F)
return (pt);
return (method_or_bust_with_type_one_arg
(sc, pt, sc->flush_output_port_symbol, args,
an_output_port_string));
}
s7_flush_output_port(sc, pt);
return (pt);
}
/* -------------------------------- close-output-port -------------------------------- */
static void close_output_file(s7_scheme * sc, s7_pointer p)
{
if (port_filename(p)) { /* only a file output port has a filename(?) */
liberate(sc, port_filename_block(p));
port_filename(p) = NULL;
port_filename_length(p) = 0;
}
if (port_file(p)) {
#if (WITH_WARNINGS)
if ((port_position(p) > 0) &&
(fwrite
((void *) (port_data(p)), 1, port_position(p),
port_file(p)) != (size_t) port_position(p)))
s7_warn(sc, 64, "fwrite trouble in close-output-port\n");
#else
if (port_position(p) > 0)
fwrite((void *) (port_data(p)), 1, port_position(p),
port_file(p));
#endif
fflush(port_file(p));
fclose(port_file(p));
port_file(p) = NULL;
}
port_port(p)->pf = &closed_port_functions;
port_set_closed(p, true);
port_position(p) = 0;
}
static void close_output_string(s7_scheme * sc, s7_pointer p)
{
if (port_data(p)) {
port_data(p) = NULL;
port_data_size(p) = 0;
}
port_port(p)->pf = &closed_port_functions;
port_set_closed(p, true);
port_position(p) = 0;
}
static void close_output_port(s7_scheme * sc, s7_pointer p)
{
port_close(p) (sc, p);
}
void s7_close_output_port(s7_scheme * sc, s7_pointer p)
{
if ((p == sc->F) || (is_immutable_port(p)))
return; /* can these happen? */
close_output_port(sc, p);
}
static s7_pointer g_close_output_port(s7_scheme * sc, s7_pointer args)
{
#define H_close_output_port "(close-output-port port) closes the port"
#define Q_close_output_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
s7_pointer pt = car(args);
if (!is_output_port(pt)) {
if (pt == sc->F)
return (sc->unspecified);
return (method_or_bust_with_type_one_arg_p
(sc, pt, sc->close_output_port_symbol,
an_output_port_string));
}
s7_close_output_port(sc, pt);
return (sc->unspecified);
}
/* -------- read character functions -------- */
static int32_t file_read_char(s7_scheme * sc, s7_pointer port)
{
return (fgetc(port_file(port)));
}
static int32_t function_read_char(s7_scheme * sc, s7_pointer port)
{
s7_pointer res;
res = (*(port_input_function(port))) (sc, S7_READ_CHAR, port);
if (is_eof(res))
return (EOF);
if (!is_character(res)) { /* port_input_function might return some non-character */
if (is_multiple_value(res)) {
clear_multiple_value(res);
s7_error(sc, sc->bad_result_symbol,
set_elist_2(sc,
wrap_string(sc,
"input-function-port read-char returned: ~S",
42), res));
}
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"input_function_port read_char returned: ~S",
42), res));
}
return ((int32_t) character(res)); /* kinda nutty -- we return chars[this] in g_read_char! */
}
static int32_t string_read_char(s7_scheme * sc, s7_pointer port)
{
return ((port_data_size(port) <= port_position(port)) ? EOF : (uint8_t) port_data(port)[port_position(port)++]); /* port_string_length is 0 if no port string */
}
static int32_t 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 int32_t 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)
{
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)
{
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)
{
s7_pointer res;
res = (*(port_input_function(port))) (sc, S7_READ_LINE, port);
if (is_multiple_value(res)) {
clear_multiple_value(res);
s7_error(sc, sc->bad_result_symbol,
set_elist_2(sc,
wrap_string(sc,
"input-function-port read-line returned: ~S",
42), res));
}
return (res);
}
static s7_pointer stdin_read_line(s7_scheme * sc, s7_pointer port,
bool with_eol)
{
if (!sc->read_line_buf) {
sc->read_line_buf_size = 1024;
sc->read_line_buf = (char *) Malloc(sc->read_line_buf_size);
}
if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin))
return (s7_make_string(sc, sc->read_line_buf)); /* fgets adds the trailing '\0' */
return (nil_string); /* make_string_with_length(sc, NULL, 0)); */
}
static s7_pointer file_read_line(s7_scheme * sc, s7_pointer port,
bool with_eol)
{
/* read into read_line_buf concatenating reads until newline found. string is read_line_buf to pos-of-newline.
* reset file position to reflect newline pos.
*/
int32_t reads = 0;
char *str;
s7_int read_size;
if (!sc->read_line_buf) {
sc->read_line_buf_size = 1024;
sc->read_line_buf = (char *) Malloc(sc->read_line_buf_size);
}
read_size = sc->read_line_buf_size;
str = fgets(sc->read_line_buf, read_size, port_file(port)); /* reads size-1 at most, EOF and newline also terminate read */
if (!str)
return (eof_object); /* EOF or error with no char read */
while (true) {
s7_int cur_size;
char *buf, *snew;
snew = strchr(sc->read_line_buf, (int) '\n'); /* or maybe just strlen + end-of-string=newline */
if (snew) {
s7_int pos = (s7_int) (snew - sc->read_line_buf);
port_line_number(port)++;
return (make_string_with_length
(sc, sc->read_line_buf, (with_eol) ? (pos + 1) : pos));
}
reads++;
cur_size = strlen(sc->read_line_buf);
if ((cur_size + reads) < read_size) /* end of data, no newline */
return (make_string_with_length
(sc, sc->read_line_buf, cur_size));
/* need more data */
sc->read_line_buf_size *= 2;
sc->read_line_buf =
(char *) Realloc(sc->read_line_buf, sc->read_line_buf_size);
buf = (char *) (sc->read_line_buf + cur_size);
str = fgets(buf, read_size, port_file(port));
if (!str)
return (eof_object);
read_size = sc->read_line_buf_size;
}
return (eof_object);
}
static s7_pointer string_read_line(s7_scheme * sc, s7_pointer port,
bool with_eol)
{
s7_int i, port_start = port_position(port);
uint8_t *cur, *start, *port_str = port_data(port);
start = (uint8_t *) (port_str + port_start);
cur = (uint8_t *) 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;
return (make_string_with_length
(sc, (const 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 (eof_object);
return (inline_make_string_with_length
(sc, (const char *) start, i - port_start));
}
/* -------- write character functions -------- */
static void resize_port_data(s7_scheme * sc, s7_pointer pt,
s7_int new_size)
{
s7_int loc = port_data_size(pt);
block_t *nb;
if (new_size < loc)
return;
if (new_size > sc->max_port_data_size)
s7_error(sc, make_symbol(sc, "port-too-big"),
set_elist_1(sc,
wrap_string(sc,
"port data size has grown past (*s7* 'max-port-data-size)",
56)));
nb = reallocate(sc, port_data_block(pt), new_size);
port_data_block(pt) = nb;
port_data(pt) = (uint8_t *) (block_data(nb));
port_data_size(pt) = new_size;
}
static void string_write_char_resized(s7_scheme * sc, uint8_t c,
s7_pointer pt)
{
/* this division looks repetitive, but it is much faster */
resize_port_data(sc, pt, port_data_size(pt) * 2);
port_data(pt)[port_position(pt)++] = c;
}
static void string_write_char(s7_scheme * sc, uint8_t c, s7_pointer pt)
{
if (port_position(pt) < port_data_size(pt))
port_data(pt)[port_position(pt)++] = c;
else
string_write_char_resized(sc, c, pt);
}
static void stdout_write_char(s7_scheme * sc, uint8_t c, s7_pointer port)
{
fputc(c, stdout);
}
static void stderr_write_char(s7_scheme * sc, uint8_t c, s7_pointer port)
{
fputc(c, stderr);
}
static void function_write_char(s7_scheme * sc, uint8_t c, s7_pointer port)
{
push_stack_no_let_no_code(sc, OP_NO_VALUES, sc->nil);
(*(port_output_function(port))) (sc, c, port);
unstack_with(sc, OP_NO_VALUES);
}
static Inline void inline_file_write_char(s7_scheme * sc, uint8_t c,
s7_pointer port)
{
if (port_position(port) == sc->output_port_data_size) {
fwrite((void *) (port_data(port)), 1, sc->output_port_data_size,
port_file(port));
port_position(port) = 0;
}
port_data(port)[port_position(port)++] = c;
}
static void file_write_char(s7_scheme * sc, uint8_t c, s7_pointer port)
{
return (inline_file_write_char(sc, c, port));
}
static void input_write_char(s7_scheme * sc, uint8_t 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, uint8_t 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, s7_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,
s7_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->display_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->display_symbol, port,
an_open_port_string);
}
static void stdout_write_string(s7_scheme * sc, const char *str,
s7_int len, s7_pointer port)
{
if (str[len] == '\0')
fputs(str, stdout);
else {
s7_int i;
for (i = 0; i < len; i++)
fputc(str[i], stdout);
}
}
static void stderr_write_string(s7_scheme * sc, const char *str,
s7_int len, s7_pointer port)
{
if (str[len] == '\0')
fputs(str, stderr);
else {
s7_int i;
for (i = 0; i < len; i++)
fputc(str[i], stderr);
}
}
static void string_write_string_resized(s7_scheme * sc, const char *str,
s7_int len, s7_pointer pt)
{
s7_int new_len = port_position(pt) + len; /* len is known to be non-zero, str might not be 0-terminated */
resize_port_data(sc, pt, new_len * 2);
memcpy((void *) (port_data(pt) + port_position(pt)), (void *) str,
len);
port_position(pt) = new_len;
}
static void string_write_string(s7_scheme * sc, const char *str,
s7_int len, s7_pointer pt)
{
if ((S7_DEBUGGING) && (len == 0)) {
fprintf(stderr, "string_write_string len == 0\n");
abort();
}
if (port_position(pt) + len < port_data_size(pt)) {
memcpy((void *) (port_data(pt) + port_position(pt)), (void *) str,
len);
/* memcpy is much faster than the equivalent while loop, and faster than using the 4-bytes-at-a-time shuffle */
port_position(pt) += len;
} else
string_write_string_resized(sc, str, len, pt);
}
static void file_write_string(s7_scheme * sc, const char *str, s7_int len,
s7_pointer pt)
{
s7_int new_len = port_position(pt) + len;
if (new_len >= sc->output_port_data_size) {
if (port_position(pt) > 0) {
#if (WITH_WARNINGS)
if (fwrite
((void *) (port_data(pt)), 1, port_position(pt),
port_file(pt)) != (size_t) port_position(pt))
s7_warn(sc, 64, "fwrite trouble in write-string\n");
#else
fwrite((void *) (port_data(pt)), 1, port_position(pt),
port_file(pt));
#endif
port_position(pt) = 0;
}
fwrite((void *) str, 1, len, port_file(pt));
} 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 file_display(s7_scheme * sc, const char *s, s7_pointer port)
{
if (s) {
if (port_position(port) > 0) {
#if (WITH_WARNINGS)
if (fwrite
((void *) (port_data(port)), 1, port_position(port),
port_file(port)) != (size_t) port_position(port))
s7_warn(sc, 64, "fwrite trouble in display\n");
#else
fwrite((void *) (port_data(port)), 1, port_position(port),
port_file(port));
#endif
port_position(port) = 0;
}
#if (WITH_WARNINGS)
if (fputs(s, port_file(port)) == EOF)
s7_warn(sc, 64, "write to %s: %s\n", port_filename(port),
strerror(errno));
#else
fputs(s, port_file(port));
#endif
}
}
static void function_display(s7_scheme * sc, const char *s,
s7_pointer port)
{
if (s)
for (; *s; s++)
(*(port_output_function(port))) (sc, *s, port);
}
static void function_write_string(s7_scheme * sc, const char *str,
s7_int len, s7_pointer pt)
{
s7_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);
}
/* -------------------------------- write-string -------------------------------- */
static s7_pointer g_write_string(s7_scheme * sc, s7_pointer args)
{
#define H_write_string "(write-string str port start end) writes str to port."
#define Q_write_string s7_make_circular_signature(sc, 3, 4, sc->is_string_symbol, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_integer_symbol)
s7_pointer str = car(args), port;
s7_int start = 0, end;
if (!is_string(str))
return (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, args, 3, inds,
&start, &end);
if (p != sc->unused)
return (p);
}
} else
port = current_output_port(sc);
if (!is_output_port(port)) {
if (port == sc->F) {
s7_int len;
if ((start == 0) && (end == string_length(str)))
return (str);
len = (s7_int) (end - start);
return (make_string_with_length
(sc, (char *) (string_value(str) + start), len));
}
return (method_or_bust_with_type
(sc, port, sc->write_string_symbol, args,
an_output_port_string, 2));
}
if (start == end)
return (str);
port_write_string(port) (sc, (char *) (string_value(str) + start),
(end - start), port);
return (str);
}
static s7_pointer write_string_p_pp(s7_scheme * sc, s7_pointer str,
s7_pointer port)
{
if (!is_string(str))
return (method_or_bust_pp
(sc, str, sc->write_string_symbol, str, port, T_STRING,
1));
if (!is_output_port(port)) {
if (port == sc->F)
return (str);
return (method_or_bust_with_type_pp
(sc, port, sc->write_string_symbol, str, port,
an_output_port_string, 2));
}
if (string_length(str) > 0)
port_write_string(port) (sc, string_value(str), string_length(str),
port);
return (str);
}
/* -------- skip to newline readers -------- */
static token_t token(s7_scheme * sc);
static token_t file_read_semicolon(s7_scheme * sc, s7_pointer pt)
{
int32_t c;
do
(c = fgetc(port_file(pt)));
while ((c != '\n') && (c != EOF));
port_line_number(pt)++;
return ((c == EOF) ? TOKEN_EOF : 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 int32_t file_read_white_space(s7_scheme * sc, s7_pointer port)
{
int32_t c;
while (is_white_space(c = fgetc(port_file(port))))
if (c == '\n')
port_line_number(port)++;
return (c);
}
static int32_t terminated_string_read_white_space(s7_scheme * sc,
s7_pointer pt)
{
const uint8_t *str;
uint8_t c;
/* here we know we have null termination and white_space[#\null] is false. */
str = (const uint8_t *) (port_data(pt) + port_position(pt));
while (white_space[c = *str++]) /* 255 is not -1 = EOF */
if (c == '\n')
port_line_number(pt)++;
port_position(pt) = (c) ? str - port_data(pt) : port_data_size(pt);
return ((int32_t) c);
}
/* -------- name readers -------- */
#define BASE_10 10
static s7_pointer file_read_name_or_sharp(s7_scheme * sc, s7_pointer pt,
bool atom_case)
{
int32_t c;
s7_int i = 1;
/* sc->strbuf[0] has the first char of the string we're reading */
do {
c = fgetc(port_file(pt)); /* might return EOF */
if (c == '\n')
port_line_number(pt)++;
sc->strbuf[i++] = (unsigned char) c;
if (i >= sc->strbuf_size)
resize_strbuf(sc, i);
} while ((c != EOF) && (char_ok_in_a_name[c]));
if ((i == 2) && (sc->strbuf[0] == '\\'))
sc->strbuf[2] = '\0';
else {
if (c != EOF) {
if (c == '\n')
port_line_number(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, WITH_OVERFLOW_ERROR, pt, true));
}
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 */
s7_pointer result;
char *str;
str = (char *) (port_data(pt) + port_position(pt));
if (char_ok_in_a_name[(uint8_t) * str]) {
s7_int k;
char *orig_str = (char *) (str - 1);
str++;
while (char_ok_in_a_name[(uint8_t) (*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[(uint8_t) (*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));
}
result = sc->singletons[(uint8_t) (sc->strbuf[0])];
if (!result) {
sc->strbuf[1] = '\0';
result = make_symbol_with_length(sc, sc->strbuf, 1);
sc->singletons[(uint8_t) (sc->strbuf[0])] = result;
}
return (result);
}
static s7_pointer string_read_sharp(s7_scheme * sc, s7_pointer 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
*/
char *str;
str = (char *) (port_data(pt) + port_position(pt));
if (char_ok_in_a_name[(uint8_t) * str]) {
s7_int k;
char *orig_str = (char *) (str - 1);
str++;
while (char_ok_in_a_name[(uint8_t) (*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, WITH_OVERFLOW_ERROR, pt, true));
}
if (sc->strbuf[0] == 'f')
return (sc->F);
if (sc->strbuf[0] == 't')
return (sc->T);
if (sc->strbuf[0] == '\\') {
/* must be from #\( and friends -- a character that happens to be not ok-in-a-name */
sc->strbuf[1] = str[0];
sc->strbuf[2] = '\0';
port_position(pt)++;
} else
sc->strbuf[1] = '\0';
return (make_sharp_constant
(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true));
}
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;
char *str;
str = (char *) (port_data(pt) + port_position(pt));
if (char_ok_in_a_name[(uint8_t) * str]) {
s7_int k;
char endc;
char *orig_str = (char *) (str - 1);
str++;
while (char_ok_in_a_name[(uint8_t) (*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[(uint8_t) (*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);
}
result = sc->singletons[(uint8_t) (sc->strbuf[0])];
if (!result) {
sc->strbuf[1] = '\0';
result = make_symbol_with_length(sc, sc->strbuf, 1);
sc->singletons[(uint8_t) (sc->strbuf[0])] = result;
}
return (result);
}
static inline void port_set_filename(s7_scheme * sc, s7_pointer p,
const char *name, size_t len)
{
block_t *b;
b = mallocate(sc, len + 1);
port_filename_block(p) = b;
port_filename(p) = (char *) block_data(b);
memcpy((void *) block_data(b), (void *) name, len);
port_filename(p)[len] = '\0';
}
static block_t *mallocate_port(s7_scheme * sc)
{
#define PORT_LIST 8 /* sizeof(port_t): 160 */
block_t *p;
p = sc->block_lists[PORT_LIST];
if (p)
sc->block_lists[PORT_LIST] = (block_t *) block_next(p);
else { /* this is mallocate without the index calc */
p = mallocate_block(sc);
block_data(p) = (void *) permalloc(sc, (size_t) (1 << PORT_LIST));
block_set_index(p, PORT_LIST);
}
block_set_size(p, sizeof(port_t));
return (p);
}
static port_functions_t input_file_functions =
{ file_read_char, input_write_char, input_write_string,
file_read_semicolon, file_read_white_space,
file_read_name, file_read_sharp, file_read_line, input_display,
close_input_file
};
static port_functions_t input_string_functions_1 =
{ string_read_char, input_write_char, input_write_string,
string_read_semicolon, terminated_string_read_white_space,
string_read_name, string_read_sharp, string_read_line, input_display,
close_input_string
};
static s7_pointer read_file(s7_scheme * sc, FILE * fp, const char *name,
s7_int max_size, const char *caller)
{
s7_pointer port;
#if (!MS_WINDOWS)
s7_int size;
#endif
s7_int port_loc;
block_t *b;
new_cell(sc, port, T_INPUT_PORT);
port_loc = gc_protect_1(sc, port);
b = mallocate_port(sc);
port_block(port) = b;
port_port(port) = (port_t *) block_data(b);
port_set_closed(port, false);
port_original_input_string(port) = sc->nil;
/* 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_set_filename(sc, port, name, port_filename_length(port));
port_line_number(port) = 1; /* first line is numbered 1 */
port_file_number(port) = 0;
add_input_port(sc, port);
#if (!MS_WINDOWS)
/* this doesn't work in MS C */
fseek(fp, 0, SEEK_END);
size = ftell(fp);
rewind(fp);
/* pseudo files (under /proc for example) have size=0, but we can read them, so don't assume a 0 length file is empty */
if ((size > 0) && /* if (size != 0) we get (open-input-file "/dev/tty") -> (open "/dev/tty") read 0 bytes of an expected -1? */
((max_size < 0) || (size < max_size))) { /* load uses max_size = -1 */
size_t bytes;
block_t *block;
uint8_t *content;
block = mallocate(sc, size + 2);
content = (uint8_t *) (block_data(block));
bytes = fread(content, sizeof(uint8_t), size, fp);
if (bytes != (size_t) size) {
if (current_output_port(sc) != sc->F) {
char tmp[256];
int32_t len;
len =
snprintf(tmp, 256,
"(%s \"%s\") read %ld bytes of an expected %"
ld64 "?", caller, name, (long) bytes, size);
port_write_string(current_output_port(sc)) (sc, tmp,
clamp_length
(len, 256),
current_output_port
(sc));
}
size = bytes;
}
content[size] = '\0';
content[size + 1] = '\0';
fclose(fp);
port_file(port) = NULL; /* make valgrind happy */
port_type(port) = STRING_PORT;
port_data(port) = content;
port_data_block(port) = block;
port_data_size(port) = size;
port_position(port) = 0;
port_needs_free(port) = true;
port_port(port)->pf = &input_string_functions_1;
} else {
port_file(port) = fp;
port_type(port) = FILE_PORT;
port_data(port) = NULL;
port_data_block(port) = NULL;
port_data_size(port) = 0;
port_position(port) = 0;
port_needs_free(port) = false;
port_port(port)->pf = &input_file_functions;
}
#else
/* _stat64 is no better than the fseek/ftell route, and
* GetFileSizeEx and friends requires Windows.h which makes hash of everything else.
* fread until done takes too long on big files, so use a file port
*/
port_file(port) = fp;
port_type(port) = FILE_PORT;
port_needs_free(port) = false;
port_data(port) = NULL;
port_data_block(port) = NULL;
port_data_size(port) = 0;
port_position(port) = 0;
port_port(port)->pf = &input_file_functions;
#endif
s7_gc_unprotect_at(sc, port_loc);
return (port);
}
/* -------------------------------- open-input-file -------------------------------- */
static int32_t remember_file_name(s7_scheme * sc, const char *file)
{
int32_t 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) {
int32_t old_size = 0;
/* what if file_names_size is greater than file_bits in pair|profile_file? */
if (sc->file_names_size == 0) {
sc->file_names_size = INITIAL_FILE_NAMES_SIZE;
sc->file_names =
(s7_pointer *) Malloc(sc->file_names_size *
sizeof(s7_pointer));
} else {
old_size = sc->file_names_size;
sc->file_names_size *= 2;
sc->file_names =
(s7_pointer *) Realloc(sc->file_names,
sc->file_names_size *
sizeof(s7_pointer));
}
for (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(sc, file);
return (sc->file_names_top);
}
#ifndef MAX_SIZE_FOR_STRING_PORT
#define MAX_SIZE_FOR_STRING_PORT 10000000
#endif
static s7_pointer make_input_file(s7_scheme * sc, const char *name,
FILE * fp)
{
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 file_error(s7_scheme * sc, const char *caller,
const char *descr, const char *name);
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, "file is a directory:", name));
errno = 0;
fp = fopen(name, mode);
if (fp)
return (make_input_file(sc, name, fp));
#if (!MS_WINDOWS)
if (errno == EINVAL)
return (file_error(sc, caller, "invalid mode", mode));
#if WITH_GCC
if ((name[0] == '~') && /* catch one special case, "~/..." */
(name[1] == '/')) {
char *home;
home = getenv("HOME");
if (home) {
block_t *b;
char *filename;
s7_int len;
len = safe_strlen(name) + safe_strlen(home) + 1;
b = mallocate(sc, len);
filename = (char *) block_data(b);
filename[0] = '\0';
catstrs(filename, len, home, (char *) (name + 1),
(char *) NULL);
fp = fopen(filename, "r");
liberate(sc, b);
if (fp)
return (make_input_file(sc, name, fp));
}
}
#endif
#endif
return (file_error(sc, caller, strerror(errno), name));
}
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 mode, name = car(args);
/* open-input-file can create a new output file if the file to be opened does not exist, and the "a" mode is given */
if (!is_string(name))
return (method_or_bust
(sc, name, sc->open_input_file_symbol, args, T_STRING, 1));
if (!is_pair(cdr(args)))
return (open_input_file_1
(sc, string_value(name), "r", "open-input-file"));
mode = cadr(args);
if (!is_string(mode))
return (method_or_bust_with_type
(sc, mode, sc->open_input_file_symbol, args,
wrap_string(sc, "a string (a mode such as \"r\")", 29),
2));
/* since scheme allows embedded nulls, dumb stuff is accepted here: (open-input-file file "a\x00b") -- should this be an error? */
return (open_input_file_1
(sc, string_value(name), string_value(mode),
"open-input-file"));
}
static void close_stdin(s7_scheme * sc, s7_pointer port)
{
return;
}
static void close_stdout(s7_scheme * sc, s7_pointer port)
{
return;
}
static void close_stderr(s7_scheme * sc, s7_pointer port)
{
return;
}
static const port_functions_t stdin_functions =
{ file_read_char, input_write_char, input_write_string,
file_read_semicolon, file_read_white_space,
file_read_name, file_read_sharp, stdin_read_line, input_display,
close_stdin
};
static const port_functions_t stdout_functions =
{ output_read_char, stdout_write_char, stdout_write_string, NULL, NULL,
NULL, NULL, output_read_line, stdout_display, close_stdout
};
static const port_functions_t stderr_functions =
{ output_read_char, stderr_write_char, stderr_write_string, NULL, NULL,
NULL, NULL, output_read_line, stderr_display, close_stderr
};
static void init_standard_ports(s7_scheme * sc)
{
s7_pointer x;
/* standard output */
x = alloc_pointer(sc);
set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP);
port_port(x) = (port_t *) calloc(1, sizeof(port_t));
port_type(x) = FILE_PORT;
port_data(x) = NULL;
port_data_block(x) = NULL;
port_set_closed(x, false);
port_filename_length(x) = 8;
port_set_filename(sc, x, "*stdout*", 8);
port_file_number(x) = remember_file_name(sc, port_filename(x)); /* these numbers need to be correct for the evaluator (*function* data) */
port_line_number(x) = 0;
port_file(x) = stdout;
port_needs_free(x) = false;
port_port(x)->pf = &stdout_functions;
sc->standard_output = x;
/* standard error */
x = alloc_pointer(sc);
set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP);
port_port(x) = (port_t *) calloc(1, sizeof(port_t));
port_type(x) = FILE_PORT;
port_data(x) = NULL;
port_data_block(x) = NULL;
port_set_closed(x, false);
port_filename_length(x) = 8;
port_set_filename(sc, x, "*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_port(x)->pf = &stderr_functions;
sc->standard_error = x;
/* standard input */
x = alloc_pointer(sc);
set_full_type(x, T_INPUT_PORT | T_IMMUTABLE | T_UNHEAP);
port_port(x) = (port_t *) calloc(1, sizeof(port_t));
port_type(x) = FILE_PORT;
port_set_closed(x, false);
port_original_input_string(x) = sc->nil;
port_filename_length(x) = 7;
port_set_filename(sc, x, "*stdin*", 7);
port_file_number(x) = remember_file_name(sc, port_filename(x));
port_line_number(x) = 0;
port_file(x) = stdin;
port_data_block(x) = NULL;
port_needs_free(x) = false;
port_port(x)->pf = &stdin_functions;
sc->standard_input = x;
s7_define_variable_with_documentation(sc, "*stdin*",
sc->standard_input,
"*stdin* is the built-in input port, C's stdin");
s7_define_variable_with_documentation(sc, "*stdout*",
sc->standard_output,
"*stdout* is the built-in buffered output port, C's stdout");
s7_define_variable_with_documentation(sc, "*stderr*",
sc->standard_error,
"*stderr* is the built-in unbuffered output port, C's stderr");
set_current_input_port(sc, sc->standard_input);
set_current_output_port(sc, sc->standard_output);
sc->error_port = sc->standard_error;
sc->current_file = NULL;
sc->current_line = -1;
}
/* -------------------------------- open-output-file -------------------------------- */
static const port_functions_t output_file_functions =
{ output_read_char, file_write_char, file_write_string, NULL, NULL,
NULL, NULL, output_read_line, file_display, close_output_file
};
s7_pointer s7_open_output_file(s7_scheme * sc, const char *name,
const char *mode)
{
FILE *fp;
s7_pointer x;
block_t *block, *b;
/* see if we can open this file before allocating a port */
errno = 0;
fp = fopen(name, mode);
if (!fp) {
#if (!MS_WINDOWS)
if (errno == EINVAL)
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);
b = mallocate_port(sc);
port_block(x) = b;
port_port(x) = (port_t *) block_data(b);
port_type(x) = FILE_PORT;
port_set_closed(x, false);
port_filename_length(x) = safe_strlen(name);
port_set_filename(sc, x, name, port_filename_length(x));
port_line_number(x) = 1;
port_file_number(x) = 0;
port_file(x) = fp;
port_needs_free(x) = true; /* hmm -- I think these are freed via s7_close_output_port -> close_output_port */
port_position(x) = 0;
port_data_size(x) = sc->output_port_data_size;
block = mallocate(sc, sc->output_port_data_size);
port_data_block(x) = block;
port_data(x) = (uint8_t *) (block_data(block));
port_port(x)->pf = &output_file_functions;
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))
return (method_or_bust
(sc, name, sc->open_output_file_symbol, args, T_STRING,
1));
if (!is_pair(cdr(args)))
return (s7_open_output_file(sc, string_value(name), "w"));
if (!is_string(cadr(args)))
return (method_or_bust_with_type
(sc, cadr(args), sc->open_output_file_symbol, args,
wrap_string(sc, "a string (a mode such as \"w\")", 29),
2));
return (s7_open_output_file
(sc, string_value(name), string_value(cadr(args))));
}
/* -------------------------------- open-input-string -------------------------------- */
/* a version of string ports using a pointer to the current location and a pointer to the end
* (rather than an integer for both, indexing from the base string) was not faster.
*/
static const port_functions_t input_string_functions =
{ string_read_char, input_write_char, input_write_string,
string_read_semicolon, terminated_string_read_white_space,
string_read_name_no_free, string_read_sharp, string_read_line,
input_display, close_simple_input_string
};
static s7_pointer open_input_string(s7_scheme * sc,
const char *input_string, s7_int len)
{
s7_pointer x;
block_t *b;
new_cell(sc, x, T_INPUT_PORT);
b = mallocate_port(sc);
port_block(x) = b;
port_port(x) = (port_t *) block_data(b);
port_type(x) = STRING_PORT;
port_set_closed(x, false);
port_original_input_string(x) = sc->nil;
port_data(x) = (uint8_t *) input_string;
port_data_block(x) = NULL;
port_data_size(x) = len;
port_position(x) = 0;
port_filename_block(x) = NULL;
port_filename_length(x) = 0;
port_filename(x) = NULL;
port_file_number(x) = 0;
port_line_number(x) = 0;
port_file(x) = NULL;
port_needs_free(x) = false;
#if S7_DEBUGGING
if (input_string[len] != '\0') {
fprintf(stderr,
"%s[%d]: read_white_space string is not terminated: len: %"
ld64 ", at end: %c%c, str: %s", __func__, __LINE__, len,
input_string[len - 1], input_string[len], input_string);
abort();
}
#endif
port_port(x)->pf = &input_string_functions;
add_input_string_port(sc, x);
return (x);
}
static inline 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_original_input_string(p) = 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 = car(args), port;
if (!is_string(input_string))
return (method_or_bust_one_arg
(sc, input_string, sc->open_input_string_symbol, args,
T_STRING));
port = open_and_protect_input_string(sc, input_string);
return (port);
}
/* -------------------------------- open-output-string -------------------------------- */
#define FORMAT_PORT_LENGTH 128
/* the large majority (> 99% in my tests) of the output strings have less than 128 chars when the port is finally closed
* 256 is slightly slower (the calloc time below dominates the realloc time in string_write_string)
* 64 is much slower (realloc dominates)
*/
static const port_functions_t output_string_functions =
{ output_read_char, string_write_char, string_write_string, NULL, NULL,
NULL, NULL, output_read_line, string_display, close_output_string
};
s7_pointer s7_open_output_string(s7_scheme * sc)
{
s7_pointer x;
block_t *block, *b;
new_cell(sc, x, T_OUTPUT_PORT);
b = mallocate_port(sc);
port_block(x) = b;
port_port(x) = (port_t *) block_data(b);
port_type(x) = STRING_PORT;
port_set_closed(x, false);
port_data_size(x) = sc->initial_string_port_length;
block = mallocate(sc, sc->initial_string_port_length);
port_data_block(x) = block;
port_data(x) = (uint8_t *) (block_data(block));
port_data(x)[0] = '\0'; /* in case s7_get_output_string before any output */
port_position(x) = 0;
port_needs_free(x) = true;
port_filename_block(x) = NULL;
port_filename_length(x) = 0; /* protect against (port-filename (open-output-string)) */
port_filename(x) = NULL;
port_port(x)->pf = &output_string_functions;
add_output_port(sc, x);
return (x);
}
static s7_pointer g_open_output_string(s7_scheme * sc, s7_pointer args)
{
#define H_open_output_string "(open-output-string) opens an output string port"
#define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol)
return (s7_open_output_string(sc));
}
/* -------------------------------- get-output-string -------------------------------- */
const char *s7_get_output_string(s7_scheme * sc, s7_pointer p)
{
port_data(p)[port_position(p)] = '\0';
return ((const char *) port_data(p));
}
s7_pointer s7_output_string(s7_scheme * sc, s7_pointer p)
{
port_data(p)[port_position(p)] = '\0';
return (make_string_with_length
(sc, (const char *) port_data(p), port_position(p)));
}
static inline void check_get_output_string_port(s7_scheme * sc,
s7_pointer p)
{
if (port_is_closed(p))
simple_wrong_type_argument_with_type(sc,
sc->get_output_string_symbol,
p, wrap_string(sc,
"an active (open) string port",
28));
if (port_position(p) > sc->max_string_length)
s7_error(sc, sc->out_of_range_symbol,
set_elist_2(sc,
wrap_string(sc,
"port-position ~D is greater than (*s7* 'max-string-length)",
58), wrap_integer1(sc,
port_position
(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, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_boolean_symbol)
s7_pointer p;
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 (nil_string);
return (method_or_bust_with_type_one_arg
(sc, p, sc->get_output_string_symbol, args,
wrap_string(sc, "an output string port", 21)));
}
check_get_output_string_port(sc, p);
if ((clear_port) && (port_position(p) < port_data_size(p))) {
block_t *block;
s7_pointer result;
result = block_to_string(sc, port_data_block(p), port_position(p));
/* this is slightly faster than make_string_with_length(sc, (char *)(port_data(p)), port_position(p)): we're trading a mallocate for a memcpy */
port_data_size(p) = sc->initial_string_port_length;
block = mallocate(sc, port_data_size(p));
port_data_block(p) = block;
port_data(p) = (uint8_t *) (block_data(block));
port_position(p) = 0;
port_data(p)[0] = '\0';
return (result);
}
return (make_string_with_length
(sc, (const char *) port_data(p), port_position(p)));
}
static void op_get_output_string(s7_scheme * sc)
{
s7_pointer port = sc->code;
if (!is_output_port(port))
simple_wrong_type_argument_with_type(sc,
sc->with_output_to_string_symbol,
port, wrap_string(sc,
"an open string output port",
26));
check_get_output_string_port(sc, port);
if (port_position(port) >= port_data_size(port)) /* can the > part happen? */
sc->value =
block_to_string(sc,
reallocate(sc, port_data_block(port),
port_position(port) + 1),
port_position(port));
else
sc->value =
block_to_string(sc, port_data_block(port),
port_position(port));
port_data(port) = NULL;
port_data_size(port) = 0;
port_data_block(port) = NULL;
port_needs_free(port) = false;
}
static s7_pointer g_get_output_string_uncopied(s7_scheme * sc,
s7_pointer args)
{
s7_pointer p = car(args);
if ((!is_output_port(p)) || (!is_string_port(p))) {
if (p == sc->F)
return (nil_string);
return (method_or_bust_with_type_one_arg
(sc, p, sc->get_output_string_symbol, args,
wrap_string(sc, "an output string port", 21)));
}
check_get_output_string_port(sc, p);
return (wrap_string
(sc, (const char *) port_data(p), port_position(p)));
}
/* -------------------------------- open-input-function -------------------------------- */
static s7_pointer g_closed_input_function_port(s7_scheme * sc,
s7_pointer args)
{
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_1(sc,
wrap_string(sc,
"attempt to read from a closed input-function port",
49))));
}
static void close_input_function(s7_scheme * sc, s7_pointer p)
{
port_port(p)->pf = &closed_port_functions;
port_input_scheme_function(p) = sc->closed_input_function; /* from s7_make_function so it is GC-protected */
port_set_closed(p, true);
}
static const port_functions_t input_function_functions =
{ function_read_char, input_write_char, input_write_string, NULL, NULL,
NULL, NULL, function_read_line, input_display, close_input_function
};
static void function_port_set_defaults(s7_pointer x)
{
port_type(x) = FUNCTION_PORT;
port_data(x) = NULL;
port_data_block(x) = NULL;
port_set_closed(x, false);
port_needs_free(x) = false;
port_filename_block(x) = NULL; /* next three protect against port-filename misunderstandings */
port_filename(x) = NULL;
port_filename_length(x) = 0;
port_file_number(x) = 0;
port_line_number(x) = 0;
port_file(x) = NULL;
}
s7_pointer s7_open_input_function(s7_scheme * sc,
s7_pointer(*function) (s7_scheme * sc,
s7_read_t
read_choice,
s7_pointer port))
{
s7_pointer x;
block_t *b;
new_cell(sc, x, T_INPUT_PORT);
b = mallocate_port(sc);
port_block(x) = b;
port_port(x) = (port_t *) block_data(b);
function_port_set_defaults(x);
port_input_scheme_function(x) = sc->nil;
port_input_function(x) = function;
port_port(x)->pf = &input_function_functions;
add_input_port(sc, x);
return (x);
}
static void init_open_input_function_choices(s7_scheme * sc)
{
sc->open_input_function_choices[S7_READ] = sc->read_symbol;
sc->open_input_function_choices[S7_READ_CHAR] = sc->read_char_symbol;
sc->open_input_function_choices[S7_READ_LINE] = sc->read_line_symbol;
sc->open_input_function_choices[S7_PEEK_CHAR] = sc->peek_char_symbol;
#if (!WITH_PURE_S7)
sc->open_input_function_choices[S7_IS_CHAR_READY] =
sc->is_char_ready_symbol;
#endif
}
static s7_pointer input_scheme_function_wrapper(s7_scheme * sc,
s7_read_t read_choice,
s7_pointer port)
{
return (s7_apply_function
(sc, port_input_scheme_function(port),
set_plist_1(sc,
sc->open_input_function_choices[(int)
read_choice])));
}
static s7_pointer g_open_input_function(s7_scheme * sc, s7_pointer args)
{
#define H_open_input_function "(open-input-function func) opens an input function port"
#define Q_open_input_function s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_procedure_symbol)
s7_pointer port, func = car(args);
if (!is_any_procedure(func)) /* is_procedure is too lenient: we need to flag (open-input-function (block)) for example */
return (wrong_type_argument_with_type
(sc, sc->open_input_function_symbol, 0, func,
a_procedure_string));
if (!s7_is_aritable(sc, func, 1))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"input-function-port function, ~A, should take one argument",
58), func)));
port = s7_open_input_function(sc, input_scheme_function_wrapper);
port_input_scheme_function(port) = func;
return (port);
}
/* -------------------------------- open-output-function -------------------------------- */
static s7_pointer g_closed_output_function_port(s7_scheme * sc,
s7_pointer args)
{
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_1(sc,
wrap_string(sc,
"attempt to write to a closed output-function port",
49))));
}
static void close_output_function(s7_scheme * sc, s7_pointer p)
{
port_port(p)->pf = &closed_port_functions;
port_output_scheme_function(p) = sc->closed_output_function;
port_set_closed(p, true);
}
static const port_functions_t output_function_functions =
{ output_read_char, function_write_char, function_write_string, NULL,
NULL, NULL, NULL, output_read_line, function_display,
close_output_function
};
s7_pointer s7_open_output_function(s7_scheme * sc,
void (*function)(s7_scheme * sc,
uint8_t c,
s7_pointer port))
{
s7_pointer x;
block_t *b;
new_cell(sc, x, T_OUTPUT_PORT);
b = mallocate_port(sc);
port_block(x) = b;
port_port(x) = (port_t *) block_data(b);
function_port_set_defaults(x);
port_output_function(x) = function;
port_output_scheme_function(x) = sc->nil;
port_port(x)->pf = &output_function_functions;
add_output_port(sc, x);
return (x);
}
static void output_scheme_function_wrapper(s7_scheme * sc, uint8_t c,
s7_pointer port)
{
s7_apply_function(sc, port_output_scheme_function(port),
set_plist_1(sc, make_integer(sc, c)));
}
static s7_pointer g_open_output_function(s7_scheme * sc, s7_pointer args)
{
#define H_open_output_function "(open-output-function func) opens an output function port"
#define Q_open_output_function s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->is_procedure_symbol)
s7_pointer port, func = car(args);
if (!is_any_procedure(func))
return (wrong_type_argument_with_type
(sc, sc->open_output_function_symbol, 0, func,
a_procedure_string));
if (!s7_is_aritable(sc, func, 1))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"output-function-port function, ~A, should take one argument",
59), func)));
port = s7_open_output_function(sc, output_scheme_function_wrapper);
port_output_scheme_function(port) = func;
mark_function[T_OUTPUT_PORT] = mark_output_port;
return (port);
}
/* -------- current-input-port stack -------- */
#define INPUT_PORT_STACK_INITIAL_SIZE 4
static inline void push_input_port(s7_scheme * sc, s7_pointer new_port)
{
if (sc->input_port_stack_loc >= sc->input_port_stack_size) {
sc->input_port_stack_size *= 2;
sc->input_port_stack =
(s7_pointer *) Realloc(sc->input_port_stack,
sc->input_port_stack_size *
sizeof(s7_pointer));
}
sc->input_port_stack[sc->input_port_stack_loc++] =
current_input_port(sc);
set_current_input_port(sc, new_port);
}
static void pop_input_port(s7_scheme * sc)
{
if (sc->input_port_stack_loc > 0)
set_current_input_port(sc,
sc->input_port_stack[--
(sc->input_port_stack_loc)]);
else
set_current_input_port(sc, sc->standard_input);
}
static s7_pointer input_port_if_not_loading(s7_scheme * sc)
{
s7_pointer port = current_input_port(sc);
int32_t c;
if (!is_loader_port(port)) /* this flag is turned off by the reader macros, so we aren't in that context */
return (port);
c = port_read_white_space(port) (sc, port);
if (c > 0) { /* we can get either EOF or NULL at the end */
backchar(c, port);
return (NULL);
}
return (sc->standard_input);
}
/* -------------------------------- read-char -------------------------------- */
s7_pointer s7_read_char(s7_scheme * sc, s7_pointer port)
{
int32_t c;
c = port_read_character(port) (sc, port);
return ((c == EOF) ? eof_object : chars[c]);
}
static s7_pointer g_read_char(s7_scheme * sc, s7_pointer args)
{
#define H_read_char "(read-char (port (current-input-port))) returns the next character in the input port"
#define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
s7_pointer port;
if (is_not_null(args))
port = car(args);
else {
port = input_port_if_not_loading(sc);
if (!port)
return (eof_object);
}
if (!is_input_port(port))
return (method_or_bust_with_type_one_arg
(sc, port, sc->read_char_symbol, args,
an_input_port_string));
return (chars[port_read_character(port) (sc, port)]);
}
static s7_pointer read_char_p_p(s7_scheme * sc, s7_pointer port)
{
if (!is_input_port(port))
return (method_or_bust_with_type_one_arg_p
(sc, port, sc->read_char_symbol, an_input_port_string));
return (chars[port_read_character(port) (sc, port)]);
}
static s7_pointer g_read_char_1(s7_scheme * sc, s7_pointer args)
{
s7_pointer port = car(args);
if (!is_input_port(port))
return (method_or_bust_with_type_one_arg
(sc, port, sc->read_char_symbol, args,
an_input_port_string));
return (chars[port_read_character(port) (sc, port)]);
}
static s7_pointer read_char_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 1) ? sc->read_char_1 : f);
}
/* -------------------------------- write-char -------------------------------- */
s7_pointer s7_write_char(s7_scheme * sc, s7_pointer c, s7_pointer pt)
{
if (pt != sc->F)
port_write_character(pt) (sc, s7_character(c), pt);
return (c);
}
static s7_pointer write_char_p_pp(s7_scheme * sc, s7_pointer c,
s7_pointer port)
{
if (!is_character(c))
return (method_or_bust_pp
(sc, c, sc->write_char_symbol, c, port, T_CHARACTER, 1));
if (port == sc->F)
return (c);
if (!is_output_port(port))
return (method_or_bust_with_type_pp
(sc, port, sc->write_char_symbol, c, port,
an_output_port_string, 2));
port_write_character(port) (sc, s7_character(c), port);
return (c);
}
static s7_pointer g_write_char(s7_scheme * sc, s7_pointer args)
{
#define H_write_char "(write-char char (port (current-output-port))) writes char to the output port"
#define Q_write_char s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
return (write_char_p_pp
(sc, car(args),
(is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
}
static s7_pointer write_char_p_p(s7_scheme * sc, s7_pointer c)
{
if (!is_character(c))
return (method_or_bust_p
(sc, c, sc->write_char_symbol, T_CHARACTER));
if (current_output_port(sc) == sc->F)
return (c);
port_write_character(current_output_port(sc)) (sc, s7_character(c),
current_output_port
(sc));
return (c);
}
/* (with-output-to-string (lambda () (write-char #\space))) -> " "
* (with-output-to-string (lambda () (write #\space))) -> "#\\space"
* (with-output-to-string (lambda () (display #\space))) -> " "
* is this correct? It's what Guile does. write-char is actually display-char.
*/
/* -------------------------------- peek-char -------------------------------- */
s7_pointer s7_peek_char(s7_scheme * sc, s7_pointer port)
{
int32_t c; /* needs to be an int32_t so EOF=-1, but not 255 */
if (is_string_port(port))
return ((port_data_size(port) <=
port_position(port)) ? chars[EOF] : chars[(uint8_t)
port_data(port)
[port_position
(port)]]);
c = port_read_character(port) (sc, port);
if (c == EOF)
return (eof_object);
backchar(c, port);
return (chars[c]);
}
static s7_pointer g_peek_char(s7_scheme * sc, s7_pointer args)
{
#define H_peek_char "(peek-char (port (current-input-port))) returns the next character in the input port, but does not remove it from the input stream"
#define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
s7_pointer port, res;
port = (is_not_null(args)) ? car(args) : current_input_port(sc);
if (!is_input_port(port))
return (method_or_bust_with_type_one_arg
(sc, port, sc->peek_char_symbol, args,
an_input_port_string));
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 (s7_peek_char(sc, port));
res = (*(port_input_function(port))) (sc, S7_PEEK_CHAR, port);
if (is_multiple_value(res)) {
clear_multiple_value(res);
s7_error(sc, sc->bad_result_symbol,
set_elist_2(sc,
wrap_string(sc,
"input-function-port peek-char returned: ~S",
42), res));
}
if (!is_character(res))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"input_function_port peek_char returned: ~S",
42), res));
return (res);
}
/* -------------------------------- read-byte -------------------------------- */
static s7_pointer g_read_byte(s7_scheme * sc, s7_pointer args)
{
#define H_read_byte "(read-byte (port (current-input-port))): reads a byte from the input port"
#define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
s7_pointer port;
int32_t c;
if (is_not_null(args))
port = car(args);
else {
port = input_port_if_not_loading(sc);
if (!port)
return (eof_object);
}
if (!is_input_port(port))
return (method_or_bust_with_type_one_arg
(sc, port, sc->read_byte_symbol, args,
an_input_port_string));
c = port_read_character(port) (sc, port);
return ((c == EOF) ? eof_object : small_int(c));
}
/* -------------------------------- write-byte -------------------------------- */
static s7_pointer g_write_byte(s7_scheme * sc, s7_pointer args)
{
#define H_write_byte "(write-byte byte (port (current-output-port))): writes byte to the output port"
#define Q_write_byte s7_make_signature(sc, 3, sc->is_byte_symbol, sc->is_byte_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
s7_pointer port, b = car(args);
s7_int val;
if (!s7_is_integer(b))
return (method_or_bust
(sc, car(args), sc->write_byte_symbol, args, T_INTEGER,
1));
val = s7_integer_checked(sc, b);
if ((val < 0) || (val > 255)) /* need to check this before port==#f, else (write-byte most-positive-fixnum #f) is not an error */
return (wrong_type_argument_with_type
(sc, sc->write_byte_symbol, 1, b,
an_unsigned_byte_string));
port = (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc);
if (!is_output_port(port)) {
if (port == sc->F)
return (car(args));
return (method_or_bust_with_type_one_arg
(sc, port, sc->write_byte_symbol, args,
an_output_port_string));
}
port_write_character(port) (sc, (uint8_t) val, port);
return (b);
}
/* -------------------------------- read-line -------------------------------- */
static s7_pointer g_read_line(s7_scheme * sc, s7_pointer args)
{
#define H_read_line "(read-line port (with-eol #f)) returns the next line from port, or #<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))
return (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); /* perhaps this should insist on #t: (read-line port (c-pointer 0)) */
} else {
port = input_port_if_not_loading(sc);
if (!port)
return (eof_object);
}
return (port_read_line(port) (sc, port, with_eol));
}
static s7_pointer read_line_p_pp(s7_scheme * sc, s7_pointer port,
s7_pointer with_eol)
{
if (!is_input_port(port))
return (method_or_bust_with_type_pp
(sc, port, sc->read_line_symbol, port, with_eol,
an_input_port_string, 1));
return (port_read_line(port) (sc, port, with_eol != sc->F));
}
static s7_pointer read_line_p_p(s7_scheme * sc, s7_pointer port)
{
if (!is_input_port(port))
return (method_or_bust_with_type_one_arg_p
(sc, port, sc->read_line_symbol, an_input_port_string));
return (port_read_line(port) (sc, port, false)); /* with_eol default is #f */
}
/* -------------------------------- read-string -------------------------------- */
static s7_pointer g_read_string(s7_scheme * sc, s7_pointer args)
{
/* read-chars would be a better name -- read-string could mean CL-style read-from-string (like eval-string)
* similarly read-bytes could return a byte-vector (rather than r7rs's read-bytevector)
* and write-string -> write-chars, write-bytevector -> write-bytes
*/
#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 = car(args), port, s;
s7_int i, nchars;
uint8_t *str;
if (!s7_is_integer(k))
return (method_or_bust
(sc, k, sc->read_string_symbol, args, T_INTEGER, 1));
nchars = s7_integer_checked(sc, k);
if (nchars < 0)
return (wrong_type_argument_with_type
(sc, sc->read_string_symbol, 1, k,
a_non_negative_integer_string));
if (nchars > sc->max_string_length)
return (out_of_range
(sc, sc->read_string_symbol, int_one, k,
its_too_large_string));
if (!is_null(cdr(args)))
port = cadr(args);
else {
port = input_port_if_not_loading(sc);
if (!port)
return (eof_object);
}
if (!is_input_port(port))
return (method_or_bust_with_type_pp
(sc, port, sc->read_string_symbol, k, port,
an_input_port_string, 2));
if (port_is_closed(port))
return (simple_wrong_type_argument_with_type
(sc, sc->read_string_symbol, port, an_open_port_string));
s = make_empty_string(sc, nchars, 0);
if (nchars == 0)
return (s);
str = (uint8_t *) string_value(s);
if (is_string_port(port)) {
s7_int len, pos = port_position(port), end = port_data_size(port);
len = end - pos;
if (len > nchars)
len = nchars;
if (len <= 0)
return (eof_object);
memcpy((void *) str, (void *) (port_data(port) + pos), len);
string_length(s) = len;
str[len] = '\0';
port_position(port) += len;
return (s);
}
if (is_file_port(port)) {
size_t len;
len = fread((void *) str, 1, nchars, port_file(port));
str[len] = '\0';
string_length(s) = len;
return (s);
}
for (i = 0; i < nchars; i++) {
int32_t c;
c = port_read_character(port) (sc, port);
if (c == EOF) {
if (i == 0)
return (eof_object);
string_length(s) = i;
return (s);
}
str[i] = (uint8_t) c;
}
return (s);
}
/* -------------------------------- read -------------------------------- */
#define declare_jump_info() bool old_longjmp; int32_t 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, 1); \
} while (0)
s7_pointer s7_read(s7_scheme * sc, s7_pointer port)
{
if (is_input_port(port)) {
s7_pointer old_let;
declare_jump_info();
old_let = sc->curlet;
sc->curlet = 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->cur_op);
} else {
push_stack_no_let_no_code(sc, OP_BARRIER, port);
push_stack_direct(sc, OP_EVAL_DONE);
eval(sc, OP_READ_INTERNAL);
if (sc->tok == TOKEN_EOF)
sc->value = eof_object;
if ((sc->cur_op == OP_EVAL_DONE) &&
(stack_op(sc->stack, current_stack_top(sc) - 1) ==
OP_BARRIER))
pop_stack(sc);
}
pop_input_port(sc);
set_curlet(sc, old_let);
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)
{
#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 (eof_object);
}
if (!is_input_port(port))
return (method_or_bust_with_type_one_arg
(sc, port, sc->read_symbol, args, an_input_port_string));
if (is_function_port(port)) {
s7_pointer res;
res = (*(port_input_function(port))) (sc, S7_READ, port);
if (is_multiple_value(res)) {
clear_multiple_value(res);
s7_error(sc, sc->bad_result_symbol,
set_elist_2(sc,
wrap_string(sc,
"input-function-port read returned: ~S",
37), res));
}
return (res);
}
if ((is_string_port(port)) &&
(port_data_size(port) <= port_position(port)))
return (eof_object);
push_input_port(sc, port);
push_stack_op_let(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */
push_stack_op_let(sc, OP_READ_INTERNAL);
return (port);
}
/* -------------------------------- load -------------------------------- */
#if WITH_MULTITHREAD_CHECKS
typedef struct {
s7_scheme *sc;
const int32_t lock_count; /* Remember lock count in case we have skipped calls to leave_track_scope by longjmp-ing. */
} lock_scope_t;
static lock_scope_t enter_lock_scope(s7_scheme * sc)
{
int result = pthread_mutex_trylock(&sc->lock);
if (result != 0) {
fprintf(stderr, "pthread_mutex_trylock failed: %d (EBUSY: %d)",
result, EBUSY);
abort();
}
sc->lock_count++;
{
lock_scope_t st = {.sc = sc,.lock_count = sc->lock_count };
return (st);
}
}
static void leave_lock_scope(lock_scope_t * st)
{
while (st->sc->lock_count > st->lock_count) {
st->sc->lock_count--;
pthread_mutex_unlock(&st->sc->lock);
}
}
#define TRACK(Sc) lock_scope_t lock_scope __attribute__ ((__cleanup__(leave_lock_scope))) = enter_lock_scope(Sc)
#else
#define TRACK(Sc)
#endif
/* various changes in this section courtesy of Woody Douglass 12-Jul-19 */
static block_t *search_load_path(s7_scheme * sc, const char *name)
{
s7_pointer lst = s7_load_path(sc);
if (is_pair(lst)) {
block_t *b;
char *filename;
s7_pointer dir_names;
s7_int name_len;
/* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: MAX_PATH_LENGTH: 1024 */
#if MS_WINDOWS || defined(__linux__)
#define S7_FILENAME_MAX 4096 /* so we can handle 4095 chars (need trailing null) -- this limit could be added to *s7* */
#else
#define S7_FILENAME_MAX 1024
#endif
b = mallocate(sc, S7_FILENAME_MAX);
filename = (char *) block_data(b);
name_len = safe_strlen(name);
for (dir_names = lst; is_pair(dir_names);
dir_names = cdr(dir_names)) {
const char *new_dir = string_value(car(dir_names));
if (new_dir) {
if ((WITH_WARNINGS)
&& (string_length(car(dir_names)) + name_len >=
S7_FILENAME_MAX))
s7_warn(sc, 256,
"load: file + directory name too long: %" ld64
" + %" ld64 " > %d\n", name_len,
string_length(car(dir_names)),
S7_FILENAME_MAX);
filename[0] = '\0';
if (new_dir[strlen(new_dir) - 1] == '/')
catstrs(filename, S7_FILENAME_MAX, new_dir, name,
(char *) NULL);
else
catstrs(filename, S7_FILENAME_MAX, new_dir, "/", name,
(char *) NULL);
#ifdef _MSC_VER
if (_access(filename, 0) != -1)
return (b);
#else
if (access(filename, F_OK) == 0)
return (b);
#endif
}
}
liberate(sc, b);
}
return (NULL);
}
#if WITH_C_LOADER
#include <dlfcn.h>
static block_t *full_filename(s7_scheme * sc, const char *filename)
{
s7_int len;
char *rtn;
block_t *block;
if (filename[0] == '/') {
len = safe_strlen(filename);
block = mallocate(sc, len + 1);
rtn = (char *) block_data(block);
memcpy((void *) rtn, (void *) filename, len);
rtn[len] = '\0';
} else {
size_t pwd_len, filename_len;
char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */
pwd_len = safe_strlen(pwd);
filename_len = safe_strlen(filename);
len = pwd_len + filename_len + 2; /* not 1! we need room for the '/' and the terminating 0 */
block = mallocate(sc, len);
rtn = (char *) block_data(block);
if (pwd) {
memcpy((void *) rtn, (void *) pwd, pwd_len);
rtn[pwd_len] = '/';
memcpy((void *) (rtn + pwd_len + 1), (void *) filename,
filename_len);
rtn[pwd_len + filename_len + 1] = '\0';
free(pwd);
} else { /* isn't this an error? -- perhaps warn about getcwd, strerror(errno) */
memcpy((void *) rtn, (void *) filename, filename_len);
rtn[filename_len] = '\0';
}}
return (block);
}
static s7_pointer load_shared_object(s7_scheme * sc, const char *fname,
s7_pointer let)
{
/* if fname ends in .so, try loading it as a C shared object: (load "/home/bil/cl/m_j0.so" (inlet 'init_func 'init_m_j0)) */
s7_int fname_len;
fname_len = safe_strlen(fname);
if ((fname_len > 3) &&
(local_strcmp((const char *) (fname + (fname_len - 3)), ".so"))) {
void *library;
char *pwd_name = NULL;
block_t *pname = NULL;
if ((access(fname, F_OK) == 0) || (fname[0] == '/')) {
pname = full_filename(sc, fname);
pwd_name = (char *) block_data(pname);
} else {
block_t *searched;
searched = search_load_path(sc, fname); /* returns NULL if *load-path* is nil, or if nothing matches */
if (searched) {
if (((const char *) block_data(searched))[0] == '/')
pname = searched;
else {
pname = full_filename(sc, (const char *) block_data(searched)); /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */
liberate(sc, searched);
}
pwd_name = (char *) block_data(pname);
} else { /* perhaps no *load-path* entries */
pname = full_filename(sc, fname);
pwd_name = (char *) block_data(pname);
}}
/* else pname is NULL, so use fname -- can this happen? */
if ((S7_DEBUGGING) && (!pname))
fprintf(stderr, "pname is null\n");
library = dlopen((pname) ? pwd_name : fname, RTLD_NOW);
if (!library)
s7_warn(sc, 512, "load %s failed: %s\n",
(pname) ? pwd_name : fname, dlerror());
else if (let) { /* look for 'init_func in let */
s7_pointer init;
init = s7_let_ref(sc, let, make_symbol(sc, "init_func"));
/* init is a symbol (surely not a gensym?), so it should not need to be protected */
if (!is_symbol(init))
s7_warn(sc, 512, "can't load %s: no init function\n",
fname);
else {
const char *init_name;
void *init_func;
if (hook_has_functions(sc->load_hook))
s7_apply_function(sc, sc->load_hook,
set_plist_1(sc, sc->temp6 =
s7_make_string(sc,
(pname)
? (const
char *)
pwd_name :
fname)));
init_name = symbol_name(init);
init_func = dlsym(library, init_name);
if (init_func) {
typedef void (*dl_func)(s7_scheme * sc);
typedef s7_pointer(*dl_func_with_args) (s7_scheme * sc,
s7_pointer
args);
s7_pointer init_args, p;
init_args =
s7_let_ref(sc, let, make_symbol(sc, "init_args"));
gc_protect_via_stack(sc, init_args);
if (is_pair(init_args)) {
p = ((dl_func_with_args) init_func) (sc,
init_args);
stack_protected2(sc) = p;
}
/* if caller includes init_args, but init_func is actually a dl_func, it seems to be ok,
* but the returned value is whatever was last computed in the init_func.
*/
else {
/* if the init_func is expecting args, but caller forgets init_args, this gives a segfault when
* init_func accesses the forgotten args. s7_is_valid can't catch this currently --
* we need a better way to tell that a random value can't be a cell pointer (scan permallocs and use heap_location?)
*/
((dl_func) init_func) (sc);
p = sc->F;
}
unstack(sc);
if (pname)
liberate(sc, pname);
return (p);
}
s7_warn(sc, 512,
"loaded %s, but can't find init_func %s, dlerror: %s, let: %s\n",
fname, init_name, dlerror(), display(let));
dlclose(library);
}
if (S7_DEBUGGING)
fprintf(stderr, "init_func trouble in %s, %s\n", fname,
display(init));
if (pname)
liberate(sc, pname);
return (sc->undefined);
}
if (pname)
liberate(sc, pname);
}
return (NULL);
}
#endif
static s7_pointer load_file_1(s7_scheme * sc, const char *filename)
{
FILE *fp;
if (is_directory(filename))
return (NULL);
fp = fopen(filename, "r");
#if WITH_GCC
if ((!fp) && /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */
(filename[0] == '~') && (filename[1] == '/')) {
char *home;
home = getenv("HOME");
if (home) {
block_t *b;
char *fname;
s7_int len, file_len, home_len;
file_len = safe_strlen(filename);
home_len = safe_strlen(home);
len = file_len + home_len;
b = mallocate(sc, len);
fname = (char *) block_data(b);
memcpy((void *) fname, home, home_len);
memcpy((void *) (fname + home_len), (char *) (filename + 1),
file_len - 1);
fname[len - 1] = '\0';
fp = fopen(fname, "r");
if (fp)
filename = copy_string_with_length(fname, len - 1);
liberate(sc, b);
}
}
#endif
if (!fp) {
block_t *b;
const char *fname;
b = search_load_path(sc, filename);
if (!b)
return (NULL);
fname = (const char *) block_data(b);
fp = fopen(fname, "r");
if (fp)
filename = copy_string(fname);
liberate(sc, b);
}
if (fp) {
s7_pointer port;
if (hook_has_functions(sc->load_hook))
s7_apply_function(sc, sc->load_hook,
set_plist_1(sc, sc->temp6 =
s7_make_string(sc, filename)));
port = read_file(sc, fp, filename, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */
port_file_number(port) = remember_file_name(sc, filename);
set_loader_port(port);
sc->temp6 = port;
push_input_port(sc, port);
sc->temp6 = sc->nil;
return (port);
}
return (NULL);
}
s7_pointer s7_load_with_environment(s7_scheme * sc, const char *filename,
s7_pointer e)
{
/* returns either the value of the load or NULL if filename not found */
s7_pointer port;
declare_jump_info();
TRACK(sc);
if (e == sc->s7_let)
return (NULL);
#if WITH_C_LOADER
port =
load_shared_object(sc, filename, (is_null(e)) ? sc->rootlet : e);
if (port)
return (port);
#endif
port = load_file_1(sc, filename);
if (!port)
return (NULL);
set_curlet(sc, (e == sc->rootlet) ? sc->nil : e);
push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code);
store_jump_info(sc);
set_jump_info(sc, LOAD_SET_JUMP);
if (jump_loc == NO_JUMP)
eval(sc, OP_READ_INTERNAL);
else if (jump_loc != ERROR_JUMP)
eval(sc, sc->cur_op);
pop_input_port(sc);
if (is_input_port(port))
s7_close_input_port(sc, port);
restore_jump_info(sc);
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
return (sc->value);
}
s7_pointer s7_load(s7_scheme * sc, const char *filename)
{
return (s7_load_with_environment(sc, filename, sc->nil));
}
s7_pointer s7_load_c_string_with_environment(s7_scheme * sc,
const char *content,
s7_int bytes, s7_pointer e)
{
#if (!MS_WINDOWS)
s7_pointer port;
s7_int port_loc;
declare_jump_info();
TRACK(sc);
if (content[bytes] != 0)
s7_error(sc, make_symbol(sc, "bad-data"),
set_elist_1(sc,
wrap_string(sc,
"s7_load_c_string content is not terminated",
42)));
port = open_input_string(sc, content, bytes);
port_loc = gc_protect_1(sc, port);
set_loader_port(port);
push_input_port(sc, port);
set_curlet(sc, (e == sc->rootlet) ? sc->nil : e);
push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code);
s7_gc_unprotect_at(sc, port_loc);
store_jump_info(sc);
set_jump_info(sc, LOAD_SET_JUMP);
if (jump_loc == NO_JUMP)
eval(sc, OP_READ_INTERNAL);
else if (jump_loc != ERROR_JUMP)
eval(sc, sc->cur_op);
pop_input_port(sc);
if (is_input_port(port))
s7_close_input_port(sc, port);
restore_jump_info(sc);
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
return (sc->value);
#else
return (sc->F);
#endif
}
s7_pointer s7_load_c_string(s7_scheme * sc, const char *content,
s7_int bytes)
{
return (s7_load_c_string_with_environment
(sc, content, bytes, sc->nil));
}
static s7_pointer g_load(s7_scheme * sc, s7_pointer args)
{
#define H_load "(load file (let (rootlet))) loads the scheme file 'file'. The 'let' argument \
defaults to the rootlet. To load into the current environment instead, pass (curlet)."
#define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol)
s7_pointer name = car(args);
const char *fname;
if (!is_string(name))
return (method_or_bust
(sc, name, sc->load_symbol, args, T_STRING, 1));
if (is_pair(cdr(args))) {
s7_pointer 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->s7_let)
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't load ~S into *s7*",
23), name)));
set_curlet(sc, (e == sc->rootlet) ? sc->nil : e);
} else
sc->curlet = 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,
wrap_string(sc,
"load's first argument, ~S, should be a filename",
47), name)));
#if WITH_C_LOADER
{
s7_pointer p;
p = load_shared_object(sc, fname,
(is_null(sc->curlet)) ? sc->
rootlet : sc->curlet);
if (p)
return (p);
}
#endif
errno = 0;
if (!load_file_1(sc, fname))
return (file_error(sc, "load", strerror(errno), fname));
push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was pushing args and code, but I don't think they're used later */
push_stack_op_let(sc, OP_READ_INTERNAL);
return (sc->unspecified);
}
/* -------- *load-path* -------- */
s7_pointer s7_load_path(s7_scheme * sc)
{
return (s7_symbol_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 (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"can't set *load-path* to ~S",
27), cadr(args))));
if (is_null(x))
return (cadr(args));
}
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't set *load-path* to ~S",
27), cadr(args))));
}
/* -------- *cload-directory* -------- */
static s7_pointer g_cload_directory_set(s7_scheme * sc, s7_pointer args)
{
/* this sets the directory for cload.scm's output */
s7_pointer cl_dir = cadr(args);
if (!is_string(cl_dir))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"can't set *cload-directory* to ~S",
33), cadr(args))));
s7_symbol_set_value(sc, sc->cload_directory_symbol, cl_dir);
if (safe_strlen(string_value(cl_dir)) > 0)
s7_add_to_load_path(sc, (const char *) (string_value(cl_dir)));
/* should this remove the previous *cload-directory* name first? or not affect *load-path* at all? */
return (cl_dir);
}
/* ---------------- autoload ---------------- */
#define INITIAL_AUTOLOAD_NAMES_SIZE 4
void s7_autoload_set_names(s7_scheme * sc, const char **names, s7_int size)
{
/* names should be sorted alphabetically by the symbol name (the even indexes in the names array)
* size is the number of symbol names (half the size of the names array(
* the idea here is that by sticking to string constants we can handle 90% of the work at compile-time,
* with less start-up memory. Then eventually we'll add C libraries and every name in those libraries
* will come as an import once dlopen has picked up the library.
*/
if (sc->safety > 1) {
int32_t i, k;
for (i = 0, k = 2; k < (size * 2); i += 2, k += 2)
if ((names[i]) && (names[k])
&& (strcmp(names[i], names[k]) > 0)) {
s7_warn(sc, 256, "%s: names[%d]: %s is out of order\n",
__func__, k, names[k]);
break;
}
}
if (!sc->autoload_names) {
sc->autoload_names =
(const char ***) Calloc(INITIAL_AUTOLOAD_NAMES_SIZE,
sizeof(const char **));
sc->autoload_names_sizes =
(s7_int *) Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(s7_int));
sc->autoloaded_already =
(bool **) Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(bool *));
sc->autoload_names_top = INITIAL_AUTOLOAD_NAMES_SIZE;
sc->autoload_names_loc = 0;
} else if (sc->autoload_names_loc >= sc->autoload_names_top) {
s7_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 =
(s7_int *) Realloc(sc->autoload_names_sizes,
sc->autoload_names_top * sizeof(s7_int));
sc->autoloaded_already =
(bool **) Realloc(sc->autoloaded_already,
sc->autoload_names_top * sizeof(bool *));
for (i = sc->autoload_names_loc; i < sc->autoload_names_top; i++) {
sc->autoload_names[i] = NULL;
sc->autoload_names_sizes[i] = 0;
sc->autoloaded_already[i] = NULL;
}
}
sc->autoload_names[sc->autoload_names_loc] = names;
sc->autoload_names_sizes[sc->autoload_names_loc] = size;
sc->autoloaded_already[sc->autoload_names_loc] =
(bool *) Calloc(size, sizeof(bool));
sc->autoload_names_loc++;
}
static const char *find_autoload_name(s7_scheme * sc, s7_pointer symbol,
bool *already_loaded, bool loading)
{
s7_int l = 0, lib, libs;
const char *name = symbol_name(symbol);
libs = sc->autoload_names_loc;
for (lib = 0; lib < libs; lib++) {
const char **names;
s7_int u;
u = sc->autoload_names_sizes[lib] - 1;
names = sc->autoload_names[lib];
while (true) {
s7_int comp, pos;
const char *this_name;
if (u < l)
break;
pos = (l + u) / 2;
this_name = names[pos * 2];
comp = strcmp(this_name, name);
if (comp == 0) {
*already_loaded = sc->autoloaded_already[lib][pos];
if (loading)
sc->autoloaded_already[lib][pos] = true;
return (names[pos * 2 + 1]); /* file name given func name */
}
if (comp < 0)
l = pos + 1;
else
u = pos - 1;
}
}
return (NULL);
}
s7_pointer s7_autoload(s7_scheme * sc, s7_pointer symbol,
s7_pointer file_or_function)
{
/* add '(symbol . file) to s7's autoload table */
if (is_null(sc->autoload_table))
sc->autoload_table =
s7_make_hash_table(sc, sc->default_hash_table_length);
if (sc->safety >= MORE_SAFETY_WARNINGS) {
s7_pointer p;
p = s7_hash_table_ref(sc, sc->autoload_table, symbol);
if ((p != sc->F) && (p != file_or_function))
s7_warn(sc, 256, "'%s autoload value changed\n",
symbol_name(symbol));
}
s7_hash_table_set(sc, sc->autoload_table, symbol, file_or_function);
return (file_or_function);
}
static s7_pointer g_autoload(s7_scheme * sc, s7_pointer args)
{
#define H_autoload "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \
If that symbol is encountered as an unbound variable, s7 either loads the file (following *load-path*), or calls \
the function. The function takes one argument, the calling environment. Presumably the symbol is defined \
in the file, or by the function."
#define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T)
s7_pointer sym = car(args), value;
if (is_string(sym)) {
if (string_length(sym) == 0) /* (autoload "" ...) */
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,
s7_immutable(make_string_with_length
(sc, string_value(value),
string_length(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"));
}
/* -------------------------------- *autoload* -------------------------------- */
static s7_pointer g_autoloader(s7_scheme * sc, s7_pointer args)
{ /* the *autoload* function */
#define H_autoloader "(*autoload* sym) returns the autoload info for the symbol sym, or #f."
#define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)
s7_pointer sym = car(args);
if (!is_symbol(sym)) {
check_method(sc, sym, sc->autoloader_symbol, set_plist_1(sc, sym));
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);
}
/* ---------------- require ---------------- */
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 g_require(s7_scheme * sc, s7_pointer args)
{
#define H_require "(require symbol . symbols) loads each file associated with each symbol if it has not been loaded already.\
The symbols refer to the argument to \"provide\". (require lint.scm)"
/* #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol) */
s7_pointer p;
s7_gc_protect_via_stack(sc, args);
for (p = args; is_pair(p); p = cdr(p)) {
s7_pointer sym;
if (is_symbol(car(p)))
sym = car(p);
else if ((is_proper_quote(sc, car(p))) && (is_symbol(cadar(p))))
sym = cadar(p);
else
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"require: ~S is not a symbol",
27), car(p))));
if ((!is_memq(sym, s7_symbol_value(sc, sc->features_symbol))) &&
(sc->is_autoloading)) {
s7_pointer f;
f = g_autoloader(sc, set_plist_1(sc, sym));
if (is_false(sc, f))
return (s7_error
(sc, sc->autoload_error_symbol,
set_elist_2(sc,
wrap_string(sc,
"require: no autoload info for ~S",
32), sym)));
if (hook_has_functions(sc->autoload_hook))
s7_apply_function(sc, sc->autoload_hook,
set_plist_2(sc, sym, f));
if (is_string(f))
s7_load_with_environment(sc, string_value(f), sc->curlet);
else if (is_closure(f)) /* f should be a function of one argument, the current (calling) environment */
s7_call(sc, f, set_ulist_1(sc, sc->curlet, sc->nil));
}
}
unstack(sc);
return (sc->T);
}
/* ---------------- provided? ---------------- */
static s7_pointer g_is_provided(s7_scheme * sc, s7_pointer args)
{
#define H_is_provided "(provided? symbol) returns #t if symbol is a member of the *features* list"
#define Q_is_provided s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_symbol_symbol)
s7_pointer sym = car(args), topf, x;
if (!is_symbol(sym))
return (method_or_bust_one_arg_p
(sc, sym, sc->is_provided_symbol, T_SYMBOL));
/* here the *features* list is spread out (or can be anyway) along the curlet chain,
* so we need to travel back all the way to the top level checking each *features* list in turn.
* Since *features* grows via cons (newest first), we can stop the scan if we hit the shared
* top-level at least.
*/
topf = global_value(sc->features_symbol);
if (is_memq(sym, topf))
return (sc->T);
if (is_global(sc->features_symbol))
return (sc->F);
for (x = sc->curlet; symbol_id(sc->features_symbol) < let_id(x);
x = let_outlet(x));
for (; is_let(x); x = let_outlet(x)) {
s7_pointer y;
for (y = let_slots(x); tis_slot(y); y = next_slot(y))
if ((slot_symbol(y) == sc->features_symbol) &&
(slot_value(y) != topf) && (is_memq(sym, slot_value(y))))
return (sc->T);
}
return (sc->F);
}
bool s7_is_provided(s7_scheme * sc, const char *feature)
{
return (is_memq(make_symbol(sc, feature), s7_symbol_value(sc, sc->features_symbol))); /* this goes from local outward */
}
static bool is_provided_b_7p(s7_scheme * sc, s7_pointer sym)
{
if (!is_symbol(sym))
return (method_or_bust_one_arg_p
(sc, sym, sc->is_provided_symbol, T_SYMBOL) != sc->F);
return (is_memq(sym, s7_symbol_value(sc, sc->features_symbol)));
}
/* ---------------- provide ---------------- */
static s7_pointer c_provide(s7_scheme * sc, s7_pointer sym)
{
/* this has to be relative to the curlet: (load file env)
* the things loaded are only present in env, and go away with it, so should not be in the global *features* list
*/
s7_pointer p;
if (!is_symbol(sym))
return (method_or_bust_one_arg_p
(sc, sym, sc->provide_symbol, T_SYMBOL));
if ((S7_DEBUGGING) && (sc->curlet == sc->rootlet))
fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, __LINE__);
if ((sc->curlet == sc->nil) || (sc->curlet == sc->shadow_rootlet))
p = global_slot(sc->features_symbol);
else
p = symbol_to_local_slot(sc, sc->features_symbol, sc->curlet); /* if sc->curlet is nil, this returns the global slot, else local slot */
if ((is_slot(p)) && (is_immutable(p)))
s7_warn(sc, 256, "provide: *features* is immutable!\n");
else {
s7_pointer lst;
lst = slot_value(lookup_slot_from(sc->features_symbol, sc->curlet)); /* in either case, we want the current *features* list */
if (p == sc->undefined)
add_slot_checked_with_id(sc, sc->curlet, sc->features_symbol,
cons(sc, sym, lst));
else if ((!is_memq(sym, lst)) && (!is_memq(sym, slot_value(p))))
slot_set_value(p, cons(sc, sym, slot_value(p)));
}
return (sym);
}
static s7_pointer g_provide(s7_scheme * sc, s7_pointer args)
{
#define H_provide "(provide symbol) adds symbol to the *features* list"
#define Q_provide s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_symbol_symbol)
if ((is_immutable(sc->curlet)) && (sc->curlet != sc->nil))
s7_error(sc, sc->immutable_error_symbol,
set_elist_2(sc,
wrap_string(sc,
"can't provide '~S (current environment is immutable)",
52), car(args)));
return (c_provide(sc, car(args)));
}
void s7_provide(s7_scheme * sc, const char *feature)
{
c_provide(sc, s7_make_symbol(sc, feature));
}
static s7_pointer g_features_set(s7_scheme * sc, s7_pointer args)
{ /* *features* setter */
s7_pointer p, nf = cadr(args);
if (is_null(nf))
return (sc->nil);
if (!is_pair(nf))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't set *features* to ~S",
26), nf)));
if (s7_list_length(sc, nf) <= 0)
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't set *features* to ~S",
26), nf)));
for (p = nf; is_pair(p); p = cdr(p))
if (!is_symbol(car(p)))
return (simple_wrong_type_argument
(sc, sc->features_symbol, car(p), T_SYMBOL));
return (nf);
}
static s7_pointer g_libraries_set(s7_scheme * sc, s7_pointer args)
{ /* *libraries* setter */
s7_pointer p, nf = cadr(args);
if (is_null(nf))
return (sc->nil);
if (!is_pair(nf))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't set *libraries* to ~S",
27), nf)));
if (s7_list_length(sc, nf) <= 0)
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't set *libraries* to ~S",
27), nf)));
for (p = nf; is_pair(p); p = cdr(p))
if ((!is_pair(car(p))) ||
(!is_string(caar(p))) || (!is_let(cdar(p))))
return (simple_wrong_type_argument_with_type
(sc, sc->libraries_symbol, car(p),
wrap_string(sc,
"a list of conses of the form (string . let)",
43)));
return (nf);
}
/* -------------------------------- eval-string -------------------------------- */
s7_pointer s7_eval_c_string_with_environment(s7_scheme * sc,
const char *str, s7_pointer e)
{
s7_pointer code, port, result;
TRACK(sc);
push_stack_direct(sc, OP_GC_PROTECT); /* not gc protection here, but restoration of original context */
port = s7_open_input_string(sc, str);
code = s7_read(sc, port);
s7_close_input_port(sc, port);
result = s7_eval(sc, T_Pos(code), e);
pop_stack(sc);
return (result);
}
s7_pointer s7_eval_c_string(s7_scheme * sc, const char *str)
{
return (s7_eval_c_string_with_environment(sc, str, sc->nil));
}
static s7_pointer g_eval_string(s7_scheme * sc, s7_pointer args)
{
#define H_eval_string "(eval-string str (let (curlet))) returns the result of evaluating the string str as Scheme code"
#define Q_eval_string s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol)
s7_pointer port, str = car(args);
if (!is_string(str))
return (method_or_bust
(sc, str, sc->eval_string_symbol, args, T_STRING, 1));
if (is_not_null(cdr(args))) {
s7_pointer e = cadr(args);
if (!is_let(e))
return (wrong_type_argument_with_type
(sc, sc->eval_string_symbol, 2, e, a_let_string));
set_curlet(sc, (e == sc->rootlet) ? sc->nil : e);
}
sc->temp3 = sc->args;
push_stack(sc, OP_EVAL_STRING, args, sc->code);
port = open_and_protect_input_string(sc, str);
push_input_port(sc, port);
push_stack_op_let(sc, OP_READ_INTERNAL);
return (sc->F); /* I think this means that sc->value defaults to #f in op_eval_string below, so (eval-string "") mimics (eval) -> #f */
}
static s7_pointer eval_string_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
check_for_substring_temp(sc, expr);
return (f);
}
static s7_pointer op_eval_string(s7_scheme * sc)
{
while (s7_peek_char(sc, current_input_port(sc)) != eof_object) { /* (eval-string "(+ 1 2) this is a mistake") */
int32_t tk;
tk = token(sc); /* (eval-string "(+ 1 2) ; a comment (not a mistake)") */
if (tk != TOKEN_EOF) {
s7_int trail_len;
s7_pointer trail_data;
trail_len =
port_data_size(current_input_port(sc)) -
port_position(current_input_port(sc)) + 1;
if (trail_len > 32)
trail_len = 32;
trail_data =
make_string_with_length(sc,
(const char
*) (port_data(current_input_port
(sc)) +
port_position
(current_input_port(sc)) - 1),
trail_len);
s7_close_input_port(sc, current_input_port(sc));
pop_input_port(sc);
s7_error(sc, sc->read_error_symbol,
set_elist_2(sc,
wrap_string(sc,
"eval-string trailing junk: ~S",
29), trail_data));
}
}
s7_close_input_port(sc, current_input_port(sc));
pop_input_port(sc);
sc->code = sc->value;
set_current_code(sc, sc->code);
return (NULL);
}
/* -------------------------------- call-with-input-string -------------------------------- */
static s7_pointer call_with_input(s7_scheme * sc, s7_pointer port,
s7_pointer args)
{
s7_pointer p = cadr(args);
port_original_input_string(port) = car(args);
push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); /* #<unused> here is a marker (needed) */
push_stack(sc, OP_APPLY, list_1(sc, port), p);
return (sc->F);
}
static s7_pointer g_call_with_input_string(s7_scheme * sc, s7_pointer args)
{
#define H_call_with_input_string "(call-with-input-string str proc) opens a string port for str and applies proc to it"
#define Q_call_with_input_string sc->pl_sf
/* (call-with-input-string "44" (lambda (p) (+ 1 (read p)))) -> 45 */
s7_pointer str = car(args), proc;
if (!is_string(str))
return (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,
wrap_string(sc, "a procedure of one argument (the port)",
38)));
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));
}
/* -------------------------------- call-with-input-file -------------------------------- */
static s7_pointer g_call_with_input_file(s7_scheme * sc, s7_pointer args)
{
#define H_call_with_input_file "(call-with-input-file filename proc) opens filename and calls proc with the input port as its argument"
#define Q_call_with_input_file sc->pl_sf
s7_pointer str = car(args), proc;
if (!is_string(str))
return (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,
wrap_string(sc, "a procedure of one argument (the port)",
38)));
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));
}
/* -------------------------------- with-input-from-string -------------------------------- */
static s7_pointer with_input(s7_scheme * sc, s7_pointer port,
s7_pointer args)
{
s7_pointer p, old_input_port = current_input_port(sc);
set_current_input_port(sc, 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);
}
static s7_pointer g_with_input_from_string(s7_scheme * sc, s7_pointer args)
{
#define H_with_input_from_string "(with-input-from-string str thunk) opens str as the temporary current-input-port and calls thunk"
#define Q_with_input_from_string sc->pl_sf
s7_pointer str = car(args);
if (!is_string(str))
return (method_or_bust
(sc, str, sc->with_input_from_string_symbol, args,
T_STRING, 1));
if (cadr(args) == global_value(sc->read_symbol)) {
if (string_length(str) == 0)
return (eof_object);
push_input_port(sc, current_input_port(sc));
set_current_input_port(sc, open_and_protect_input_string(sc, str));
port_original_input_string(current_input_port(sc)) = str;
push_stack(sc, OP_UNWIND_INPUT, sc->unused,
current_input_port(sc));
push_stack_op_let(sc, OP_READ_DONE);
push_stack_op_let(sc, OP_READ_INTERNAL);
return (current_input_port(sc));
}
if (!is_thunk(sc, cadr(args)))
return (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"
* (with-input-from-string "" (read-line)) -> hangs awaiting stdin input
*/
return (with_input(sc, open_and_protect_input_string(sc, str), args));
}
/* -------------------------------- with-input-from-file -------------------------------- */
static s7_pointer g_with_input_from_file(s7_scheme * sc, s7_pointer args)
{
#define H_with_input_from_file "(with-input-from-file filename thunk) opens filename as the temporary current-input-port and calls thunk"
#define Q_with_input_from_file sc->pl_sf
if (!is_string(car(args)))
return (method_or_bust
(sc, car(args), sc->with_input_from_file_symbol, args,
T_STRING, 1));
if (!is_thunk(sc, cadr(args)))
return (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 with_string_in(s7_scheme * sc, s7_pointer args)
{
s7_pointer old_port = current_input_port(sc);
set_current_input_port(sc,
open_and_protect_input_string(sc, sc->value));
push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc));
sc->curlet = make_let(sc, sc->curlet);
return (opt2_pair(sc->code));
}
static s7_pointer with_file_in(s7_scheme * sc, s7_pointer args)
{
s7_pointer old_port = current_input_port(sc);
set_current_input_port(sc,
open_input_file_1(sc, string_value(sc->value),
"r", "with-input-from-file"));
push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc));
sc->curlet = make_let(sc, sc->curlet);
return (opt2_pair(sc->code));
}
static s7_pointer with_file_out(s7_scheme * sc, s7_pointer args)
{
s7_pointer old_port = current_output_port(sc);
set_current_output_port(sc,
s7_open_output_file(sc,
string_value(sc->value),
"w"));
push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc));
sc->curlet = make_let(sc, sc->curlet);
return (opt2_pair(sc->code));
}
static s7_pointer call_string_in(s7_scheme * sc, s7_pointer args)
{
s7_pointer port;
port = open_and_protect_input_string(sc, sc->value);
push_stack(sc, OP_UNWIND_INPUT, sc->unused, port);
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port);
return (opt2_pair(sc->code));
}
static s7_pointer call_file_in(s7_scheme * sc, s7_pointer args)
{
s7_pointer port;
port =
open_input_file_1(sc, string_value(sc->value), "r",
"with-input-from-file");
push_stack(sc, OP_UNWIND_INPUT, sc->unused, port);
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port);
return (opt2_pair(sc->code));
}
static s7_pointer call_file_out(s7_scheme * sc, s7_pointer args)
{
s7_pointer port;
port = s7_open_output_file(sc, string_value(sc->value), "w");
push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port);
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port);
return (opt2_pair(sc->code));
}
#define op_with_io_1(Sc) (((s7_function)((Sc->code)->object.cons.opt1))(Sc, Sc->nil))
static s7_pointer op_lambda(s7_scheme * sc, s7_pointer code);
static void op_with_io_1_method(s7_scheme * sc)
{
s7_pointer lt = sc->value;
if (has_active_methods(sc, lt)) {
s7_pointer method = car(sc->code);
if (is_c_function(method)) /* #_call-with-input-string et al */
method = make_symbol(sc, c_function_name(method));
push_stack(sc, OP_GC_PROTECT, lt, sc->code);
sc->code = caddr(sc->code);
sc->value = op_lambda(sc, sc->code); /* don't unstack */
sc->value =
find_and_apply_method(sc, lt, method,
list_2(sc, lt, sc->value));
} else if (is_symbol(car(sc->code))) /* might be e.g. #_call-with-input-string so use c_function_name */
wrong_type_argument(sc, car(sc->code), 1, lt, T_STRING);
else
wrong_type_arg_error_prepackaged(sc,
wrap_string(sc,
c_function_name(car
(sc->code)),
strlen(c_function_name
(car
(sc->code)))),
int_one, lt, sc->unused,
sc->prepackaged_type_names
[T_STRING]);
}
static bool op_with_io_op(s7_scheme * sc)
{
sc->value = cadr(sc->code);
if (is_string(sc->value)) {
sc->code = op_with_io_1(sc);
return (false);
}
push_stack_no_args(sc, OP_WITH_IO_1, sc->code);
sc->code = sc->value;
return (true);
}
static void op_with_output_to_string(s7_scheme * sc)
{
s7_pointer old_port = current_output_port(sc);
set_current_output_port(sc, s7_open_output_string(sc));
push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc));
sc->curlet = make_let(sc, sc->curlet);
push_stack(sc, OP_GET_OUTPUT_STRING, old_port,
current_output_port(sc));
sc->code = opt2_pair(sc->code);
}
static void op_call_with_output_string(s7_scheme * sc)
{
s7_pointer port;
port = s7_open_output_string(sc);
push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port);
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port);
push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port);
sc->code = opt2_pair(sc->code);
}
/* -------------------------------- iterators -------------------------------- */
#if S7_DEBUGGING
static s7_pointer titr_let(s7_scheme * sc, s7_pointer p, const char *func,
int32_t line)
{
if (!is_let(iterator_sequence(p))) {
fprintf(stderr, "%s%s[%d]: let iterator sequence is %s%s\n",
BOLD_TEXT, func, line, check_name(sc,
unchecked_type
(iterator_sequence(p))),
UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
return (p);
}
static s7_pointer titr_pair(s7_scheme * sc, s7_pointer p, const char *func,
int32_t line)
{
if (!is_pair(iterator_sequence(p))) {
fprintf(stderr, "%s%s[%d]: pair iterator sequence is %s%s\n",
BOLD_TEXT, func, line, check_name(sc,
unchecked_type
(iterator_sequence(p))),
UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
return (p);
}
static s7_pointer titr_hash(s7_scheme * sc, s7_pointer p, const char *func,
int32_t line)
{
if (!is_hash_table(iterator_sequence(p))) {
fprintf(stderr, "%s%s[%d]: hash iterator sequence is %s%s\n",
BOLD_TEXT, func, line, check_name(sc,
unchecked_type
(iterator_sequence(p))),
UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
return (p);
}
static s7_pointer titr_len(s7_scheme * sc, s7_pointer p, const char *func,
int32_t line)
{
if ((is_hash_table(iterator_sequence(p)))
|| (is_pair(iterator_sequence(p)))) {
fprintf(stderr, "%s%s[%d]: iterator length sequence is %s%s\n",
BOLD_TEXT, func, line, check_name(sc,
unchecked_type
(iterator_sequence(p))),
UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
return (p);
}
static s7_pointer titr_pos(s7_scheme * sc, s7_pointer p, const char *func,
int32_t line)
{
if (((is_let(iterator_sequence(p)))
&& (iterator_sequence(p) != sc->rootlet)
&& (iterator_sequence(p) != sc->s7_let))
|| (is_pair(iterator_sequence(p)))) {
fprintf(stderr, "%s%s[%d]: iterator-position sequence is %s%s\n",
BOLD_TEXT, func, line, check_name(sc,
unchecked_type
(iterator_sequence(p))),
UNBOLD_TEXT);
if (sc->stop_at_error)
abort();
}
return (p);
}
#endif
/* -------------------------------- iterator? -------------------------------- */
static s7_pointer g_is_iterator(s7_scheme * sc, s7_pointer args)
{
#define H_is_iterator "(iterator? obj) returns #t if obj is an iterator."
#define Q_is_iterator sc->pl_bt
s7_pointer x = car(args);
if (is_iterator(x))
return (sc->T);
/* closure itself is not an iterator: (let ((c1 (let ((+iterator+ #t) (a 0)) (lambda () (set! a (+ a 1)))))) (iterate c1)): error (a function not an iterator) */
check_boolean_method(sc, is_iterator, sc->is_iterator_symbol, args);
return (sc->F);
}
bool s7_is_iterator(s7_pointer obj)
{
return (is_iterator(obj));
}
static bool is_iterator_b_7p(s7_scheme * sc, s7_pointer obj)
{
return (g_is_iterator(sc, set_plist_1(sc, obj)) != sc->F);
}
static s7_pointer iterator_copy(s7_scheme * sc, s7_pointer p)
{
/* fields are obj cur [loc|lcur] [len|slow|hcur] next, but untangling them in debugging case is a pain */
s7_pointer iter;
new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE);
memcpy((void *) iter, (void *) p, sizeof(s7_cell));
return (iter);
}
static s7_pointer iterator_finished(s7_scheme * sc, s7_pointer iterator)
{
return (ITERATOR_END);
}
static s7_pointer iterator_quit(s7_pointer iterator)
{
iterator_next(iterator) = iterator_finished;
clear_iter_ok(iterator);
return (ITERATOR_END);
}
static s7_pointer let_iterate(s7_scheme * sc, s7_pointer iterator)
{
s7_pointer p, slot = iterator_current_slot(iterator);
if (!tis_slot(slot))
return (iterator_quit(iterator));
iterator_set_current_slot(iterator, next_slot(slot));
if (!iterator_let_cons(iterator))
return (cons(sc, slot_symbol(slot), slot_value(slot)));
p = iterator_let_cons(iterator);
set_car(p, slot_symbol(slot));
set_cdr(p, slot_value(slot));
return (p);
}
static s7_pointer rootlet_iterate(s7_scheme * sc, s7_pointer iterator)
{
s7_pointer slot = iterator_current(iterator);
if (!is_slot(slot))
return (iterator_quit(iterator));
if (iterator_position(iterator) < sc->rootlet_entries) {
iterator_position(iterator)++;
iterator_current(iterator) =
rootlet_element(sc->rootlet, iterator_position(iterator));
} else
iterator_current(iterator) = sc->nil;
return (cons(sc, slot_symbol(slot), slot_value(slot)));
}
static s7_pointer hash_entry_to_cons(s7_scheme * sc, hash_entry_t * entry,
s7_pointer p)
{
if (!p)
return (cons(sc, hash_entry_key(entry), hash_entry_value(entry)));
set_car(p, hash_entry_key(entry));
set_cdr(p, hash_entry_value(entry));
return (p);
}
static s7_pointer hash_table_iterate(s7_scheme * sc, s7_pointer iterator)
{
s7_pointer table;
s7_int loc, len;
hash_entry_t **elements;
hash_entry_t *lst;
lst = iterator_hash_current(iterator);
if (lst) {
iterator_hash_current(iterator) = hash_entry_next(lst);
return (hash_entry_to_cons(sc, lst, iterator_current(iterator)));
}
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 = elements[loc];
if (x) {
iterator_position(iterator) = loc;
iterator_hash_current(iterator) = hash_entry_next(x);
return (hash_entry_to_cons(sc, x, iterator_current(iterator)));
}
}
if (is_weak_hash_table(table)) {
clear_weak_hash_iterator(iterator);
weak_hash_iters(table)--;
}
return (iterator_quit(iterator));
}
static s7_pointer string_iterate(s7_scheme * sc, s7_pointer obj)
{
if (iterator_position(obj) < iterator_length(obj))
return (chars[(uint8_t)
(string_value(iterator_sequence(obj))
[iterator_position(obj)++])]);
return (iterator_quit(obj));
}
static s7_pointer byte_vector_iterate(s7_scheme * sc, s7_pointer obj)
{
if (iterator_position(obj) < iterator_length(obj))
return (small_int
(byte_vector
(iterator_sequence(obj), iterator_position(obj)++)));
return (iterator_quit(obj));
}
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(iterator_sequence(obj),
iterator_position(obj)++)));
return (iterator_quit(obj));
}
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(iterator_sequence(obj),
iterator_position(obj)++)));
return (iterator_quit(obj));
}
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)++));
return (iterator_quit(obj));
}
static s7_pointer closure_iterate(s7_scheme * sc, s7_pointer obj)
{
s7_pointer result;
result = s7_call(sc, iterator_sequence(obj), sc->nil);
/* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */
if (result == ITERATOR_END) {
iterator_next(obj) = iterator_finished;
clear_iter_ok(obj);
}
return (result);
}
static s7_pointer c_object_iterate(s7_scheme * sc, s7_pointer obj)
{
s7_pointer result, p, cur;
if (iterator_position(obj) >= iterator_length(obj))
return (iterator_quit(obj));
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? (save/restore sc->x/y across c_object iteration) */
set_car(cur, p);
set_car(cdr(cur), make_integer(sc, iterator_position(obj)));
result = (*(c_object_ref(sc, p))) (sc, cur);
sc->x = car(sc->z2_1);
sc->z = car(sc->z2_2);
iterator_position(obj)++;
if (result == ITERATOR_END) {
iterator_next(obj) = iterator_finished;
clear_iter_ok(obj);
}
return (result);
}
static s7_pointer pair_iterate_1(s7_scheme * sc, s7_pointer obj);
static s7_pointer pair_iterate(s7_scheme * sc, s7_pointer obj)
{
s7_pointer result;
if (!is_pair(iterator_current(obj)))
return (iterator_quit(obj));
result = car(iterator_current(obj));
iterator_current(obj) = cdr(iterator_current(obj));
if (iterator_current(obj) == iterator_slow(obj))
iterator_current(obj) = sc->nil;
iterator_next(obj) = pair_iterate_1;
return (result);
}
static s7_pointer pair_iterate_1(s7_scheme * sc, s7_pointer obj)
{
s7_pointer result;
if (!is_pair(iterator_current(obj)))
return (iterator_quit(obj));
result = car(iterator_current(obj));
iterator_current(obj) = cdr(iterator_current(obj));
if (iterator_current(obj) == iterator_slow(obj))
iterator_current(obj) = sc->nil;
else
iterator_set_slow(obj, cdr(iterator_slow(obj)));
iterator_next(obj) = pair_iterate;
return (result);
}
static s7_pointer find_make_iterator_method(s7_scheme * sc, s7_pointer e)
{
s7_pointer func;
if ((has_active_methods(sc, e)) &&
((func =
find_method_with_let(sc, e,
sc->make_iterator_symbol)) !=
sc->undefined)) {
s7_pointer it;
it = call_method(sc, e, func, set_plist_1(sc, e));
if (!is_iterator(it))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"make-iterator method must return an iterator: ~S",
48), it)));
return (it);
}
return (NULL);
}
/* -------------------------------- make-iterator -------------------------------- */
static s7_pointer funclet_entry(s7_scheme * sc, s7_pointer x,
s7_pointer sym)
{
if ((has_closure_let(x)) && (is_let(closure_let(x)))) {
s7_pointer val;
val = symbol_to_local_slot(sc, sym, closure_let(x));
if ((!is_slot(val)) && (is_let(let_outlet(closure_let(x)))))
val =
symbol_to_local_slot(sc, sym, let_outlet(closure_let(x)));
if (is_slot(val))
return (slot_value(val));
}
return (NULL);
}
static bool is_iterable_closure(s7_scheme * sc, s7_pointer x)
{
s7_pointer iter;
if (!is_thunk(sc, x))
wrong_type_argument_with_type(sc, sc->make_iterator_symbol, 1, x,
a_thunk_string);
iter = funclet_entry(sc, x, sc->local_iterator_symbol);
return ((iter) && (iter != sc->F));
}
static s7_pointer s7_let_make_iterator(s7_scheme * sc, s7_pointer iter);
static s7_int c_object_length_to_int(s7_scheme * sc, s7_pointer obj);
s7_pointer s7_make_iterator(s7_scheme * sc, s7_pointer e)
{
s7_pointer iter, p;
new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK);
iterator_sequence(iter) = e;
if (is_pair(e)) { /* by far the most common case */
iterator_current(iter) = e;
iterator_next(iter) = pair_iterate;
iterator_set_slow(iter, e);
return (iter);
}
if (!is_let(e))
iterator_position(iter) = 0;
switch (type(e)) {
case T_LET:
if (e == sc->rootlet) {
iterator_current(iter) = rootlet_element(e, 0); /* unfortunately tricky -- let_iterate uses different fields */
iterator_position(iter) = 0;
iterator_next(iter) = rootlet_iterate;
return (iter);
}
if (e == sc->s7_let)
return (s7_let_make_iterator(sc, iter));
sc->temp6 = iter;
p = find_make_iterator_method(sc, e);
sc->temp6 = sc->nil;
if (p) {
free_cell(sc, iter);
return (p);
}
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;
if (is_weak_hash_table(e)) {
set_weak_hash_iterator(iter);
weak_hash_iters(e)++;
add_weak_hash_iterator(sc, iter);
}
break;
case T_STRING:
iterator_length(iter) = string_length(e);
iterator_next(iter) = string_iterate;
break;
case T_BYTE_VECTOR:
iterator_length(iter) = byte_vector_length(e);
iterator_next(iter) = byte_vector_iterate;
break;
case T_VECTOR:
iterator_length(iter) = vector_length(e);
iterator_next(iter) = vector_iterate;
break;
case T_INT_VECTOR:
iterator_length(iter) = vector_length(e);
iterator_next(iter) = int_vector_iterate;
break;
case T_FLOAT_VECTOR:
iterator_length(iter) = vector_length(e);
iterator_next(iter) = float_vector_iterate;
break;
case T_NIL: /* (make-iterator #()) -> #<iterator: vector>, so I guess () should also work */
iterator_length(iter) = 0;
iterator_next(iter) = iterator_finished;
clear_iter_ok(iter);
break;
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
case T_CLOSURE:
case T_CLOSURE_STAR:
if (is_iterable_closure(sc, e)) {
p = list_1_unchecked(sc, int_zero);
iterator_current(iter) = p;
set_mark_seq(iter);
iterator_next(iter) = closure_iterate;
iterator_length(iter) =
(has_active_methods(sc, e)) ? closure_length(sc,
e) :
S7_INT64_MAX;
} else {
free_cell(sc, iter);
return (simple_wrong_type_argument_with_type
(sc, sc->make_iterator_symbol, e,
wrap_string(sc,
"a function or macro with a '+iterator+ local that is not #f",
59)));
}
break;
case T_C_OBJECT:
iterator_length(iter) = c_object_length_to_int(sc, e);
sc->temp6 = iter;
p = find_make_iterator_method(sc, e);
sc->temp6 = sc->nil;
if (p) {
free_cell(sc, iter);
return (p);
}
iterator_current(iter) = list_2(sc, e, int_zero);
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 carrier) returns an iterator object that returns the next value \
in the sequence each time it is called. When it reaches the end, it returns " 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 iter, seq = car(args), carrier;
/* we need to call s7_make_iterator before fixing up the optional second arg in case let->method */
carrier = (is_pair(cdr(args))) ? cadr(args) : NULL;
iter = s7_make_iterator(sc, seq);
if (carrier) {
if (!is_pair(carrier))
return (simple_wrong_type_argument
(sc, sc->make_iterator_symbol, carrier, T_PAIR));
if (is_immutable_pair(carrier))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->make_iterator_symbol, carrier)));
if (is_hash_table(iterator_sequence(iter))) {
iterator_current(iter) = carrier;
set_mark_seq(iter);
} else
if ((is_let(iterator_sequence(iter))) &&
(iterator_sequence(iter) != sc->rootlet)) {
iterator_let_cons(iter) = carrier;
set_mark_seq(iter);
}
}
return (iter);
}
/* -------------------------------- iterate -------------------------------- */
static s7_pointer g_iterate(s7_scheme * sc, s7_pointer args)
{
#define H_iterate "(iterate obj) returns the next element from the iterator obj, or " ITERATOR_END_NAME "."
#define Q_iterate s7_make_signature(sc, 2, sc->T, sc->is_iterator_symbol)
s7_pointer iter = car(args);
if (!is_iterator(iter))
return (method_or_bust_one_arg
(sc, iter, sc->iterate_symbol, args, T_ITERATOR));
return ((iterator_next(iter)) (sc, iter));
}
static s7_pointer iterate_p_p(s7_scheme * sc, s7_pointer iter)
{
if (!is_iterator(iter))
return (method_or_bust_one_arg_p
(sc, iter, sc->iterate_symbol, T_ITERATOR));
return ((iterator_next(iter)) (sc, iter));
}
s7_pointer s7_iterate(s7_scheme * sc, s7_pointer obj)
{
return ((iterator_next(obj)) (sc, obj));
}
bool s7_iterator_is_at_end(s7_scheme * sc, s7_pointer obj)
{
if (!is_iterator(obj))
simple_wrong_type_argument(sc, sc->iterator_is_at_end_symbol, obj,
T_ITERATOR);
return (!iter_ok(obj));
}
static bool op_implicit_iterate(s7_scheme * sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
if (!is_iterator(s)) {
sc->last_function = s;
return (false);
}
sc->value = (iterator_next(s)) (sc, s);
return (true);
}
/* -------------------------------- iterator-at-end? -------------------------------- */
static bool iterator_is_at_end_b_7p(s7_scheme * sc, s7_pointer obj)
{
if (!is_iterator(obj))
simple_wrong_type_argument(sc, sc->iterator_is_at_end_symbol, obj,
T_ITERATOR);
return (!iter_ok(obj));
}
static s7_pointer g_iterator_is_at_end(s7_scheme * sc, s7_pointer args)
{
#define H_iterator_is_at_end "(iterator-at-end? iter) returns #t if the iterator has reached the end of its sequence."
#define Q_iterator_is_at_end s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_iterator_symbol)
s7_pointer iter = car(args);
if (!is_iterator(iter))
return (method_or_bust_one_arg
(sc, iter, sc->iterator_is_at_end_symbol, args,
T_ITERATOR));
return (make_boolean(sc, !iter_ok(iter)));
}
/* -------------------------------- iterator-sequence -------------------------------- */
static s7_pointer g_iterator_sequence(s7_scheme * sc, s7_pointer args)
{
#define H_iterator_sequence "(iterator-sequence iterator) returns the sequence that iterator is traversing."
#define Q_iterator_sequence s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_iterator_symbol)
s7_pointer iter = car(args);
if (!is_iterator(iter))
return (method_or_bust_one_arg
(sc, iter, sc->iterator_sequence_symbol, args,
T_ITERATOR));
return (iterator_sequence(iter));
}
/* -------- cycles -------- */
#define INITIAL_SHARED_INFO_SIZE 8
static int32_t shared_ref(shared_info_t * ci, s7_pointer p)
{
/* from print after collecting refs, not called by equality check, only called in object_to_port_with_circle_check_1 */
int32_t i;
s7_pointer *objs = ci->objs;
for (i = 0; i < ci->top; i++)
if (objs[i] == p) {
int32_t val = ci->refs[i];
if (val > 0)
ci->refs[i] = -ci->refs[i];
return (val);
}
return (0);
}
static void flip_ref(shared_info_t * ci, s7_pointer p)
{
int32_t i;
s7_pointer *objs = ci->objs;
for (i = 0; i < ci->top; i++)
if (objs[i] == p) {
ci->refs[i] = -ci->refs[i];
break;
}
}
static int32_t peek_shared_ref_1(shared_info_t * ci, s7_pointer p)
{
/* returns 0 if not found, otherwise the ref value for p */
int32_t i;
s7_pointer *objs = ci->objs;
for (i = 0; i < ci->top; i++)
if (objs[i] == p)
return (ci->refs[i]);
return (0);
}
static int32_t peek_shared_ref(shared_info_t * ci, s7_pointer p)
{
/* returns 0 if not found, otherwise the ref value for p */
return ((is_collected_unchecked(p)) ? peek_shared_ref_1(ci, p) : 0);
}
static void enlarge_shared_info(shared_info_t * ci)
{
int32_t i;
ci->size *= 2;
ci->size2 = ci->size - 2;
ci->objs =
(s7_pointer *) Realloc(ci->objs, ci->size * sizeof(s7_pointer));
ci->refs = (int32_t *) Realloc(ci->refs, ci->size * sizeof(int32_t));
ci->defined = (bool *) Realloc(ci->defined, ci->size * sizeof(bool));
/* this clearing is needed */
for (i = ci->top; i < ci->size; i++) {
ci->refs[i] = 0;
ci->objs[i] = NULL;
}
}
static bool collect_shared_info(s7_scheme * sc, shared_info_t * ci,
s7_pointer top, bool stop_at_print_length);
static hash_entry_t *hash_equal(s7_scheme * sc, s7_pointer table,
s7_pointer key);
static hash_entry_t *hash_equivalent(s7_scheme * sc, s7_pointer table,
s7_pointer key);
static bool check_collected(s7_pointer top, shared_info_t * ci)
{
s7_pointer *p, *objs_end;
int32_t i;
objs_end = (s7_pointer *) (ci->objs + ci->top);
for (p = ci->objs; p < objs_end; p++)
if ((*p) == top) {
i = (int32_t) (p - ci->objs);
if (ci->refs[i] == 0) {
ci->has_hits = true;
ci->refs[i] = ++ci->ref; /* if found, set the ref number */
}
break;
}
set_cyclic(top);
return (true);
}
static bool collect_vector_info(s7_scheme * sc, shared_info_t * ci,
s7_pointer top, bool stop_at_print_length)
{
s7_int i, plen;
bool cyclic = false;
if (stop_at_print_length) {
plen = sc->print_length;
if (plen > vector_length(top))
plen = vector_length(top);
} else
plen = vector_length(top);
for (i = 0; i < plen; i++) {
s7_pointer vel = unchecked_vector_element(top, i); /* "unchecked" because top might be rootlet, I think */
if ((has_structure(vel)) &&
(collect_shared_info(sc, ci, vel, stop_at_print_length))) {
set_cyclic(vel);
cyclic = true;
if ((is_c_pointer(vel)) ||
(is_iterator(vel)) || (is_c_object(vel)))
check_collected(top, ci);
}
}
if (cyclic)
set_cyclic(top);
return (cyclic);
}
static bool collect_shared_info(s7_scheme * sc, shared_info_t * ci,
s7_pointer top, bool stop_at_print_length)
{
/* look for top in current list.
* As we collect objects (guaranteed to have structure) we set the collected bit. If we ever
* encounter an object with that bit on, we've seen it before so we have a possible cycle.
* Once the collection pass is done, we run through our list, and clear all these bits.
*/
bool top_cyclic;
if (is_collected_or_shared(top))
return ((!is_shared(top)) && (check_collected(top, ci)));
/* top not seen before -- add it to the list */
set_collected(top);
if (ci->top == ci->size)
enlarge_shared_info(ci);
ci->objs[ci->top++] = top;
top_cyclic = false;
/* now search the rest of this structure */
if (is_pair(top)) {
s7_pointer p, cp;
if ((has_structure(car(top))) &&
(collect_shared_info(sc, ci, car(top), stop_at_print_length)))
top_cyclic = true;
for (p = cdr(top); is_pair(p); p = cdr(p)) {
if (is_collected_or_shared(p)) {
set_cyclic(top);
set_cyclic(p);
if (!is_shared(p))
return (check_collected(p, ci));
if (!top_cyclic)
for (cp = top; cp != p; cp = cdr(cp))
set_shared(cp);
return (top_cyclic);
}
set_collected(p);
if (ci->top == ci->size)
enlarge_shared_info(ci);
ci->objs[ci->top++] = p;
if ((has_structure(car(p))) &&
(collect_shared_info
(sc, ci, car(p), stop_at_print_length)))
top_cyclic = true;
}
if ((has_structure(p)) &&
(collect_shared_info(sc, ci, p, stop_at_print_length))) {
set_cyclic(top);
return (true);
}
if (!top_cyclic)
for (cp = top; is_pair(cp); cp = cdr(cp))
set_shared(cp);
else
set_cyclic(top);
return (top_cyclic);
}
switch (type(top)) {
case T_VECTOR:
if (collect_vector_info(sc, ci, top, stop_at_print_length))
top_cyclic = true;
break;
case T_ITERATOR:
if ((is_sequence(iterator_sequence(top))) && /* might be a function with +iterator+ local */
(collect_shared_info
(sc, ci, iterator_sequence(top), stop_at_print_length))) {
if (peek_shared_ref(ci, iterator_sequence(top)) == 0)
check_collected(iterator_sequence(top), ci);
top_cyclic = true;
}
break;
case T_HASH_TABLE:
if (hash_table_entries(top) > 0) {
s7_int i, len = hash_table_mask(top) + 1;
hash_entry_t **entries = hash_table_elements(top);
bool keys_safe;
keys_safe = ((hash_table_checker(top) != hash_equal) &&
(hash_table_checker(top) != hash_equivalent) &&
(!hash_table_checker_locked(top)));
for (i = 0; i < len; i++) {
hash_entry_t *p;
for (p = entries[i]; p; p = hash_entry_next(p)) {
if ((!keys_safe) &&
(has_structure(hash_entry_key(p))) &&
(collect_shared_info
(sc, ci, hash_entry_key(p),
stop_at_print_length)))
top_cyclic = true;
if ((has_structure(hash_entry_value(p))) &&
(collect_shared_info
(sc, ci, hash_entry_value(p),
stop_at_print_length))) {
if ((is_c_pointer(hash_entry_value(p)))
|| (is_iterator(hash_entry_value(p)))
|| (is_c_object(hash_entry_value(p))))
check_collected(top, ci);
top_cyclic = true;
}
}
}
}
break;
case T_SLOT: /* this can be hit if we somehow collect_shared_info on sc->rootlet via collect_vector_info (see the let case below) */
if ((has_structure(slot_value(top))) &&
(collect_shared_info
(sc, ci, slot_value(top), stop_at_print_length)))
top_cyclic = true;
break;
case T_LET:
if (top == sc->rootlet) {
if (collect_vector_info(sc, ci, top, stop_at_print_length))
top_cyclic = true;
} else {
s7_pointer p, q;
for (q = top; is_let(q) && (q != sc->rootlet);
q = let_outlet(q))
for (p = let_slots(q); tis_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 = true;
if ((is_c_pointer(slot_value(p))) ||
(is_iterator(slot_value(p))) ||
(is_c_object(slot_value(p))))
check_collected(top, ci);
}
}
break;
case T_CLOSURE:
case T_CLOSURE_STAR:
if (collect_shared_info
(sc, ci, closure_body(top), stop_at_print_length)) {
if (peek_shared_ref(ci, top) == 0)
check_collected(top, ci);
top_cyclic = true;
}
break;
case T_C_POINTER:
if ((has_structure(c_pointer_type(top))) &&
(collect_shared_info
(sc, ci, c_pointer_type(top), stop_at_print_length))) {
if (peek_shared_ref(ci, c_pointer_type(top)) == 0)
check_collected(c_pointer_type(top), ci);
top_cyclic = true;
}
if ((has_structure(c_pointer_info(top))) &&
(collect_shared_info
(sc, ci, c_pointer_info(top), stop_at_print_length))) {
if (peek_shared_ref(ci, c_pointer_info(top)) == 0)
check_collected(c_pointer_info(top), ci);
top_cyclic = true;
}
break;
case T_C_OBJECT:
if ((c_object_to_list(sc, top)) &&
(c_object_set(sc, top)) &&
(collect_shared_info
(sc, ci,
(*(c_object_to_list(sc, top))) (sc, set_plist_1(sc, top)),
stop_at_print_length))) {
if (peek_shared_ref(ci, top) == 0)
check_collected(top, ci);
top_cyclic = true;
}
break;
}
if (!top_cyclic)
set_shared(top);
else
set_cyclic(top);
return (top_cyclic);
}
static shared_info_t *init_circle_info(s7_scheme * sc)
{
shared_info_t *ci;
ci = (shared_info_t *) calloc(1, sizeof(shared_info_t));
ci->size = INITIAL_SHARED_INFO_SIZE;
ci->size2 = ci->size - 2;
ci->objs = (s7_pointer *) malloc(ci->size * sizeof(s7_pointer));
ci->refs = (int32_t *) calloc(ci->size, sizeof(int32_t)); /* finder expects 0 = unseen previously */
ci->defined = (bool *) calloc(ci->size, sizeof(bool));
ci->cycle_port = sc->F;
ci->init_port = sc->F;
return (ci);
}
static inline shared_info_t *new_shared_info(s7_scheme * sc)
{
shared_info_t *ci = sc->circle_info;
if (ci->top > 0) {
int32_t i;
memclr((void *) (ci->refs), ci->top * sizeof(int32_t));
memclr((void *) (ci->defined), ci->top * sizeof(bool));
for (i = 0; i < ci->top; i++)
clear_cyclic_bits(ci->objs[i]); /* LOOP_4 is not faster */
ci->top = 0;
}
ci->ref = 0;
ci->has_hits = false;
return (ci);
}
static shared_info_t *make_shared_info(s7_scheme * sc, s7_pointer top,
bool stop_at_print_length)
{
/* for the printer */
shared_info_t *ci;
int32_t i, refs;
s7_pointer *ci_objs;
int32_t *ci_refs;
bool no_problem = true, cyclic = false;
s7_int k, stop_len;
/* check for simple cases first */
if (is_pair(top)) {
s7_pointer x = top;
if (stop_at_print_length) {
s7_pointer slow = top;
stop_len = sc->print_length;
for (k = 0; k < stop_len; k += 2) {
if (!is_pair(x))
break;
if (has_structure(car(x))) {
no_problem = false;
break;
}
x = cdr(x);
if (!is_pair(x))
break;
if (has_structure(car(x))) {
no_problem = false;
break;
}
x = cdr(x);
slow = cdr(slow);
if (x == slow) {
no_problem = false;
break;
}
}
} else if (s7_list_length(sc, top) == 0) /* it is circular at the top level (following cdr) */
no_problem = false;
else
for (; is_pair(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 (is_any_vector(top)) {
if (!is_normal_vector(top))
return (NULL);
stop_len = vector_length(top);
if ((stop_at_print_length) && (stop_len > sc->print_length))
stop_len = sc->print_length;
for (k = 0; k < stop_len; k++)
if (has_structure(vector_element(top, k))) {
no_problem = false;
break;
}
if (no_problem)
return (NULL);
}
ci = new_shared_info(sc);
/* collect all pointers associated with top */
cyclic = collect_shared_info(sc, ci, top, stop_at_print_length);
ci_objs = ci->objs;
for (i = 0; i < ci->top; i++)
clear_collected_and_shared(ci_objs[i]);
if (!cyclic)
return (NULL);
if (!(ci->has_hits))
return (NULL);
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_p_p(s7_scheme * sc, s7_pointer obj)
{
if (has_structure(obj)) {
shared_info_t *ci;
ci = (sc->object_out_locked) ? sc->circle_info : make_shared_info(sc, obj, false); /* false=don't stop at print length (vectors etc) */
if (ci) {
int32_t i;
s7_pointer lst;
sc->w = sc->nil;
check_free_heap_size(sc, ci->top);
for (i = 0; i < ci->top; i++)
sc->w = cons_unchecked(sc, ci->objs[i], sc->w);
lst = sc->w;
sc->w = sc->nil;
return (lst);
}
}
return (sc->nil);
}
static s7_pointer g_cyclic_sequences(s7_scheme * sc, s7_pointer args)
{
#define H_cyclic_sequences "(cyclic-sequences obj) returns a list of elements that are cyclic."
#define Q_cyclic_sequences s7_make_signature(sc, 2, sc->is_proper_list_symbol, sc->T)
return (cyclic_sequences_p_p(sc, car(args)));
}
static int32_t circular_list_entries(s7_pointer lst)
{
int32_t i;
s7_pointer x;
for (i = 1, x = cdr(lst);; i++, x = cdr(x)) {
int32_t 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_1(s7_scheme * sc,
s7_pointer vr,
s7_pointer port,
use_write_t use_write,
shared_info_t * ci);
#define object_to_port_with_circle_check(Sc, Vr, Port, Use_Write, Ci) \
do { \
s7_pointer _V_ = Vr; \
if ((Ci) && (has_structure(_V_))) \
object_to_port_with_circle_check_1(Sc, _V_, Port, Use_Write, Ci); \
else object_to_port(Sc, _V_, Port, Use_Write, Ci); \
} while (0)
static void (*display_functions[256])(s7_scheme * sc, s7_pointer obj,
s7_pointer port,
use_write_t use_write,
shared_info_t * ci);
#define object_to_port(Sc, Obj, Port, Use_Write, Ci) (*display_functions[unchecked_type(Obj)])(Sc, Obj, Port, Use_Write, Ci)
static bool string_needs_slashification(const char *str, s7_int len)
{
/* we have to go by len (str len) not *s==0 because s7 strings can have embedded nulls */
uint8_t *p, *pend;
pend = (uint8_t *) (str + len);
for (p = (uint8_t *) str; p < pend; p++)
if (slashify_table[*p])
return (true);
return (false);
}
#define IN_QUOTES true
#define NOT_IN_QUOTES false
static void slashify_string_to_port(s7_scheme * sc, s7_pointer port,
const char *p, s7_int len, bool quoted)
{
uint8_t *pcur, *pend, *pstart = NULL;
if (len == 0) {
if (quoted)
port_write_string(port) (sc, "\"\"", 2, port);
return;
}
pend = (uint8_t *) (p + len);
/* what about the trailing nulls? Guile writes them out (as does s7 currently)
* but that is not ideal. I'd like to use ~S for error messages, so that
* strings are clearly identified via the double-quotes, but this way of
* writing them is ugly:
* (let ((str (make-string 8 #\null))) (set! (str 0) #\a) str) -> "a\x00\x00\x00\x00\x00\x00\x00"
* but it would be misleading to omit them because:
* (let ((str (make-string 8 #\null))) (set! (str 0) #\a) (string-append str "bc")) -> "a\x00\x00\x00\x00\x00\x00\x00bc"
* also it is problematic to use sc->print_length here (rather than a separate string-print-length) because
* it is normally (say) 8 which truncates just about every string. In CL, *print-length*
* does not affect strings, symbols, or bit-vectors. But if the string is enormous,
* this function can bring us to a complete halt. string-print-length (as a *s7* field) is
* also problematic -- it does not behave as expected in many cases if it is limited to this
* function and string_to_port below, and if set too low, disables the repl.
*/
if (quoted)
port_write_character(port) (sc, '"', port);
for (pcur = (uint8_t *) p; pcur < pend; pcur++) {
if (slashify_table[*pcur]) {
if (pstart)
pstart++;
else
pstart = (uint8_t *) p;
if (pstart != pcur) {
port_write_string(port) (sc, (char *) pstart,
pcur - pstart, port);
pstart = pcur;
}
port_write_character(port) (sc, '\\', port);
switch (*pcur) {
case '"':
port_write_character(port) (sc, '"', port);
break;
case '\\':
port_write_character(port) (sc, '\\', port);
break;
case '\'':
port_write_character(port) (sc, '\'', port);
break;
case '\t':
port_write_character(port) (sc, 't', port);
break;
case '\r':
port_write_character(port) (sc, 'r', port);
break;
case '\b':
port_write_character(port) (sc, 'b', port);
break;
case '\f':
port_write_character(port) (sc, 'f', port);
break;
case '\?':
port_write_character(port) (sc, '?', port);
break;
case 'x':
port_write_character(port) (sc, 'x', port);
break;
default:
{
char buf[5];
s7_int n = (s7_int) (*pcur);
buf[0] = 'x';
buf[1] = (n < 16) ? '0' : dignum[(n / 16) % 16];
buf[2] = dignum[n % 16];
buf[3] = ';';
buf[4] = '\0';
port_write_string(port) (sc, buf, 4, port);
}
break;
}
}
}
if (!pstart)
port_write_string(port) (sc, (char *) p, len, port);
else {
pstart++;
if (pstart != pcur)
port_write_string(port) (sc, (char *) pstart, pcur - pstart,
port);
}
if (quoted)
port_write_character(port) (sc, '"', port);
}
static void output_port_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if ((obj == sc->standard_output) || (obj == sc->standard_error))
port_write_string(port) (sc, port_filename(obj),
port_filename_length(obj), port);
else {
if (use_write == P_READABLE) {
if (port_is_closed(obj))
port_write_string(port) (sc,
"(let ((p (open-output-string))) (close-output-port p) p)",
56, port);
else {
if (is_string_port(obj)) {
port_write_string(port) (sc,
"(let ((p (open-output-string)))",
31, port);
if (port_position(obj) > 0) {
port_write_string(port) (sc, " (display ", 10,
port);
slashify_string_to_port(sc, port, (const char *)
port_data(obj),
port_position(obj),
IN_QUOTES);
port_write_string(port) (sc, " p)", 3, port);
}
port_write_string(port) (sc, " p)", 3, port);
} else if (is_file_port(obj)) {
char str[256];
int32_t nlen;
str[0] = '\0';
nlen =
catstrs(str, 256, "(open-output-file \"",
port_filename(obj), "\" \"a\")",
(char *) NULL);
port_write_string(port) (sc, str, nlen, port);
} else
port_write_string(port) (sc, "#<output-function-port>",
23, port);
}
} else {
if (is_string_port(obj))
port_write_string(port) (sc, "#<output-string-port", 20,
port);
else if (is_file_port(obj))
port_write_string(port) (sc, "#<output-file-port", 18,
port);
else
port_write_string(port) (sc, "#<output-function-port", 22,
port);
if (port_is_closed(obj))
port_write_string(port) (sc, ":closed>", 8, port);
else
port_write_character(port) (sc, '>', port);
}
}
}
static void input_port_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if (obj == sc->standard_input)
port_write_string(port) (sc, port_filename(obj),
port_filename_length(obj), port);
else {
if (use_write == P_READABLE) {
if (port_is_closed(obj))
port_write_string(port) (sc,
"(call-with-input-string \"\" (lambda (p) p))",
42, port);
else if (is_function_port(obj))
port_write_string(port) (sc, "#<input-function-port>", 22,
port);
else if (is_file_port(obj)) {
char str[256];
int32_t nlen;
str[0] = '\0';
nlen =
catstrs(str, 256, "(open-input-file \"",
port_filename(obj), "\")", (char *) NULL);
port_write_string(port) (sc, str, nlen, port);
} else {
s7_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(sc, obj);
if (filename) {
#define DO_STR_LEN 1024
char do_str[DO_STR_LEN];
int32_t len;
do_str[0] = '\0';
if (port_position(obj) > 0) {
len =
catstrs(do_str, DO_STR_LEN,
"(let ((port (open-input-file \"",
filename, "\")))", (char *) NULL);
port_write_string(port) (sc, do_str, len,
port);
do_str[0] = '\0';
len =
catstrs(do_str, DO_STR_LEN,
" (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i ",
pos_int_to_str_direct(sc,
port_position
(obj) - 1),
") port)))", (char *) NULL);
} else
len =
catstrs(do_str, DO_STR_LEN,
"(open-input-file \"", filename,
"\")", (char *) NULL);
port_write_string(port) (sc, do_str, len, port);
return;
}
}
port_write_string(port) (sc, "(open-input-string ", 19,
port);
/* not port_write_string here because there might be embedded double-quotes */
slashify_string_to_port(sc, port,
(const char *) (port_data(obj) +
port_position
(obj)),
port_data_size(obj) -
port_position(obj), IN_QUOTES);
port_write_character(port) (sc, ')', port);
}} else {
if (is_string_port(obj))
port_write_string(port) (sc, "#<input-string-port", 19,
port);
else if (is_file_port(obj))
port_write_string(port) (sc, "#<input-file-port", 17,
port);
else
port_write_string(port) (sc, "#<input-function-port", 21,
port);
if (port_is_closed(obj))
port_write_string(port) (sc, ":closed>", 8, port);
else
port_write_character(port) (sc, '>', port);
}
}
}
static bool symbol_needs_slashification(s7_scheme * sc, s7_pointer obj)
{
uint8_t *p, *pend;
const char *str = symbol_name(obj);
s7_int len;
if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ','))
return (true);
if (is_number
(make_atom
(sc, (char *) str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR)))
return (true);
len = symbol_name_length(obj);
pend = (uint8_t *) (str + len);
for (p = (uint8_t *) str; p < pend; p++)
if (symbol_slashify_table[*p])
return (true);
set_clean_symbol(obj);
return (false);
}
static inline void symbol_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
/* I think this is the only place we print a symbol's name */
if ((!is_clean_symbol(obj)) && (symbol_needs_slashification(sc, obj))) {
port_write_string(port) (sc, "(symbol \"", 9, port);
slashify_string_to_port(sc, port, symbol_name(obj),
symbol_name_length(obj), NOT_IN_QUOTES);
port_write_string(port) (sc, "\")", 2, port);
} else {
char c = '\0';
if (use_write == P_READABLE) {
if (!is_keyword(obj))
c = '\'';
} else if ((use_write == P_KEY) && (!is_keyword(obj)))
c = ':';
if (is_string_port(port)) {
s7_int new_len;
new_len =
port_position(port) + symbol_name_length(obj) +
((c) ? 1 : 0);
if (new_len >= port_data_size(port))
resize_port_data(sc, port, new_len * 2);
if (c)
port_data(port)[port_position(port)++] = c;
memcpy((void *) (port_data(port) + port_position(port)),
(void *) symbol_name(obj), symbol_name_length(obj));
port_position(port) = new_len;
} else {
if (c)
port_write_character(port) (sc, c, port);
port_write_string(port) (sc, symbol_name(obj),
symbol_name_length(obj), port);
}
}
}
static char *multivector_indices_to_string(s7_scheme * sc, s7_int index,
s7_pointer vect, char *str,
int32_t str_len,
int32_t cur_dim)
{
s7_int size, ind;
size = vector_dimension(vect, cur_dim);
ind = index % size;
if (cur_dim > 0)
multivector_indices_to_string(sc, (index - ind) / size, vect, str,
str_len, cur_dim - 1);
catstrs(str, str_len, " ", pos_int_to_str_direct(sc, ind),
(char *) NULL);
return (str);
}
#define NOT_P_DISPLAY(Choice) ((Choice == P_DISPLAY) ? P_WRITE : Choice)
static int32_t multivector_to_port(s7_scheme * sc, s7_pointer vec,
s7_pointer port, int32_t out_len,
int32_t flat_ref, int32_t dimension,
int32_t dimensions, bool *last,
use_write_t use_write,
shared_info_t * ci)
{
int32_t i;
if (use_write != P_READABLE) {
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) {
object_to_port_with_circle_check(sc,
vector_getter(vec) (sc,
vec,
flat_ref),
port,
NOT_P_DISPLAY(use_write),
ci);
if (use_write == P_READABLE)
port_write_string(port) (sc, ") ", 2, port);
flat_ref++;
} else {
port_write_string(port) (sc, "...)", 4, port);
return (flat_ref);
}
if ((use_write != P_READABLE) &&
(i < (vector_dimension(vec, dimension) - 1)))
port_write_character(port) (sc, ' ', port);
} else if (flat_ref < out_len)
flat_ref =
multivector_to_port(sc, vec, port, out_len, flat_ref,
dimension + 1, dimensions, last,
NOT_P_DISPLAY(use_write), ci);
else {
port_write_string(port) (sc, "...)", 4, port);
return (flat_ref);
}
}
if (use_write != P_READABLE)
port_write_character(port) (sc, ')', port);
(*last) = true;
return (flat_ref);
}
static void make_vector_to_port(s7_scheme * sc, s7_pointer vect,
s7_pointer port)
{
s7_int vlen;
int32_t plen;
char buf[128];
const char *vtyp = "";
if (is_float_vector(vect))
vtyp = "float-";
else if (is_int_vector(vect))
vtyp = "int-";
else if (is_byte_vector(vect))
vtyp = "byte-";
vlen = vector_length(vect);
if (vector_rank(vect) == 1) {
plen =
catstrs_direct(buf, "(make-", vtyp, "vector ",
integer_to_string_no_length(sc, vlen), " ",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
} else {
s7_int dim;
plen =
catstrs_direct(buf, "(make-", vtyp, "vector '(",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
for (dim = 0; dim < vector_ndims(vect) - 1; dim++) {
plen =
catstrs_direct(buf,
integer_to_string_no_length(sc,
vector_dimension
(vect, dim)),
" ", (const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
}
plen =
catstrs_direct(buf,
integer_to_string_no_length(sc,
vector_dimension
(vect, dim)), ") ",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
}
}
static void write_vector_dimensions(s7_scheme * sc, s7_pointer vect,
s7_pointer port)
{
char buf[128];
s7_int dim, plen;
port_write_string(port) (sc, " '(", 3, port);
for (dim = 0; dim < vector_ndims(vect) - 1; dim++) {
plen =
catstrs_direct(buf,
integer_to_string_no_length(sc,
vector_dimension
(vect, dim)), " ",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
}
plen =
catstrs_direct(buf,
integer_to_string_no_length(sc,
vector_dimension(vect,
dim)),
"))", (const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
}
static void vector_to_port(s7_scheme * sc, s7_pointer vect,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
s7_int i, len = vector_length(vect), plen;
bool too_long = false;
char buf[2048]; /* 128 is too small -- this is the list of indices with a few minor flourishes */
if (len == 0) {
if (vector_rank(vect) > 1) {
plen =
catstrs_direct(buf, "#",
pos_int_to_str_direct(sc,
vector_ndims(vect)),
"d()", (const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
} else
port_write_string(port) (sc, "#()", 3, port);
return;
}
if (use_write != P_READABLE) {
if (sc->print_length == 0) {
if (vector_rank(vect) > 1) {
plen =
catstrs_direct(buf, "#",
pos_int_to_str_direct(sc,
vector_ndims
(vect)), "d(...)",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
} else
port_write_string(port) (sc, "#(...)", 6, port);
return;
}
if (len > sc->print_length) {
too_long = true;
len = sc->print_length;
}
}
if ((!ci) && (len > 1000)) {
s7_int vlen = vector_length(vect);
s7_pointer p0;
s7_pointer *els = vector_elements(vect);
p0 = els[0];
for (i = 1; i < vlen; i++)
if (els[i] != p0)
break;
if (i == vlen) {
make_vector_to_port(sc, vect, port);
object_to_port(sc, p0, port, use_write, NULL);
port_write_character(port) (sc, ')', port);
return;
}
}
check_stack_size(sc);
s7_gc_protect_via_stack(sc, vect);
if (use_write == P_READABLE) {
int32_t vref;
if ((ci) &&
(is_cyclic(vect)) &&
((vref = peek_shared_ref(ci, vect)) != 0)) {
s7_pointer *els = vector_elements(vect);
if (vref < 0)
vref = -vref;
if ((ci->defined[vref]) || (port == ci->cycle_port)) {
plen =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc, vref), ">",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
unstack(sc);
return;
}
if (vector_rank(vect) > 1)
port_write_string(port) (sc, "(subvector ", 11, port);
port_write_string(port) (sc, "(vector", 7, port); /* top level let */
for (i = 0; i < len; i++) {
if (has_structure(els[i])) {
char *indices;
int32_t eref;
port_write_string(port) (sc, " #f", 3, port);
eref = peek_shared_ref(ci, els[i]);
if (eref != 0) {
if (eref < 0)
eref = -eref;
if (vector_rank(vect) > 1) {
s7_int dimension = vector_rank(vect) - 1;
int32_t str_len;
block_t *b;
str_len =
(dimension <
8) ? 128 : ((dimension + 1) * 16);
b = callocate(sc, str_len);
indices = (char *) block_data(b);
multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* calls pos_int_to_str_direct, writes to indices */
plen =
catstrs_direct(buf, " (set! (<",
pos_int_to_str_direct(sc,
vref),
">", indices, ") <",
pos_int_to_str_direct_1(sc,
eref),
">) ", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf,
plen,
ci->cycle_port);
liberate(sc, b);
} else {
size_t len1;
len1 =
catstrs_direct(buf, " (set! (<",
pos_int_to_str_direct(sc,
vref),
"> ", integer_to_string(sc,
i,
&plen),
") <",
pos_int_to_str_direct_1(sc,
eref),
">) ", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf,
len1,
ci->cycle_port);
}} else {
if (vector_rank(vect) > 1) {
s7_int dimension = vector_rank(vect) - 1;
int32_t str_len;
block_t *b;
str_len =
(dimension <
8) ? 128 : ((dimension + 1) * 16);
b = callocate(sc, str_len);
indices = (char *) block_data(b);
buf[0] = '\0';
multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* writes to indices */
plen =
catstrs(buf, 2048, " (set! (<",
pos_int_to_str_direct(sc, vref),
">", indices, ") ", (char *) NULL);
port_write_string(ci->cycle_port) (sc, buf,
plen,
ci->cycle_port);
liberate(sc, b);
} else {
size_t len1;
len1 =
catstrs_direct(buf, " (set! (<",
pos_int_to_str_direct(sc,
vref),
"> ",
integer_to_string_no_length
(sc, i), ") ",
(const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf,
len1,
ci->cycle_port);
}
object_to_port_with_circle_check(sc, els[i],
ci->cycle_port,
P_READABLE, ci);
port_write_string(ci->cycle_port) (sc, ") ", 2,
ci->cycle_port);
}} else {
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, els[i], port,
P_READABLE, ci);
}
}
port_write_character(port) (sc, ')', port);
if (vector_rank(vect) > 1) {
plen =
catstrs_direct(buf, " 0 ",
pos_int_to_str_direct(sc, len),
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
write_vector_dimensions(sc, vect, port);
}
} else {
if (vector_rank(vect) > 1)
port_write_string(port) (sc, "(subvector ", 11, port);
if (is_immutable_vector(vect))
port_write_string(port) (sc, "(immutable! ", 12, port);
port_write_string(port) (sc, "(vector", 7, port);
for (i = 0; i < len; i++) {
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc,
vector_element(vect, i),
port, P_READABLE, ci);
}
if (is_immutable_vector(vect))
port_write_string(port) (sc, "))", 2, port);
else
port_write_character(port) (sc, ')', port);
if (vector_rank(vect) > 1) {
plen =
catstrs_direct(buf, " 0 ",
pos_int_to_str_direct(sc, len),
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
write_vector_dimensions(sc, vect, port);
}
}} else { /* not readable write */
if (vector_rank(vect) > 1) {
bool last = false;
if (vector_ndims(vect) > 1) {
plen =
catstrs_direct(buf, "#",
pos_int_to_str_direct(sc,
vector_ndims
(vect)), "d",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
} else
port_write_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,
NOT_P_DISPLAY(use_write),
ci);
port_write_character(port) (sc, ' ', port);
}
object_to_port_with_circle_check(sc, vector_element(vect, i),
port,
NOT_P_DISPLAY(use_write), ci);
if (too_long)
port_write_string(port) (sc, " ...)", 5, port);
else
port_write_character(port) (sc, ')', port);
}
}
unstack(sc);
}
static int32_t print_vector_length(s7_scheme * sc, s7_pointer vect,
s7_pointer port, use_write_t use_write)
{
int32_t plen, len = vector_length(vect);
char buf[128];
const char *vtype = "r";
if (is_int_vector(vect))
vtype = "i";
else if (is_byte_vector(vect))
vtype = "u";
if (len == 0) {
if (vector_rank(vect) > 1)
plen =
catstrs_direct(buf, "#", vtype,
pos_int_to_str_direct(sc,
vector_ndims(vect)),
"d()", (const char *) (const char *) NULL);
else
plen =
catstrs_direct(buf, "#", vtype, "()", (const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
return (-1);
}
if (use_write == P_READABLE)
return (len);
if (sc->print_length != 0)
return ((len > sc->print_length) ? sc->print_length : len);
if (vector_rank(vect) > 1) {
plen =
catstrs_direct(buf, "#", vtype,
pos_int_to_str_direct(sc, vector_ndims(vect)),
"d(...)", (const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
} else if (is_int_vector(vect))
port_write_string(port) (sc, "#i(...)", 7, port);
else if (is_float_vector(vect))
port_write_string(port) (sc, "#r(...)", 7, port);
else
port_write_string(port) (sc, "#u(...)", 7, port);
return (-1);
}
static void int_vector_to_port(s7_scheme * sc, s7_pointer vect,
s7_pointer port, use_write_t use_write,
shared_info_t * ignored)
{
s7_int i, len, plen;
bool too_long;
char buf[128];
char *p;
len = print_vector_length(sc, vect, port, use_write);
if (len < 0)
return;
too_long = (len < vector_length(vect));
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_string(port) (sc, "(immutable! ", 12, port);
if (len > 1000) {
s7_int vlen = vector_length(vect);
s7_int first;
s7_int *els = int_vector_ints(vect);
first = els[0];
for (i = 1; i < vlen; i++)
if (els[i] != first)
break;
if (i == vlen) {
make_vector_to_port(sc, vect, port);
p = integer_to_string(sc, int_vector(vect, 0), &plen);
port_write_string(port) (sc, p, plen, port);
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_string(port) (sc, "))", 2, port);
else
port_write_character(port) (sc, ')', port);
return;
}
}
if (vector_rank(vect) == 1) {
port_write_string(port) (sc, "#i(", 3, port);
if (!is_string_port(port)) {
p = integer_to_string(sc, int_vector(vect, 0), &plen);
port_write_string(port) (sc, p, plen, port);
for (i = 1; i < len; i++) {
plen =
catstrs_direct(buf, " ",
integer_to_string_no_length(sc,
int_vector
(vect, i)),
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
}} else {
s7_int new_len = port_position(port), next_len =
port_data_size(port) - 128;
uint8_t *dbuf = port_data(port);
if (new_len >= next_len) {
resize_port_data(sc, port, port_data_size(port) * 2);
next_len = port_data_size(port) - 128;
dbuf = port_data(port);
}
p = integer_to_string(sc, int_vector(vect, 0), &plen);
memcpy((void *) (dbuf + new_len), (void *) p, plen);
new_len += plen;
for (i = 1; i < len; i++) {
if (new_len >= next_len) {
resize_port_data(sc, port, port_data_size(port) * 2);
next_len = port_data_size(port) - 128;
dbuf = port_data(port);
}
plen =
catstrs_direct((char *) (dbuf + new_len), " ",
integer_to_string_no_length(sc,
int_vector
(vect, i)),
(const char *) NULL);
new_len += plen;
}
port_position(port) = new_len;
}
if (too_long)
port_write_string(port) (sc, " ...)", 5, port);
else
port_write_character(port) (sc, ')', port);
} else {
bool last = false;
plen =
catstrs_direct(buf, "#i",
pos_int_to_str_direct(sc, vector_ndims(vect)),
"d", (const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
s7_gc_protect_via_stack(sc, vect);
multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect),
&last, P_DISPLAY, NULL);
unstack(sc);
}
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_character(port) (sc, ')', port);
}
static void float_vector_to_port(s7_scheme * sc, s7_pointer vect,
s7_pointer port, use_write_t use_write,
shared_info_t * ignored)
{
s7_int i, len, plen;
bool too_long;
#define FV_BUFSIZE 256
char buf[FV_BUFSIZE];
s7_double *els = float_vector_floats(vect);
len = print_vector_length(sc, vect, port, use_write);
if (len < 0)
return; /* vector-length=0 etc */
too_long = (len < vector_length(vect));
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_string(port) (sc, "(immutable! ", 12, port);
if (len > 1000) {
s7_int vlen = vector_length(vect);
s7_double first = els[0];
for (i = 1; i < vlen; i++)
if (els[i] != first)
break;
if (i == vlen) {
make_vector_to_port(sc, vect, port);
plen =
snprintf(buf, FV_BUFSIZE, "%.*g)",
sc->float_format_precision, first);
port_write_string(port) (sc, buf,
clamp_length(plen, FV_BUFSIZE), port);
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_character(port) (sc, ')', port);
return;
}
}
if (vector_rank(vect) == 1) {
port_write_string(port) (sc, "#r(", 3, port);
plen = snprintf(buf, FV_BUFSIZE - 4, "%.*g", sc->float_format_precision, els[0]); /* -4 so floatify has room */
floatify(buf, &plen);
port_write_string(port) (sc, buf, clamp_length(plen, FV_BUFSIZE),
port);
for (i = 1; i < len; i++) {
plen =
snprintf(buf, FV_BUFSIZE - 4, " %.*g",
sc->float_format_precision, els[i]);
plen--; /* fixup for the initial #\space */
floatify((char *) (buf + 1), &plen);
port_write_string(port) (sc, buf,
clamp_length(plen + 1, FV_BUFSIZE),
port);
}
if (too_long)
port_write_string(port) (sc, " ...)", 5, port);
else
port_write_character(port) (sc, ')', port);
} else {
bool last = false;
plen =
catstrs_direct(buf, "#r",
pos_int_to_str_direct(sc, vector_ndims(vect)),
"d", (const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
s7_gc_protect_via_stack(sc, vect);
multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect),
&last, P_DISPLAY, NULL);
unstack(sc);
}
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_character(port) (sc, ')', port);
}
static void byte_vector_to_port(s7_scheme * sc, s7_pointer vect,
s7_pointer port, use_write_t use_write,
shared_info_t * ignored)
{
s7_int i, len, plen;
bool too_long;
char buf[128];
char *p;
len = print_vector_length(sc, vect, port, use_write);
if (len < 0)
return;
too_long = (len < vector_length(vect));
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_string(port) (sc, "(immutable! ", 12, port);
if (len > 1000) {
s7_int vlen = vector_length(vect);
uint8_t first;
uint8_t *els = byte_vector_bytes(vect);
first = els[0];
for (i = 1; i < vlen; i++)
if (els[i] != first)
break;
if (i == vlen) {
make_vector_to_port(sc, vect, port);
p = integer_to_string(sc, byte_vector(vect, 0), &plen);
port_write_string(port) (sc, p, plen, port);
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_string(port) (sc, "))", 2, port);
else
port_write_character(port) (sc, ')', port);
return;
}
}
if (vector_rank(vect) == 1) {
port_write_string(port) (sc, "#u(", 3, port);
p = integer_to_string(sc, byte_vector(vect, 0), &plen);
port_write_string(port) (sc, p, plen, port);
for (i = 1; i < len; i++) {
plen =
catstrs_direct(buf, " ",
integer_to_string_no_length(sc,
byte_vector
(vect, i)),
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
}
if (too_long)
port_write_string(port) (sc, " ...)", 5, port);
else
port_write_character(port) (sc, ')', port);
} else {
bool last = false;
plen =
catstrs_direct(buf, "#u",
pos_int_to_str_direct(sc, vector_ndims(vect)),
"d", (const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect),
&last, P_DISPLAY, NULL);
}
if ((use_write == P_READABLE) && (is_immutable_vector(vect)))
port_write_character(port) (sc, ')', port);
}
static void string_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ignored)
{
bool immutable;
immutable = ((use_write == P_READABLE) && (is_immutable_string(obj)) && (string_length(obj) > 0)); /* (immutable "") looks dumb */
if (immutable)
port_write_string(port) (sc, "(immutable! ", 12, port);
if (string_length(obj) > 0) {
/* since string_length is a scheme length, not C, this write can embed nulls from C's point of view */
if (string_length(obj) > 1000) { /* was 10000 28-Feb-18 */
size_t size;
char buf[128];
buf[0] = string_value(obj)[0];
buf[1] = '\0';
size = strspn((const char *) (string_value(obj) + 1), buf); /* if all #\null, this won't work */
if (size == (size_t) (string_length(obj) - 1)) {
int32_t nlen;
s7_pointer c = chars[(int32_t) ((uint8_t) (buf[0]))];
nlen =
catstrs_direct(buf, "(make-string ",
pos_int_to_str_direct(sc,
string_length
(obj)), " ",
(const char *) NULL);
port_write_string(port) (sc, buf, nlen, port);
port_write_string(port) (sc, character_name(c),
character_name_length(c), port);
if (immutable)
port_write_string(port) (sc, "))", 2, port);
else
port_write_character(port) (sc, ')', port);
return;
}
}
if (use_write == P_DISPLAY)
port_write_string(port) (sc, string_value(obj),
string_length(obj), port);
else if (!string_needs_slashification
(string_value(obj), string_length(obj))) {
port_write_character(port) (sc, '"', port);
port_write_string(port) (sc, string_value(obj),
string_length(obj), port);
port_write_character(port) (sc, '"', port);
} else
slashify_string_to_port(sc, port, string_value(obj),
string_length(obj), IN_QUOTES);
} else if (use_write != P_DISPLAY)
port_write_string(port) (sc, "\"\"", 2, port);
if (immutable)
port_write_character(port) (sc, ')', port);
}
static void simple_list_readable_display(s7_scheme * sc, s7_pointer lst,
s7_int true_len, s7_int len,
s7_pointer port,
shared_info_t * ci)
{
/* the easier cases: no circles or shared refs to patch up */
s7_pointer x;
if (is_immutable(lst))
port_write_string(port) (sc, "immutable! (", 12, port);
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, P_READABLE,
ci);
}
port_write_character(port) (sc, ')', port);
} else {
s7_int i;
port_write_string(port) (sc, "cons ", 5, port);
object_to_port_with_circle_check(sc, car(lst), port, P_READABLE,
ci);
for (x = cdr(lst); is_pair(x); x = cdr(x)) {
port_write_string(port) (sc, " (cons ", 7, port);
object_to_port_with_circle_check(sc, car(x), port, P_READABLE,
ci);
}
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, x, port, P_READABLE, ci);
for (i = 1; i < len; i++)
port_write_character(port) (sc, ')', port);
}
if (is_immutable(lst))
port_write_character(port) (sc, ')', port);
}
static void pair_to_port(s7_scheme * sc, s7_pointer lst, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
s7_pointer x;
s7_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
len = (true_len == 0) ? circular_list_entries(lst) : true_len; /* circular list (nil is handled by unique_to_port) */
if ((use_write == P_READABLE) && (ci)) {
int32_t href;
href = peek_shared_ref(ci, lst);
if (href != 0) {
if (href < 0)
href = -href;
if ((ci->defined[href]) || (port == ci->cycle_port)) {
char buf[128];
int32_t plen;
plen =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc, href), ">",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
return;
}
}
}
if ((use_write != P_READABLE) &&
(car(lst) == sc->quote_symbol) && (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)
* :readable is tricky because the list might be something like (list 'quote (lambda () #f)) which needs to be evalable back to its original
*/
port_write_character(port) (sc, '\'', port);
object_to_port_with_circle_check(sc, cadr(lst), port, P_WRITE, ci);
return;
}
if (is_multiple_value(lst))
port_write_string(port) (sc, "(values ", 8, port);
else
port_write_character(port) (sc, '(', port);
check_stack_size(sc);
s7_gc_protect_via_stack(sc, lst);
if (use_write == P_READABLE) {
if (!is_cyclic(lst)) {
simple_list_readable_display(sc, lst, true_len, len, port, ci);
unstack(sc);
return;
}
if (ci) {
int32_t plen;
char buf[128], lst_name[128];
int32_t lst_ref;
bool lst_local = false;
s7_pointer local_port;
lst_ref = peek_shared_ref(ci, lst);
if (lst_ref == 0) {
s7_pointer p;
for (p = lst; is_pair(p); p = cdr(p))
if ((has_structure(car(p))) ||
((is_pair(cdr(p))) &&
(peek_shared_ref(ci, cdr(p)) != 0))) {
lst_name[0] = '<';
lst_name[1] = 'L';
lst_name[2] = '>';
lst_name[3] = '\0';
lst_local = true;
port_write_string(port) (sc, "let ((<L> (list", 15, port); /* '(' above */
break;
}
if (!lst_local) {
if (has_structure(p)) {
lst_name[0] = '<';
lst_name[1] = 'L';
lst_name[2] = '>';
lst_name[3] = '\0';
lst_local = true;
port_write_string(port) (sc, "let ((<L> (list", 15, port); /* '(' above */
} else {
simple_list_readable_display(sc, lst, true_len,
len, port, ci);
unstack(sc);
return;
}
}
} else {
if (lst_ref < 0)
lst_ref = -lst_ref;
catstrs_direct(lst_name, "<",
pos_int_to_str_direct(sc, lst_ref), ">",
(const char *) NULL);
port_write_string(port) (sc, "list", 4, port); /* '(' above */
}
for (i = 0, x = lst; (i < len) && (is_pair(x));
x = cdr(x), i++) {
if ((has_structure(car(x))) && (is_cyclic(car(x))))
port_write_string(port) (sc, " #f", 3, port);
else {
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, car(x), port,
use_write, ci);
}
if ((is_pair(cdr(x))) &&
(peek_shared_ref(ci, cdr(x)) != 0))
break;
}
if (lst_local)
port_write_string(port) (sc, "))) ", 4, port);
else
port_write_character(port) (sc, ')', port);
/* fill in the cyclic entries */
local_port = ((lst_local) || (ci->cycle_port == sc->F)) ? port : ci->cycle_port; /* (object->string (list-values `(x . 1) (signature (int-vector))) :readable) */
for (x = lst, i = 0; (i < len) && (is_pair(x));
x = cdr(x), i++) {
int32_t lref;
if ((has_structure(car(x))) && (is_cyclic(car(x)))) {
if (i == 0)
plen =
catstrs_direct(buf, " (set-car! ", lst_name,
" ", (const char *) NULL);
else
plen =
catstrs_direct(buf, " (set! (", lst_name, " ",
pos_int_to_str_direct(sc, i),
") ", (const char *) NULL);
port_write_string(local_port) (sc, buf, plen,
local_port);
lref = peek_shared_ref(ci, car(x));
if (lref == 0)
object_to_port_with_circle_check(sc, car(x),
local_port,
use_write, ci);
else {
if (lref < 0)
lref = -lref;
plen =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc, lref),
">", (const char *) NULL);
port_write_string(local_port) (sc, buf, plen,
local_port);
}
port_write_string(local_port) (sc, ") ", 2,
local_port);
}
if ((is_pair(cdr(x))) &&
((lref = peek_shared_ref(ci, cdr(x))) != 0)) {
if (lref < 0)
lref = -lref;
if (i == 0)
plen =
catstrs_direct(buf,
(lst_local) ? " " : " ",
"(set-cdr! ", lst_name, " <",
pos_int_to_str_direct(sc, lref),
">) ", (const char *) NULL);
else if (i == 1)
plen =
catstrs_direct(buf,
(lst_local) ? " " : " ",
"(set-cdr! (cdr ", lst_name,
") <", pos_int_to_str_direct(sc,
lref),
">) ", (const char *) NULL);
else
plen =
catstrs_direct(buf,
(lst_local) ? " " : " ",
"(set-cdr! (list-tail ",
lst_name, " ",
pos_int_to_str_direct_1(sc, i),
") <", pos_int_to_str_direct(sc,
lref),
">) ", (const char *) NULL);
port_write_string(local_port) (sc, buf, plen,
local_port);
break;
}
}
if (true_len < 0) { /* dotted list */
s7_pointer end_x;
for (end_x = lst; is_pair(end_x); end_x = cdr(end_x)); /* or maybe faster, start at x? */
/* we can't depend on the loops above to set x to the last element because they sometimes break out */
if (true_len == -1) /* cons cell */
plen =
catstrs_direct(buf, (lst_local) ? " " : " ",
"(set-cdr! ", lst_name, " ",
(const char *) NULL);
else if (true_len == -2)
plen =
catstrs_direct(buf, (lst_local) ? " " : " ",
"(set-cdr! (cdr ", lst_name, ") ",
(const char *) NULL);
else
plen =
catstrs_direct(buf, "(set-cdr! (list-tail ",
lst_name, " ",
pos_int_to_str_direct(sc, len - 2),
") ", (const char *) NULL);
port_write_string(local_port) (sc, buf, plen, local_port);
object_to_port_with_circle_check(sc, end_x, local_port,
use_write, ci);
port_write_string(local_port) (sc, ") ", 2, local_port);
}
if (lst_local)
port_write_string(local_port) (sc, " <L>)", 8,
local_port);
} else
simple_list_readable_display(sc, lst, true_len, len, port, ci);
} else { /* not :readable */
s7_int plen;
plen = (len > sc->print_length) ? sc->print_length : len;
if (plen <= 0) {
port_write_string(port) (sc, "(...))", 6, port); /* open paren above about 150 lines, "list" here is wrong if it's a cons */
unstack(sc);
return;
}
if (ci) {
for (x = lst, i = 0; (is_pair(x)) && (i < plen) && ((i == 0)
||
(peek_shared_ref
(ci, x)
== 0));
i++, x = cdr(x)) {
object_to_port_with_circle_check(sc, car(x), port,
NOT_P_DISPLAY(use_write),
ci);
if (i < (len - 1))
port_write_character(port) (sc, ' ', port);
}
if (is_not_null(x)) {
if (plen < len)
port_write_string(port) (sc, " ...", 4, port);
else {
if ((true_len == 0) && (i == len))
port_write_string(port) (sc, " . ", 3, port);
else
port_write_string(port) (sc, ". ", 2, port);
object_to_port_with_circle_check(sc, x, port,
NOT_P_DISPLAY
(use_write), ci);
}
}
port_write_character(port) (sc, ')', port);
} else {
s7_int len1;
len1 = plen - 1;
if (is_string_port(port)) {
for (x = lst, i = 0; (is_pair(x)) && (i < len1);
i++, x = cdr(x)) {
object_to_port(sc, car(x), port,
NOT_P_DISPLAY(use_write), ci);
if (port_position(port) >= sc->objstr_max_len) {
unstack(sc);
return;
}
if (port_position(port) >= port_data_size(port))
resize_port_data(sc, port,
port_data_size(port) * 2);
port_data(port)[port_position(port)++] = (uint8_t) ' ';
}
} else
for (x = lst, i = 0; (is_pair(x)) && (i < len1);
i++, x = cdr(x)) {
object_to_port(sc, car(x), port,
NOT_P_DISPLAY(use_write), ci);
port_write_character(port) (sc, ' ', port);
}
if (is_pair(x)) {
object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write),
ci);
x = cdr(x);
}
if (is_not_null(x)) {
if (plen < len)
port_write_string(port) (sc, " ...", 4, port);
else {
port_write_string(port) (sc, ". ", 2, port);
object_to_port(sc, x, port, NOT_P_DISPLAY(use_write),
ci);
}
}
port_write_character(port) (sc, ')', port);
}
}
unstack(sc);
}
static void hash_table_to_port(s7_scheme * sc, s7_pointer hash,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
s7_int i, gc_iter, len = hash_table_entries(hash);
bool too_long = false;
s7_pointer iterator, p;
int32_t href;
/* 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
* there's no way to make a truly :readable version of a weak hash-table (or a normal hash-table that uses eq? with pairs, for example)
*/
if (len == 0) {
if (is_weak_hash_table(hash))
port_write_string(port) (sc, "(weak-hash-table)", 17, port);
else
port_write_string(port) (sc, "(hash-table)", 12, port);
return;
}
if (use_write != P_READABLE) {
s7_int plen = sc->print_length;
if (plen <= 0) {
port_write_string(port) (sc, "(hash-table ...)", 16, port);
return;
}
if (len > plen) {
too_long = true;
len = plen;
}
}
if ((use_write == P_READABLE) && (ci)) {
href = peek_shared_ref(ci, hash);
if (href != 0) {
if (href < 0)
href = -href;
if ((ci->defined[href]) || (port == ci->cycle_port)) {
char buf[128];
int32_t plen;
plen =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc, href), ">",
(const char *) NULL);
port_write_string(port) (sc, buf, plen, port);
return;
}
}
}
iterator = s7_make_iterator(sc, hash);
gc_iter = gc_protect_1(sc, iterator);
p = cons_unchecked(sc, sc->F, sc->F);
iterator_current(iterator) = p;
set_mark_seq(iterator);
if ((use_write == P_READABLE) && (is_immutable(hash)))
port_write_string(port) (sc, "(immutable! ", 12, port);
if ((use_write == P_READABLE) &&
(ci) &&
(is_cyclic(hash)) && ((href = peek_shared_ref(ci, hash)) != 0)) {
if (href < 0)
href = -href;
if (is_weak_hash_table(hash))
port_write_string(port) (sc, "(weak-hash-table", 16, port);
else
port_write_string(port) (sc, "(hash-table", 11, port); /* top level let */
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);
if ((has_structure(val)) || (has_structure(key))) {
char buf[128];
int32_t eref, kref, plen;
eref = peek_shared_ref(ci, val);
kref = peek_shared_ref(ci, key);
plen =
catstrs_direct(buf, " (set! (<",
pos_int_to_str_direct(sc, href), "> ",
(const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf, plen,
ci->cycle_port);
if (kref != 0) {
if (kref < 0)
kref = -kref;
plen =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc, kref),
">", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf, plen,
ci->cycle_port);
} else
object_to_port(sc, key, ci->cycle_port, P_READABLE,
ci);
if (eref != 0) {
if (eref < 0)
eref = -eref;
plen =
catstrs_direct(buf, ") <",
pos_int_to_str_direct(sc, eref),
">) ", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf, plen,
ci->cycle_port);
} else {
port_write_string(ci->cycle_port) (sc, ") ", 2,
ci->cycle_port);
object_to_port_with_circle_check(sc, val,
ci->cycle_port,
P_READABLE, ci);
port_write_string(ci->cycle_port) (sc, ") ", 2,
ci->cycle_port);
}
} else {
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, key, port, P_READABLE,
ci);
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, val, port, P_READABLE,
ci);
}
}
port_write_character(port) (sc, ')', port);
} else {
if (is_weak_hash_table(hash))
port_write_string(port) (sc, "(weak-hash-table", 16, port);
else
port_write_string(port) (sc, "(hash-table", 11, port);
for (i = 0; i < len; i++) {
s7_pointer key_val;
port_write_character(port) (sc, ' ', port);
key_val = hash_table_iterate(sc, iterator);
if ((use_write != P_READABLE) &&
(is_normal_symbol(car(key_val))))
port_write_character(port) (sc, '\'', port);
object_to_port_with_circle_check(sc, car(key_val), port,
NOT_P_DISPLAY(use_write), ci);
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, cdr(key_val), port,
NOT_P_DISPLAY(use_write), ci);
}
if (too_long)
port_write_string(port) (sc, " ...)", 5, port);
else
port_write_character(port) (sc, ')', port);
}
if ((use_write == P_READABLE) && (is_immutable(hash)))
port_write_character(port) (sc, ')', port);
s7_gc_unprotect_at(sc, gc_iter);
iterator_current(iterator) = sc->nil;
free_cell(sc, p); /* free_cell(sc, iterator); *//* 18-Dec-18 removed */
}
static int32_t slot_to_port_1(s7_scheme * sc, s7_pointer x,
s7_pointer port, use_write_t use_write,
shared_info_t * ci, int32_t n)
{
#if S7_DEBUGGING
if ((x) && (!is_slot(x)))
fprintf(stderr, "%s: x is %s\n", __func__,
s7_type_names[unchecked_type(x)]);
#endif
if (tis_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);
} else if (n == (sc->print_length + 1))
port_write_string(port) (sc, " ...", 4, port);
}
return (n + 1);
}
static void funclet_slots_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
int32_t i;
s7_pointer slot;
for (i = 0, slot = let_slots(obj); tis_slot(slot);
i++, slot = next_slot(slot)) {
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, slot, port, use_write, ci);
if (i == (sc->print_length + 1)) {
port_write_string(port) (sc, " ...", 4, port);
break;
}
}
}
static void slot_list_to_port(s7_scheme * sc, s7_pointer slot,
s7_pointer port, shared_info_t * ci,
bool bindings)
{
if (tis_slot(slot)) {
slot_list_to_port(sc, next_slot(slot), port, ci, bindings);
if (bindings) {
if (tis_slot(next_slot(slot)))
port_write_string(port) (sc, " (", 2, port);
else
port_write_character(port) (sc, '(', port);
} else
port_write_character(port) (sc, ' ', port);
symbol_to_port(sc, slot_symbol(slot), port, (bindings) ? P_DISPLAY : P_KEY, ci); /* (object->string (inlet (symbol "(\")") 1) :readable) */
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, slot_value(slot), port,
P_READABLE, ci);
if (bindings)
port_write_character(port) (sc, ')', port);
}
}
static void slot_list_to_port_with_cycle(s7_scheme * sc, s7_pointer obj,
s7_pointer slot, s7_pointer port,
shared_info_t * ci, bool bindings)
{
if (tis_slot(slot)) {
s7_pointer sym, val;
slot_list_to_port_with_cycle(sc, obj, next_slot(slot), port, ci,
bindings);
sym = slot_symbol(slot);
val = slot_value(slot);
if (bindings) {
if (tis_slot(next_slot(slot)))
port_write_string(port) (sc, " (", 2, port);
else
port_write_character(port) (sc, '(', port);
} else
port_write_character(port) (sc, ' ', port);
symbol_to_port(sc, sym, port, (bindings) ? P_DISPLAY : P_KEY, ci);
if (has_structure(val)) {
char buf[128];
int32_t symref, len;
port_write_string(port) (sc, " #f", 3, port);
len =
catstrs_direct(buf, " (set! (<",
pos_int_to_str_direct(sc,
-peek_shared_ref(ci,
obj)),
"> ", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf, len,
ci->cycle_port);
symbol_to_port(sc, sym, ci->cycle_port, P_KEY, ci);
symref = peek_shared_ref(ci, val);
if (symref != 0) {
if (symref < 0)
symref = -symref;
len =
catstrs_direct(buf, ") <",
pos_int_to_str_direct(sc, symref),
">) ", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf, len,
ci->cycle_port);
} else {
port_write_string(ci->cycle_port) (sc, ") ", 2,
ci->cycle_port);
object_to_port_with_circle_check(sc, val, ci->cycle_port,
P_READABLE, ci);
port_write_string(ci->cycle_port) (sc, ") ", 2,
ci->cycle_port);
}
} else {
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, val, port, P_READABLE,
ci);
}
if (bindings)
port_write_character(port) (sc, ')', port);
if (is_immutable(obj)) {
char buf[128];
int32_t len;
len =
catstrs_direct(buf, " (immutable! <",
pos_int_to_str_direct(sc,
-peek_shared_ref(ci,
obj)),
">) ", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf, len,
ci->cycle_port);
}
}
}
static bool let_has_setter(s7_pointer obj)
{
s7_pointer slot;
for (slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot))
if (slot_has_setter(slot))
return (true);
return (false);
}
static void slot_setters_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, shared_info_t * ci)
{
s7_pointer slot;
for (slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot))
if (slot_has_setter(slot)) {
port_write_string(port) (sc, "(set! (setter '", 15, port);
symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, ci);
port_write_string(port) (sc, ") ", 2, port);
object_to_port_with_circle_check(sc, slot_setter(slot), port,
P_READABLE, ci);
port_write_character(port) (sc, ')', port);
}
}
static void let_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
/* if outer env points to (say) method list, the object needs to specialize object->string itself */
if (has_active_methods(sc, 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 == P_WRITE)
p = call_method(sc, obj, print_func, set_plist_1(sc, obj));
else
p = call_method(sc, obj, print_func,
set_plist_2(sc, obj,
(use_write ==
P_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 (obj == sc->s7_let)
port_write_string(port) (sc, "*s7*", 4, 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 == P_READABLE) {
int32_t lref;
if ((ci) &&
(is_cyclic(obj)) &&
((lref = peek_shared_ref(ci, obj)) != 0)) {
if (lref < 0)
lref = -lref;
if ((ci->defined[lref])
|| (port == ci->cycle_port)) {
char buf[128];
int32_t len;
len =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc,
lref),
">", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf,
len,
ci->cycle_port);
return;
}
if ((let_outlet(obj) != sc->nil) &&
(let_outlet(obj) != sc->rootlet)) {
char buf[128];
int32_t len;
len =
catstrs_direct(buf, " (set! (outlet <",
pos_int_to_str_direct(sc,
lref),
">) ", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf,
len,
ci->cycle_port);
let_to_port(sc, let_outlet(obj),
ci->cycle_port, use_write, ci);
port_write_string(ci->cycle_port) (sc, ") ", 2,
ci->cycle_port);
}
if (has_methods(obj))
port_write_string(port) (sc, "(openlet ", 9,
port);
/* not immutable here because we'll need to set the let fields below, then declare it immutable */
if (let_has_setter(obj)) {
port_write_string(port) (sc, "(let (", 6,
port);
slot_list_to_port_with_cycle(sc, obj,
let_slots(obj),
port, ci, true);
port_write_string(port) (sc, ") ", 2, port);
slot_setters_to_port(sc, obj, port, ci);
port_write_string(port) (sc, " (curlet))", 10,
port);
} else {
port_write_string(port) (sc, "(inlet", 6,
port);
slot_list_to_port_with_cycle(sc, obj,
let_slots(obj),
port, ci, false);
port_write_character(port) (sc, ')', port);
}
if (has_methods(obj))
port_write_character(port) (sc, ')', port);
} else {
if (has_methods(obj))
port_write_string(port) (sc, "(openlet ", 9,
port);
if (is_immutable(obj))
port_write_string(port) (sc, "(immutable! ",
12, port);
/* this ignores outlet -- but is that a problem? */
/* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */
if (let_has_setter(obj)) {
port_write_string(port) (sc, "(let (", 6,
port);
slot_list_to_port(sc, let_slots(obj), port, ci,
true);
port_write_string(port) (sc, ") ", 2, port);
slot_setters_to_port(sc, obj, port, ci);
/* perhaps set outlet here?? */
port_write_string(port) (sc, " (curlet))", 10,
port);
} else {
if ((let_outlet(obj) != sc->nil) &&
(let_outlet(obj) != sc->rootlet)) {
int32_t ref;
port_write_string(port) (sc, "(sublet ", 8,
port);
if ((ci)
&&
((ref =
peek_shared_ref(ci,
let_outlet(obj))) <
0)) {
char buf[128];
int32_t len;
len =
catstrs_direct(buf, "<",
pos_int_to_str_direct
(sc, -ref), ">",
(const char *)
NULL);
port_write_string(port) (sc, buf, len,
port);
} else {
s7_pointer name;
name =
s7_let_ref(sc, obj,
sc->class_name_symbol);
if (is_symbol(name))
symbol_to_port(sc, name, port,
P_DISPLAY, ci);
else
let_to_port(sc, let_outlet(obj),
port, use_write, ci);
}
} else
port_write_string(port) (sc, "(inlet", 6,
port);
slot_list_to_port(sc, let_slots(obj), port, ci,
false);
port_write_character(port) (sc, ')', port);
}
if (is_immutable(obj))
port_write_character(port) (sc, ')', port);
if (has_methods(obj))
port_write_character(port) (sc, ')', port);
}
} else { /* not readable write */
port_write_string(port) (sc, "(inlet", 6, port);
if (is_funclet(obj))
funclet_slots_to_port(sc, obj, port, use_write,
ci);
else
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 expr, body = closure_body(obj), arglist = closure_args(obj);
port_write_string(port) (sc,
(is_either_macro(obj)) ? "(macro" : "(bacro",
6, port);
if ((is_macro_star(obj)) || (is_bacro_star(obj)))
port_write_character(port) (sc, '*', port);
if (is_symbol(arglist)) {
port_write_character(port) (sc, ' ', port);
port_write_string(port) (sc, symbol_name(arglist),
symbol_name_length(arglist), port);
port_write_character(port) (sc, ' ', port);
} else if (is_pair(arglist)) {
port_write_string(port) (sc, " (", 2, port);
for (expr = arglist; is_pair(expr); expr = cdr(expr)) {
object_to_port(sc, car(expr), port, P_WRITE, NULL);
if (is_pair(cdr(expr)))
port_write_character(port) (sc, ' ', port);
}
if (!is_null(expr)) {
port_write_string(port) (sc, " . ", 3, port);
object_to_port(sc, expr, port, P_WRITE, NULL);
}
port_write_string(port) (sc, ") ", 2, port);
} else
port_write_string(port) (sc, " () ", 4, port);
for (expr = body; is_pair(expr); expr = cdr(expr))
object_to_port(sc, car(expr), port, P_WRITE, NULL);
port_write_character(port) (sc, ')', port);
}
static s7_pointer match_symbol(s7_pointer symbol, s7_pointer e)
{
s7_pointer y, le;
for (le = e; is_let(le); le = let_outlet(le))
for (y = let_slots(le); tis_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_symbol(s7_scheme * sc, s7_pointer sym, s7_pointer e,
s7_pointer args, s7_int gc_loc)
{
if ((!arg_memq(T_Sym(sym), args)) &&
(!slot_memq(sym, gc_protected_at(sc, gc_loc)))) {
s7_pointer slot;
slot = match_symbol(sym, e);
if (slot)
gc_protected_at(sc, gc_loc) =
cons(sc, slot, gc_protected_at(sc, gc_loc));
}
}
static void collect_locals(s7_scheme * sc, s7_pointer body, s7_pointer e,
s7_pointer args, s7_int gc_loc)
{ /* currently called only in write_closure_readably */
if (is_pair(body)) {
collect_locals(sc, car(body), e, args, gc_loc);
collect_locals(sc, cdr(body), e, args, gc_loc);
} else if (is_symbol(body))
collect_symbol(sc, body, e, args, gc_loc);
}
static void collect_specials(s7_scheme * sc, s7_pointer e, s7_pointer args,
s7_int gc_loc)
{
collect_symbol(sc, sc->local_signature_symbol, e, args, gc_loc);
collect_symbol(sc, sc->local_setter_symbol, e, args, gc_loc);
collect_symbol(sc, sc->local_documentation_symbol, e, args, gc_loc);
collect_symbol(sc, sc->local_iterator_symbol, e, args, gc_loc);
}
static s7_pointer find_closure(s7_scheme * sc, s7_pointer closure,
s7_pointer current_let)
{
s7_pointer e, y;
for (e = current_let; is_let(e); e = let_outlet(e)) {
if ((is_funclet(e)) || (is_maclet(e))) {
s7_pointer sym, f;
sym = funclet_function(e);
f = s7_symbol_local_value(sc, sym, e);
if (f == closure)
return (sym);
}
for (y = let_slots(e); tis_slot(y); y = next_slot(y))
if (slot_value(y) == closure)
return (slot_symbol(y));
}
if ((is_any_macro(closure)) && /* can't be a c_macro here */
(has_pair_macro(closure))) /* maybe macro never called, so no maclet exists */
return (pair_macro(closure_body(closure)));
return (sc->nil);
}
static void write_closure_name(s7_scheme * sc, s7_pointer closure,
s7_pointer port)
{
s7_pointer x;
x = find_closure(sc, closure, closure_let(closure));
/* this can be confusing!
* (let ((a (lambda () 1))) a) -> #<lambda ()>
* (letrec ((a (lambda () 1))) a) -> a
* (let () (define (a) 1) a) -> a
* (let () (define a (lambda () 1))) -> a
* (let () (define (a) (lambda () 1)) (a)) -> #<lambda ()>
*/
if (is_symbol(x)) { /* after find_closure */
port_write_string(port) (sc, symbol_name(x), symbol_name_length(x),
port);
return;
}
switch (type(closure)) {
case T_CLOSURE:
port_write_string(port) (sc, "#<lambda ", 9, port);
break;
case T_CLOSURE_STAR:
port_write_string(port) (sc, "#<lambda* ", 10, port);
break;
case T_BACRO:
port_write_string(port) (sc, "#<bacro ", 8, port);
break;
case T_BACRO_STAR:
port_write_string(port) (sc, "#<bacro* ", 9, port);
break;
case T_MACRO:
if (is_expansion(closure))
port_write_string(port) (sc, "#<expansion ", 12, port);
else
port_write_string(port) (sc, "#<macro ", 8, port);
break;
case T_MACRO_STAR:
if (is_expansion(closure))
port_write_string(port) (sc, "#<expansion* ", 13, port);
else
port_write_string(port) (sc, "#<macro* ", 9, port);
break;
}
if (is_null(closure_args(closure)))
port_write_string(port) (sc, "()>", 3, port);
else {
s7_pointer 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->curlet);
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 s7_pointer pair_append(s7_scheme * sc, s7_pointer a, s7_pointer b)
{
s7_pointer p = cdr(a), tp, np;
if (is_null(p))
return (cons(sc, car(a), b));
tp = list_1(sc, car(a));
gc_protect_via_stack(sc, tp);
for (np = tp; is_pair(p); p = cdr(p), np = cdr(np))
set_cdr(np, list_1(sc, car(p)));
set_cdr(np, b);
unstack(sc);
return (tp);
}
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 =
(is_null(cdr(arglist))) ? set_plist_2(sc, car(arglist),
sc->key_allow_other_keys_symbol)
: pair_append(sc, arglist,
list_1(sc, sc->key_allow_other_keys_symbol));
object_to_port(sc, sc->temp9, port, P_WRITE, NULL);
sc->temp9 = sc->nil;
} else
object_to_port(sc, arglist, port, P_WRITE, NULL); /* 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_to_port(sc, car(p), port, P_WRITE, NULL);
}
port_write_character(port) (sc, ')', port);
sc->print_length = old_print_length;
}
static void write_closure_readably(s7_scheme * sc, s7_pointer obj,
s7_pointer port, shared_info_t * ci)
{
s7_pointer body = closure_body(obj), arglist, pe, local_slots, setter =
NULL;
s7_int gc_loc;
if (sc->safety > NO_SAFETY) {
if (tree_is_cyclic(sc, body)) {
port_write_string(port) (sc, "#<write_closure: body is cyclic>", 32, port); /* not s7_error here! */
return;
}
/* perhaps: if any sequence in the closure_body is cyclic, complain, but how to check without clobbering ci?
* perhaps pass ci, and use make_shared_info if ci=null else continue_shared_info?
* this can happen only if (apply lambda ... cyclic-seq ...) I think
* long-term we need to include closure_body(obj) in the top object_out make_shared_info
*/
}
arglist = closure_args(obj);
if (is_symbol(arglist))
arglist = set_dlist_1(sc, arglist);
pe = closure_let(obj);
gc_loc = gc_protect_1(sc, sc->nil);
collect_locals(sc, body, pe, arglist, gc_loc); /* collect locals used only here (and below) */
collect_specials(sc, pe, arglist, gc_loc);
if (s7_is_dilambda(obj)) {
setter = closure_setter(obj);
if (has_closure_let(setter)) { /* collect args etc so need the arglist */
arglist = closure_args(setter);
if (is_symbol(arglist))
arglist = set_dlist_1(sc, arglist);
collect_locals(sc, closure_body(setter), pe, arglist, gc_loc);
}
}
local_slots = T_Lst(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);
if ((!is_any_closure(slot_value(slot))) && /* mutually referencing closures? ./snd -l snd-test 24 hits this in the effects dialogs */
((!has_structure(slot_value(slot))) || /* see s7test example, vector has closure that refers to vector */
(slot_symbol(slot) == sc->local_signature_symbol))) {
port_write_character(port) (sc, '(', port);
port_write_string(port) (sc,
symbol_name(slot_symbol(slot)),
symbol_name_length(slot_symbol
(slot)), port);
port_write_character(port) (sc, ' ', port);
/* (object->string (list (let ((local 1)) (lambda (x) (+ x local)))) :readable) */
object_to_port(sc, slot_value(slot), port, P_READABLE,
NULL);
if (is_null(cdr(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, closure_args(obj), body, port);
if (setter) {
port_write_character(port) (sc, ' ', port);
if (has_closure_let(setter))
write_closure_readably_1(sc, setter, closure_args(setter),
closure_body(setter), port);
else
object_to_port_with_circle_check(sc, setter, port, P_READABLE,
ci);
port_write_character(port) (sc, ')', port);
}
if (!is_null(local_slots))
port_write_character(port) (sc, ')', port);
s7_gc_unprotect_at(sc, gc_loc);
}
static void iterator_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if (use_write == P_READABLE) {
if (iterator_is_at_end(obj)) {
switch (type(iterator_sequence(obj))) {
case T_NIL:
case T_PAIR:
port_write_string(port) (sc, "(make-iterator ())", 18,
port);
break;
case T_STRING:
port_write_string(port) (sc, "(make-iterator \"\")", 18,
port);
break;
case T_BYTE_VECTOR:
port_write_string(port) (sc, "(make-iterator #u())", 20,
port);
break;
case T_VECTOR:
port_write_string(port) (sc, "(make-iterator #())", 19,
port);
break;
case T_INT_VECTOR:
port_write_string(port) (sc, "(make-iterator #i())", 20,
port);
break;
case T_FLOAT_VECTOR:
port_write_string(port) (sc, "(make-iterator #r())", 20,
port);
break;
case T_LET:
port_write_string(port) (sc, "(make-iterator (inlet))", 23,
port);
break;
case T_HASH_TABLE:
if (is_weak_hash_table(iterator_sequence(obj)))
port_write_string(port) (sc,
"(make-iterator (weak-hash-table))",
33, port);
else
port_write_string(port) (sc,
"(make-iterator (hash-table))",
28, port);
break;
default:
port_write_string(port) (sc, "(make-iterator ())", 18,
port);
break; /* c-object?? function? */
}
} else {
s7_pointer seq;
int32_t iter_ref;
seq = iterator_sequence(obj);
if ((ci) &&
(is_cyclic(obj)) &&
((iter_ref = peek_shared_ref(ci, obj)) != 0)) {
/* basically the same as c_pointer_to_port */
if (!is_cyclic_set(obj)) {
int32_t nlen;
char buf[128];
if (iter_ref < 0)
iter_ref = -iter_ref;
if (ci->init_port == sc->F) {
ci->init_port = s7_open_output_string(sc);
ci->init_loc = gc_protect_1(sc, ci->init_port);
}
port_write_string(port) (sc, "#f", 2, port);
nlen =
catstrs_direct(buf, " (set! <",
pos_int_to_str_direct(sc, iter_ref),
"> (make-iterator ",
(const char *) NULL);
port_write_string(ci->init_port) (sc, buf, nlen,
ci->init_port);
flip_ref(ci, seq);
object_to_port_with_circle_check(sc, seq,
ci->init_port,
use_write, ci);
flip_ref(ci, seq);
port_write_string(ci->init_port) (sc, "))\n", 3,
ci->init_port);
set_cyclic_set(obj);
return;
}
}
if (is_string(seq)) {
char *iter_str;
s7_int len;
iter_str =
(char *) (string_value(seq) + iterator_position(obj));
len = string_length(seq) - iterator_position(obj);
if (len == 0)
port_write_string(port) (sc, "(make-iterator \"\")",
18, port);
else {
port_write_string(port) (sc, "(make-iterator \"", 16,
port);
if (!string_needs_slashification(iter_str, len))
port_write_string(port) (sc, iter_str, len, port);
else
slashify_string_to_port(sc, port, iter_str, len,
NOT_IN_QUOTES);
port_write_string(port) (sc, "\")", 2, port);
}
} else {
if (is_pair(seq)) {
port_write_string(port) (sc, "(make-iterator ", 15,
port);
object_to_port_with_circle_check(sc,
iterator_current(obj),
port, use_write, ci);
port_write_character(port) (sc, ')', port);
} else {
if ((is_let(seq)) && (seq != sc->rootlet)
&& (seq != sc->s7_let)) {
s7_pointer slot;
port_write_string(port) (sc,
"(let ((iter (make-iterator ",
27, port);
object_to_port_with_circle_check(sc, seq, port,
use_write, ci);
port_write_string(port) (sc, "))) ", 4, port);
for (slot = let_slots(seq);
slot != iterator_current_slot(obj);
slot = next_slot(slot))
port_write_string(port) (sc, "(iter) ", 7,
port);
port_write_string(port) (sc, "iter)", 5, 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, seq, port,
use_write, ci);
if (iterator_position(obj) > 0) {
if (iterator_position(obj) == 1)
port_write_string(port) (sc,
"))) (iter) iter)",
16, port);
else {
int32_t nlen;
char str[128];
nlen =
catstrs_direct(str,
"))) (do ((i 0 (+ i 1))) ((= i ",
pos_int_to_str_direct
(sc,
iterator_position
(obj)),
") iter) (iter)))",
(const char *) NULL);
port_write_string(port) (sc, str, nlen,
port);
}} else
port_write_character(port) (sc, ')', port);
}
}
}
}
} else {
const char *str;
if ((is_hash_table(iterator_sequence(obj)))
&& (is_weak_hash_table(iterator_sequence(obj))))
str = "weak-hash-table";
else
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 c_pointer_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
#define CP_BUFSIZE 128
int32_t nlen;
char buf[CP_BUFSIZE];
/* c-pointer is special because we can't set the type or info fields from scheme except via the c-pointer function */
if (use_write == P_READABLE) {
int32_t ref;
if ((ci) &&
(is_cyclic(obj)) && ((ref = peek_shared_ref(ci, obj)) != 0)) {
port_write_string(port) (sc, "#f", 2, port);
if (!is_cyclic_set(obj)) {
if (ci->init_port == sc->F) {
ci->init_port = s7_open_output_string(sc);
ci->init_loc = gc_protect_1(sc, ci->init_port);
}
nlen =
snprintf(buf, CP_BUFSIZE,
" (set! <%d> (c-pointer %" p64, -ref,
(intptr_t) c_pointer(obj));
port_write_string(ci->init_port) (sc, buf, nlen,
ci->init_port);
if ((c_pointer_type(obj) != sc->F) ||
(c_pointer_info(obj) != sc->F)) {
flip_ref(ci, c_pointer_type(obj));
port_write_character(ci->init_port) (sc, ' ',
ci->init_port);
object_to_port_with_circle_check(sc,
c_pointer_type(obj),
ci->init_port,
use_write, ci);
flip_ref(ci, c_pointer_type(obj));
flip_ref(ci, c_pointer_info(obj));
port_write_character(ci->init_port) (sc, ' ',
ci->init_port);
object_to_port_with_circle_check(sc,
c_pointer_info(obj),
ci->init_port,
use_write, ci);
flip_ref(ci, c_pointer_info(obj));
}
port_write_string(ci->init_port) (sc, "))\n", 3,
ci->init_port);
set_cyclic_set(obj);
}
} else {
nlen =
snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64,
(intptr_t) c_pointer(obj));
port_write_string(port) (sc, buf,
clamp_length(nlen, CP_BUFSIZE), port);
if ((c_pointer_type(obj) != sc->F)
|| (c_pointer_info(obj) != sc->F)) {
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, c_pointer_type(obj),
port, use_write, ci);
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, c_pointer_info(obj),
port, use_write, ci);
}
port_write_character(port) (sc, ')', port);
}
} else {
if ((is_symbol(c_pointer_type(obj))) &&
(symbol_name_length(c_pointer_type(obj)) < (CP_BUFSIZE / 2)))
nlen =
snprintf(buf, CP_BUFSIZE, "#<%s %p>",
symbol_name(c_pointer_type(obj)), c_pointer(obj));
else
nlen =
snprintf(buf, CP_BUFSIZE, "#<c_pointer %p>",
c_pointer(obj));
port_write_string(port) (sc, buf, clamp_length(nlen, CP_BUFSIZE),
port);
}
}
static void rng_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
int32_t nlen;
char buf[128];
#if WITH_GMP
if (use_write == P_READABLE)
nlen = snprintf(buf, 128, "#<bignum random-state>");
else
nlen = snprintf(buf, 128, "#<rng %p>", obj);
#else
if (use_write == P_READABLE)
nlen =
snprintf(buf, 128, "(random-state %" PRIu64 " %" PRIu64 ")",
random_seed(obj), random_carry(obj));
else
nlen =
snprintf(buf, 128, "#<rng %" PRIu64 " %" PRIu64 ">",
random_seed(obj), random_carry(obj));
#endif
port_write_string(port) (sc, buf, clamp_length(nlen, 128), port);
}
static void display_any(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
#if S7_DEBUGGING
print_debugging_state(sc, obj, port);
#else
{
char *str, *tmp;
block_t *b;
s7_int nlen, len;
tmp = describe_type_bits(sc, obj);
len = 32 + safe_strlen(tmp);
b = mallocate(sc, len);
str = (char *) block_data(b);
if (is_free(obj))
nlen =
catstrs_direct(str, "<free cell! ", tmp, ">",
(const char *) NULL);
else
nlen =
catstrs_direct(str, "<unknown object! ", tmp, ">",
(const char *) NULL);
port_write_string(port) (sc, str, nlen, port);
free(tmp);
liberate(sc, b);
}
#endif
}
static void unique_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
port_write_string(port) (sc, unique_name(obj), unique_name_length(obj),
port);
}
static void undefined_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if ((obj != sc->undefined) && (use_write == P_READABLE)) {
port_write_string(port) (sc, "(with-input-from-string \"", 25,
port);
port_write_string(port) (sc, undefined_name(obj),
undefined_name_length(obj), port);
port_write_string(port) (sc, "\" read)", 7, port);
} else
port_write_string(port) (sc, undefined_name(obj),
undefined_name_length(obj), port);
}
static void eof_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
if (use_write == P_READABLE)
port_write_string(port) (sc, "(begin #<eof>)", 14, port);
else
port_write_string(port) (sc, eof_name(obj), eof_name_length(obj),
port);
}
static void counter_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
port_write_string(port) (sc, "#<counter>", 10, port);
}
static void integer_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if (has_number_name(obj)) {
if (is_string_port(port)) {
if (port_position(port) + number_name_length(obj) <
port_data_size(port)) {
memcpy((void *) (port_data(port) + port_position(port)),
(void *) number_name(obj), number_name_length(obj));
port_position(port) += number_name_length(obj);
} else
string_write_string_resized(sc, number_name(obj),
number_name_length(obj), port);
} else
port_write_string(port) (sc, number_name(obj),
number_name_length(obj), port);
} else {
s7_int nlen;
char *str;
str = integer_to_string(sc, integer(obj), &nlen);
set_number_name(obj, str, nlen);
port_write_string(port) (sc, str, nlen, port);
}
}
static void number_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
if (has_number_name(obj))
port_write_string(port) (sc, number_name(obj),
number_name_length(obj), port);
else {
s7_int nlen;
char *str;
nlen = 0;
str = number_to_string_base_10(sc, obj, 0, sc->float_format_precision, 'g', &nlen, use_write); /* was 14 */
if ((nlen < NUMBER_NAME_SIZE) &&
(str[0] != 'n') && (str[0] != 'i') &&
((!(is_t_complex(obj))) ||
((!is_NaN(imag_part(obj))) && (!is_inf(imag_part(obj))))))
set_number_name(obj, str, nlen);
port_write_string(port) (sc, str, nlen, port);
}
}
#if WITH_GMP
static void big_number_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
s7_int nlen;
block_t *str;
nlen = 0;
str =
big_number_to_string_with_radix(sc, obj, BASE_10, 0, &nlen,
use_write);
port_write_string(port) (sc, (char *) block_data(str), nlen, port);
liberate(sc, str);
}
#endif
static void syntax_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
port_display(port) (sc, symbol_name(syntax_symbol(obj)), port);
}
static void character_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if (use_write == P_DISPLAY)
port_write_character(port) (sc, character(obj), port);
else
port_write_string(port) (sc, character_name(obj),
character_name_length(obj), port);
}
static void closure_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if (has_active_methods(sc, 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>.
* this is tricky!: (display (openlet (with-let (mock-c-pointer 0) (lambda () 1))))
* calls object->string on the closure whose closure_let is the mock-c-pointer;
* it has an object->string method that clears mock-c-pointers and tries again...
* so, display methods need to use coverlet/openlet.
*/
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 = call_method(sc, obj, print_func, set_plist_1(sc, obj));
if (string_length(p) > 0)
port_write_string(port) (sc, string_value(p),
string_length(p), port);
return;
}
}
if (use_write == P_READABLE)
write_closure_readably(sc, obj, port, ci);
else
write_closure_name(sc, obj, port);
}
static void macro_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
if (use_write == P_READABLE)
write_macro_readably(sc, obj, port);
else
write_closure_name(sc, obj, port);
}
static void c_function_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
s7_pointer sym;
sym = make_symbol(sc, c_function_name(obj));
if ((!is_global(sym)) &&
(is_slot(initial_slot(sym))) && ((use_write == P_READABLE)
|| (lookup(sc, sym) !=
initial_value(sym)))) {
port_write_string(port) (sc, "#_", 2, port);
port_write_string(port) (sc, c_function_name(obj),
c_function_name_length(obj), port);
return;
}
if (c_function_name_length(obj) > 0)
port_write_string(port) (sc, c_function_name(obj),
c_function_name_length(obj), port);
else
port_write_string(port) (sc, "#<c-function>", 13, port);
}
static void c_macro_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if (c_macro_name_length(obj) > 0)
port_write_string(port) (sc, c_macro_name(obj),
c_macro_name_length(obj), port);
else
port_write_string(port) (sc, "#<c-macro>", 10, port);
}
static void continuation_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
if (is_symbol(continuation_name(obj))) {
port_write_string(port) (sc, "#<continuation ", 15, port);
symbol_to_port(sc, continuation_name(obj), port, P_DISPLAY, ci);
port_write_character(port) (sc, '>', port);
} else
port_write_string(port) (sc, "#<continuation>", 15, port);
}
static void goto_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
if (is_symbol(call_exit_name(obj))) {
port_write_string(port) (sc, "#<goto ", 7, port);
symbol_to_port(sc, call_exit_name(obj), port, P_DISPLAY, ci);
port_write_character(port) (sc, '>', port);
} else
port_write_string(port) (sc, "#<goto>", 7, port);
}
static void catch_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
port_write_string(port) (sc, "#<catch>", 8, port);
}
static void dynamic_wind_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
/* this can happen because (*s7* 'stack) can involve dynamic-wind markers */
port_write_string(port) (sc, "#<dynamic-wind>", 15, port);
}
static void c_object_name_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port)
{
port_write_string(port) (sc,
string_value(c_object_scheme_name(sc, obj)),
string_length(c_object_scheme_name(sc, obj)),
port);
}
static void c_object_to_port(s7_scheme * sc, s7_pointer obj,
s7_pointer port, use_write_t use_write,
shared_info_t * ci)
{
#if (!DISABLE_DEPRECATED)
if (c_object_print(sc, obj)) {
char *str;
str = ((*(c_object_print(sc, obj))) (sc, c_object_value(obj)));
port_display(port) (sc, str, port);
free(str);
return;
}
#endif
if (c_object_to_string(sc, obj))
port_display(port) (sc, s7_string((*(c_object_to_string(sc, obj)))
(sc,
set_plist_2(sc, obj,
(use_write ==
P_READABLE) ?
sc->key_readable_symbol
: sc->T))), port);
else {
if ((use_write == P_READABLE) && (c_object_to_list(sc, obj)) && /* to_list and (implicit) set are needed to reconstruct a cyclic c-object, as well as the maker (via type name) */
(c_object_set(sc, obj))) {
s7_pointer obj_list, old_w, p;
int32_t href;
obj_list = ((*(c_object_to_list(sc, obj)))
(sc, set_plist_1(sc, obj)));
old_w = sc->w;
sc->w = obj_list;
if ((ci) &&
(is_cyclic(obj)) &&
((href = peek_shared_ref(ci, obj)) != 0)) {
int32_t i;
if (href < 0)
href = -href;
if ((ci->defined[href]) || (port == ci->cycle_port)) {
int32_t nlen;
char buf[128];
nlen =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc, href),
">", (const char *) NULL);
port_write_string(port) (sc, buf, nlen, port);
return;
}
port_write_character(port) (sc, '(', port);
c_object_name_to_port(sc, obj, port);
for (i = 0, p = obj_list; is_pair(p); i++, p = cdr(p)) {
s7_pointer val;
val = car(p);
if (has_structure(val)) {
char buf[128];
int32_t symref, len;
port_write_string(port) (sc, " #f", 3, port);
len =
catstrs_direct(buf, " (set! (<",
pos_int_to_str_direct(sc, href),
"> ",
pos_int_to_str_direct_1(sc, i),
") ", (const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf, len,
ci->cycle_port);
symref = peek_shared_ref(ci, val);
if (symref != 0) {
if (symref < 0)
symref = -symref;
len =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc,
symref),
">)\n",
(const char *) NULL);
port_write_string(ci->cycle_port) (sc, buf,
len,
ci->cycle_port);
} else {
object_to_port_with_circle_check(sc, val,
ci->cycle_port,
P_READABLE,
ci);
port_write_string(ci->cycle_port) (sc, ")\n",
2,
ci->cycle_port);
}
} else {
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, val, port,
P_READABLE, ci);
}
}
} else {
port_write_character(port) (sc, '(', port);
c_object_name_to_port(sc, obj, port);
for (p = obj_list; is_pair(p); p = cdr(p)) {
s7_pointer val;
val = car(p);
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, val, port,
P_READABLE, ci);
}
}
port_write_character(port) (sc, ')', port);
sc->w = old_w;
} else {
char buf[128];
int32_t nlen;
port_write_string(port) (sc, "#<", 2, port);
c_object_name_to_port(sc, obj, port);
nlen = snprintf(buf, 128, " %p>", obj);
port_write_string(port) (sc, buf, clamp_length(nlen, 128),
port);
}}
}
static void slot_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
/* the slot symbol might need (symbol...) in which case we don't want the preceding quote */
symbol_to_port(sc, slot_symbol(obj), port, P_READABLE, ci);
port_write_character(port) (sc, ' ', port);
object_to_port_with_circle_check(sc, slot_value(obj), port, use_write,
ci);
}
static void stack_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port,
use_write_t use_write, shared_info_t * ci)
{
port_write_string(port) (sc, "#<stack>", 8, port);
}
static void init_display_functions(void)
{
int32_t i;
for (i = 0; i < 256; i++)
display_functions[i] = display_any;
display_functions[T_FLOAT_VECTOR] = float_vector_to_port;
display_functions[T_INT_VECTOR] = int_vector_to_port;
display_functions[T_BYTE_VECTOR] = byte_vector_to_port;
display_functions[T_VECTOR] = vector_to_port;
display_functions[T_PAIR] = pair_to_port;
display_functions[T_HASH_TABLE] = hash_table_to_port;
display_functions[T_ITERATOR] = iterator_to_port;
display_functions[T_LET] = let_to_port;
display_functions[T_BOOLEAN] = unique_to_port;
display_functions[T_NIL] = unique_to_port;
display_functions[T_UNUSED] = unique_to_port;
display_functions[T_UNSPECIFIED] = unique_to_port;
display_functions[T_UNDEFINED] = undefined_to_port;
display_functions[T_EOF] = eof_to_port;
display_functions[T_INPUT_PORT] = input_port_to_port;
display_functions[T_OUTPUT_PORT] = output_port_to_port;
display_functions[T_COUNTER] = counter_to_port;
display_functions[T_STACK] = stack_to_port;
display_functions[T_INTEGER] = integer_to_port;
display_functions[T_RATIO] = number_to_port;
display_functions[T_REAL] = number_to_port;
display_functions[T_COMPLEX] = number_to_port;
#if WITH_GMP
display_functions[T_BIG_INTEGER] = big_number_to_port;
display_functions[T_BIG_RATIO] = big_number_to_port;
display_functions[T_BIG_REAL] = big_number_to_port;
display_functions[T_BIG_COMPLEX] = big_number_to_port;
#endif
display_functions[T_SYMBOL] = symbol_to_port;
display_functions[T_SYNTAX] = syntax_to_port;
display_functions[T_STRING] = string_to_port;
display_functions[T_CHARACTER] = character_to_port;
display_functions[T_CLOSURE] = closure_to_port;
display_functions[T_CLOSURE_STAR] = closure_to_port;
display_functions[T_MACRO] = macro_to_port;
display_functions[T_MACRO_STAR] = macro_to_port;
display_functions[T_BACRO] = macro_to_port;
display_functions[T_BACRO_STAR] = macro_to_port;
display_functions[T_C_OPT_ARGS_FUNCTION] = c_function_to_port;
display_functions[T_C_RST_ARGS_FUNCTION] = c_function_to_port;
display_functions[T_C_ANY_ARGS_FUNCTION] = c_function_to_port;
display_functions[T_C_FUNCTION] = c_function_to_port;
display_functions[T_C_FUNCTION_STAR] = c_function_to_port;
display_functions[T_C_MACRO] = c_macro_to_port;
display_functions[T_C_POINTER] = c_pointer_to_port;
display_functions[T_RANDOM_STATE] = rng_to_port;
display_functions[T_CONTINUATION] = continuation_to_port;
display_functions[T_GOTO] = goto_to_port;
display_functions[T_CATCH] = catch_to_port;
display_functions[T_DYNAMIC_WIND] = dynamic_wind_to_port;
display_functions[T_C_OBJECT] = c_object_to_port;
display_functions[T_SLOT] = slot_to_port;
}
static void object_to_port_with_circle_check_1(s7_scheme * sc,
s7_pointer vr,
s7_pointer port,
use_write_t use_write,
shared_info_t * ci)
{
int32_t ref;
ref = (is_collected(vr)) ? shared_ref(ci, vr) : 0;
if (ref == 0)
object_to_port(sc, vr, port, use_write, ci);
else {
char buf[32];
int32_t nlen;
char *p;
s7_int len;
if (ref > 0) {
if (use_write == P_READABLE) {
if (ci->defined[ref]) {
flip_ref(ci, vr);
nlen =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc, ref), ">",
(const char *) NULL);
port_write_string(port) (sc, buf, nlen, port);
return;
}
object_to_port(sc, vr, port, P_READABLE, ci);
} else {
/* "normal" printout involving #n= and #n# */
p = pos_int_to_str(sc, (s7_int) ref, &len, '=');
*--p = '#';
port_write_string(port) (sc, p, len, port);
object_to_port(sc, vr, port, NOT_P_DISPLAY(use_write), ci);
}
} else if (use_write == P_READABLE) {
nlen =
catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref),
">", (const char *) NULL);
port_write_string(port) (sc, buf, nlen, port);
} else {
p = pos_int_to_str(sc, (s7_int) (-ref), &len, '#');
*--p = '#';
port_write_string(port) (sc, p, len, port);
}
}
}
static s7_pointer cyclic_out(s7_scheme * sc, s7_pointer obj,
s7_pointer port, shared_info_t * ci)
{
int32_t i, ref, len;
char buf[128];
ci->cycle_port = s7_open_output_string(sc);
ci->cycle_loc = gc_protect_1(sc, ci->cycle_port);
port_write_string(port) (sc, "(let (", 6, port);
for (i = 0; i < ci->top; i++) {
ref = peek_shared_ref(ci, ci->objs[i]); /* refs may be in any order */
if (ref < 0) {
ref = -ref;
flip_ref(ci, ci->objs[i]);
}
len =
catstrs_direct(buf, (i == 0) ? "(<" : "\n (<",
pos_int_to_str_direct(sc, ref), "> ",
(const char *) NULL);
port_write_string(port) (sc, buf, len, port);
ci->defined[ref] = false;
object_to_port_with_circle_check(sc, ci->objs[i], port, P_READABLE,
ci);
port_write_character(port) (sc, ')', port);
ci->defined[ref] = true;
if (peek_shared_ref(ci, ci->objs[i]) > 0)
flip_ref(ci, ci->objs[i]); /* ref < 0 -> use <%d> in object_to_port */
}
port_write_string(port) (sc, ")\n", 2, port);
if (ci->init_port != sc->F) {
port_write_string(port) (sc,
(const char *) (port_data(ci->init_port)),
port_position(ci->init_port), port);
s7_close_output_port(sc, ci->init_port);
s7_gc_unprotect_at(sc, ci->init_loc);
ci->init_port = sc->F;
}
if (port_position(ci->cycle_port) > 0) /* 0 if e.g. (object->string (object->let (rootlet)) :readable) */
port_write_string(port) (sc,
(const char
*) (port_data(ci->cycle_port)),
port_position(ci->cycle_port), port);
s7_close_output_port(sc, ci->cycle_port);
s7_gc_unprotect_at(sc, ci->cycle_loc);
ci->cycle_port = sc->F;
if ((is_immutable(obj)) && (!is_let(obj)))
port_write_string(port) (sc, " (immutable! ", 14, port);
else
port_write_string(port) (sc, " ", 2, port);
ref = peek_shared_ref(ci, obj);
if (ref == 0)
object_to_port_with_circle_check(sc, obj, port, P_READABLE, ci);
else {
len =
catstrs_direct(buf, "<",
pos_int_to_str_direct(sc,
(ref < 0) ? -ref : ref),
">", (const char *) NULL);
port_write_string(port) (sc, buf, len, port);
}
if ((is_immutable(obj)) && (!is_let(obj)))
port_write_string(port) (sc, "))\n", 3, port);
else
port_write_string(port) (sc, ")\n", 2, port);
return (obj);
}
static void object_out_1(s7_scheme * sc, s7_pointer obj,
s7_pointer strport, use_write_t choice)
{
if (sc->object_out_locked)
object_to_port_with_circle_check(sc, T_Any(obj), strport, choice,
sc->circle_info);
else {
shared_info_t *ci;
ci = make_shared_info(sc, T_Any(obj), choice != P_READABLE);
if (ci) {
sc->object_out_locked = true;
if (choice == P_READABLE)
cyclic_out(sc, obj, strport, ci);
else
object_to_port_with_circle_check(sc, obj, strport, choice,
ci);
sc->object_out_locked = false;
} else
object_to_port(sc, obj, strport, choice, NULL);
}
}
static inline s7_pointer object_out(s7_scheme * sc, s7_pointer obj,
s7_pointer strport, use_write_t choice)
{
if ((has_structure(obj)) && (obj != sc->rootlet))
object_out_1(sc, obj, strport, choice);
else
object_to_port(sc, obj, strport, choice, NULL);
return (obj);
}
static s7_pointer new_format_port(s7_scheme * sc)
{
s7_pointer x;
s7_int len = FORMAT_PORT_LENGTH;
block_t *block, *b;
x = alloc_pointer(sc);
set_full_type(x, T_OUTPUT_PORT);
b = mallocate_port(sc);
port_block(x) = b;
port_port(x) = (port_t *) block_data(b);
port_type(x) = STRING_PORT;
port_set_closed(x, false);
port_data_size(x) = len;
port_next(x) = NULL;
block = mallocate(sc, len);
port_data(x) = (uint8_t *) (block_data(block));
port_data_block(x) = block;
port_data(x)[0] = '\0';
port_position(x) = 0;
port_needs_free(x) = false;
port_port(x)->pf = &output_string_functions;
return (x);
}
static inline s7_pointer open_format_port(s7_scheme * sc)
{
s7_pointer x;
if (!sc->format_ports)
return (new_format_port(sc));
x = sc->format_ports;
sc->format_ports = (s7_pointer) (port_next(x));
port_position(x) = 0;
port_data(x)[0] = '\0';
return (x);
}
static void close_format_port(s7_scheme * sc, s7_pointer port)
{
port_next(port) = (struct block_t *) (sc->format_ports);
sc->format_ports = port;
}
char *s7_object_to_c_string(s7_scheme * sc, s7_pointer obj)
{
char *str;
s7_pointer strport;
s7_int len;
TRACK(sc);
if ((sc->safety > NO_SAFETY) && (!s7_is_valid(sc, obj)))
s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj);
strport = open_format_port(sc);
object_out(sc, T_Pos(obj), strport, P_WRITE);
len = port_position(strport);
if (len == 0) {
close_format_port(sc, strport);
return (NULL);
} /* probably never happens */
str = (char *) Malloc(len + 1);
memcpy((void *) str, (void *) port_data(strport), len);
str[len] = '\0';
close_format_port(sc, strport);
return (str);
}
static inline void restore_format_port(s7_scheme * sc, s7_pointer strport)
{
block_t *block;
block = mallocate(sc, FORMAT_PORT_LENGTH);
port_data(strport) = (uint8_t *) (block_data(block));
port_data_block(strport) = block;
port_data(strport)[0] = '\0';
port_position(strport) = 0;
port_data_size(strport) = FORMAT_PORT_LENGTH;
port_needs_free(strport) = false;
close_format_port(sc, strport);
}
/* -------------------------------- object->string -------------------------------- */
s7_pointer s7_object_to_string(s7_scheme * sc, s7_pointer obj,
bool use_write)
{ /* unavoidable backwards compatibility rigidity here */
s7_pointer strport, res;
if ((sc->safety > NO_SAFETY) && (!s7_is_valid(sc, obj)))
s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj);
strport = open_format_port(sc);
object_out(sc, obj, strport, (use_write) ? P_WRITE : P_DISPLAY);
if (port_position(strport) >= port_data_size(strport))
res =
block_to_string(sc,
reallocate(sc, port_data_block(strport),
port_position(strport) + 1),
port_position(strport));
else
res =
block_to_string(sc, port_data_block(strport),
port_position(strport));
restore_format_port(sc, strport);
return (res);
}
static s7_pointer g_object_to_string(s7_scheme * sc, s7_pointer args)
{
#define H_object_to_string "(object->string obj (write #t) (max-len most-positive-fixnum)) returns a string representation of obj."
#define Q_object_to_string s7_make_signature(sc, 4, sc->is_string_symbol, sc->T, s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_keyword_symbol), sc->is_integer_symbol)
use_write_t choice;
s7_pointer obj = car(args), strport, res;
s7_int out_len, pending_max = S7_INT64_MAX;
bool old_openlets;
old_openlets = sc->has_openlets;
if (is_not_null(cdr(args))) {
s7_pointer arg;
arg = cadr(args);
if (arg == sc->F)
choice = P_DISPLAY;
else {
if (arg == sc->T)
choice = P_WRITE;
else {
if (arg == sc->key_readable_symbol)
choice = P_READABLE;
else {
if (arg == sc->key_display_symbol)
choice = P_DISPLAY;
else {
if (arg == sc->key_write_symbol)
choice = P_WRITE;
else
return (wrong_type_argument_with_type
(sc, sc->object_to_string_symbol, 2,
arg, wrap_string(sc,
"a boolean or :readable",
22)));
}
}
}
}
if (is_not_null(cddr(args))) {
arg = caddr(args);
if (!s7_is_integer(arg)) {
if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable "hi") */
return (wrong_type_argument
(sc, sc->object_to_string_symbol, 3, arg,
T_INTEGER));
return (method_or_bust
(sc, arg, sc->object_to_string_symbol, args,
T_INTEGER, 3));
}
if (s7_integer_checked(sc, arg) < 0)
return (out_of_range
(sc, sc->object_to_string_symbol, int_three, arg,
a_non_negative_integer_string));
pending_max = s7_integer_checked(sc, arg);
}
} else
choice = P_WRITE;
/* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */
if (choice == P_READABLE)
sc->has_openlets = false;
else
check_method(sc, obj, sc->object_to_string_symbol, args);
strport = open_format_port(sc);
sc->objstr_max_len = pending_max;
object_out(sc, obj, strport, choice);
sc->objstr_max_len = S7_INT64_MAX;
out_len = port_position(strport);
if ((pending_max >= 0) && (out_len > pending_max)) {
s7_int i;
if (choice == P_READABLE) { /* (object->string #r(1 2 3) :readable 4) */
close_format_port(sc, strport);
sc->has_openlets = old_openlets;
return (out_of_range
(sc, sc->object_to_string_symbol, int_three,
wrap_integer1(sc, out_len), wrap_string(sc,
"the readable string is too long",
31)));
}
out_len = pending_max;
if (out_len < 3) {
close_format_port(sc, strport);
sc->has_openlets = old_openlets;
return (make_string_with_length(sc, "...", 3));
}
for (i = out_len - 3; i < out_len; i++)
port_data(strport)[i] = (uint8_t) '.';
}
if (out_len >= port_data_size(strport)) /* this can happen (but only == I think) */
res =
block_to_string(sc,
reallocate(sc, port_data_block(strport),
out_len + 1), out_len);
else
res = block_to_string(sc, port_data_block(strport), out_len);
restore_format_port(sc, strport);
sc->has_openlets = old_openlets;
return (res);
}
/* -------------------------------- newline -------------------------------- */
void s7_newline(s7_scheme * sc, s7_pointer port)
{
if (port != sc->F)
port_write_character(port) (sc, (uint8_t) '\n', port);
}
#define newline_char chars[(uint8_t)'\n']
static s7_pointer g_newline(s7_scheme * sc, s7_pointer args)
{
#define H_newline "(newline (port (current-output-port))) writes a carriage return to the port"
#define Q_newline s7_make_signature(sc, 2, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
s7_pointer port;
port = (is_not_null(args)) ? car(args) : current_output_port(sc);
if (port == sc->F)
return (newline_char);
if (!is_output_port(port))
return (method_or_bust_with_type_one_arg
(sc, port, sc->newline_symbol, args,
an_output_port_string));
if (port_is_closed(port))
s7_wrong_type_arg_error(sc, "newline", 1, port,
"an open output port");
s7_newline(sc, port);
return (newline_char); /* return(sc->unspecified) until 28-Sep-17, but for example (display c) returns c */
}
static s7_pointer newline_p(s7_scheme * sc)
{
s7_newline(sc, current_output_port(sc));
return (newline_char);
}
static s7_pointer newline_p_p(s7_scheme * sc, s7_pointer port)
{
if (!is_output_port(port)) {
if (port == sc->F)
return (newline_char);
return (method_or_bust_with_type_one_arg_p
(sc, port, sc->newline_symbol, an_output_port_string));
}
s7_newline(sc, port);
return (newline_char);
}
/* -------------------------------- write -------------------------------- */
s7_pointer s7_write(s7_scheme * sc, s7_pointer obj, s7_pointer port)
{
if (port != sc->F) {
if (port_is_closed(port))
s7_wrong_type_arg_error(sc, "write", 2, port,
"an open output port");
object_out(sc, obj, port, P_WRITE);
}
return (obj);
}
static s7_pointer write_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer port)
{
if (port == sc->F)
return (x);
if (!is_output_port(port))
return (method_or_bust_with_type_pp
(sc, port, sc->write_symbol, x, port,
an_output_port_string, 2));
if (port_is_closed(port))
s7_wrong_type_arg_error(sc, "write", 2, port,
"an open output port");
return (object_out(sc, x, port, P_WRITE));
}
static s7_pointer g_write(s7_scheme * sc, s7_pointer args)
{
#define H_write "(write obj (port (current-output-port))) writes (object->string obj) to the output port"
#define Q_write s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
check_method(sc, car(args), sc->write_symbol, args);
return (write_p_pp
(sc, car(args),
(is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
}
static s7_pointer write_p_p(s7_scheme * sc, s7_pointer x)
{
return ((current_output_port(sc) == sc->F) ? x : object_out(sc, x,
current_output_port
(sc),
P_WRITE));
}
/* -------------------------------- display -------------------------------- */
s7_pointer 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, P_DISPLAY);
}
return (obj);
}
static s7_pointer display_p_pp(s7_scheme * sc, s7_pointer x,
s7_pointer port)
{
if (port == sc->F)
return (x);
if (!is_output_port(port))
return (method_or_bust_with_type_pp
(sc, port, sc->display_symbol, x, port,
an_output_port_string, 2));
if (port_is_closed(port))
s7_wrong_type_arg_error(sc, "display", 2, port,
"an open output port");
check_method(sc, x, sc->display_symbol, set_plist_2(sc, x, port));
return (object_out(sc, x, port, P_DISPLAY));
}
static s7_pointer g_display(s7_scheme * sc, s7_pointer args)
{
#define H_display "(display obj (port (current-output-port))) prints obj"
#define Q_display s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
return (display_p_pp
(sc, car(args),
(is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
}
static s7_pointer g_display_2(s7_scheme * sc, s7_pointer args)
{
/* calling display_p_pp here is much slower */
s7_pointer port = cadr(args);
if (port == sc->F)
return (car(args));
if (!is_output_port(port))
return (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"));
check_method(sc, car(args), sc->display_symbol, args);
return (object_out(sc, car(args), port, P_DISPLAY));
}
static s7_pointer g_display_f(s7_scheme * sc, s7_pointer args)
{
return (car(args));
}
static s7_pointer display_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 2) /* not check_for_substring_temp(sc, expr) here -- display returns arg so can be immutable if substring_uncopied */
return ((caddr(expr) == sc->F) ? sc->display_f : sc->display_2);
return (f);
}
static s7_pointer display_p_p(s7_scheme * sc, s7_pointer x)
{
if (current_output_port(sc) == sc->F)
return (x);
check_method(sc, x, sc->display_symbol, set_plist_1(sc, x));
return (object_out(sc, x, current_output_port(sc), P_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, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
s7_pointer port, proc = car(args);
if (is_let(proc))
check_method(sc, proc, sc->call_with_output_string_symbol, args);
if ((!is_any_procedure(proc)) || /* this disallows goto/continuation */
(!s7_is_aritable(sc, proc, 1)))
return (method_or_bust_with_type
(sc, proc, sc->call_with_output_string_symbol, args,
wrap_string(sc, "a procedure of one argument (the port)",
38), 1));
port = s7_open_output_string(sc);
push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* #<unused> here is a marker (needed) */
push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); /* args checked in call_with_exit */
push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc);
return (sc->F);
}
/* -------------------------------- call-with-output-file -------------------------------- */
static s7_pointer g_call_with_output_file(s7_scheme * sc, s7_pointer args)
{
#define H_call_with_output_file "(call-with-output-file filename proc) opens filename and calls proc with the output port as its argument"
#define Q_call_with_output_file sc->pl_sf
s7_pointer port, file = car(args), proc;
if (!is_string(file))
return (method_or_bust
(sc, file, sc->call_with_output_file_symbol, args,
T_STRING, 1));
proc = cadr(args);
if ((!is_any_procedure(proc)) || (!s7_is_aritable(sc, proc, 1)))
return (method_or_bust_with_type
(sc, proc, sc->call_with_output_file_symbol, args,
wrap_string(sc, "a procedure of one argument (the port)",
38), 2));
port = s7_open_output_file(sc, string_value(file), "w");
push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* #<unused> here is a marker (needed) */
push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc);
return (sc->F);
}
/* -------------------------------- with-output-to-string -------------------------------- */
static s7_pointer g_with_output_to_string(s7_scheme * sc, s7_pointer args)
{
#define H_with_output_to_string "(with-output-to-string thunk) opens a string as a temporary current-output-port, calls thunk, then returns the collected output"
#define Q_with_output_to_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
s7_pointer old_output_port, p = car(args);
if (!is_thunk(sc, p))
return (method_or_bust_with_type
(sc, p, sc->with_output_to_string_symbol, args,
a_thunk_string, 1));
if ((is_continuation(p)) || (is_goto(p)))
return (wrong_type_argument_with_type
(sc, sc->with_output_to_string_symbol, 1, p,
a_normal_procedure_string));
old_output_port = current_output_port(sc);
set_current_output_port(sc, s7_open_output_string(sc));
push_stack(sc, OP_UNWIND_OUTPUT, old_output_port,
current_output_port(sc));
push_stack(sc, OP_GET_OUTPUT_STRING, old_output_port,
current_output_port(sc));
push_stack(sc, OP_APPLY, sc->nil, p);
return (sc->F);
}
/* (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 sc->pl_sf
s7_pointer old_output_port, file = car(args), proc;
if (!is_string(file))
return (method_or_bust
(sc, file, sc->with_output_to_file_symbol, args, T_STRING,
1));
proc = cadr(args);
if (!is_thunk(sc, proc))
return (method_or_bust_with_type
(sc, proc, sc->with_output_to_file_symbol, args,
a_thunk_string, 2));
if ((is_continuation(proc)) || (is_goto(proc)))
return (wrong_type_argument_with_type
(sc, sc->with_output_to_file_symbol, 1, proc,
a_normal_procedure_string));
old_output_port = current_output_port(sc);
set_current_output_port(sc,
s7_open_output_file(sc, string_value(file),
"w"));
push_stack(sc, OP_UNWIND_OUTPUT, old_output_port,
current_output_port(sc));
push_stack(sc, OP_APPLY, sc->nil, proc);
return (sc->F);
}
/* -------------------------------- format -------------------------------- */
static s7_pointer format_error_1(s7_scheme * sc, s7_pointer msg,
const char *str, s7_pointer args,
format_data_t * fdat)
{
s7_pointer x = NULL, ctrl_str;
ctrl_str =
(fdat->orig_str) ? fdat->orig_str : s7_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,
wrap_integer1(sc, fdat->loc + 20), msg);
else
x = set_elist_4(sc, format_string_4, ctrl_str,
wrap_integer1(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, Len, Str, Args, Fdat) return(format_error_1(Sc, wrap_string(Sc, Msg, Len), Str, Args, Fdat))
#define just_format_error(Sc, Msg, Len, Str, Args, Fdat) format_error_1(Sc, wrap_string(Sc, Msg, Len), Str, Args, Fdat)
static void format_append_char(s7_scheme * sc, 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"
* if -O3 compiler flag, we hit a segfault here during s7test
*/
}
static void format_append_newline(s7_scheme * sc, s7_pointer port)
{
port_write_character(port) (sc, '\n', port);
sc->format_column = 0;
}
static void format_append_string(s7_scheme * sc, format_data_t * fdat,
const char *str, s7_int len,
s7_pointer port)
{
port_write_string(port) (sc, str, len, port);
fdat->loc += len;
sc->format_column += len;
}
static void format_append_chars(s7_scheme * sc, format_data_t * fdat,
char pad, s7_int chars, s7_pointer port)
{
if (is_string_port(port)) {
if ((port_position(port) + chars) < port_data_size(port)) {
local_memset((char *) port_data(port) + port_position(port),
pad, chars);
port_position(port) += chars;
} else {
s7_int new_len = port_position(port) + chars;
resize_port_data(sc, port, new_len * 2);
local_memset((char *) port_data(port) + port_position(port),
pad, chars);
port_position(port) = new_len;
}
fdat->loc += chars;
sc->format_column += chars;
} else {
block_t *b;
char *str;
b = mallocate(sc, chars + 1);
str = (char *) block_data(b);
local_memset((void *) str, pad, chars);
str[chars] = '\0';
format_append_string(sc, fdat, str, chars, port);
liberate(sc, b);
}
}
static s7_int format_read_integer(s7_int * cur_i, s7_int str_len,
const char *str)
{
/* we know that str[*cur_i] is a digit */
s7_int i, lval = 0;
for (i = *cur_i; i < str_len - 1; i++) {
int32_t dig;
dig = digits[(uint8_t) str[i]];
if (dig < 10) {
#if HAVE_OVERFLOW_CHECKS
if ((multiply_overflow(lval, 10, &lval)) ||
(add_overflow(lval, dig, &lval)))
break;
#else
lval = dig + (lval * 10);
#endif
} else
break;
}
*cur_i = i;
return (lval);
}
static void format_number(s7_scheme * sc, format_data_t * fdat,
int32_t radix, s7_int width, s7_int precision,
char float_choice, char pad, s7_pointer port)
{
char *tmp;
block_t *b = NULL;
s7_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" */
if (pad != ' ') {
char *padtmp;
#if (!WITH_GMP)
if (radix == 10)
tmp =
number_to_string_base_10(sc, car(fdat->args), width,
precision, float_choice, &nlen,
P_WRITE);
else
#endif
{
b = number_to_string_with_radix(sc, car(fdat->args), radix,
width, precision, float_choice,
&nlen);
tmp = (char *) block_data(b);
}
padtmp = tmp;
while (*padtmp == ' ')
(*(padtmp++)) = pad;
format_append_string(sc, fdat, tmp, nlen, port);
if ((WITH_GMP) || (radix != 10))
liberate(sc, b);
} else {
#if (!WITH_GMP)
if (radix == 10)
tmp =
number_to_string_base_10(sc, car(fdat->args), width,
precision, float_choice, &nlen,
P_WRITE);
else
#endif
{
b = number_to_string_with_radix(sc, car(fdat->args), radix,
width, precision, float_choice,
&nlen);
tmp = (char *) block_data(b);
}
format_append_string(sc, fdat, tmp, nlen, port);
if ((WITH_GMP) || (radix != 10))
liberate(sc, b);
}
fdat->args = cdr(fdat->args);
fdat->ctr++;
}
static s7_int format_nesting(const char *str, char opener, char closer,
s7_int start, s7_int end)
{ /* start=i, end=str_len-1 */
s7_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_t * fdat, s7_pointer port)
{
s7_pointer func, obj = car(fdat->args);
char ctrl_str[3];
if ((!has_active_methods(sc, obj)) ||
((func =
find_method_with_let(sc, obj,
sc->format_symbol)) == sc->undefined))
return (false);
ctrl_str[0] = '~';
ctrl_str[1] = str[0];
ctrl_str[2] = '\0';
if (port == obj) /* a problem! we need the openlet port for format, but that's an infinite loop when it calls format again as obj */
call_method(sc, obj, func,
set_plist_3(sc, port,
s7_make_string_wrapper(sc, ctrl_str),
s7_make_string_wrapper(sc,
"#<format port>")));
else
call_method(sc, obj, func,
set_plist_3(sc, port,
s7_make_string_wrapper(sc, ctrl_str),
obj));
fdat->args = cdr(fdat->args);
fdat->ctr++;
return (true);
}
static s7_int format_n_arg(s7_scheme * sc, const char *str,
format_data_t * fdat, s7_pointer args)
{
s7_int n;
if (is_null(fdat->args)) /* (format #f "~nT") */
just_format_error(sc, "~~N: missing argument", 21, str, args,
fdat);
if (!s7_is_integer(car(fdat->args)))
just_format_error(sc, "~~N: integer argument required", 30, str,
args, fdat);
n = s7_integer_checked(sc, car(fdat->args));
if (n < 0)
just_format_error(sc, "~~N value is negative?", 22, str, args,
fdat);
else if (n > sc->max_format_length)
just_format_error(sc, "~~N value is too big", 20, 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 s7_int format_numeric_arg(s7_scheme * sc, const char *str,
s7_int str_len, format_data_t * fdat,
s7_int * i)
{
s7_int width, old_i;
old_i = *i;
width = format_read_integer(i, str_len, str);
if (width < 0) {
if (str[old_i - 1] != ',') /* need branches here, not if-expr because just_format_error creates the permanent string */
just_format_error(sc, "width is negative?", 18, str,
fdat->args, fdat);
else
just_format_error(sc, "precision is negative?", 22, str,
fdat->args, fdat);
} else if (width > sc->max_format_length) {
if (str[old_i - 1] != ',')
just_format_error(sc, "width is too big", 16, str, fdat->args,
fdat);
else
just_format_error(sc, "precision is too big", 20, str,
fdat->args, fdat);
}
return (width);
}
static format_data_t *open_format_data(s7_scheme * sc)
{
format_data_t *fdat;
sc->format_depth++;
if (sc->format_depth >= sc->num_fdats) {
int32_t k, new_num_fdats = sc->format_depth * 2;
sc->fdats =
(format_data_t **) Realloc(sc->fdats,
sizeof(format_data_t *) *
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_t *) Malloc(sizeof(format_data_t));
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->curly_arg = sc->nil;
return (fdat);
}
#if WITH_GMP
static bool is_one_or_big_one(s7_scheme * sc, s7_pointer p)
{
if (!is_big_number(p))
return (is_one(p));
if (is_t_big_integer(p))
return (mpz_cmp_ui(big_integer(p), 1) == 0);
if (is_t_big_real(p))
return (mpfr_cmp_d(big_real(p), 1.0) == 0);
return (false);
}
#else
#define is_one_or_big_one(Sc, Num) is_one(Num)
#endif
static s7_pointer object_to_list(s7_scheme * sc, s7_pointer obj);
static s7_pointer format_to_port_1(s7_scheme * sc, s7_pointer port,
const char *str, s7_pointer args,
s7_pointer * next_arg, bool with_result,
bool columnized, s7_int len,
s7_pointer orig_str)
{
s7_int i, str_len;
format_data_t *fdat;
s7_pointer deferred_port;
if (len <= 0) {
str_len = safe_strlen(str);
if (str_len == 0) {
if (is_not_null(args))
return (s7_error(sc, sc->format_error_symbol,
set_elist_2(sc,
wrap_string(sc,
"format control string is null, but there are arguments: ~S",
58), args)));
return ((with_result) ? nil_string : sc->F);
}
} else
str_len = len;
fdat = open_format_data(sc);
fdat->args = args;
fdat->orig_str = orig_str;
if (with_result) {
deferred_port = port;
port = open_format_port(sc);
fdat->port = port;
} else
deferred_port = sc->F;
for (i = 0; i < str_len - 1; i++) {
if ((uint8_t) (str[i]) == (uint8_t) '~') {
use_write_t use_write;
switch (str[i + 1]) {
case '%': /* -------- newline -------- */
/* sbcl apparently accepts numeric args here (including 0) */
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, port);
i++;
break;
case '&': /* -------- conditional newline -------- */
/* this only works if all output goes through format -- display/write for example do not update format_column */
if (sc->format_column > 0)
format_append_newline(sc, port);
i++;
break;
case '~': /* -------- tilde -------- */
format_append_char(sc, '~', port);
i++;
break;
case '\n': /* -------- trim white-space -------- so (format #f "hiho~\n") -> "hiho"! */
for (i = i + 2; i < str_len - 1; i++)
if (!(white_space[(uint8_t) (str[i])])) {
i--;
break;
}
break;
case '*': /* -------- ignore arg -------- */
i++;
if (is_null(fdat->args)) /* (format #f "~*~A") */
format_error(sc, "can't skip argument!", 20, str, args,
fdat);
fdat->args = cdr(fdat->args);
break;
case '|': /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */
if ((is_pair(fdat->args)) &&
(fdat->ctr >= sc->print_length)) {
format_append_string(sc, fdat, " ...", 4, port);
fdat->args = sc->nil;
}
/* fall through */
case '^': /* -------- exit -------- */
if (is_null(fdat->args)) {
i = str_len;
goto ALL_DONE;
}
i++;
break;
case '@': /* -------- plural, 'y' or 'ies' -------- */
i += 2;
if ((str[i] != 'P') && (str[i] != 'p'))
format_error(sc, "unknown '@' directive", 21, str,
args, fdat);
if (!is_pair(fdat->args))
format_error(sc, "'@' directive argument missing", 30,
str, args, fdat);
if (!is_real(car(fdat->args))) /* CL accepts non numbers here */
format_error(sc,
"'@P' directive argument is not a real number",
44, str, args, fdat);
if (!is_one_or_big_one(sc, car(fdat->args)))
format_append_string(sc, fdat, "ies", 3, port);
else
format_append_char(sc, 'y', port);
fdat->args = cdr(fdat->args);
break;
case 'P':
case 'p': /* -------- plural in 's' -------- */
if (!is_pair(fdat->args))
format_error(sc, "'P' directive argument missing", 30,
str, args, fdat);
if (!is_real(car(fdat->args)))
format_error(sc,
"'P' directive argument is not a real number",
43, str, args, fdat);
if (!is_one_or_big_one(sc, car(fdat->args)))
format_append_char(sc, 's', port);
i++;
fdat->args = cdr(fdat->args);
break;
case '{': /* -------- iteration -------- */
{
s7_int curly_len;
if (is_null(fdat->args))
format_error(sc, "missing argument", 16, str, args,
fdat);
if ((is_pair(car(fdat->args))) && /* any sequence is possible here */
(s7_list_length(sc, car(fdat->args)) < 0)) /* (format #f "~{~a~e~}" (cons 1 2)) */
format_error(sc, "~{ argument is a dotted list",
28, str, args, fdat);
curly_len =
format_nesting(str, '{', '}', i, str_len - 1);
if (curly_len == -1)
format_error(sc,
"'{' directive, but no matching '}'",
34, str, args, fdat);
if (curly_len == 1)
format_error(sc,
"~{~}' doesn't consume any arguments!",
36, 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;
/* perhaps use an iterator here -- rootlet->list is expensive! */
curly_arg = object_to_list(sc, car(fdat->args)); /* if a pair (or non-sequence), this simply returns the original */
if (is_pair(curly_arg)) { /* (format #f "~{~A ~}" #()) -> "" */
char *curly_str = NULL; /* this is the local (nested) format control string */
s7_pointer orig_arg, cycle_arg;
fdat->curly_arg = curly_arg;
orig_arg =
(curly_arg !=
car(fdat->args)) ? curly_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);
}
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.
*/
cycle_arg = curly_arg;
while (is_pair(curly_arg)) {
s7_pointer new_arg = sc->nil;
format_to_port_1(sc, port, curly_str,
curly_arg, &new_arg,
false, columnized,
curly_len - 1, NULL);
if (curly_arg == new_arg) {
if (cdr(curly_arg) == curly_arg)
break;
fdat->curly_arg = sc->nil;
format_error(sc,
"'{...}' doesn't consume any arguments!",
38, str, args, fdat);
}
curly_arg = new_arg;
if ((!is_pair(curly_arg))
|| (curly_arg == cycle_arg))
break;
cycle_arg = cdr(cycle_arg);
format_to_port_1(sc, port, curly_str,
curly_arg, &new_arg,
false, columnized,
curly_len - 1, NULL);
curly_arg = new_arg;
}
fdat->curly_arg = sc->nil;
while (is_pair(orig_arg)) { /* free_cell below clears the type, so a circular list here is ok */
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 */
}
} else if (!is_null(curly_arg))
format_error(sc,
"'{' directive argument should be a list or something we can turn into a list",
76, str, args, fdat);
}
i += (curly_len + 2); /* jump past the ending '}' too */
fdat->args = cdr(fdat->args);
fdat->ctr++;
}
break;
case '}':
format_error(sc, "unmatched '}'", 13, str, args, fdat);
case 'W':
case 'w':
use_write = P_READABLE;
goto OBJSTR;
case 'S':
case 's':
use_write = P_WRITE;
goto OBJSTR;
case 'A':
case 'a':
use_write = P_DISPLAY;
OBJSTR: /* object->string */
{
s7_pointer obj, strport;
if (is_null(fdat->args))
format_error(sc, "missing argument", 16, str, args,
fdat);
i++;
obj = car(fdat->args);
if ((use_write == P_READABLE) ||
(!has_active_methods(sc, obj)) ||
(!format_method
(sc, (char *) (str + i), fdat, port))) {
bool old_openlets = sc->has_openlets;
/* for the column check, we need to know the length of the object->string output */
if (columnized) {
strport = open_format_port(sc);
fdat->strport = strport;
} else
strport = port;
if (use_write == P_READABLE)
sc->has_openlets = false;
object_out(sc, obj, strport, use_write);
if (use_write == P_READABLE)
sc->has_openlets = old_openlets;
if (columnized) {
if (port_position(strport) >=
port_data_size(strport))
resize_port_data(sc, strport,
port_data_size(strport) *
2);
port_data(strport)[port_position(strport)] =
'\0';
if (port_position(strport) > 0)
format_append_string(sc, fdat,
(const char *)
port_data(strport),
port_position
(strport), port);
close_format_port(sc, strport);
fdat->strport = NULL;
}
fdat->args = cdr(fdat->args);
fdat->ctr++;
}
}
break;
/* -------- numeric args -------- */
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
case ',':
case 'N':
case 'n':
case 'B':
case 'b':
case 'D':
case 'd':
case 'E':
case 'e':
case 'F':
case 'f':
case 'G':
case 'g':
case 'O':
case 'o':
case 'X':
case 'x':
case 'T':
case 't':
case 'C':
case 'c':
{
s7_int width = -1, precision = -1;
char pad = ' ';
i++; /* str[i] == '~' */
if (isdigit((int32_t) (str[i])))
width =
format_numeric_arg(sc, str, str_len, fdat, &i);
else if ((str[i] == 'N') || (str[i] == 'n')) {
i++;
width = format_n_arg(sc, str, fdat, args);
}
if (str[i] == ',') {
i++; /* is (format #f "~12,12D" 1) an error? The precision (or is it the width?) has no use here. */
if (isdigit((int32_t) (str[i])))
precision =
format_numeric_arg(sc, str, str_len, fdat,
&i);
else if ((str[i] == 'N') || (str[i] == 'n')) {
i++;
precision = format_n_arg(sc, str, fdat, args);
} else if (str[i] == '\'') { /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */
pad = str[i + 1];
i += 2;
if (i >= str_len) /* (format #f "~,'") */
format_error(sc,
"incomplete numeric argument",
27, str, args, fdat);
}
} /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */
switch (str[i]) {
/* -------- pad to column --------
* are columns numbered from 1 or 0? there seems to be disagreement about this directive
* does "space over to" mean including?
*/
case 'T':
case 't':
if (width == -1)
width = 0;
if (precision == -1)
precision = 0;
if ((width > 0) || (precision > 0)) { /* (format #f "a~8Tb") */
/* (length (substring (format #f "~%~10T.") 1)) == (length (format #f "~10T."))
* (length (substring (format #f "~%-~10T.~%") 1)) == (length (format #f "-~10T.~%"))
*/
if (precision > 0) {
int32_t mult;
mult = (int32_t) (ceil((s7_double) (sc->format_column + 1 - width) / (s7_double) precision)); /* CLtL2 ("least positive int") */
if (mult < 1)
mult = 1;
width += (precision * mult);
}
width -= (sc->format_column + 1);
if (width > 0)
format_append_chars(sc, fdat, pad, width,
port);
}
break;
case 'C':
case 'c':
{
s7_pointer obj;
if (is_null(fdat->args))
format_error(sc, "~~C: missing argument",
21, str, args, fdat);
/* the "~~" here and below protects against "~C" being treated as a directive */
obj = car(fdat->args);
if (!is_character(obj)) {
if (!format_method(sc, (char *) (str + i), fdat, port)) /* i stepped forward above */
format_error(sc,
"'C' directive requires a character argument",
43, str, args, fdat);
} else {
/* here use_write is false, so we just add the char, not its name */
if (width == -1)
format_append_char(sc, character(obj),
port);
else if (width > 0)
format_append_chars(sc, fdat,
character(obj),
width, port);
fdat->args = cdr(fdat->args);
fdat->ctr++;
}
}
break;
/* -------- numbers -------- */
case 'F':
case 'f':
if (is_null(fdat->args))
format_error(sc, "~~F: missing argument", 21,
str, args, fdat);
if (!(is_number(car(fdat->args)))) {
if (!format_method
(sc, (char *) (str + i), fdat, port))
format_error(sc,
"~~F: numeric argument required",
30, str, args, fdat);
} else
format_number(sc, fdat, 10, width, precision,
'f', pad, port);
break;
case 'G':
case 'g':
if (is_null(fdat->args))
format_error(sc, "~~G: missing argument", 21,
str, args, fdat);
if (!(is_number(car(fdat->args)))) {
if (!format_method
(sc, (char *) (str + i), fdat, port))
format_error(sc,
"~~G: numeric argument required",
30, str, args, fdat);
} else
format_number(sc, fdat, 10, width, precision,
'g', pad, port);
break;
case 'E':
case 'e':
if (is_null(fdat->args))
format_error(sc, "~~E: missing argument", 21,
str, args, fdat);
if (!(is_number(car(fdat->args)))) {
if (!format_method
(sc, (char *) (str + i), fdat, port))
format_error(sc,
"~~E: numeric argument required",
30, str, args, fdat);
} else
format_number(sc, fdat, 10, width, precision,
'e', pad, port);
break;
/* how to handle non-integer arguments in the next 4 cases? clisp just returns
* the argument: (format nil "~X" 1.25) -> "1.25" which is perverse (ClTl2 p 581:
* "if arg is not an integer, it is printed in ~A format and decimal base")!!
* I think I'll use the type of the number to choose the output format.
*/
case 'D':
case 'd':
if (is_null(fdat->args))
format_error(sc, "~~D: missing argument", 21,
str, args, fdat);
if (!(is_number(car(fdat->args)))) {
/* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123)))
* port here is a string-port, str has the width/precision data if the caller wants it,
* args is the current arg. But format_number handles fdat->args and so on, so
* I think I'll pass the format method the current control string (str), the
* current object (car(fdat->args)), and the arglist (args), and assume it will
* return a (scheme) string.
*/
if (!format_method
(sc, (char *) (str + i), fdat, port))
format_error(sc,
"~~D: numeric argument required",
30, str, args, fdat);
} else
format_number(sc, fdat, 10, width, precision,
'd', pad, port);
break;
case 'O':
case 'o':
if (is_null(fdat->args))
format_error(sc, "~~O: missing argument", 21,
str, args, fdat);
if (!(is_number(car(fdat->args)))) {
if (!format_method
(sc, (char *) (str + i), fdat, port))
format_error(sc,
"~~O: numeric argument required",
30, str, args, fdat);
} else
format_number(sc, fdat, 8, width, precision,
'o', pad, port);
break;
case 'X':
case 'x':
if (is_null(fdat->args))
format_error(sc, "~~X: missing argument", 21,
str, args, fdat);
if (!(is_number(car(fdat->args)))) {
if (!format_method
(sc, (char *) (str + i), fdat, port))
format_error(sc,
"~~X: numeric argument required",
30, str, args, fdat);
} else
format_number(sc, fdat, 16, width, precision,
'x', pad, port);
break;
case 'B':
case 'b':
if (is_null(fdat->args))
format_error(sc, "~~B: missing argument", 21,
str, args, fdat);
if (!(is_number(car(fdat->args)))) {
if (!format_method
(sc, (char *) (str + i), fdat, port))
format_error(sc,
"~~B: numeric argument required",
30, str, args, fdat);
} else
format_number(sc, fdat, 2, width, precision,
'b', pad, port);
break;
default:
if (width > 0)
format_error(sc, "unused numeric argument", 23,
str, args, fdat);
format_error(sc, "unimplemented format directive",
30, str, args, fdat);
}
}
break;
default:
format_error(sc, "unimplemented format directive", 30, str,
args, fdat);
}
} else { /* str[i] is not #\~ */
s7_int j, new_len;
const char *p;
p = (char *) strchr((const char *) (str + i + 1), (int) '~');
j = (p) ? p - str : str_len;
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", 18, str, args, fdat);
if (i < str_len) {
if (str[i] == '~')
format_error(sc, "control string ends in tilde", 28, str, args,
fdat);
format_append_char(sc, str[i], port);
}
sc->format_depth--;
if (with_result) {
s7_pointer result;
if ((is_output_port(deferred_port)) && (port_position(port) > 0)) {
if (port_position(port) < port_data_size(port))
port_data(port)[port_position(port)] = '\0';
port_write_string(deferred_port) (sc, (const char *)
port_data(port),
port_position(port),
deferred_port);
}
if (port_position(port) < port_data_size(port)) {
block_t *block;
result =
block_to_string(sc, port_data_block(port),
port_position(port));
port_data_size(port) = FORMAT_PORT_LENGTH;
block = mallocate(sc, FORMAT_PORT_LENGTH);
port_data_block(port) = block;
port_data(port) = (uint8_t *) (block_data(block));
port_data(port)[0] = '\0';
port_position(port) = 0;
} else
result =
make_string_with_length(sc, (char *) port_data(port),
port_position(port));
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,
bool with_result, s7_int len)
{
if ((with_result) || (port != sc->F))
return (format_to_port_1
(sc, port, str, args, NULL, with_result,
true /* is_columnizing(str) */ , len, NULL));
/* is_columnizing on every call is much slower than ignoring the issue */
return (sc->F);
}
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, 2, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T)
s7_pointer pt = car(args), str;
sc->format_column = 0;
if (is_null(pt)) {
pt = current_output_port(sc); /* () -> (current-output-port) */
if (pt == sc->F) /* otherwise () -> #f so we get a returned string, which is confusing */
return (pt); /* but this means some error checks are skipped? */
}
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)))))
return (method_or_bust_with_type
(sc, pt, sc->format_symbol, args, an_output_port_string,
1));
str = cadr(args);
if (!is_string(str))
return (method_or_bust
(sc, str, sc->format_symbol, args, T_STRING, 2));
return (format_to_port_1
(sc, (pt == sc->T) ? current_output_port(sc) : pt,
string_value(str), cddr(args), NULL, !is_output_port(pt),
true, string_length(str), str));
}
const char *s7_format(s7_scheme * sc, s7_pointer args)
{
s7_pointer result;
result = g_format(sc, args);
return ((is_string(result)) ? string_value(result) : NULL);
}
static s7_pointer g_format_f(s7_scheme * sc, s7_pointer args)
{
/* port == #f, there are other args */
s7_pointer str = cadr(args);
sc->format_column = 0;
if (!is_string(str))
return (method_or_bust
(sc, str, sc->format_symbol, args, T_STRING, 2));
return (format_to_port_1
(sc, sc->F, string_value(str), cddr(args), NULL, true, true,
string_length(str), str));
}
static s7_pointer g_format_just_control_string(s7_scheme * sc,
s7_pointer args)
{
s7_pointer pt = car(args), str = cadr(args);
if (pt == sc->F)
return (str);
if (is_null(pt)) {
pt = current_output_port(sc);
if (pt == sc->F)
return (sc->F);
}
if (pt == sc->T) {
if ((current_output_port(sc) != sc->F)
&& (string_length(str) != 0))
port_write_string(sc->output_port) (sc, string_value(str),
string_length(str),
current_output_port(sc));
return (str);
}
if ((!is_output_port(pt)) || (port_is_closed(pt)))
return (method_or_bust_with_type
(sc, pt, sc->format_symbol, args, a_format_port_string,
1));
if (string_length(str) == 0)
return ((is_output_port(pt)) ? sc->F : nil_string);
port_write_string(pt) (sc, string_value(str), string_length(str), pt);
return (sc->F);
}
static s7_pointer g_format_as_objstr(s7_scheme * sc, s7_pointer args)
{
s7_pointer func, obj = caddr(args);
if ((!has_active_methods(sc, obj)) ||
((func =
find_method_with_let(sc, obj,
sc->format_symbol)) == sc->undefined))
return (s7_object_to_string(sc, obj, false));
return (call_method
(sc, obj, func, set_plist_3(sc, sc->F, cadr(args), obj)));
}
static s7_pointer g_format_no_column(s7_scheme * sc, s7_pointer args)
{
s7_pointer pt = car(args), str;
if (is_null(pt)) {
pt = current_output_port(sc);
if (pt == sc->F)
return (sc->F);
}
if (!((s7_is_boolean(pt)) || ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */
(!port_is_closed(pt)))))
return (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) ? current_output_port(sc) : 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,
int32_t args, s7_pointer expr, bool ops)
{
if (args > 1) {
s7_pointer port = cadr(expr), str_arg = caddr(expr);
if (is_string(str_arg)) {
if ((ops) && ((args == 2) || (args == 3))) {
s7_int len;
char *orig = string_value(str_arg);
const char *p;
p = strchr((const char *) orig, (int) '~');
if (!p)
return ((args ==
2) ? sc->format_just_control_string : f);
len = string_length(str_arg);
if ((args == 2) &&
(len > 1) &&
(orig[len - 1] == '%') && ((p - orig) == len - 2)) {
orig[len - 2] = '\n';
orig[len - 1] = '\0';
string_length(str_arg) = len - 1;
return (sc->format_just_control_string);
}
if ((args == 3) &&
(len == 2) &&
(port == sc->F) &&
(orig[0] == '~') &&
((orig[1] == 'A') || (orig[1] == 'a')))
return (sc->format_as_objstr);
}
/* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */
if (!is_columnizing(string_value(str_arg)))
return (sc->format_no_column);
}
if (port == sc->F)
return (sc->format_f);
}
return (f);
}
/* -------------------------------- system extras -------------------------------- */
#if WITH_SYSTEM_EXTRAS
#include <fcntl.h>
/* -------------------------------- directory? -------------------------------- */
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 = car(args);
if (!is_string(name))
return (method_or_bust_one_arg
(sc, name, sc->is_directory_symbol, args, T_STRING));
return (s7_make_boolean(sc, is_directory(string_value(name))));
}
static bool is_directory_b_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_string(p))
simple_wrong_type_argument(sc, sc->is_directory_symbol, p,
T_STRING);
return (is_directory(string_value(p)));
}
static bool file_probe(const char *arg)
{
#if (!MS_WINDOWS)
return (access(arg, F_OK) == 0);
#else
int32_t fd;
fd = open(arg, O_RDONLY, 0);
if (fd == -1)
return (false);
close(fd);
return (true);
#endif
}
/* -------------------------------- file-exists? -------------------------------- */
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 = car(args);
if (!is_string(name))
return (method_or_bust_one_arg
(sc, name, sc->file_exists_symbol, args, T_STRING));
return (s7_make_boolean(sc, file_probe(string_value(name))));
}
static bool file_exists_b_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_string(p))
simple_wrong_type_argument(sc, sc->file_exists_symbol, p,
T_STRING);
return (file_probe(string_value(p)));
}
/* -------------------------------- delete-file -------------------------------- */
static s7_pointer g_delete_file(s7_scheme * sc, s7_pointer args)
{
#define H_delete_file "(delete-file filename) deletes the file filename."
#define Q_delete_file s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
s7_pointer name = car(args);
if (!is_string(name))
return (method_or_bust_one_arg
(sc, name, sc->delete_file_symbol, args, T_STRING));
return (make_integer(sc, unlink(string_value(name))));
}
/* -------------------------------- getenv -------------------------------- */
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 sc->pcl_s
s7_pointer name = car(args);
if (!is_string(name))
return (method_or_bust_one_arg
(sc, name, sc->getenv_symbol, args, T_STRING));
return (s7_make_string(sc, getenv(string_value(name))));
}
/* -------------------------------- system -------------------------------- */
static s7_pointer g_system(s7_scheme * sc, s7_pointer args)
{
#define H_system "(system command) executes the command. If the optional second argument is #t, \
system captures the output as a string and returns it."
#define Q_system s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_boolean_symbol)
#ifdef __EMSCRIPTEN__
return s7_nil(sc);
#else
s7_pointer name = car(args);
if (!is_string(name))
return (method_or_bust_one_arg
(sc, name, sc->system_symbol, args, T_STRING));
if ((is_pair(cdr(args))) && (cadr(args) == sc->T)) {
#define BUF_SIZE 256
char buf[BUF_SIZE];
char *str = NULL;
int32_t cur_len = 0, full_len = 0;
FILE *fd;
fd = popen(string_value(name), "r");
while (fgets(buf, BUF_SIZE, fd)) {
s7_int buf_len;
buf_len = safe_strlen(buf);
if (cur_len + buf_len >= full_len) {
full_len += BUF_SIZE * 2;
str = (str) ? (char *) Realloc(str, full_len) : (char *)
Malloc(full_len);
}
memcpy((void *) (str + cur_len), (void *) buf, buf_len);
cur_len += buf_len;
}
pclose(fd);
if (str) {
block_t *b;
b = mallocate_block(sc);
block_data(b) = (void *) str;
block_set_index(b, TOP_BLOCK_LIST);
return (block_to_string(sc, b, cur_len));
}
return (nil_string);
}
return (make_integer(sc, system(string_value(name))));
#endif
}
#if (!MS_WINDOWS)
#include <dirent.h>
/* -------------------------------- directory->list -------------------------------- */
static s7_pointer g_directory_to_list(s7_scheme * sc, s7_pointer args)
{
#define H_directory_to_list "(directory->list directory) returns the contents of the directory as a list of strings (filenames)."
#define Q_directory_to_list s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_string_symbol) /* can return nil */
s7_pointer name = car(args);
DIR *dpos;
s7_pointer result;
if (!is_string(name))
return (method_or_bust_one_arg_p
(sc, name, sc->directory_to_list_symbol, T_STRING));
sc->w = sc->nil;
if ((dpos = opendir(string_value(name)))) {
struct dirent *dirp;
while ((dirp = readdir(dpos)))
sc->w =
cons_unchecked(sc, s7_make_string(sc, dirp->d_name),
sc->w);
closedir(dpos);
}
result = sc->w;
sc->w = sc->nil;
return (result);
}
/* -------------------------------- file-mtime -------------------------------- */
static s7_pointer g_file_mtime(s7_scheme * sc, s7_pointer args)
{
#define H_file_mtime "(file-mtime file): return the write date of file"
#define Q_file_mtime s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
struct stat statbuf;
int32_t err;
s7_pointer name = car(args);
if (!is_string(name))
return (method_or_bust_one_arg
(sc, name, sc->file_mtime_symbol, args, T_STRING));
err = stat(string_value(name), &statbuf);
if (err < 0)
return (file_error
(sc, "file-mtime", strerror(errno), string_value(name)));
return (make_integer(sc, (s7_int) (statbuf.st_mtime)));
}
#endif
#endif /* with_system_extras */
/* -------------------------------- 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 cons_unchecked_with_type(s7_scheme * sc, s7_pointer p,
s7_pointer a, s7_pointer b)
{
/* apparently slightly faster as a function? (used only in copy_tree_with_type) */
s7_pointer x;
new_cell_no_check(sc, x,
full_type(p) & (TYPE_MASK | T_IMMUTABLE |
T_SAFE_PROCEDURE));
set_car(x, a);
set_cdr(x, b);
return (x);
}
static s7_pointer permanent_cons(s7_scheme * sc, s7_pointer a,
s7_pointer b, uint64_t type)
{
s7_pointer x;
x = alloc_pointer(sc);
set_full_type(x, type | T_UNHEAP);
set_car(x, a);
set_cdr(x, b);
return (x);
}
static s7_pointer permanent_list(s7_scheme * sc, s7_int len)
{
s7_int j;
s7_pointer p = sc->nil;
for (j = 0; j < len; j++)
p = permanent_cons(sc, sc->nil, p, T_PAIR | T_IMMUTABLE);
return (p);
}
static void check_sig_entry(s7_scheme * sc, s7_pointer p, s7_int pos,
bool circle)
{
if ((!is_normal_symbol(car(p))) &&
(!s7_is_boolean(car(p))) && (!is_pair(car(p)))) {
s7_warn(sc, 512,
"s7_make_%ssignature got an invalid entry at position %"
ld64 ": (", (circle) ? "circular_" : "", pos);
set_car(p, sc->nil);
}
}
s7_pointer s7_make_signature(s7_scheme * sc, s7_int len, ...)
{
va_list ap;
s7_int i;
s7_pointer p, res;
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, i, false);
}
va_end(ap);
return ((s7_pointer) res);
}
s7_pointer s7_make_circular_signature(s7_scheme * sc, s7_int cycle_point,
s7_int len, ...)
{
va_list ap;
s7_int i;
s7_pointer p, res, back = NULL, end = NULL;
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, i, 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)
s7_warn(sc, 256,
"s7_make_circular_signature got too few entries: %s\n",
s7_object_to_c_string(sc, res));
return ((s7_pointer) res);
}
bool s7_is_pair(s7_pointer p)
{
return (is_pair(p));
}
static s7_pointer is_pair_p_p(s7_scheme * sc, s7_pointer p)
{
return ((is_pair(p)) ? sc->T : sc->F);
}
s7_pointer s7_car(s7_pointer p)
{
return (car(p));
}
s7_pointer s7_cdr(s7_pointer p)
{
return (cdr(p));
}
s7_pointer s7_cadr(s7_pointer p)
{
return (cadr(p));
}
s7_pointer s7_cddr(s7_pointer p)
{
return (cddr(p));
}
s7_pointer s7_cdar(s7_pointer p)
{
return (cdar(p));
}
s7_pointer s7_caar(s7_pointer p)
{
return (caar(p));
}
s7_pointer s7_caadr(s7_pointer p)
{
return (caadr(p));
}
s7_pointer s7_caddr(s7_pointer p)
{
return (caddr(p));
}
s7_pointer s7_cadar(s7_pointer p)
{
return (cadar(p));
}
s7_pointer s7_caaar(s7_pointer p)
{
return (caaar(p));
}
s7_pointer s7_cdadr(s7_pointer p)
{
return (cdadr(p));
}
s7_pointer s7_cdddr(s7_pointer p)
{
return (cdddr(p));
}
s7_pointer s7_cddar(s7_pointer p)
{
return (cddar(p));
}
s7_pointer s7_cdaar(s7_pointer p)
{
return (cdaar(p));
}
s7_pointer s7_caaadr(s7_pointer p)
{
return (caaadr(p));
}
s7_pointer s7_caaddr(s7_pointer p)
{
return (caaddr(p));
}
s7_pointer s7_caadar(s7_pointer p)
{
return (caadar(p));
}
s7_pointer s7_caaaar(s7_pointer p)
{
return (caaaar(p));
}
s7_pointer s7_cadadr(s7_pointer p)
{
return (cadadr(p));
}
s7_pointer s7_cadddr(s7_pointer p)
{
return (cadddr(p));
}
s7_pointer s7_caddar(s7_pointer p)
{
return (caddar(p));
}
s7_pointer s7_cadaar(s7_pointer p)
{
return (cadaar(p));
}
s7_pointer s7_cdaadr(s7_pointer p)
{
return (cdaadr(p));
}
s7_pointer s7_cdaddr(s7_pointer p)
{
return (cdaddr(p));
}
s7_pointer s7_cdadar(s7_pointer p)
{
return (cdadar(p));
}
s7_pointer s7_cdaaar(s7_pointer p)
{
return (cdaaar(p));
}
s7_pointer s7_cddadr(s7_pointer p)
{
return (cddadr(p));
}
s7_pointer s7_cddddr(s7_pointer p)
{
return (cddddr(p));
}
s7_pointer s7_cdddar(s7_pointer p)
{
return (cdddar(p));
}
s7_pointer s7_cddaar(s7_pointer p)
{
return (cddaar(p));
}
s7_pointer s7_set_car(s7_pointer p, s7_pointer q)
{
set_car(p, q);
return (q);
}
s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q)
{
set_cdr(p, q);
return (q);
}
/* -------------------------------------------------------------------------------- */
/* these are used in clm2xen et al under names like Xen_wrap_5_args -- they should go away! */
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 = 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 = 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 = car(args), a2 = cadr(args), a3, a4;
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 = car(args), a2 = cadr(args), a3, a4;
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 = car(args), a2 = cadr(args), a3, a4, a5, a6;
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 = car(args), a2 = cadr(args), a3, a4, a5, a6;
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 = car(args), a2 = cadr(args), a3, a4, a5, a6;
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))
return ((is_pair(cdr(args))) ? f2(car(args), cadr(args)) :
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))
{
s7_pointer a1, a2;
if (!is_pair(args))
return (f3(sc->undefined, sc->undefined, sc->undefined));
a1 = car(args);
args = cdr(args);
if (!is_pair(args))
return (f3(a1, sc->undefined, sc->undefined));
a2 = car(args);
return ((is_pair(cdr(args))) ? f3(a1, a2, cadr(args)) :
f3(a1, a2, sc->undefined));
}
#define apply_n_args(N) \
do {int32_t i; s7_pointer p; for (i = 0, p = args; is_pair(p); p = cdr(p), i++) a[i] = car(p); for (; i < N; i++) a[i] = sc->undefined;} while (0)
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))
{
s7_pointer a[4];
apply_n_args(4);
return (f4(a[0], a[1], a[2], a[3]));
}
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))
{
s7_pointer a[5];
apply_n_args(5);
return (f5(a[0], a[1], a[2], a[3], a[4]));
}
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 a[6];
apply_n_args(6);
return (f6(a[0], a[1], a[2], a[3], a[4], a[5]));
}
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 a[7];
apply_n_args(7);
return (f7(a[0], a[1], a[2], a[3], a[4], a[5], a[6]));
}
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 a[8];
apply_n_args(8);
return (f8(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7]));
}
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 a[9];
apply_n_args(9);
return (f9(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8]));
}
/* ---------------- tree-leaves ---------------- */
static inline s7_int tree_len_1(s7_scheme * sc, s7_pointer p)
{
s7_int sum;
for (sum = 0; is_pair(p); p = cdr(p)) {
s7_pointer cp;
cp = car(p);
if ((!is_pair(cp)) || (car(cp) == sc->quote_symbol))
sum++;
else {
do {
s7_pointer ccp;
ccp = car(cp);
if ((!is_pair(ccp)) || (car(ccp) == sc->quote_symbol))
sum++;
else {
do {
s7_pointer cccp;
cccp = car(ccp);
if ((!is_pair(cccp)) ||
(car(cccp) == sc->quote_symbol))
sum++;
else
sum += tree_len_1(sc, cccp);
ccp = cdr(ccp);
} while (is_pair(ccp));
if (!is_null(ccp))
sum++;
}
cp = cdr(cp);
} while (is_pair(cp));
if (!is_null(cp))
sum++;
}
}
return ((is_null(p)) ? sum : sum + 1);
}
static inline s7_int tree_len(s7_scheme * sc, s7_pointer p)
{
if (is_null(p))
return (0);
if ((!is_pair(p)) || (car(p) == sc->quote_symbol))
return (1);
return (tree_len_1(sc, p));
}
static s7_int tree_leaves_i_7p(s7_scheme * sc, s7_pointer p)
{
if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, p)))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"tree-leaves: tree is cyclic: ~S",
31), p));
return (tree_len(sc, p));
}
static s7_pointer tree_leaves_p_p(s7_scheme * sc, s7_pointer tree)
{
if ((sc->safety > NO_SAFETY) && /* repeat code to avoid extra call overhead */
(tree_is_cyclic(sc, tree)))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"tree-leaves: tree is cyclic: ~S",
31), tree));
return (make_integer(sc, tree_len(sc, tree)));
}
static s7_pointer g_tree_leaves(s7_scheme * sc, s7_pointer args)
{
#define H_tree_leaves "(tree-leaves tree) returns the number of leaves in the tree"
#define Q_tree_leaves s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T)
return (tree_leaves_p_p(sc, car(args)));
}
/* ---------------- tree-memq ---------------- */
static inline bool tree_memq_1(s7_scheme * sc, s7_pointer sym,
s7_pointer tree)
{ /* sym need not be a symbol */
if (car(tree) == sc->quote_symbol)
return ((!is_symbol(sym)) && (!is_pair(sym))
&& (is_pair(cdr(tree))) && (sym == cadr(tree)));
do {
if (sym == car(tree))
return (true);
if (is_pair(car(tree))) {
s7_pointer cp = car(tree);
if (car(cp) == sc->quote_symbol) {
if ((!is_symbol(sym)) && (!is_pair(sym))
&& (is_pair(cdr(cp))) && (sym == cadr(cp)))
return (true);
} else
do {
if (sym == car(cp))
return (true);
if ((is_pair(car(cp)))
&& (tree_memq_1(sc, sym, car(cp))))
return (true);
cp = cdr(cp);
if (sym == cp)
return (true);
} while (is_pair(cp));
}
tree = cdr(tree);
if (sym == tree)
return (true);
} while (is_pair(tree));
return (false);
}
bool s7_tree_memq(s7_scheme * sc, s7_pointer sym, s7_pointer tree)
{
if (sym == tree)
return (true);
if (!is_pair(tree))
return (false);
if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, tree)))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"tree-memq: tree is cyclic: ~S",
29), tree));
return (tree_memq_1(sc, sym, tree));
}
static s7_pointer g_tree_memq(s7_scheme * sc, s7_pointer args)
{
#define H_tree_memq "(tree-memq obj tree) is a tree-oriented version of memq, but returning #t if the object is in the tree."
#define Q_tree_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T)
return (make_boolean(sc, s7_tree_memq(sc, car(args), cadr(args))));
}
/* ---------------- tree-set-memq ---------------- */
static inline bool pair_set_memq(s7_scheme * sc, s7_pointer tree)
{
while (true) {
s7_pointer p = car(tree);
if (is_symbol(p)) {
if (symbol_is_in_list(sc, p))
return (true);
} else if ((is_unquoted_pair(p)) && (pair_set_memq(sc, p)))
return (true);
tree = cdr(tree);
if (!is_pair(tree))
break;
}
return ((is_symbol(tree)) && (symbol_is_in_list(sc, tree)));
}
static bool tree_set_memq(s7_scheme * sc, s7_pointer tree)
{
if (is_symbol(tree))
return (symbol_is_in_list(sc, tree));
if ((!is_pair(tree)) || (car(tree) == sc->quote_symbol))
return (false);
return (pair_set_memq(sc, tree));
}
static bool tree_set_memq_b_7pp(s7_scheme * sc, s7_pointer syms,
s7_pointer tree)
{
s7_pointer p;
if (!is_pair(syms))
return (false);
if (sc->safety > NO_SAFETY) {
if (tree_is_cyclic(sc, syms))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"tree-set-memq: symbol list is cyclic: ~S",
40), syms));
if (tree_is_cyclic(sc, tree))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"tree-set-memq: tree is cyclic: ~S",
33), tree));
}
clear_symbol_list(sc);
for (p = syms; is_pair(p); p = cdr(p))
if (is_symbol(car(p)))
add_symbol_to_list(sc, car(p));
return (tree_set_memq(sc, tree));
}
static s7_pointer tree_set_memq_p_pp(s7_scheme * sc, s7_pointer syms,
s7_pointer tree)
{
return (make_boolean(sc, tree_set_memq_b_7pp(sc, syms, tree)));
}
static s7_pointer g_tree_set_memq(s7_scheme * sc, s7_pointer args)
{
#define H_tree_set_memq "(tree-set-memq symbols tree) returns #t if any of the list of symbols is in the tree"
#define Q_tree_set_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T)
return (make_boolean
(sc, tree_set_memq_b_7pp(sc, car(args), cadr(args))));
}
static s7_pointer tree_set_memq_direct(s7_scheme * sc, s7_pointer syms,
s7_pointer tree)
{
s7_pointer p;
if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, tree)))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"tree-set-memq: tree is cyclic: ~S",
33), tree));
clear_symbol_list(sc);
for (p = syms; is_pair(p); p = cdr(p))
add_symbol_to_list(sc, car(p));
return (make_boolean(sc, tree_set_memq(sc, tree)));
}
static s7_pointer g_tree_set_memq_1(s7_scheme * sc, s7_pointer args)
{
return (tree_set_memq_direct(sc, car(args), cadr(args)));
}
static s7_pointer tree_set_memq_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if ((is_proper_quote(sc, cadr(expr))) && /* not (tree-set-memq (quote) ... */
(is_pair(cadadr(expr)))) {
s7_pointer p;
for (p = cadadr(expr); is_pair(p); p = cdr(p))
if (!is_symbol(car(p)))
return (f);
return (sc->tree_set_memq_syms); /* this is tree_set_memq_1 */
}
return (f);
}
/* ---------------- tree-count ---------------- */
static s7_int tree_count(s7_scheme * sc, s7_pointer x, s7_pointer p,
s7_int count)
{
if (p == x)
return (count + 1);
if ((!is_pair(p)) || (car(p) == sc->quote_symbol))
return (count);
return (tree_count(sc, x, cdr(p), tree_count(sc, x, car(p), count)));
}
static inline s7_int tree_count_at_least(s7_scheme * sc, s7_pointer x,
s7_pointer p, s7_int count,
s7_int top)
{
if (p == x)
return (count + 1);
if (!is_pair(p))
return (count);
if (car(p) == sc->quote_symbol)
return (count);
do {
count = tree_count_at_least(sc, x, car(p), count, top);
if (count >= top)
return (count);
p = cdr(p);
if (p == x)
return (count + 1);
} while (is_pair(p));
return (count);
}
static s7_pointer g_tree_count(s7_scheme * sc, s7_pointer args)
{
#define H_tree_count "(tree-count obj tree max-count) returns how many times obj is in tree (using eq?), stopping at max-count (if specified)"
#define Q_tree_count s7_make_signature(sc, 4, sc->is_integer_symbol, sc->T, sc->T, sc->is_integer_symbol)
s7_pointer obj = car(args), tree = cadr(args), count;
if (!is_pair(tree)) {
if ((is_pair(cddr(args))) && (!s7_is_integer(caddr(args))))
return (wrong_type_argument
(sc, sc->tree_count_symbol, 3, caddr(args),
T_INTEGER));
/* here we need eqv? not eq? for integers: (tree-count <0-int-zero> <0-not-int-zero>)
* perhaps split tree_count|_at_least into eq?/eqv?/equal?/equivalent? cases?
* this is used primarily for symbol counts in lint.scm
*/
return ((obj == tree) ? int_one : int_zero);
}
if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, tree)))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"tree-count: tree is cyclic: ~S",
30), tree));
if (is_null(cddr(args)))
return (make_integer(sc, tree_count(sc, obj, tree, 0)));
count = caddr(args);
if (!s7_is_integer(count))
return (wrong_type_argument
(sc, sc->tree_count_symbol, 3, count, T_INTEGER));
return (make_integer
(sc,
tree_count_at_least(sc, obj, tree, 0,
s7_integer_checked(sc, count))));
}
/* -------------------------------- pair? -------------------------------- */
static s7_pointer g_is_pair(s7_scheme * sc, s7_pointer args)
{
#define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)"
#define Q_is_pair sc->pl_bt
check_boolean_method(sc, is_pair, sc->is_pair_symbol, args);
}
/* -------------------------------- list? -------------------------------- */
bool s7_is_list(s7_scheme * sc, s7_pointer p)
{
return (is_list(p));
}
static bool is_list_b(s7_pointer p)
{
return ((is_pair(p)) || (type(p) == T_NIL));
}
static s7_pointer g_is_list(s7_scheme * sc, s7_pointer args)
{
#define H_is_list "(list? obj) returns #t if obj is a pair or null"
#define Q_is_list sc->pl_bt
#define is_a_list(p) s7_is_list(sc, p)
check_boolean_method(sc, is_a_list, sc->is_list_symbol, args);
}
static s7_int proper_list_length(s7_pointer a)
{
s7_int i = 0;
s7_pointer b;
for (b = a; is_pair(b); i++, b = cdr(b)) {
};
return (i);
}
static s7_int proper_list_length_with_end(s7_pointer a, s7_pointer * c)
{
s7_int i = 0;
s7_pointer b;
for (b = a; is_pair(b); i++, b = cdr(b)) {
};
*c = b;
return (i);
}
s7_int s7_list_length(s7_scheme * sc, s7_pointer a)
{
/* returns -len if list is dotted, 0 if it's (directly) circular */
s7_int i;
s7_pointer slow = a, fast = a;
for (i = 0;; i += 2) {
if (!is_pair(fast))
return ((is_null(fast)) ? i : -i);
fast = cdr(fast);
if (!is_pair(fast))
return ((is_null(fast)) ? (i + 1) : (-i - 1));
/* if unrolled further, it's a lot slower? */
fast = cdr(fast);
slow = cdr(slow);
if (fast == slow)
return (0);
}
return (0);
}
static inline s7_pointer copy_proper_list(s7_scheme * sc, s7_pointer lst)
{
s7_pointer p, tp, np;
if (!is_pair(lst))
return (sc->nil);
sc->u = lst;
tp = list_1(sc, car(lst));
sc->y = tp;
for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np)) {
set_cdr(np, list_1_unchecked(sc, car(p)));
p = cdr(p);
if (is_pair(p)) {
np = cdr(np);
set_cdr(np, list_1_unchecked(sc, car(p)));
} else
break;
p = cdr(p);
if (is_pair(p)) {
np = cdr(np);
set_cdr(np, list_1(sc, car(p)));
} else
break;
}
sc->y = sc->nil;
sc->u = sc->nil;
return (tp);
}
static s7_pointer copy_proper_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, wrap_string(sc, "stray dot?: ~S", 14),
lst));
sc->u = lst;
tp = list_1(sc, car(lst));
sc->y = tp;
for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np))
set_cdr(np, list_1(sc, car(p)));
sc->y = sc->nil;
sc->u = sc->nil;
if (!is_null(p))
s7_error(sc, sc->syntax_error_symbol,
set_elist_2(sc,
wrap_string(sc,
"improper list of arguments: ~S",
30), lst));
return (tp);
}
/* -------------------------------- proper-list? -------------------------------- */
bool s7_is_proper_list(s7_scheme * sc, s7_pointer lst)
{
/* #t if () or undotted/non-circular pair */
s7_pointer slow = lst, fast = lst;
while (true) {
if (!is_pair(fast))
return (is_null(fast)); /* else it's an improper list */
LOOP_4(fast = cdr(fast);
if (!is_pair(fast)) return (is_null(fast)));
fast = cdr(fast);
slow = cdr(slow);
if (fast == slow)
return (false);
}
return (true);
}
static s7_pointer g_is_proper_list(s7_scheme * sc, s7_pointer args)
{
#define H_is_proper_list "(proper-list? x) returns #t is x is a list that is neither circular nor dotted."
#define Q_is_proper_list sc->pl_bt
return (make_boolean(sc, s7_is_proper_list(sc, car(args))));
}
static s7_pointer is_proper_list_p_p(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean(sc, s7_is_proper_list(sc, arg)));
}
static bool is_proper_list_1(s7_scheme * sc, s7_pointer p)
{
return ((is_pair(p)) && (is_null(cdr(p))));
}
static bool is_proper_list_2(s7_scheme * sc, s7_pointer p)
{
return ((is_pair(p)) && (is_pair(cdr(p))) && (is_null(cddr(p))));
}
static bool is_proper_list_3(s7_scheme * sc, s7_pointer p)
{
return ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p)))
&& (is_null(cdddr(p))));
}
static bool is_proper_list_4(s7_scheme * sc, s7_pointer p)
{
return (proper_list_length(p) == 4);
}
/* -------------------------------- make-list -------------------------------- */
static s7_pointer make_big_list(s7_scheme * sc, s7_int len,
s7_pointer init)
{
s7_int i;
check_free_heap_size(sc, len + 1); /* using cons_unchecked below, +1 in case we are on the trigger at the end */
sc->value = sc->nil;
for (i = 0; i < len; i++)
sc->value = cons_unchecked(sc, init, sc->value);
return (sc->value);
}
static inline s7_pointer make_list(s7_scheme * sc, s7_int len,
s7_pointer init)
{
switch (len) {
case 0:
return (sc->nil);
case 1:
return (T_Pair(cons(sc, init, sc->nil)));
case 2:
return (T_Pair(cons_unchecked(sc, init, cons(sc, init, sc->nil))));
case 3:
return (T_Pair
(cons_unchecked
(sc, init,
cons_unchecked(sc, init, cons(sc, init, sc->nil)))));
case 4:
return (T_Pair
(cons_unchecked
(sc, init,
cons_unchecked(sc, init,
cons_unchecked(sc, init,
cons(sc, init,
sc->nil))))));
case 5:
return (T_Pair
(cons_unchecked
(sc, init,
cons_unchecked(sc, init,
cons_unchecked(sc, init,
cons_unchecked(sc, init,
cons(sc,
init,
sc->nil)))))));
case 6:
return (T_Pair
(cons_unchecked
(sc, init,
cons_unchecked(sc, init,
cons_unchecked(sc, init,
cons_unchecked(sc, init,
cons_unchecked
(sc, init,
cons(sc,
init,
sc->nil))))))));
case 7:
return (T_Pair
(cons_unchecked
(sc, init,
cons_unchecked(sc, init,
cons_unchecked(sc, init,
cons_unchecked(sc, init,
cons_unchecked
(sc, init,
cons_unchecked
(sc, init,
cons(sc,
init,
sc->nil)))))))));
default:
return (make_big_list(sc, len, init));
}
return (sc->nil); /* never happens, I hope */
}
s7_pointer s7_make_list(s7_scheme * sc, s7_int len, s7_pointer init)
{
return (make_list(sc, len, init));
}
static s7_pointer protected_make_list(s7_scheme * sc, s7_int len,
s7_pointer init)
{
sc->temp6 = make_list(sc, len, init);
return (sc->temp6);
}
static s7_pointer make_list_p_pp(s7_scheme * sc, s7_pointer n,
s7_pointer init)
{
s7_int len;
if (!s7_is_integer(n))
return (method_or_bust
(sc, n, sc->make_list_symbol, set_plist_2(sc, n, init),
T_INTEGER, 1));
len = s7_integer_checked(sc, n);
#if WITH_GMP
if ((len == 0) && (!is_zero(sc, n)))
return (s7_out_of_range_error
(sc, "make-list", 1, n,
"big integer is too big for s7_int"));
#endif
if (len == 0)
return (sc->nil); /* what about (make-list 0 123)? */
if ((len < 0) || (len > sc->max_list_length))
return (out_of_range
(sc, sc->make_list_symbol, int_one, n,
(len < 0) ? its_negative_string : its_too_large_string));
return (make_list(sc, len, init));
}
static s7_pointer g_make_list(s7_scheme * sc, s7_pointer args)
{
#define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'."
#define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T)
return (make_list_p_pp
(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->F));
}
/* -------------------------------- list-ref -------------------------------- */
s7_pointer s7_list_ref(s7_scheme * sc, s7_pointer lst, s7_int num)
{
s7_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);
}
static s7_pointer list_ref_1(s7_scheme * sc, s7_pointer lst,
s7_pointer ind)
{
s7_int i, index;
s7_pointer p;
if (!s7_is_integer(ind))
return (method_or_bust_pp
(sc, ind, sc->list_ref_symbol, lst, ind, T_INTEGER, 2));
index = s7_integer_checked(sc, ind);
if ((index < 0) || (index > sc->max_list_length))
return (out_of_range
(sc, sc->list_ref_symbol, int_two, 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))
return (car(p));
if (is_null(p))
return (out_of_range
(sc, sc->list_ref_symbol, int_two, ind,
its_too_large_string));
return (wrong_type_argument_with_type
(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string));
}
static s7_pointer implicit_index(s7_scheme * sc, s7_pointer obj,
s7_pointer indices);
static s7_pointer g_list_ref(s7_scheme * sc, s7_pointer args)
{
#define H_list_ref "(list-ref lst i ...) returns the i-th element (0-based) of the list"
#define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol)
/* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2)) */
s7_pointer lst = car(args), inds;
if (!is_pair(lst))
return (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))
return (implicit_index(sc, lst, inds)); /* 9-Jan-19 */
}
}
static bool op_implicit_pair_ref_a(s7_scheme * sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
if (!is_pair(s)) {
sc->last_function = s;
return (false);
}
sc->value = list_ref_1(sc, s, fx_call(sc, cdr(sc->code)));
return (true);
}
static bool op_implicit_pair_ref_aa(s7_scheme * sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
if (!is_pair(s)) {
sc->last_function = s;
return (false);
}
sc->args = fx_call(sc, cddr(sc->code));
sc->value =
implicit_index(sc, list_ref_1(sc, s, fx_call(sc, cdr(sc->code))),
set_plist_1(sc, sc->args));
return (true);
}
static s7_pointer list_ref_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 2) {
s7_pointer index = caddr(expr);
if (is_t_integer(index)) {
if (integer(index) == 0)
return (sc->list_ref_at_0);
if (integer(index) == 1)
return (sc->list_ref_at_1);
if (integer(index) == 2)
return (sc->list_ref_at_2);
}
}
return (f);
}
/* -------------------------------- list-set! -------------------------------- */
s7_pointer s7_list_set(s7_scheme * sc, s7_pointer lst, s7_int num,
s7_pointer val)
{
s7_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, T_Pos(val));
return (val);
}
static s7_pointer g_list_set_1(s7_scheme * sc, s7_pointer lst,
s7_pointer args, int32_t arg_num)
{
#define H_list_set "(list-set! lst i ... val) sets the i-th element (0-based) of the list to val"
#define Q_list_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_pair_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol)
int32_t 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_mutable_pair(lst))
return (mutable_method_or_bust
(sc, lst, sc->list_set_symbol, set_ulist_1(sc, lst, args),
T_PAIR, 1));
ind = car(args);
if ((arg_num > 2) && (is_null(cdr(args)))) {
set_car(lst, ind);
return (ind);
}
if (!s7_is_integer(ind))
return (method_or_bust
(sc, ind, sc->list_set_symbol, set_ulist_1(sc, lst, args),
T_INTEGER, 2));
index = s7_integer_checked(sc, ind);
if ((index < 0) || (index > sc->max_list_length))
return (out_of_range
(sc, sc->list_set_symbol, wrap_integer1(sc, arg_num), 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_set_symbol, wrap_integer1(sc, 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 {
if (!s7_is_pair(car(p)))
return (s7_wrong_number_of_args_error
(sc, "too many arguments for list-set!: ~S", args));
return (g_list_set_1(sc, car(p), cdr(args), arg_num + 1));
}
return (cadr(args));
}
static s7_pointer g_list_set(s7_scheme * sc, s7_pointer args)
{
return (g_list_set_1(sc, car(args), cdr(args), 2));
}
static inline s7_pointer list_ref_p_pi_unchecked(s7_scheme * sc,
s7_pointer p1, s7_int i1)
{
s7_pointer p;
s7_int i;
if ((i1 < 0) || (i1 > sc->max_list_length))
out_of_range(sc, sc->list_ref_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
for (i = 0, p = p1; ((is_pair(p)) && (i < i1)); i++, p = cdr(p));
if (!is_pair(p)) {
if (is_null(p))
out_of_range(sc, sc->list_ref_symbol, int_two,
wrap_integer1(sc, i1), its_too_large_string);
else
simple_wrong_type_argument_with_type(sc, sc->list_ref_symbol,
p1, a_proper_list_string);
}
return (car(p));
}
static s7_pointer list_ref_p_pi(s7_scheme * sc, s7_pointer p1, s7_int i1)
{
if (!is_pair(p1))
simple_wrong_type_argument(sc, sc->list_ref_symbol, p1, T_PAIR);
return (list_ref_p_pi_unchecked(sc, p1, i1));
}
static inline s7_pointer list_set_p_pip_unchecked(s7_scheme * sc,
s7_pointer p1, s7_int i1,
s7_pointer p2)
{
s7_pointer p;
s7_int i;
if ((i1 < 0) || (i1 > sc->max_list_length))
out_of_range(sc, sc->list_set_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
for (i = 0, p = p1; ((is_pair(p)) && (i < i1)); i++, p = cdr(p));
if (!is_pair(p)) {
if (is_null(p))
out_of_range(sc, sc->list_set_symbol, int_two,
wrap_integer1(sc, i1), its_too_large_string);
else
simple_wrong_type_argument_with_type(sc, sc->list_set_symbol,
p1, a_proper_list_string);
}
set_car(p, p2);
return (p2);
}
static s7_pointer list_increment_p_pip_unchecked(opt_info * o)
{
s7_scheme *sc = opt_sc(o);
s7_pointer p = slot_value(o->v[2].p), p1, p2;
s7_int i, index;
index = integer(p);
if ((index < 0) || (index > sc->max_list_length))
out_of_range(sc, sc->list_set_symbol, int_two, p,
(index <
0) ? its_negative_string : its_too_large_string);
p1 = slot_value(o->v[1].p);
for (i = 0, p = p1; ((is_pair(p)) && (i < index)); i++, p = cdr(p));
if (!is_pair(p)) {
if (is_null(p))
out_of_range(sc, sc->list_set_symbol, int_two,
wrap_integer1(sc, index), its_too_large_string);
else
simple_wrong_type_argument_with_type(sc, sc->list_set_symbol,
p1, a_proper_list_string);
}
p2 = g_add_xi(sc, car(p), integer(o->v[3].p));
set_car(p, p2);
return (p2);
}
static s7_pointer list_set_p_pip(s7_scheme * sc, s7_pointer p1, s7_int i1,
s7_pointer p2)
{
if (!is_pair(p1))
simple_wrong_type_argument(sc, sc->list_set_symbol, p1, T_PAIR);
return (list_set_p_pip_unchecked(sc, p1, i1, p2));
}
static s7_pointer g_list_set_i(s7_scheme * sc, s7_pointer args)
{
s7_pointer p, lst = car(args), val;
s7_int i, index;
if (!is_mutable_pair(lst))
return (mutable_method_or_bust
(sc, lst, sc->list_set_symbol, args, T_PAIR, 1));
index = s7_integer_checked(sc, cadr(args));
if ((index < 0) || (index > sc->max_list_length))
return (out_of_range
(sc, sc->list_set_symbol, int_two,
wrap_integer1(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, int_two,
wrap_integer1(sc, index), its_too_large_string));
return (wrong_type_argument_with_type
(sc, sc->list_set_symbol, 1, lst, a_proper_list_string));
}
val = caddr(args);
set_car(p, val);
return (val);
}
static s7_pointer list_set_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if ((args == 3) &&
(s7_is_integer(caddr(expr))) &&
(s7_integer_checked(sc, caddr(expr)) >= 0) &&
(s7_integer_checked(sc, caddr(expr)) < sc->max_list_length))
return (sc->list_set_i);
return (f);
}
/* -------------------------------- list-tail -------------------------------- */
static s7_pointer list_tail_p_pp(s7_scheme * sc, s7_pointer lst,
s7_pointer p)
{
s7_int i, index;
if (!s7_is_integer(p))
return (method_or_bust_pp
(sc, p, sc->list_tail_symbol, lst, p, T_INTEGER, 2));
index = s7_integer_checked(sc, p);
if (!is_list(lst)) /* (list-tail () 0) -> () */
return (method_or_bust_with_type_pi
(sc, lst, sc->list_tail_symbol, lst, index,
a_list_string));
if ((index < 0) || (index > sc->max_list_length))
return (out_of_range
(sc, sc->list_tail_symbol, int_two,
wrap_integer1(sc, index),
(index <
0) ? its_negative_string : its_too_large_string));
for (i = 0; (i < index) && (is_pair(lst)); i++, lst = cdr(lst)) {
}
if (i < index)
return (out_of_range
(sc, sc->list_tail_symbol, int_two,
wrap_integer1(sc, index), its_too_large_string));
return (lst);
}
static s7_pointer g_list_tail(s7_scheme * sc, s7_pointer args)
{
#define H_list_tail "(list-tail lst i) returns the list from the i-th element on"
#define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */
return (list_tail_p_pp(sc, car(args), cadr(args)));
}
/* -------------------------------- cons -------------------------------- */
static s7_pointer g_cons(s7_scheme * sc, s7_pointer args)
{
#define H_cons "(cons a b) returns a pair containing a and b"
#define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T)
s7_pointer x;
new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE);
set_car(x, car(args));
set_cdr(x, cadr(args));
return (x);
}
static s7_pointer cons_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
s7_pointer x;
new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE);
set_car(x, p1);
set_cdr(x, p2);
return (x);
}
/* -------- car -------- */
static s7_pointer g_car(s7_scheme * sc, s7_pointer args)
{
#define H_car "(car pair) returns the first element of the pair"
#define Q_car sc->pl_p
s7_pointer lst = car(args);
if (is_pair(lst))
return (car(lst));
return (method_or_bust_one_arg(sc, lst, sc->car_symbol, args, T_PAIR));
}
static s7_pointer car_p_p(s7_scheme * sc, s7_pointer p)
{
if (is_pair(p))
return (car(p));
return (method_or_bust_one_arg
(sc, p, sc->car_symbol, set_plist_1(sc, p), T_PAIR));
}
static s7_pointer g_list_ref_at_0(s7_scheme * sc, s7_pointer args)
{
if (is_pair(car(args)))
return (caar(args));
return (method_or_bust(sc, car(args), sc->list_ref_symbol, args, T_PAIR, 1)); /* 1=arg num if error */
}
static s7_pointer g_set_car(s7_scheme * sc, s7_pointer args)
{
#define H_set_car "(set-car! pair val) sets the pair's first element to val"
#define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)
s7_pointer p = car(args);
if (!is_mutable_pair(p))
return (mutable_method_or_bust
(sc, p, sc->set_car_symbol, args, T_PAIR, 1));
set_car(p, cadr(args));
return (car(p));
}
static Inline s7_pointer inline_set_car(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
if (!is_mutable_pair(p1))
return (mutable_method_or_bust
(sc, p1, sc->set_car_symbol, set_plist_1(sc, p1), T_PAIR,
1));
set_car(p1, p2);
return (p2);
}
static s7_pointer set_car_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
return (inline_set_car(sc, p1, p2));
}
/* -------- cdr -------- */
static s7_pointer g_cdr(s7_scheme * sc, s7_pointer args)
{
#define H_cdr "(cdr pair) returns the second element of the pair"
#define Q_cdr sc->pl_p
s7_pointer lst = car(args);
if (is_pair(lst))
return (cdr(lst));
return (method_or_bust_one_arg(sc, lst, sc->cdr_symbol, args, T_PAIR));
}
static s7_pointer cdr_p_p(s7_scheme * sc, s7_pointer p)
{
if (is_pair(p))
return (cdr(p));
return (method_or_bust_one_arg
(sc, p, sc->cdr_symbol, set_plist_1(sc, p), T_PAIR));
}
static s7_pointer g_set_cdr(s7_scheme * sc, s7_pointer args)
{
#define H_set_cdr "(set-cdr! pair val) sets the pair's second element to val"
#define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)
s7_pointer p = car(args);
if (!is_mutable_pair(p))
return (mutable_method_or_bust
(sc, p, sc->set_cdr_symbol, args, T_PAIR, 1));
set_cdr(p, cadr(args));
return (cdr(p));
}
static Inline s7_pointer inline_set_cdr(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
if (!is_mutable_pair(p1))
return (mutable_method_or_bust
(sc, p1, sc->set_cdr_symbol, set_plist_1(sc, p1), T_PAIR,
1));
set_cdr(p1, p2);
return (p2);
}
static s7_pointer set_cdr_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
return (inline_set_cdr(sc, p1, p2));
}
/* -------- caar --------*/
static s7_pointer g_caar(s7_scheme * sc, s7_pointer args)
{
#define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1"
#define Q_caar sc->pl_p
s7_pointer lst = car(args);
/* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caar_symbol, args, T_PAIR));
return ((is_pair(car(lst))) ? caar(lst) :
simple_wrong_type_argument_with_type(sc, sc->caar_symbol, lst,
car_a_list_string));
}
static s7_pointer caar_p_p(s7_scheme * sc, s7_pointer p)
{
if ((is_pair(p)) && (is_pair(car(p))))
return (caar(p));
if (!is_pair(p))
return (method_or_bust_one_arg
(sc, p, sc->caar_symbol, set_plist_1(sc, p), T_PAIR));
return (simple_wrong_type_argument_with_type
(sc, sc->caar_symbol, p, car_a_list_string));
}
/* -------- cadr --------*/
static s7_pointer g_cadr(s7_scheme * sc, s7_pointer args)
{
#define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2"
#define Q_cadr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cadr_symbol, args, T_PAIR));
return ((is_pair(cdr(lst))) ? cadr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cadr_symbol, lst,
cdr_a_list_string));
}
static s7_pointer cadr_p_p(s7_scheme * sc, s7_pointer p)
{
if ((is_pair(p)) && (is_pair(cdr(p))))
return (cadr(p));
if (!is_pair(p))
return (method_or_bust_one_arg
(sc, p, sc->cadr_symbol, set_plist_1(sc, p), T_PAIR));
return (simple_wrong_type_argument_with_type
(sc, sc->cadr_symbol, p, cdr_a_list_string));
}
static s7_pointer g_list_ref_at_1(s7_scheme * sc, s7_pointer args)
{
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust
(sc, lst, sc->list_ref_symbol, args, T_PAIR, 1));
if (is_pair(cdr(lst)))
return (cadr(lst));
return (out_of_range
(sc, sc->list_ref_symbol, int_two, cadr(args),
its_too_large_string));
}
/* -------- cdar -------- */
static s7_pointer g_cdar(s7_scheme * sc, s7_pointer args)
{
#define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)"
#define Q_cdar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdar_symbol, args, T_PAIR));
return ((is_pair(car(lst))) ? cdar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdar_symbol, lst,
car_a_list_string));
}
static s7_pointer cdar_p_p(s7_scheme * sc, s7_pointer p)
{
if ((is_pair(p)) && (is_pair(car(p))))
return (cdar(p));
if (!is_pair(p))
return (method_or_bust_one_arg
(sc, p, sc->cdar_symbol, set_plist_1(sc, p), T_PAIR));
return (simple_wrong_type_argument_with_type
(sc, sc->cdar_symbol, p, car_a_list_string));
}
/* -------- cddr -------- */
static s7_pointer g_cddr(s7_scheme * sc, s7_pointer args)
{
#define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)"
#define Q_cddr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cddr_symbol, args, T_PAIR));
return ((is_pair(cdr(lst))) ? cddr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cddr_symbol, lst,
cdr_a_list_string));
}
static s7_pointer cddr_p_p(s7_scheme * sc, s7_pointer p)
{
if ((is_pair(p)) && (is_pair(cdr(p))))
return (cddr(p));
if (!is_pair(p))
return (method_or_bust_one_arg
(sc, p, sc->cddr_symbol, set_plist_1(sc, p), T_PAIR));
return (simple_wrong_type_argument_with_type
(sc, sc->cddr_symbol, p, cdr_a_list_string));
}
/* -------- caaar -------- */
static s7_pointer caaar_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), T_PAIR));
if (!is_pair(car(lst)))
return (simple_wrong_type_argument_with_type
(sc, sc->caaar_symbol, lst, car_a_list_string));
return ((is_pair(caar(lst))) ? caaar(lst) :
simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst,
caar_a_list_string));
}
static s7_pointer g_caaar(s7_scheme * sc, s7_pointer args)
{
#define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1"
#define Q_caaar sc->pl_p
return (caaar_p_p(sc, car(args)));
}
/* -------- caadr -------- */
static s7_pointer caadr_p_p(s7_scheme * sc, s7_pointer p)
{
if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cadr(p))))
return (caadr(p));
if (!is_pair(p))
return (method_or_bust_one_arg
(sc, p, sc->caadr_symbol, set_plist_1(sc, p), T_PAIR));
if (!is_pair(cdr(p)))
return (simple_wrong_type_argument_with_type
(sc, sc->caadr_symbol, p, cdr_a_list_string));
return (simple_wrong_type_argument_with_type
(sc, sc->caadr_symbol, p, cadr_a_list_string));
}
static s7_pointer g_caadr(s7_scheme * sc, s7_pointer args)
{
#define H_caadr "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2"
#define Q_caadr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caadr_symbol, args, T_PAIR));
if (!is_pair(cdr(lst)))
return (simple_wrong_type_argument_with_type
(sc, sc->caadr_symbol, lst, cdr_a_list_string));
return ((is_pair(cadr(lst))) ? caadr(lst) :
simple_wrong_type_argument_with_type(sc, sc->caadr_symbol, lst,
cadr_a_list_string));
}
/* -------- cadar -------- */
static s7_pointer g_cadar(s7_scheme * sc, s7_pointer args)
{
#define H_cadar "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2"
#define Q_cadar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cadar_symbol, args, T_PAIR));
if (!is_pair(car(lst)))
return (simple_wrong_type_argument_with_type
(sc, sc->cadar_symbol, lst, car_a_list_string));
return ((is_pair(cdar(lst))) ? cadar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cadar_symbol, lst,
cdar_a_list_string));
}
static s7_pointer cadar_p_p(s7_scheme * sc, s7_pointer p)
{
if ((is_pair(p)) && (is_pair(car(p))) && (is_pair(cdar(p))))
return (cadar(p));
if (!is_pair(p))
return (method_or_bust_one_arg
(sc, p, sc->cadar_symbol, set_plist_1(sc, p), T_PAIR));
if (!is_pair(car(p)))
return (simple_wrong_type_argument_with_type
(sc, sc->cadar_symbol, p, car_a_list_string));
return (simple_wrong_type_argument_with_type
(sc, sc->cadar_symbol, p, cdar_a_list_string));
}
/* -------- cdaar -------- */
static s7_pointer cdaar_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), T_PAIR));
if (!is_pair(car(lst)))
return (simple_wrong_type_argument_with_type
(sc, sc->cdaar_symbol, lst, car_a_list_string));
return ((is_pair(caar(lst))) ? cdaar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst,
caar_a_list_string));
}
static s7_pointer g_cdaar(s7_scheme * sc, s7_pointer args)
{
#define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)"
#define Q_cdaar sc->pl_p
return (cdaar_p_p(sc, car(args)));
}
/* -------- caddr -------- */
static s7_pointer g_caddr(s7_scheme * sc, s7_pointer args)
{
#define H_caddr "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3"
#define Q_caddr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caddr_symbol, args, T_PAIR));
if (!is_pair(cdr(lst)))
return (simple_wrong_type_argument_with_type
(sc, sc->caddr_symbol, lst, cdr_a_list_string));
return ((is_pair(cddr(lst))) ? caddr(lst) :
simple_wrong_type_argument_with_type(sc, sc->caddr_symbol, lst,
cddr_a_list_string));
}
static s7_pointer caddr_p_p(s7_scheme * sc, s7_pointer p)
{
if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p))))
return (caddr(p));
if (!is_pair(p))
return (method_or_bust_one_arg
(sc, p, sc->caddr_symbol, set_plist_1(sc, p), T_PAIR));
if (!is_pair(cdr(p)))
return (simple_wrong_type_argument_with_type
(sc, sc->caddr_symbol, p, cdr_a_list_string));
return (simple_wrong_type_argument_with_type
(sc, sc->caddr_symbol, p, cddr_a_list_string));
}
static s7_pointer g_list_ref_at_2(s7_scheme * sc, s7_pointer args)
{
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust
(sc, lst, sc->list_ref_symbol, args, T_PAIR, 1));
if ((is_pair(cdr(lst))) && (is_pair(cddr(lst))))
return (caddr(lst));
return (out_of_range
(sc, sc->list_ref_symbol, int_two, cadr(args),
its_too_large_string));
}
/* -------- cdddr -------- */
static s7_pointer cdddr_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdddr_symbol, set_plist_1(sc, lst), T_PAIR));
if (!is_pair(cdr(lst)))
return (simple_wrong_type_argument_with_type
(sc, sc->cdddr_symbol, lst, cdr_a_list_string));
return ((is_pair(cddr(lst))) ? cdddr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdddr_symbol, lst,
cddr_a_list_string));
}
static s7_pointer g_cdddr(s7_scheme * sc, s7_pointer args)
{
#define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)"
#define Q_cdddr sc->pl_p
return (cdddr_p_p(sc, car(args)));
}
/* -------- cdadr -------- */
static s7_pointer cdadr_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdadr_symbol, set_plist_1(sc, lst), T_PAIR));
if (!is_pair(cdr(lst)))
return (simple_wrong_type_argument_with_type
(sc, sc->cdadr_symbol, lst, cdr_a_list_string));
return ((is_pair(cadr(lst))) ? cdadr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdadr_symbol, lst,
cadr_a_list_string));
}
static s7_pointer g_cdadr(s7_scheme * sc, s7_pointer args)
{
#define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)"
#define Q_cdadr sc->pl_p
return (cdadr_p_p(sc, car(args)));
}
/* -------- cddar -------- */
static s7_pointer cddar_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), T_PAIR));
if (!is_pair(car(lst)))
return (simple_wrong_type_argument_with_type
(sc, sc->cddar_symbol, lst, car_a_list_string));
return ((is_pair(cdar(lst))) ? cddar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst,
cdar_a_list_string));
}
static s7_pointer g_cddar(s7_scheme * sc, s7_pointer args)
{
#define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)"
#define Q_cddar sc->pl_p
return (cddar_p_p(sc, car(args)));
}
/* -------- caaaar -------- */
static s7_pointer g_caaaar(s7_scheme * sc, s7_pointer args)
{
#define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1"
#define Q_caaaar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caaaar_symbol, args, T_PAIR));
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));
return ((is_pair(caaar(lst))) ? caaaar(lst) :
simple_wrong_type_argument_with_type(sc, sc->caaaar_symbol,
lst,
caaar_a_list_string));
}
/* -------- caaadr -------- */
static s7_pointer g_caaadr(s7_scheme * sc, s7_pointer args)
{
#define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2"
#define Q_caaadr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caaadr_symbol, args, T_PAIR));
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));
return ((is_pair(caadr(lst))) ? caaadr(lst) :
simple_wrong_type_argument_with_type(sc, sc->caaadr_symbol,
lst,
caadr_a_list_string));
}
/* -------- caadar -------- */
static s7_pointer g_caadar(s7_scheme * sc, s7_pointer args)
{
#define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2"
#define Q_caadar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caadar_symbol, args, T_PAIR));
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));
return ((is_pair(cadar(lst))) ? caadar(lst) :
simple_wrong_type_argument_with_type(sc, sc->caadar_symbol,
lst,
cadar_a_list_string));
}
/* -------- cadaar -------- */
static s7_pointer g_cadaar(s7_scheme * sc, s7_pointer args)
{
#define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2"
#define Q_cadaar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cadaar_symbol, args, T_PAIR));
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));
return ((is_pair(cdaar(lst))) ? cadaar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cadaar_symbol,
lst,
cdaar_a_list_string));
}
/* -------- caaddr -------- */
static s7_pointer caaddr_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caaddr_symbol, set_plist_1(sc, lst),
T_PAIR));
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));
return ((is_pair(caddr(lst))) ? caaddr(lst) :
simple_wrong_type_argument_with_type(sc, sc->caaddr_symbol,
lst,
caddr_a_list_string));
}
static s7_pointer g_caaddr(s7_scheme * sc, s7_pointer args)
{
#define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3"
#define Q_caaddr sc->pl_p
return (caaddr_p_p(sc, car(args)));
}
/* -------- cadddr -------- */
static s7_pointer cadddr_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cadddr_symbol, set_plist_1(sc, lst),
T_PAIR));
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));
return ((is_pair(cdddr(lst))) ? cadddr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cadddr_symbol,
lst,
cdddr_a_list_string));
}
static s7_pointer g_cadddr(s7_scheme * sc, s7_pointer args)
{
#define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4"
#define Q_cadddr sc->pl_p
return (cadddr_p_p(sc, car(args)));
}
/* -------- cadadr -------- */
static s7_pointer cadadr_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cadadr_symbol, set_plist_1(sc, lst),
T_PAIR));
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));
return ((is_pair(cdadr(lst))) ? cadadr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cadadr_symbol,
lst,
cdadr_a_list_string));
}
static s7_pointer g_cadadr(s7_scheme * sc, s7_pointer args)
{
#define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3"
#define Q_cadadr sc->pl_p
return (cadadr_p_p(sc, car(args)));
}
/* -------- caddar -------- */
static s7_pointer caddar_p_p(s7_scheme * sc, s7_pointer lst)
{
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->caddar_symbol, set_plist_1(sc, lst),
T_PAIR));
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));
return ((is_pair(cddar(lst))) ? caddar(lst) :
simple_wrong_type_argument_with_type(sc, sc->caddar_symbol,
lst,
cddar_a_list_string));
}
static s7_pointer g_caddar(s7_scheme * sc, s7_pointer args)
{
#define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3"
#define Q_caddar sc->pl_p
return (caddar_p_p(sc, car(args)));
}
/* -------- cdaaar -------- */
static s7_pointer g_cdaaar(s7_scheme * sc, s7_pointer args)
{
#define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)"
#define Q_cdaaar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdaaar_symbol, args, T_PAIR));
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));
return ((is_pair(caaar(lst))) ? cdaaar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdaaar_symbol,
lst,
caaar_a_list_string));
}
/* -------- cdaadr -------- */
static s7_pointer g_cdaadr(s7_scheme * sc, s7_pointer args)
{
#define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)"
#define Q_cdaadr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdaadr_symbol, args, T_PAIR));
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));
return ((is_pair(caadr(lst))) ? cdaadr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdaadr_symbol,
lst,
caadr_a_list_string));
}
/* -------- cdadar -------- */
static s7_pointer g_cdadar(s7_scheme * sc, s7_pointer args)
{
#define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)"
#define Q_cdadar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdadar_symbol, args, T_PAIR));
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));
return ((is_pair(cadar(lst))) ? cdadar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdadar_symbol,
lst,
cadar_a_list_string));
}
/* -------- cddaar -------- */
static s7_pointer g_cddaar(s7_scheme * sc, s7_pointer args)
{
#define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)"
#define Q_cddaar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cddaar_symbol, args, T_PAIR));
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));
return ((is_pair(cdaar(lst))) ? cddaar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cddaar_symbol,
lst,
cdaar_a_list_string));
}
/* -------- cdaddr -------- */
static s7_pointer g_cdaddr(s7_scheme * sc, s7_pointer args)
{
#define H_cdaddr "(cdaddr lst) returns (cdr (car (cdr (cdr lst)))): (cdaddr '(1 2 (3 4 5))) -> '(4 5)"
#define Q_cdaddr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdaddr_symbol, args, T_PAIR));
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));
return ((is_pair(caddr(lst))) ? cdaddr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdaddr_symbol,
lst,
caddr_a_list_string));
}
/* -------- cddddr -------- */
static s7_pointer g_cddddr(s7_scheme * sc, s7_pointer args)
{
#define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)"
#define Q_cddddr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cddddr_symbol, args, T_PAIR));
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));
return ((is_pair(cdddr(lst))) ? cddddr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cddddr_symbol,
lst,
cdddr_a_list_string));
}
/* -------- cddadr -------- */
static s7_pointer g_cddadr(s7_scheme * sc, s7_pointer args)
{
#define H_cddadr "(cddadr lst) returns (cdr (cdr (car (cdr lst)))): (cddadr '(1 (2 3 4 5))) -> '(4 5)"
#define Q_cddadr sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cddadr_symbol, args, T_PAIR));
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));
return ((is_pair(cdadr(lst))) ? cddadr(lst) :
simple_wrong_type_argument_with_type(sc, sc->cddadr_symbol,
lst,
cdadr_a_list_string));
}
/* -------- cdddar -------- */
static s7_pointer g_cdddar(s7_scheme * sc, s7_pointer args)
{
#define H_cdddar "(cdddar lst) returns (cdr (cdr (cdr (car lst)))): (cdddar '((1 2 3 4 5))) -> '(4 5)"
#define Q_cdddar sc->pl_p
s7_pointer lst = car(args);
if (!is_pair(lst))
return (method_or_bust_one_arg
(sc, lst, sc->cdddar_symbol, args, T_PAIR));
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));
return ((is_pair(cddar(lst))) ? cdddar(lst) :
simple_wrong_type_argument_with_type(sc, sc->cdddar_symbol,
lst,
cddar_a_list_string));
}
/* -------------------------------- assoc assv assq -------------------------------- */
s7_pointer s7_assq(s7_scheme * sc, s7_pointer obj, s7_pointer x)
{
s7_pointer 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(unspec)->unspec so we could forgo half the is_pair checks below.
* This breaks if "x" is a dotted list -- the last cdr is not nil, so we lose.
*/
LOOP_8(if ((obj == unchecked_car(car(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 assq_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
return ((is_pair(y)) ? s7_assq(sc, x, y) :
((is_null(y)) ? sc->F :
method_or_bust_with_type_pp(sc, y, sc->assq_symbol, x, y,
an_association_list_string, 2)));
}
static s7_pointer g_assq(s7_scheme * sc, s7_pointer args)
{
#define H_assq "(assq obj alist) returns the key-value pair associated (via eq?) with the key obj in the association list alist"
#define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol)
return (assq_p_pp(sc, car(args), cadr(args)));
/* we don't check for (pair? (car x)) here (or in assv) so we get some inconsistency with assoc:
* (assq #f '(#f 2 . 3)) -> #f, (assoc #f '(#f 2 . 3)) -> 'error
*/
}
static s7_pointer assv_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
s7_pointer z;
if (!is_pair(y)) {
if (is_null(y))
return (sc->F);
return (method_or_bust_with_type_pp
(sc, y, sc->assv_symbol, 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(sc, x, caar(y))))
return (car(y));
y = cdr(y);
if (!is_pair(y))
return (sc->F);
if ((is_pair(car(y))) && (s7_is_eqv(sc, 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 (assv_p_pp(sc, car(args), cadr(args)));
}
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);
}
static s7_pointer g_is_eq(s7_scheme * sc, s7_pointer args);
static s7_pointer g_is_eqv(s7_scheme * sc, s7_pointer args);
static s7_pfunc s7_bool_optimize(s7_scheme * sc, s7_pointer expr);
static s7_pointer g_assoc(s7_scheme * sc, s7_pointer args)
{
#define H_assoc "(assoc obj alist (func #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 = cadr(args), y, obj, eq_func = NULL;
if (!is_null(x)) {
if (!is_pair(x))
return (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_pair(cddr(args))) {
eq_func = caddr(args);
/* here we know x is a pair, but need to protect against circular lists */
/* I wonder if the assoc equality function should get the cons, not just caar? */
if ((is_c_function(eq_func)) && (is_safe_procedure(eq_func))) {
s7_function func;
s7_pointer slow;
func = c_function_call(eq_func);
if (func == g_is_eq)
return (is_null(x) ? sc->F : s7_assq(sc, car(args), x));
if (func == g_is_eqv)
return (assv_p_pp(sc, car(args), x));
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));
set_car(sc->t2_1, car(args));
for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) {
if (!is_pair(car(x)))
return (wrong_type_argument_with_type
(sc, sc->assoc_symbol, 2, cadr(args),
an_association_list_string));
set_car(sc->t2_2, caar(x));
if (is_true(sc, func(sc, sc->t2_1)))
return (car(x));
x = cdr(x);
if ((!is_pair(x)) || (x == slow))
return (sc->F);
if (!is_pair(car(x)))
return (wrong_type_argument_with_type
(sc, sc->assoc_symbol, 2, cadr(args),
an_association_list_string));
set_car(sc->t2_2, caar(x));
if (is_true(sc, func(sc, sc->t2_1)))
return (car(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 */
(is_null(cddr(closure_args(eq_func))))) { /* arity == 2 */
s7_pointer body = closure_body(eq_func);
if (is_null(x))
return (sc->F);
if (is_null(cdr(body))) {
s7_pfunc func;
sc->curlet =
make_let_with_two_slots(sc, sc->curlet,
car(closure_args(eq_func)),
car(args),
cadr(closure_args(eq_func)),
sc->F);
func = s7_bool_optimize(sc, body);
if (func) {
s7_pointer slowx = x, b;
opt_info *o = sc->opts[0];
b = next_slot(let_slots(sc->curlet));
while (true) {
if (!is_pair(car(x)))
return (wrong_type_argument_with_type
(sc, sc->assoc_symbol, 2, cadr(args),
an_association_list_string));
slot_set_value(b, caar(x));
if (o->v[0].fb(o))
return (car(x));
x = cdr(x);
if (!is_pair(x))
return (sc->F);
if (!is_pair(car(x)))
return (wrong_type_argument_with_type
(sc, sc->assoc_symbol, 2, cadr(args),
an_association_list_string));
slot_set_value(b, caar(x));
if (o->v[0].fb(o))
return (car(x));
x = cdr(x);
if (!is_pair(x))
return (sc->F);
slowx = cdr(slowx);
if (x == slowx)
return (sc->F);
}
return (sc->F);
}
}
}
/* member_if is similar. Do not call eval here with op_eval_done to return! An error will longjmp past the
* assoc point, leaving the op_eval_done on the stack, causing s7 to quit.
*/
if (type(eq_func) < T_CONTINUATION)
return (method_or_bust_with_type_one_arg
(sc, eq_func, sc->assoc_symbol, args,
a_procedure_string));
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);
y = list_1(sc, args);
set_opt1_fast(y, x);
set_opt2_slow(y, x);
push_stack(sc, OP_ASSOC_IF, list_1_unchecked(sc, y), eq_func);
if (needs_copied_args(eq_func))
push_stack(sc, OP_APPLY,
list_2_unchecked(sc, car(args), caar(x)), eq_func);
else {
set_car(sc->t2_1, car(args));
set_car(sc->t2_2, caar(x));
push_stack(sc, OP_APPLY, sc->t2_1, eq_func);
}
return (sc->unspecified);
}
if (is_null(x))
return (sc->F);
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 assoc_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
return (g_assoc(sc, set_plist_2(sc, p1, p2)));
}
static bool op_assoc_if(s7_scheme * sc)
{
s7_pointer orig_args = car(sc->args);
/* code=func, args=(list (list args)) with f/opt1_fast=list, value=result of comparison
* (assoc 3 '((1 . a) (2 . b) (3 . c) (4 . d)) =)
*/
if (sc->value != sc->F) { /* previous comparison was not #f -- return (car list) */
sc->value = car(opt1_fast(orig_args));
return (true);
}
if (!is_pair(cdr(opt1_fast(orig_args)))) { /* (assoc 3 '((1 . 2) . 3) =) or nil */
sc->value = sc->F;
return (true);
}
set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */
if (sc->cur_op == OP_ASSOC_IF1) {
/* circular list check */
if (opt1_fast(orig_args) == opt2_slow(orig_args)) {
sc->value = sc->F;
return (true);
}
set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list */
push_stack_direct(sc, OP_ASSOC_IF);
} else
push_stack_direct(sc, OP_ASSOC_IF1);
if (!is_pair(car(opt1_fast(orig_args)))) /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */
eval_error_any(sc, sc->wrong_type_arg_symbol,
"assoc: second argument is not an alist: ~S", 42,
orig_args);
/* not sure about this -- we could simply skip the entry both here and in g_assoc
* (assoc 1 '((2 . 2) 3)) -> #f
* (assoc 1 '((2 . 2) 3) =) -> error currently
*/
if (needs_copied_args(sc->code))
sc->args = list_2(sc, caar(orig_args), caar(opt1_fast(orig_args)));
else
sc->args =
set_plist_2(sc, caar(orig_args), caar(opt1_fast(orig_args)));
return (false);
}
static s7_pointer assoc_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
if (!ops)
return (f);
if ((args == 3) && (is_normal_symbol(cadddr(expr)))) {
if (cadddr(expr) == sc->is_eq_symbol)
return (global_value(sc->assq_symbol));
if (cadddr(expr) == sc->is_eqv_symbol)
return (global_value(sc->assv_symbol));
}
return (f);
}
/* ---------------- member, memv, memq ---------------- */
s7_pointer s7_memq(s7_scheme * sc, s7_pointer obj, s7_pointer x)
{
s7_pointer y = x;
while (true) {
LOOP_4(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 memq_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
return ((is_pair(y)) ? s7_memq(sc, x, y) :
((is_null(y)) ? sc->F :
method_or_bust_with_type_pp(sc, y, sc->memq_symbol, x, y,
a_list_string, 2)));
}
static s7_pointer g_memq(s7_scheme * sc, s7_pointer args)
{
#define H_memq "(memq obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memq uses eq?"
#define Q_memq sc->pl_tl
s7_pointer x = car(args), y = cadr(args);
if (is_pair(y))
return (s7_memq(sc, x, y));
if (is_null(y))
return (sc->F);
return (method_or_bust_with_type_pp
(sc, y, sc->memq_symbol, x, y, a_list_string, 2));
}
/* I think (memq 'c '(a b . c)) should return #f because otherwise (memq () ...) would return the () at the end. */
/* if memq's list is a quoted list, it won't be changing, so we can tell ahead of time that it is a proper list, and what its length is. */
static s7_pointer g_memq_2(s7_scheme * sc, s7_pointer args)
{
s7_pointer x = cadr(args), obj = car(args);
if (obj == car(x))
return (x);
return ((obj == cadr(x)) ? cdr(x) : sc->F);
}
static s7_pointer memq_2_p_pp(s7_scheme * sc, s7_pointer obj, s7_pointer x)
{
if (obj == car(x))
return (x);
return ((obj == cadr(x)) ? cdr(x) : sc->F);
}
static s7_pointer memq_3_p_pp(s7_scheme * sc, s7_pointer obj, s7_pointer x)
{
if (obj == car(x))
return (x);
if (obj == cadr(x))
return (cdr(x));
return ((obj == caddr(x)) ? cddr(x) : sc->F);
}
static s7_pointer g_memq_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer 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 memq_4_p_pp(s7_scheme * sc, s7_pointer obj, s7_pointer x)
{
while (true) {
LOOP_4(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)
{
return (memq_4_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_memq_any(s7_scheme * sc, s7_pointer args)
{
/* no circular list check needed in this case */
s7_pointer x = cadr(args), obj = car(args);
while (true) {
LOOP_4(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, int32_t args,
s7_pointer expr, bool ops)
{
s7_pointer lst = caddr(expr);
if ((is_proper_quote(sc, lst)) && (is_pair(cadr(lst)))) {
s7_int len;
len = s7_list_length(sc, cadr(lst));
if (len > 0) {
if (len == 2) /* this used to set opt3_any to cadr, but that doesn't survive call/cc's copy_stack */
return (sc->memq_2);
if ((len % 4) == 0)
return (sc->memq_4);
return (((len % 3) == 0) ? sc->memq_3 : sc->memq_any);
}
}
return (f);
}
static bool numbers_are_eqv(s7_scheme * sc, s7_pointer a, s7_pointer b)
{
#if WITH_GMP
if ((is_big_number(a)) || (is_big_number(b)))
return (big_numbers_are_eqv(sc, a, b));
#endif
if (type(a) != type(b))
return (false); /* (eqv? 1 1.0) -> #f! */
/* switch is apparently as expensive as 3-4 if's! so this only loses if every call involves complex numbers? */
if (is_t_integer(a))
return (integer(a) == integer(b));
if (is_t_real(a))
return ((!is_NaN(real(a))) && (real(a) == real(b)));
if (is_t_ratio(a))
return ((numerator(a) == numerator(b))
&& (denominator(a) == denominator(b)));
if (!is_t_complex(a))
return (false);
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)));
}
static s7_pointer memv_number(s7_scheme * sc, s7_pointer obj, s7_pointer x)
{
s7_pointer y = x;
while (true) {
LOOP_4(if ((is_number(car(x)))
&& (numbers_are_eqv(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);
}
static s7_pointer memv_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
s7_pointer z;
if (!is_pair(y)) {
if (is_null(y))
return (sc->F);
return (method_or_bust_with_type_pp
(sc, y, sc->memv_symbol, x, y, a_list_string, 2));
}
if (is_simple(x))
return (s7_memq(sc, x, y));
if (is_number(x))
return (memv_number(sc, x, y));
z = y;
while (true) {
if (s7_is_eqv(sc, x, car(y)))
return (y);
y = cdr(y);
if (!is_pair(y))
return (sc->F);
if (s7_is_eqv(sc, 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 sc->pl_tl
return (memv_p_pp(sc, car(args), cadr(args)));
}
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 s7_pointer member(s7_scheme * sc, s7_pointer obj, s7_pointer x)
{
s7_pointer 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);
} else
while (true) {
LOOP_4(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);
}
static bool p_to_b(opt_info * p);
static s7_pointer g_member(s7_scheme * sc, s7_pointer args)
{
#define H_member "(member obj list (func #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->not_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol)
/* this could be extended to accept sequences:
* (member #\a "123123abnfc" char=?) -> "abnfc"
* (member "abc" "123abc321" string=?) -> "abc321" but there's the string length complication
* (member 1 #(0 1 2) =) -> #(1 2) etc but what would it do for a hash-table?
* the third arg can be weird: (member #f (list #t) cons) -> (#t) -- cons returns '(#f . #t) which is true, so we get '(#t)
* should this be an error: (member '(1 2 3) () '(1 . 2)) -- the third arg is bogus, but the second is nil
*
* here as in assoc, sort, and make-hash-table we accept macros, but I can't think of a good reason to do so.
*/
s7_pointer x = cadr(args), obj, eq_func = NULL;
if ((!is_pair(x)) && (!is_null(x)))
return (method_or_bust_with_type
(sc, x, sc->member_symbol, args, a_list_string, 2));
if (is_not_null(cddr(args))) {
s7_pointer y, slow;
eq_func = caddr(args);
if ((is_c_function(eq_func)) && (is_safe_procedure(eq_func))) {
s7_function func = c_function_call(eq_func);
if (func == g_is_eq)
return (is_null(x) ? sc->F : s7_memq(sc, car(args), x));
if (func == g_is_eqv)
return (g_memv(sc, args));
if (func == g_less)
func = g_less_2;
else if (func == g_greater)
func = g_greater_2;
else if (!s7_is_aritable(sc, eq_func, 2))
return (wrong_type_argument_with_type
(sc, sc->member_symbol, 3, eq_func,
an_eq_func_string));
set_car(sc->t2_1, car(args));
for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) {
set_car(sc->t2_2, car(x));
if (is_true(sc, func(sc, sc->t2_1)))
return (x);
if (!is_pair(cdr(x)))
return (sc->F);
x = cdr(x);
if (x == slow)
return (sc->F);
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 */
(is_null(cddr(closure_args(eq_func))))) { /* arity == 2 */
s7_pointer body = closure_body(eq_func);
if (is_null(x))
return (sc->F);
if ((!no_bool_opt(body)) && (is_null(cdr(body)))) {
s7_pfunc func;
sc->curlet =
make_let_with_two_slots(sc, sc->curlet,
car(closure_args(eq_func)),
car(args),
cadr(closure_args(eq_func)),
sc->F);
func = s7_bool_optimize(sc, body);
if (func) {
opt_info *o = sc->opts[0];
s7_pointer b;
b = next_slot(let_slots(sc->curlet));
if (o->v[0].fb == p_to_b) {
s7_pointer(*fp) (opt_info * o);
fp = o->v[O_WRAP].fp;
for (slow = x; is_pair(x);
x = cdr(x), slow = cdr(slow)) {
slot_set_value(b, car(x));
if (fp(o) != sc->F)
return (x);
if (!is_pair(cdr(x)))
return (sc->F);
x = cdr(x);
if (x == slow)
return (sc->F);
slot_set_value(b, car(x));
if (fp(o) != sc->F)
return (x);
}
} else
for (slow = x; is_pair(x);
x = cdr(x), slow = cdr(slow)) {
slot_set_value(b, car(x));
if (o->v[0].fb(o))
return (x);
if (!is_pair(cdr(x)))
return (sc->F);
x = cdr(x);
if (x == slow)
return (sc->F);
slot_set_value(b, car(x));
if (o->v[0].fb(o))
return (x);
}
return (sc->F);
}
set_no_bool_opt(body);
}
}
if (type(eq_func) < T_CONTINUATION)
return (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);
y = list_1(sc, args); /* this could probably be handled with a counter cell (cdr here is unused) */
set_opt1_fast(y, x);
set_opt2_slow(y, x);
push_stack(sc, OP_MEMBER_IF, list_1_unchecked(sc, y), eq_func);
if (needs_copied_args(eq_func))
push_stack(sc, OP_APPLY,
list_2_unchecked(sc, car(args), car(x)), eq_func);
else {
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);
}
if (is_null(x))
return (sc->F);
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 (is_number(obj))
return (memv_number(sc, obj, x));
return (member(sc, obj, x));
}
static s7_pointer member_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
return (g_member(sc, set_plist_2(sc, p1, p2)));
}
static s7_pointer member_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (!ops)
return (f);
if ((args == 3) && (is_normal_symbol(cadddr(expr)))) {
if (cadddr(expr) == sc->is_eq_symbol)
return (memq_chooser
(sc, global_value(sc->memq_symbol), 2, expr, ops));
if (cadddr(expr) == sc->is_eqv_symbol)
return (global_value(sc->memv_symbol));
}
return (f);
}
static bool op_member_if(s7_scheme * sc)
{
s7_pointer orig_args = car(sc->args);
/* code=func, args = (list (list original args)) with opt1_fast->position in cadr (the list),
* the extra indirection (list (list...)) is needed because call/cc copies arg lists
* value = result of comparison
*/
if (sc->value != sc->F) { /* previous comparison was not #f -- return list */
sc->value = opt1_fast(orig_args);
return (true);
}
if (!is_pair(cdr(opt1_fast(orig_args)))) { /* no more args -- return #f */
sc->value = sc->F;
return (true);
}
set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */
if (sc->cur_op == OP_MEMBER_IF1) {
/* circular list check */
if (opt1_fast(orig_args) == opt2_slow(orig_args)) {
sc->value = sc->F;
return (true);
}
set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list (check for circular list) */
push_stack_direct(sc, OP_MEMBER_IF);
} else
push_stack_direct(sc, OP_MEMBER_IF1);
if (needs_copied_args(sc->code))
sc->args = list_2(sc, caar(orig_args), car(opt1_fast(orig_args)));
else
sc->args =
set_plist_2(sc, caar(orig_args), car(opt1_fast(orig_args)));
return (false);
}
/* -------------------------------- list -------------------------------- */
static s7_pointer g_list(s7_scheme * sc, s7_pointer args)
{
#define H_list "(list ...) returns its arguments in a list"
#define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T)
return (copy_proper_list(sc, args));
}
static s7_pointer g_list_0(s7_scheme * sc, s7_pointer args)
{
return (sc->nil);
}
static s7_pointer g_list_1(s7_scheme * sc, s7_pointer args)
{
return (list_1(sc, car(args)));
}
static s7_pointer g_list_2(s7_scheme * sc, s7_pointer args)
{
return (list_2(sc, car(args), cadr(args)));
}
static s7_pointer g_list_3(s7_scheme * sc, s7_pointer args)
{
return (list_3(sc, car(args), cadr(args), caddr(args)));
}
static s7_pointer g_list_4(s7_scheme * sc, s7_pointer args)
{
s7_pointer p = cddr(args);
return (list_4(sc, car(args), cadr(args), car(p), cadr(p)));
}
static s7_pointer list_chooser(s7_scheme * sc, s7_pointer f, int32_t args,
s7_pointer expr, bool ops)
{
if (args == 0)
return (sc->list_0);
if (args == 1)
return (sc->list_1);
if (args == 2)
return (sc->list_2);
if (args == 3)
return (sc->list_3);
return ((args == 4) ? sc->list_4 : f);
}
static s7_pointer list_p_p(s7_scheme * sc, s7_pointer p1)
{
return (list_1(sc, p1));
}
static s7_pointer list_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2)
{
return (list_2(sc, p1, p2));
}
static s7_pointer list_p_ppp(s7_scheme * sc, s7_pointer p1, s7_pointer p2,
s7_pointer p3)
{
return (list_3(sc, p1, p2, p3));
}
/* these used to GC protect the args, but I think the GC protection belonged in make-list */
static void check_list_validity(s7_scheme * sc, const char *caller,
s7_pointer lst)
{
s7_pointer p;
int32_t i;
for (i = 1, p = lst; is_pair(p); p = cdr(p), i++)
if (!s7_is_valid(sc, car(p)))
s7_warn(sc, 256, "bad argument (#%d) to %s: %p\n", i, caller,
car(p));
}
s7_pointer s7_list(s7_scheme * sc, s7_int num_values, ...)
{
s7_int i;
va_list ap;
s7_pointer p;
if (num_values == 0)
return (sc->nil);
sc->w = make_list(sc, num_values, sc->nil);
va_start(ap, num_values);
for (i = 0, p = sc->w; i < num_values; i++, p = cdr(p))
set_car(p, va_arg(ap, s7_pointer));
va_end(ap);
if (sc->safety > NO_SAFETY)
check_list_validity(sc, "s7_list", sc->w);
p = sc->w;
sc->w = sc->nil;
return (p);
}
s7_pointer s7_list_nl(s7_scheme * sc, s7_int num_values, ...)
{ /* arglist should be NULL terminated */
s7_int i;
va_list ap;
s7_pointer p, q;
if (num_values == 0)
return (sc->nil);
sc->w = make_list(sc, num_values, sc->nil);
va_start(ap, num_values);
for (q = sc->w, i = 0; i < num_values; i++, q = cdr(q)) {
p = va_arg(ap, s7_pointer);
if (!p) {
va_end(ap);
return (s7_wrong_number_of_args_error(sc, "not enough arguments for s7_list_nl: ~S", sc->w)); /* ideally we'd sublist this and append extra below */
}
set_car(q, p);
}
p = va_arg(ap, s7_pointer);
va_end(ap);
if (p)
return (s7_wrong_number_of_args_error
(sc, "too many arguments for s7_list_nl: ~S", sc->w));
if (sc->safety > NO_SAFETY)
check_list_validity(sc, "s7_list_nl", sc->w);
p = sc->w;
sc->w = sc->nil;
return (p);
}
static s7_pointer safe_list_1(s7_scheme * sc)
{
if (!list_is_in_use(sc->safe_lists[1])) {
sc->current_safe_list = 1;
set_list_in_use(sc->safe_lists[1]);
return (sc->safe_lists[1]);
}
return (cons(sc, sc->nil, sc->nil));
}
static s7_pointer safe_list_2(s7_scheme * sc)
{
if (!list_is_in_use(sc->safe_lists[2])) {
sc->current_safe_list = 2;
set_list_in_use(sc->safe_lists[2]);
return (sc->safe_lists[2]);
}
return (cons_unchecked(sc, sc->nil, list_1(sc, sc->nil)));
}
static s7_pointer make_safe_list(s7_scheme * sc, s7_int num_args)
{
if (num_args < NUM_SAFE_LISTS) {
sc->current_safe_list = num_args;
if (!is_pair(sc->safe_lists[num_args]))
sc->safe_lists[num_args] = permanent_list(sc, num_args);
if (!list_is_in_use(sc->safe_lists[num_args])) {
set_list_in_use(sc->safe_lists[num_args]);
return (sc->safe_lists[num_args]);
}
}
return (make_big_list(sc, num_args, sc->nil));
}
static inline s7_pointer safe_list_if_possible(s7_scheme * sc,
s7_int num_args)
{
if ((num_args < NUM_SAFE_PRELISTS) &&
(!list_is_in_use(sc->safe_lists[num_args]))) {
sc->current_safe_list = num_args;
set_list_in_use(sc->safe_lists[num_args]);
return (sc->safe_lists[num_args]);
}
return (make_safe_list(sc, num_args));
}
static s7_int sequence_length(s7_scheme * sc, s7_pointer lst);
static s7_pointer s7_copy_1(s7_scheme * sc, s7_pointer caller,
s7_pointer args);
static s7_pointer g_list_append(s7_scheme * sc, s7_pointer args)
{
s7_pointer y, tp = sc->nil, np = NULL, pp;
bool all_args_are_lists = true;
/* we know here that car(args) is a list and cdr(args) is not nil; this function does not check sc->max_list_length; called only in g_append */
s7_gc_protect_via_stack(sc, args);
for (y = args; is_pair(y); y = cdr(y)) { /* arglist so not dotted */
s7_pointer p = car(y), func;
if ((has_active_methods(sc, p)) &&
((func =
find_method_with_let(sc, p,
sc->append_symbol)) != sc->undefined)) {
unstack(sc);
return (call_method
(sc, p, func,
(is_null(tp)) ? y : set_ulist_1(sc, tp, y)));
}
if (is_null(cdr(y))) {
if (is_null(tp)) {
unstack(sc);
return (p);
}
/* (append (list 1) "hi") should return '(1 . "hi") not '(1 #\h #\i)
* but this is inconsistent with (append (list 1) "hi" "hi") -> '(1 #\h #\i . "hi") ?
* Perhaps if all args but last are lists, returned dotted list?
*/
if ((all_args_are_lists) || (is_null(p)))
set_cdr(np, p);
else {
s7_int len;
len = sequence_length(sc, p);
if (len > 0)
set_cdr(np,
s7_copy_1(sc, sc->append_symbol,
set_plist_2(sc, p,
protected_make_list(sc,
len,
sc->F))));
else if (len < 0)
set_cdr(np, p);
}
sc->y = sc->nil;
unstack(sc);
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 (!s7_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));
}
if (is_null(tp)) {
tp = list_1(sc, car(p));
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, list_1(sc, car(pp)));
} else {
s7_int len;
len = sequence_length(sc, p);
all_args_are_lists = false;
if (len > 0) {
if (is_null(tp)) {
tp = s7_copy_1(sc, sc->append_symbol,
set_plist_2(sc, p,
protected_make_list(sc,
len,
sc->F)));
np = tp;
sc->y = tp;
} else
set_cdr(np,
s7_copy_1(sc, sc->append_symbol,
set_plist_2(sc, p,
protected_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));
}
}
}
unstack(sc);
return (tp);
}
static s7_pointer append_in_place(s7_scheme * sc, s7_pointer a,
s7_pointer b)
{
/* tack b onto the end of a without copying either -- 'a' is changed! */
s7_pointer p;
if (is_null(a))
return (b);
p = a;
while (is_not_null(cdr(p)))
p = cdr(p);
set_cdr(p, b);
return (a);
}
/* -------------------------------- vectors -------------------------------- */
bool s7_is_vector(s7_pointer p)
{
return (is_any_vector(p));
}
bool s7_is_float_vector(s7_pointer p)
{
return (is_float_vector(p));
}
bool s7_is_int_vector(s7_pointer p)
{
return (is_int_vector(p));
}
static bool is_byte_vector_b_p(s7_pointer b)
{
return (is_byte_vector(b));
}
s7_int s7_vector_length(s7_pointer vec)
{
return (vector_length(vec));
}
static s7_pointer 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 typed_vector_typer_symbol(s7_scheme * sc, s7_pointer p)
{
s7_pointer typer = typed_vector_typer(p);
return ((is_c_function(typer)) ? c_function_symbol(typer) :
find_closure(sc, typer, closure_let(typer)));
}
static const char *typed_vector_typer_name(s7_scheme * sc, s7_pointer p)
{
s7_pointer typer = typed_vector_typer(p);
return ((is_c_function(typer)) ? c_function_name(typer) :
symbol_name(typed_vector_typer_symbol(sc, p)));
}
static const char *make_type_name(s7_scheme * sc, const char *name,
article_t article);
static inline s7_pointer typed_vector_setter(s7_scheme * sc,
s7_pointer vec, s7_int loc,
s7_pointer val)
{
if ((sc->safety < NO_SAFETY) || /* or == NO_SAFETY?? */
(typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) != sc->F)) {
vector_element(vec, loc) = val;
return (val);
}
return (s7_wrong_type_arg_error
(sc, "vector-set!", 3, val,
make_type_name(sc, typed_vector_typer_name(sc, vec),
INDEFINITE_ARTICLE)));
}
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_getter(s7_scheme * sc, s7_pointer vec,
s7_int loc)
{
return (make_integer(sc, int_vector(vec, loc)));
}
static s7_pointer float_vector_getter(s7_scheme * sc, s7_pointer vec,
s7_int loc)
{
return (make_real(sc, float_vector(vec, loc)));
}
static s7_pointer byte_vector_getter(s7_scheme * sc, s7_pointer bv,
s7_int loc)
{
return (make_integer(sc, (uint8_t) (byte_vector(bv, loc))));
}
static s7_pointer int_vector_setter(s7_scheme * sc, s7_pointer vec,
s7_int loc, s7_pointer val)
{
if (s7_is_integer(val))
int_vector(vec, loc) = s7_integer_checked(sc, val);
else
s7_wrong_type_arg_error(sc, "int-vector-set!", 3, val,
"an integer");
return (val);
}
static s7_pointer float_vector_setter(s7_scheme * sc, s7_pointer vec,
s7_int loc, s7_pointer val)
{
float_vector(vec, loc) = real_to_double(sc, val, "float-vector-set!");
return (val);
}
static s7_pointer byte_vector_setter(s7_scheme * sc, s7_pointer str,
s7_int loc, s7_pointer val)
{
s7_int byte;
if (!s7_is_integer(val))
return (s7_wrong_type_arg_error
(sc, "byte-vector-set!", 3, val, "an integer"));
byte = s7_integer_checked(sc, val);
if ((byte >= 0) && (byte < 256)) {
byte_vector(str, loc) = (uint8_t) byte;
return (val);
}
return (s7_wrong_type_arg_error
(sc, "byte-vector-set!", 3, val, "a byte"));
}
static Inline block_t *mallocate_vector(s7_scheme * sc, s7_int len)
{
block_t *b;
if (len > 0)
return (mallocate(sc, len));
b = mallocate_block(sc);
block_data(b) = NULL;
block_info(b) = NULL;
return (b);
}
static inline s7_pointer make_simple_vector(s7_scheme * sc, s7_int len)
{ /* len >= 0 and < max */
s7_pointer x;
block_t *b;
new_cell(sc, x, T_VECTOR | T_SAFE_PROCEDURE);
vector_length(x) = len;
b = mallocate_vector(sc, len * sizeof(s7_pointer));
vector_block(x) = b;
vector_elements(x) = (s7_pointer *) block_data(b);
vector_set_dimension_info(x, NULL);
vector_getter(x) = default_vector_getter;
vector_setter(x) = default_vector_setter;
add_vector(sc, x);
return (x);
}
static inline s7_pointer make_simple_float_vector(s7_scheme * sc,
s7_int len)
{ /* len >= 0 and < max */
s7_pointer x;
block_t *b;
new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE);
vector_length(x) = len;
b = mallocate_vector(sc, len * sizeof(s7_double));
vector_block(x) = b;
float_vector_floats(x) = (s7_double *) block_data(b);
vector_set_dimension_info(x, NULL);
vector_getter(x) = float_vector_getter;
vector_setter(x) = float_vector_setter;
add_vector(sc, x);
return (x);
}
static inline s7_pointer make_simple_int_vector(s7_scheme * sc, s7_int len)
{ /* len >= 0 and < max */
s7_pointer x;
block_t *b;
new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE);
vector_length(x) = len;
b = mallocate_vector(sc, len * sizeof(s7_int));
vector_block(x) = b;
int_vector_ints(x) = (s7_int *) block_data(b);
vector_set_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 make_simple_byte_vector(s7_scheme * sc, s7_int len)
{
s7_pointer x;
block_t *b;
new_cell(sc, x, T_BYTE_VECTOR | T_SAFE_PROCEDURE);
b = mallocate(sc, len);
vector_block(x) = b;
byte_vector_bytes(x) = (uint8_t *) block_data(b);
vector_length(x) = len;
vector_set_dimension_info(x, NULL);
vector_getter(x) = byte_vector_getter;
vector_setter(x) = byte_vector_setter;
add_vector(sc, x);
return (x);
}
static s7_pointer make_vector_1(s7_scheme * sc, s7_int len, bool filled,
uint8_t typ)
{
s7_pointer x;
if (len < 0)
return (wrong_type_argument_with_type
(sc, sc->make_vector_symbol, 1, wrap_integer1(sc, len),
a_non_negative_integer_string));
if (len > sc->max_vector_length)
return (out_of_range
(sc, sc->make_vector_symbol, int_one,
wrap_integer1(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);
vector_length(x) = len;
if (len == 0) {
vector_block(x) = mallocate_vector(sc, 0);
vector_elements(x) = NULL;
if (typ == T_VECTOR)
set_has_simple_elements(x);
} else {
block_t *b;
if (typ == T_VECTOR) {
b = mallocate_vector(sc, len * sizeof(s7_pointer));
vector_block(x) = b;
vector_elements(x) = (s7_pointer *) block_data(b);
vector_getter(x) = default_vector_getter;
vector_setter(x) = default_vector_setter;
if (filled)
s7_vector_fill(sc, x, sc->nil);
} else if (typ == T_FLOAT_VECTOR) {
b = mallocate_vector(sc, len * sizeof(s7_double));
vector_block(x) = b;
float_vector_floats(x) = (s7_double *) block_data(b);
if (filled) {
if (STEP_8(len))
memclr64((void *) vector_elements(x),
len * sizeof(s7_double));
else
memclr((void *) vector_elements(x),
len * sizeof(s7_double));
}
vector_getter(x) = float_vector_getter;
vector_setter(x) = float_vector_setter;
} else if (typ == T_INT_VECTOR) {
b = mallocate_vector(sc, len * sizeof(s7_int));
vector_block(x) = b;
int_vector_ints(x) = (s7_int *) block_data(b);
if (filled) {
if (STEP_8(len))
memclr64((void *) vector_elements(x),
len * sizeof(s7_int));
else
memclr((void *) vector_elements(x),
len * sizeof(s7_int));
}
vector_getter(x) = int_vector_getter;
vector_setter(x) = int_vector_setter;
} else { /* byte-vector */
b = mallocate(sc, len);
vector_block(x) = b;
byte_vector_bytes(x) = (uint8_t *) block_data(b);
vector_getter(x) = byte_vector_getter;
vector_setter(x) = byte_vector_setter;
if (filled) {
if (STEP_64(len))
memclr64((void *) (byte_vector_bytes(x)), len);
else
memclr((void *) (byte_vector_bytes(x)), len);
}
}}
vector_set_dimension_info(x, NULL);
return (x);
}
#define FILLED true
#define NOT_FILLED false
s7_pointer s7_make_vector(s7_scheme * sc, s7_int len)
{
s7_pointer v;
v = make_vector_1(sc, len, FILLED, T_VECTOR);
add_vector(sc, v);
return (v);
}
s7_pointer s7_make_and_fill_vector(s7_scheme * sc, s7_int len,
s7_pointer fill)
{
s7_pointer vect;
vect = make_simple_vector(sc, len);
s7_vector_fill(sc, vect, fill);
return (vect);
}
static vdims_t *make_wrap_only(s7_scheme * sc)
{ /* this makes sc->wrap_only */
vdims_t *v;
v = (vdims_t *) mallocate_block(sc);
vdims_original(v) = sc->F;
vector_elements_should_be_freed(v) = false;
vdims_rank(v) = 1;
vdims_dims(v) = NULL;
vdims_offsets(v) = NULL;
return (v);
}
static vdims_t *make_vdims(s7_scheme * sc, bool elements_should_be_freed,
s7_int dims, s7_int * dim_info)
{
vdims_t *v;
if ((dims == 1) && (!elements_should_be_freed))
return (sc->wrap_only);
if (dims > 1) {
s7_int i, offset = 1;
v = (vdims_t *) mallocate(sc, dims * 2 * sizeof(s7_int));
vdims_original(v) = sc->F;
vector_elements_should_be_freed(v) = elements_should_be_freed;
vdims_rank(v) = dims;
vdims_offsets(v) = (s7_int *) (vdims_dims(v) + dims);
for (i = 0; i < dims; i++)
vdims_dims(v)[i] = dim_info[i];
for (i = dims - 1; i >= 0; i--) {
vdims_offsets(v)[i] = offset;
offset *= vdims_dims(v)[i];
}
} else {
v = (vdims_t *) mallocate_block(sc);
vdims_original(v) = sc->F;
vector_elements_should_be_freed(v) = elements_should_be_freed;
vdims_rank(v) = 1;
vdims_dims(v) = NULL;
vdims_offsets(v) = NULL;
}
return (v);
}
static s7_pointer make_any_vector(s7_scheme * sc, int32_t type, s7_int len,
s7_int dims, s7_int * dim_info)
{
s7_pointer p;
p = make_vector_1(sc, len, FILLED, type);
if (dim_info) {
vector_set_dimension_info(p,
make_vdims(sc, false, dims, dim_info));
add_multivector(sc, p);
} else
add_vector(sc, p);
return (p);
}
s7_pointer s7_make_int_vector(s7_scheme * sc, s7_int len, s7_int dims,
s7_int * dim_info)
{
return (make_any_vector(sc, T_INT_VECTOR, len, dims, dim_info));
}
s7_pointer s7_make_float_vector(s7_scheme * sc, s7_int len, s7_int dims,
s7_int * dim_info)
{
return (make_any_vector(sc, T_FLOAT_VECTOR, len, dims, dim_info));
}
s7_pointer s7_make_normal_vector(s7_scheme * sc, s7_int len, s7_int dims,
s7_int * dim_info)
{
return (make_any_vector(sc, T_VECTOR, len, dims, dim_info));
}
s7_pointer s7_make_float_vector_wrapper(s7_scheme * sc, s7_int len,
s7_double * data, s7_int dims,
s7_int * dim_info, bool free_data)
{
/* this wraps up a C-allocated/freed double array as an s7 vector. */
s7_pointer x;
block_t *b;
new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE);
b = mallocate_vector(sc, 0);
vector_block(x) = b;
float_vector_floats(x) = data;
vector_getter(x) = float_vector_getter;
vector_setter(x) = float_vector_setter;
vector_length(x) = len;
if (!dim_info) {
s7_int di[1];
di[0] = len;
vector_set_dimension_info(x, make_vdims(sc, free_data, 1, di));
} else
vector_set_dimension_info(x,
make_vdims(sc, free_data, dims,
dim_info));
add_multivector(sc, x);
return (x);
}
/* -------------------------------- vector-fill! -------------------------------- */
static Vectorized void float_vector_fill(s7_scheme * sc, s7_pointer vec,
s7_double x)
{
s7_int len = vector_length(vec);
if (len == 0)
return;
if (x == 0.0) {
if (STEP_8(len))
memclr64((void *) float_vector_floats(vec),
len * sizeof(s7_double));
else
memclr((void *) float_vector_floats(vec),
len * sizeof(s7_double));
} else {
s7_int i = 0, left = len - 8;
s7_double *orig = float_vector_floats(vec);
while (i <= left)
LOOP_8(orig[i++] = x);
for (; i < len; i++)
orig[i] = x;
}
}
static Vectorized void int_vector_fill(s7_scheme * sc, s7_pointer vec,
s7_int k)
{
s7_int len = vector_length(vec);
if (len == 0)
return;
if (k == 0) {
if (STEP_8(len))
memclr64((void *) int_vector_ints(vec), len * sizeof(s7_int));
else
memclr((void *) int_vector_ints(vec), len * sizeof(s7_int));
} else {
s7_int i = 0, left = len - 8;
s7_int *orig = int_vector_ints(vec);
while (i <= left)
LOOP_8(orig[i++] = k);
for (; i < len; i++)
orig[i] = k;
}
}
static void byte_vector_fill(s7_scheme * sc, s7_pointer vec, uint8_t byte)
{
s7_int len = vector_length(vec);
if (len == 0)
return;
if (byte > 0)
local_memset((void *) (byte_vector_bytes(vec)), byte, len);
else /* byte == 0 */ if (STEP_64(len))
memclr64((void *) (byte_vector_bytes(vec)), len);
else
memclr((void *) (byte_vector_bytes(vec)), len);
}
static Vectorized void normal_vector_fill(s7_scheme * sc, s7_pointer vec,
s7_pointer obj)
{
s7_pointer *orig;
s7_int len = vector_length(vec), i, left;
if (len == 0)
return;
/* splitting out this part made no difference in speed; type check of obj is handled elsewhere */
orig = vector_elements(vec);
left = len - 8;
i = 0;
while (i <= left)
LOOP_8(orig[i++] = obj);
for (; i < len; i++)
orig[i] = obj;
}
void s7_vector_fill(s7_scheme * sc, s7_pointer vec, s7_pointer obj)
{
switch (type(vec)) {
case T_FLOAT_VECTOR:
if (!is_real(obj))
s7_wrong_type_arg_error(sc, "float-vector fill!", 2, obj,
"a real");
else
float_vector_fill(sc, vec, s7_real(obj));
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
int_vector_fill(sc, vec, s7_integer_checked(sc, obj));
break;
case T_BYTE_VECTOR:
if (!is_byte(obj))
s7_wrong_type_arg_error(sc, "byte-vector fill!", 2, obj,
"a byte");
else
byte_vector_fill(sc, vec,
(uint8_t) s7_integer_checked(sc, obj));
break;
case T_VECTOR:
default:
normal_vector_fill(sc, vec, obj);
}
}
static s7_pointer g_vector_fill_1(s7_scheme * sc, s7_pointer caller,
s7_pointer args)
{
s7_pointer x = car(args), fill;
s7_int start = 0, end;
if (!is_any_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, caller, 1, x, T_VECTOR));
}
if (is_immutable_vector(x))
return (immutable_object_error
(sc, set_elist_3(sc, immutable_error_string, caller, x)));
fill = cadr(args);
if ((is_typed_vector(x)) &&
(typed_vector_typer_call(sc, x, set_plist_1(sc, fill)) == sc->F))
s7_wrong_type_arg_error(sc, "vector fill!", 2, fill,
make_type_name(sc,
typed_vector_typer_name(sc,
x),
INDEFINITE_ARTICLE));
if (is_float_vector(x)) {
if (!is_real(fill)) /* possibly a bignum */
return (method_or_bust(sc, fill, caller, args, T_REAL, 2));
} else if ((is_int_vector(x)) || (is_byte_vector(x))) {
if (!s7_is_integer(fill))
return (method_or_bust(sc, fill, caller, args, T_INTEGER, 2));
if ((is_byte_vector(x)) && ((s7_integer_checked(sc, fill) < 0)
|| (s7_integer_checked(sc, fill) >
255)))
return (out_of_range
(sc, caller, int_two, fill, an_unsigned_byte_string));
}
end = vector_length(x);
if (!is_null(cddr(args))) {
s7_pointer p;
p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end);
if (p != sc->unused)
return (p);
if (start == end)
return (fill);
}
if (end == 0)
return (fill);
if ((start == 0) && (end == vector_length(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 = s7_integer_checked(sc, fill);
if (k == 0)
memclr((void *) (int_vector_ints(x) + start),
(end - start) * sizeof(s7_int));
else
for (i = start; i < end; i++)
int_vector(x, i) = k;
} else if (is_float_vector(x)) {
s7_double y = s7_real(fill);
if (y == 0.0)
memclr((void *) (float_vector_floats(x) + start),
(end - start) * sizeof(s7_double));
else {
s7_double *orig = float_vector_floats(x);
s7_int left = end - 8;
i = start;
while (i <= left)
LOOP_8(orig[i++] = y);
for (; i < end; i++)
orig[i] = y;
}
} else if (is_byte_vector(x)) {
uint8_t k = (uint8_t) s7_integer_checked(sc, fill);
if (k == 0)
memclr((void *) (byte_vector_bytes(x) + start),
end - start);
else
local_memset((void *) (byte_vector_bytes(x) + start), k,
end - start);
}
}
return (fill);
}
#if (!WITH_PURE_S7)
/* -------------------------------- vector-fill! -------------------------------- */
static s7_pointer g_vector_fill(s7_scheme * sc, s7_pointer args)
{
#define H_vector_fill "(vector-fill! v val start end) sets all elements of the vector v between start and end to val"
#define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->T, sc->is_integer_symbol)
return (g_vector_fill_1(sc, sc->vector_fill_symbol, args));
}
#endif
/* -------------------------------- vector-ref|set! -------------------------------- */
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, int_two,
wrap_integer1(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, int_two,
wrap_integer1(sc, index), its_too_large_string));
if (is_typed_vector(vec))
return (typed_vector_setter(sc, vec, index, a));
vector_setter(vec) (sc, vec, index, T_Pos(a));
return (a);
}
s7_pointer *s7_vector_elements(s7_pointer vec)
{
return (vector_elements(vec));
}
/* these are for s7.h */
s7_int *s7_int_vector_elements(s7_pointer vec)
{
return (int_vector_ints(vec));
}
s7_int s7_int_vector_ref(s7_pointer vec, s7_int index)
{
return (int_vector_ints(vec)[index]);
}
s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value)
{
int_vector_ints(vec)[index] = value;
return (value);
}
s7_double *s7_float_vector_elements(s7_pointer vec)
{
return (float_vector_floats(vec));
}
s7_double s7_float_vector_ref(s7_pointer vec, s7_int index)
{
return (float_vector_floats(vec)[index]);
}
s7_double s7_float_vector_set(s7_pointer vec, s7_int index,
s7_double value)
{
float_vector_floats(vec)[index] = value;
return (value);
}
s7_int s7_vector_dimensions(s7_pointer vec, s7_int * dims,
s7_int dims_size)
{
if (dims_size <= 0)
return (0);
if (vector_dimension_info(vec)) {
s7_int i, lim = vector_ndims(vec);
if (lim > dims_size)
lim = dims_size;
for (i = 0; i < lim; i++)
dims[i] = vector_dimension(vec, i);
return (lim);
}
dims[0] = vector_length(vec);
return (1);
}
s7_int s7_vector_dimension(s7_pointer vec, s7_int dim)
{
if (vector_dimension_info(vec))
return (vector_dimension(vec, dim));
return ((dim == 0) ? vector_length(vec) : -1);
}
s7_int s7_vector_offsets(s7_pointer vec, s7_int * offs, s7_int offs_size)
{
if (offs_size <= 0)
return (0);
if (vector_dimension_info(vec)) {
s7_int i, lim = vector_ndims(vec);
if (lim > offs_size)
lim = offs_size;
for (i = 0; i < lim; i++)
offs[i] = vector_offset(vec, i);
return (lim);
}
offs[0] = 1;
return (1);
}
#if (!WITH_PURE_S7)
/* -------------------------------- vector-append -------------------------------- */
static s7_pointer vector_append(s7_scheme * sc, s7_pointer args,
uint8_t typ, s7_pointer caller);
static s7_pointer copy_source_no_dest(s7_scheme * sc, s7_pointer caller,
s7_pointer source, s7_pointer args);
static s7_pointer g_vector_append(s7_scheme * sc, s7_pointer args)
{
/* returns a one-dimensional vector. To handle multidimensional vectors, we'd need to
* ensure all the dimensional data matches (rank, size of each dimension except the last etc),
* which is too much trouble.
*/
#define H_vector_append "(vector-append . vectors) returns a new (1-dimensional) vector containing the elements of its vector arguments."
#define Q_vector_append sc->pcl_v
s7_pointer p;
int32_t i;
if (is_null(args))
return (make_simple_vector(sc, 0));
if ((is_null(cdr(args))) && (is_any_vector(car(args))))
return (copy_source_no_dest
(sc, sc->vector_append_symbol, car(args), args));
for (i = 0, p = args; is_pair(p); p = cdr(p), i++) {
s7_pointer x = car(p);
if (!is_any_vector(x)) {
if (has_active_methods(sc, x)) {
s7_pointer func;
func =
find_method_with_let(sc, x, sc->vector_append_symbol);
if (func != sc->undefined) {
int32_t k;
s7_pointer v, y;
if (i == 0)
return (call_method(sc, x, 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 = call_method(sc, x, func, set_ulist_1(sc, v, p));
sc->temp9 = sc->nil;
return (y);
}
}
return (wrong_type_argument
(sc, sc->vector_append_symbol, i + 1, x, T_VECTOR));
}
}
return (vector_append
(sc, args, type(car(args)), sc->vector_append_symbol));
}
static s7_pointer vector_append_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
s7_pointer val;
sc->temp7 = list_2(sc, p1, p2);
val = g_vector_append(sc, sc->temp7);
sc->temp7 = sc->nil;
return (val);
}
static s7_pointer vector_append_p_ppp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2, s7_pointer p3)
{
s7_pointer val;
sc->temp7 = list_3(sc, p1, p2, p3);
val = g_vector_append(sc, sc->temp7);
sc->temp7 = sc->nil;
return (val);
}
#endif
static s7_int flatten_multivector_indices(s7_scheme * sc,
s7_pointer vector,
s7_int indices, va_list ap)
{
s7_int index, rank = vector_rank(vector);
if (rank != indices) {
va_end(ap);
s7_wrong_number_of_args_error(sc,
"s7_vector_ref_n: wrong number of indices: ~A",
wrap_integer1(sc, indices));
}
if (rank == 1)
index = va_arg(ap, s7_int);
else {
s7_int i;
s7_int *dimensions = vector_dimensions(vector), *offsets =
vector_offsets(vector);
for (i = 0, index = 0; i < indices; i++) {
s7_int ind;
ind = va_arg(ap, s7_int);
if ((ind < 0) || (ind >= dimensions[i])) {
va_end(ap);
out_of_range(sc, sc->vector_ref_symbol,
wrap_integer1(sc, i), wrap_integer1(sc, ind),
(ind <
0) ? its_negative_string :
its_too_large_string);
return (-1);
}
index += (ind * offsets[i]);
}
}
va_end(ap);
return (index);
}
s7_pointer s7_vector_ref_n(s7_scheme * sc, s7_pointer vector,
s7_int indices, ...)
{
s7_int index;
va_list ap;
va_start(ap, indices);
index = flatten_multivector_indices(sc, vector, indices, ap);
return (vector_getter(vector) (sc, vector, index));
}
s7_pointer s7_vector_set_n(s7_scheme * sc, s7_pointer vector,
s7_pointer value, s7_int indices, ...)
{
s7_int index;
va_list ap;
va_start(ap, indices);
index = flatten_multivector_indices(sc, vector, indices, ap);
if (is_typed_vector(vector))
return (typed_vector_setter(sc, vector, index, value));
return (vector_setter(vector) (sc, vector, index, value));
}
/* -------------------------------- vector->list -------------------------------- */
s7_pointer s7_vector_to_list(s7_scheme * sc, s7_pointer vect)
{
s7_int i, len = vector_length(vect);
s7_pointer result;
if (len == 0)
return (sc->nil);
check_free_heap_size(sc, len);
sc->v = sc->nil;
gc_protect_via_stack(sc, vect);
for (i = len - 1; i >= 0; i--)
sc->v = cons_unchecked(sc, vector_getter(vect) (sc, vect, i), sc->v); /* vector_getter can cause alloction/GC (int_vector_getter -> make_integer) */
unstack(sc);
result = sc->v;
sc->v = sc->nil;
return (result);
}
s7_pointer s7_array_to_list(s7_scheme * sc, s7_int num_values,
s7_pointer * array)
{
s7_int i;
s7_pointer result;
if (num_values == 0)
return (sc->nil);
sc->v = sc->nil;
for (i = num_values - 1; i >= 0; i--)
sc->v = cons(sc, array[i], sc->v);
result = sc->v;
if (sc->safety > NO_SAFETY)
check_list_validity(sc, "s7_array_to_list", result);
sc->v = sc->nil;
return (result);
}
#if (!WITH_PURE_S7)
static s7_pointer g_vector_to_list(s7_scheme * sc, s7_pointer args)
{
#define H_vector_to_list "(vector->list v (start 0) end) returns the elements of the vector v as a list; (map values v)"
#define Q_vector_to_list s7_make_signature(sc, 4, sc->is_proper_list_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol)
s7_int i, start = 0, end;
s7_pointer p, vec = car(args);
if (!is_any_vector(vec))
return (method_or_bust_one_arg
(sc, vec, sc->vector_to_list_symbol, args, T_VECTOR));
end = vector_length(vec);
if (!is_null(cdr(args))) {
p = start_and_end(sc, sc->vector_to_list_symbol, args, 2,
cdr(args), &start, &end);
if (p != sc->unused)
return (p);
if (start == end)
return (sc->nil);
}
if ((end - start) > sc->max_list_length)
return (out_of_range
(sc, sc->vector_to_list_symbol, int_one, car(args),
its_too_large_string));
check_free_heap_size(sc, end - start);
sc->w = sc->nil;
gc_protect_via_stack(sc, vec);
if (is_normal_vector(vec))
for (i = end - 1; i >= start; i--)
sc->w = cons_unchecked(sc, vector_element(vec, i), sc->w);
else
for (i = end - 1; i >= start; i--)
sc->w =
cons_unchecked(sc, vector_getter(vec) (sc, vec, i), sc->w);
unstack(sc);
p = sc->w;
sc->w = sc->nil;
return (p);
}
static s7_pointer vector_to_list_p_p(s7_scheme * sc, s7_pointer p)
{
if (!is_any_vector(p))
return (method_or_bust_one_arg_p
(sc, p, sc->vector_to_list_symbol, T_VECTOR));
return (s7_vector_to_list(sc, p));
}
#endif
/* -------------------------------- string->byte-vector -------------------------------- */
static s7_pointer g_string_to_byte_vector(s7_scheme * sc, s7_pointer args)
{
#define H_string_to_byte_vector "(string->byte-vector obj) turns a string into a byte-vector."
#define Q_string_to_byte_vector s7_make_signature(sc, 2, sc->is_byte_vector_symbol, sc->is_string_symbol)
s7_pointer str = car(args);
if (!is_string(str))
return (method_or_bust_p
(sc, str, sc->string_to_byte_vector_symbol, T_STRING));
return (s7_copy_1
(sc, sc->string_to_byte_vector_symbol,
set_plist_2(sc, str,
make_simple_byte_vector(sc,
string_length(str)))));
}
/* -------------------------------- byte-vector->string -------------------------------- */
static s7_pointer g_byte_vector_to_string(s7_scheme * sc, s7_pointer args)
{
#define H_byte_vector_to_string "(byte-vector->string obj) turns a byte-vector into a string."
#define Q_byte_vector_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_byte_vector_symbol)
s7_pointer v = car(args);
if (!is_byte_vector(v))
return (method_or_bust_p
(sc, v, sc->byte_vector_to_string_symbol, T_BYTE_VECTOR));
return (s7_copy_1
(sc, sc->byte_vector_to_string_symbol,
set_plist_2(sc, v,
make_empty_string(sc, byte_vector_length(v),
0))));
}
/* -------------------------------- vector -------------------------------- */
static s7_pointer g_vector(s7_scheme * sc, s7_pointer args)
{
#define H_vector "(vector ...) returns a vector whose elements are the arguments"
#define Q_vector s7_make_circular_signature(sc, 1, 2, sc->is_vector_symbol, sc->T)
s7_int len;
s7_pointer vec, b;
len = proper_list_length_with_end(args, &b);
if (!is_null(b))
return (s7_error
(sc, sc->read_error_symbol,
set_elist_1(sc,
wrap_string(sc,
"vector constant data is not a proper list",
41))));
vec = make_simple_vector(sc, len);
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 inline s7_pointer vector_p_pp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2)
{
s7_pointer vec;
vec = make_simple_vector(sc, 2);
vector_element(vec, 0) = p1;
vector_element(vec, 1) = p2;
return (vec);
}
static s7_pointer g_vector_2(s7_scheme * sc, s7_pointer args)
{
return (vector_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_vector_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer vec;
vec = make_simple_vector(sc, 3);
vector_element(vec, 0) = car(args);
args = cdr(args);
vector_element(vec, 1) = car(args);
vector_element(vec, 2) = cadr(args);
return (vec);
}
static s7_pointer vector_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 2)
return (sc->vector_2);
return ((args == 3) ? sc->vector_3 : f);
}
/* -------------------------------- float-vector? -------------------------------- */
static s7_pointer g_is_float_vector(s7_scheme * sc, s7_pointer args)
{
#define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogeneous float vector"
#define Q_is_float_vector sc->pl_bt
check_boolean_method(sc, s7_is_float_vector,
sc->is_float_vector_symbol, args);
}
/* -------------------------------- float-vector -------------------------------- */
static s7_pointer g_float_vector(s7_scheme * sc, s7_pointer args)
{
#define H_float_vector "(float-vector ...) returns an homogeneous float vector whose elements are the arguments"
#define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->is_float_vector_symbol, sc->is_real_symbol)
s7_int len;
s7_pointer vec, b;
len = proper_list_length_with_end(args, &b);
if (!is_null(b))
return (s7_error
(sc, sc->read_error_symbol,
set_elist_1(sc,
wrap_string(sc,
"float-vector constant data is not a proper list",
47))));
vec = make_simple_float_vector(sc, len);
if (len > 0) {
s7_int i;
s7_pointer x;
sc->w = vec;
for (x = args, i = 0; is_pair(x); x = cdr(x), i++) {
s7_pointer p = car(x);
if (is_t_real(p))
float_vector(vec, i) = real(p);
else if (is_real(p)) /* bignum is ok here */
float_vector(vec, i) = s7_real(p);
else {
sc->w = sc->nil;
return (method_or_bust
(sc, p, sc->float_vector_symbol, args, T_REAL,
i + 1));
}
}
sc->w = sc->nil;
}
return (vec);
}
static s7_pointer float_vector_p_d(s7_scheme * sc, s7_double x)
{
s7_pointer vec;
vec = make_simple_float_vector(sc, 1);
float_vector(vec, 0) = x;
return (vec);
}
/* -------------------------------- int-vector? -------------------------------- */
static s7_pointer g_is_int_vector(s7_scheme * sc, s7_pointer args)
{
#define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogeneous s7_int vector"
#define Q_is_int_vector sc->pl_bt
check_boolean_method(sc, is_int_vector, sc->is_int_vector_symbol,
args);
}
/* -------------------------------- int-vector -------------------------------- */
static s7_pointer g_int_vector(s7_scheme * sc, s7_pointer args)
{
#define H_int_vector "(int-vector ...) returns an homogeneous s7_int vector whose elements are the arguments"
#define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->is_int_vector_symbol, sc->is_integer_symbol)
s7_int i, len;
s7_pointer x, vec, b;
len = proper_list_length_with_end(args, &b);
if (!is_null(b))
return (s7_error
(sc, sc->read_error_symbol,
set_elist_1(sc,
wrap_string(sc,
"int-vector constant data is not a proper list",
45))));
vec = make_simple_int_vector(sc, len);
if (len == 0)
return (vec);
for (x = args, i = 0; is_pair(x); x = cdr(x), i++) {
s7_pointer p = car(x);
if (s7_is_integer(p))
int_vector(vec, i) = s7_integer_checked(sc, p);
else
return (method_or_bust
(sc, p, sc->int_vector_symbol, args, T_INTEGER,
i + 1));
}
return (vec);
}
static s7_pointer int_vector_p_i(s7_scheme * sc, s7_int x)
{
s7_pointer vec;
vec = make_simple_int_vector(sc, 1);
int_vector(vec, 0) = x;
return (vec);
}
/* -------------------------------- byte-vector? -------------------------------- */
static s7_pointer g_is_byte_vector(s7_scheme * sc, s7_pointer args)
{
#define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector"
#define Q_is_byte_vector sc->pl_bt
check_boolean_method(sc, is_byte_vector_b_p, sc->is_byte_vector_symbol,
args);
}
/* -------------------------------- byte-vector -------------------------------- */
static s7_pointer g_byte_vector(s7_scheme * sc, s7_pointer args)
{
#define H_byte_vector "(byte-vector ...) returns a byte-vector whose elements are the arguments"
#define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_byte_symbol)
s7_int i, len;
s7_pointer vec, x, end;
uint8_t *str;
len = proper_list_length_with_end(args, &end);
if (!is_null(end))
return (s7_error
(sc, sc->read_error_symbol,
set_elist_1(sc,
wrap_string(sc,
"byte-vector constant data is not a proper list",
46))));
vec = make_simple_byte_vector(sc, len);
str = byte_vector_bytes(vec);
for (i = 0, x = args; is_pair(x); i++, x = cdr(x)) {
s7_pointer byte = car(x);
s7_int b;
if (is_t_integer(byte))
b = integer(byte);
else
#if WITH_GMP
if (is_t_big_integer(byte))
b = big_integer_to_s7_int(sc, big_integer(byte));
else
#endif
return (method_or_bust
(sc, byte, sc->byte_vector_symbol, args, T_INTEGER,
i + 1));
if ((b < 0) || (b > 255))
return (simple_wrong_type_argument_with_type
(sc, sc->byte_vector_symbol, byte,
an_unsigned_byte_string));
str[i] = (uint8_t) b;
}
return (vec);
}
#if (!WITH_PURE_S7)
/* -------------------------------- list->vector -------------------------------- */
static s7_pointer g_list_to_vector(s7_scheme * sc, s7_pointer args)
{
#define H_list_to_vector "(list->vector lst) returns a vector containing the elements of lst; (apply vector lst)"
#define Q_list_to_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_proper_list_symbol)
s7_pointer p = car(args);
if (is_null(p))
return (s7_make_vector(sc, 0));
sc->temp3 = p;
if (!s7_is_proper_list(sc, p))
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->list_to_vector_symbol, a_proper_list_string));
p = g_vector(sc, p);
sc->temp3 = sc->nil;
return (p);
}
/* -------------------------------- vector-length -------------------------------- */
static s7_pointer g_vector_length(s7_scheme * sc, s7_pointer args)
{
#define H_vector_length "(vector-length v) returns the length of vector v"
#define Q_vector_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol)
s7_pointer vec = car(args);
if (!is_any_vector(vec))
return (method_or_bust_one_arg
(sc, vec, sc->vector_length_symbol, args, T_VECTOR));
return (make_integer(sc, vector_length(vec)));
}
static s7_int vector_length_i_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_any_vector(p))
return (integer
(method_or_bust_one_arg_p
(sc, p, sc->vector_length_symbol, T_VECTOR)));
return (vector_length(p));
}
static s7_pointer vector_length_p_p(s7_scheme * sc, s7_pointer vec)
{
if (!is_any_vector(vec))
return (method_or_bust_one_arg_p
(sc, vec, sc->vector_length_symbol, T_VECTOR));
return (make_integer(sc, vector_length(vec)));
}
#endif
/* -------------------------------- subvector subvector? subvector-vector subvector-position -------------------------------- */
static bool s7_is_subvector(s7_pointer g)
{
return ((is_any_vector(g)) && (is_subvector(g)));
}
static s7_pointer g_is_subvector(s7_scheme * sc, s7_pointer args)
{
#define H_is_subvector "(subvector? obj) returns #t if obj is a subvector"
#define Q_is_subvector sc->pl_bt
check_boolean_method(sc, s7_is_subvector, sc->is_subvector_symbol,
args);
}
static s7_pointer g_subvector_position(s7_scheme * sc, s7_pointer args)
{
#define H_subvector_position "(subvector-position obj) returns obj's offset"
#define Q_subvector_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_subvector_symbol)
s7_pointer sv = car(args);
if (s7_is_subvector(sv)) {
/* we can't use vector_elements(sv) - vector_elements(subvector_vector(sv)) because that assumes we're looking at s7_pointer*,
* so a subvector of a byte_vector gets a bogus position (0 if position is less than 8 etc).
* Since we currently let the user reset s7_int and s7_double, all four cases have to be handled explicitly.
*/
switch (type(sv)) {
case T_VECTOR:
return (make_integer
(sc,
(s7_int) (vector_elements(sv) -
vector_elements(subvector_vector(sv)))));
case T_INT_VECTOR:
return (make_integer
(sc,
(s7_int) (int_vector_ints(sv) -
int_vector_ints(subvector_vector(sv)))));
case T_FLOAT_VECTOR:
return (make_integer
(sc,
(s7_int) (float_vector_floats(sv) -
float_vector_floats(subvector_vector
(sv)))));
case T_BYTE_VECTOR:
return (make_integer
(sc,
(s7_int) (byte_vector_bytes(sv) -
byte_vector_bytes(subvector_vector(sv)))));
}
}
return (method_or_bust_one_arg
(sc, sv, sc->subvector_position_symbol, args, T_VECTOR));
}
static s7_pointer g_subvector_vector(s7_scheme * sc, s7_pointer args)
{
#define H_subvector_vector "(subvector-vector obj) returns the vector underlying the subvector obj"
#define Q_subvector_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_subvector_symbol)
if (s7_is_subvector(car(args)))
return (subvector_vector(car(args)));
return (method_or_bust_one_arg
(sc, car(args), sc->subvector_vector_symbol, args, T_VECTOR));
}
static s7_pointer subvector(s7_scheme * sc, s7_pointer vect,
s7_int skip_dims, s7_int index)
{
s7_pointer x;
s7_int dims;
new_cell(sc, x,
(full_type(vect) & (~T_COLLECTED)) | T_SUBVECTOR |
T_SAFE_PROCEDURE);
vector_length(x) = 0;
vector_block(x) = mallocate_vector(sc, 0);
vector_elements(x) = NULL;
vector_getter(x) = vector_getter(vect);
vector_setter(x) = vector_setter(vect);
dims = vector_ndims(vect) - skip_dims;
if (dims > 1) {
vdims_t *v;
v = (vdims_t *) mallocate_block(sc);
vdims_rank(v) = dims;
vdims_dims(v) = (s7_int *) (vector_dimensions(vect) + skip_dims);
vdims_offsets(v) = (s7_int *) (vector_offsets(vect) + skip_dims);
vdims_original(v) = vect;
vector_elements_should_be_freed(v) = false;
vector_set_dimension_info(x, v);
} else {
vector_set_dimension_info(x, NULL);
subvector_set_vector(x, vect);
}
if (is_normal_vector(vect))
mark_function[T_VECTOR] = mark_vector_possibly_shared;
else
mark_function[type(vect)] =
mark_int_or_float_vector_possibly_shared;
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_ints(x) = (s7_int *) (int_vector_ints(vect) + index);
else if (is_float_vector(vect))
float_vector_floats(x) =
(s7_double *) (float_vector_floats(vect) + index);
else if (is_normal_vector(vect))
vector_elements(x) =
(s7_pointer *) (vector_elements(vect) + index);
else
byte_vector_bytes(x) =
(uint8_t *) (byte_vector_bytes(vect) + index);
add_multivector(sc, x);
return (x);
}
static inline vdims_t *list_to_dims(s7_scheme * sc, s7_pointer x)
{
s7_int i, offset, len;
s7_pointer y;
vdims_t *v;
s7_int *ds, *os;
len = proper_list_length(x);
v = (vdims_t *) mallocate(sc, len * 2 * sizeof(s7_int));
vdims_rank(v) = len;
vdims_offsets(v) = (s7_int *) (vdims_dims(v) + len);
vector_elements_should_be_freed(v) = false;
ds = vdims_dims(v);
os = vdims_offsets(v);
for (i = 0, y = x; is_not_null(y); i++, y = cdr(y))
ds[i] = s7_integer_checked(sc, car(y));
for (i = len - 1, offset = 1; i >= 0; i--) {
os[i] = offset;
offset *= ds[i];
}
return (v);
}
static s7_pointer g_subvector(s7_scheme * sc, s7_pointer args)
{
#define H_subvector "(subvector original-vector (start 0) (end original-vector-len) new-dimensions) returns \
a vector that points to the same elements as the original-vector but with different starting point, end point, and dimensional info."
#define Q_subvector s7_make_signature(sc, 5, sc->is_subvector_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_pair_symbol)
/* (let ((v1 #2d((1 2 3) (4 5 6)))) (let ((v2 (subvector v1 0 6))) v2)) -> #(1 2 3 4 5 6)
* (let ((v1 #(1 2 3 4 5 6))) (let ((v2 (subvector v1 0 6 '(3 2)))) v2)) -> #2D((1 2) (3 4) (5 6))
*/
/* for a long time subvector was (subvector vector new-length-or-dimensions (new-start 0))
* but that turned out to be confusing (start after end in effect, the reverse of substring and others)
* Here is a translation:
(define (old-subvector vect len (offset 0))
(if (pair? len)
(subvector vect offset (+ offset (apply * len)) len)
(if (not len)
(subvector vect offset (vector-length vect))
(subvector vect offset (+ offset len)))))
*/
s7_pointer orig = car(args), x;
vdims_t *v = NULL;
s7_int new_len, orig_len, offset = 0;
/* get the vector */
if (!is_any_vector(orig))
return (method_or_bust
(sc, orig, sc->subvector_symbol, args, T_VECTOR, 1));
orig_len = vector_length(orig);
new_len = orig_len;
if (is_pair(cdr(args))) {
/* get start point in vector */
s7_pointer start = cadr(args);
if (!s7_is_integer(start))
return (method_or_bust
(sc, start, sc->subvector_symbol, args, T_INTEGER, 2));
offset = s7_integer_checked(sc, start);
if ((offset < 0) || (offset > orig_len)) /* we need this if, for example, offset == 9223372036854775807 */
return (out_of_range
(sc, sc->subvector_symbol, int_two, start,
(offset <
0) ? its_negative_string : its_too_large_string));
new_len -= offset;
if (is_pair(cddr(args))) {
/* get end point in vector */
s7_pointer end = caddr(args);
s7_int new_end;
if (!s7_is_integer(end))
return (method_or_bust
(sc, end, sc->subvector_symbol, args, T_INTEGER,
3));
new_end = s7_integer_checked(sc, end);
if ((new_end < 0) || (new_end > orig_len))
return (out_of_range
(sc, sc->subvector_symbol, int_three, end,
(new_end <
0) ? its_negative_string :
its_too_large_string));
if (offset > new_end)
return (out_of_range
(sc, sc->subvector_symbol, int_two, start,
wrap_string(sc, "start point > end point", 23)));
new_len = new_end - offset;
if (is_pair(cdddr(args))) {
s7_pointer y, dims = cadddr(args);
s7_int i;
if ((is_null(dims)) || (!s7_is_proper_list(sc, dims)))
return (method_or_bust
(sc, dims, sc->subvector_symbol, args, T_PAIR,
4));
for (y = dims; is_pair(y); y = cdr(y))
if ((!s7_is_integer(car(y))) || /* (subvector v '((1 2) (3 4))) */
(s7_integer_checked(sc, car(y)) > orig_len) ||
(s7_integer_checked(sc, car(y)) < 0))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_1(sc,
wrap_string(sc,
"a subvector must fit in the original vector",
43))));
v = list_to_dims(sc, dims);
new_len = vdims_dims(v)[0];
for (i = 1; i < vdims_rank(v); i++)
new_len *= vdims_dims(v)[i];
if (new_len != new_end - offset)
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"subvector dimensional length, ~S, does not match the start and end positions: ~S to ~S~%",
88),
s7_make_integer(sc, new_len),
start, end));
vdims_original(v) = orig;
}
}
}
if (is_normal_vector(orig))
mark_function[T_VECTOR] = mark_vector_possibly_shared;
else
mark_function[type(orig)] = mark_int_or_float_vector_possibly_shared; /* I think this works for byte-vectors also */
new_cell(sc, x,
(full_type(orig) & (~T_COLLECTED)) | T_SUBVECTOR |
T_SAFE_PROCEDURE);
vector_block(x) = mallocate_vector(sc, 0);
vector_set_dimension_info(x, v);
if (!v)
subvector_set_vector(x, orig);
vector_length(x) = new_len; /* might be less than original length */
if ((new_len == 0) && (is_normal_vector(orig)))
set_has_simple_elements(x);
vector_getter(x) = vector_getter(orig);
vector_setter(x) = vector_setter(orig);
if (is_int_vector(orig))
int_vector_ints(x) = (s7_int *) (int_vector_ints(orig) + offset);
else if (is_float_vector(orig))
float_vector_floats(x) =
(s7_double *) (float_vector_floats(orig) + offset);
else if (is_normal_vector(x))
vector_elements(x) =
(s7_pointer *) (vector_elements(orig) + offset);
else
byte_vector_bytes(x) =
(uint8_t *) (byte_vector_bytes(orig) + offset);
add_multivector(sc, x);
return (x);
}
/* -------------------------------- vector-ref -------------------------------- */
static s7_pointer vector_ref_1(s7_scheme * sc, s7_pointer vect,
s7_pointer indices)
{
s7_int index = 0;
if (vector_length(vect) == 0)
return (out_of_range
(sc, sc->vector_ref_symbol, int_one, vect,
its_too_large_string));
if (vector_rank(vect) > 1) {
s7_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 = car(x);
if (!s7_is_integer(p))
return (method_or_bust
(sc, p, sc->vector_ref_symbol,
set_ulist_1(sc, vect, indices), T_INTEGER,
i + 2));
n = s7_integer_checked(sc, p);
if ((n < 0) || (n >= vector_dimension(vect, i)))
return (out_of_range
(sc, sc->vector_ref_symbol,
wrap_integer1(sc, i + 2), p,
(n <
0) ? its_negative_string :
its_too_large_string));
index += n * vector_offset(vect, i);
}
if (is_not_null(x)) {
s7_pointer nv;
if (!is_normal_vector(vect))
return (out_of_range
(sc, sc->vector_ref_symbol, int_two, indices,
too_many_indices_string));
nv = vector_element(vect, index);
return (implicit_index(sc, nv, x));
}
/* if not enough indices, return a subvector covering whatever is left */
if (i < vector_ndims(vect))
return (subvector(sc, vect, i, index));
} else {
s7_pointer p = car(indices);
/* (let ((hi (make-vector 3 0.0)) (sum 0.0)) (do ((i 0 (+ i 1))) ((= i 3)) (set! sum (+ sum (hi i)))) sum) */
if (!s7_is_integer(p))
return (method_or_bust
(sc, p, sc->vector_ref_symbol,
set_ulist_1(sc, vect, indices), T_INTEGER, 2));
index = s7_integer_checked(sc, p);
if ((index < 0) || (index >= vector_length(vect)))
return (out_of_range
(sc, sc->vector_ref_symbol, int_two, 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)) */
s7_pointer nv;
if (!is_normal_vector(vect))
return (out_of_range
(sc, sc->vector_ref_symbol, int_two, indices,
too_many_indices_string));
nv = vector_element(vect, index);
return (implicit_index(sc, nv, 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 = car(args);
if (!is_any_vector(vec))
return (method_or_bust
(sc, vec, sc->vector_ref_symbol, args, T_VECTOR, 1));
return (vector_ref_1(sc, vec, cdr(args))); /* 19-Jan-19 */
}
static s7_pointer vector_ref_p_pi(s7_scheme * sc, s7_pointer v, s7_int i)
{
if ((!is_normal_vector(v)) ||
(vector_rank(v) > 1) || (i < 0) || (i >= vector_length(v)))
return (g_vector_ref(sc, set_plist_2(sc, v, make_integer(sc, i))));
return (vector_element(v, i));
}
static s7_pointer vector_ref_p_pi_unchecked(s7_scheme * sc, s7_pointer v,
s7_int i)
{
if ((i >= 0) && (i < vector_length(v)))
return (vector_getter(v) (sc, v, i));
out_of_range(sc, sc->vector_ref_symbol, int_two, wrap_integer1(sc, i),
(i < 0) ? its_negative_string : its_too_large_string);
return (v);
}
static s7_pointer normal_vector_ref_p_pi_unchecked(s7_scheme * sc,
s7_pointer v, s7_int i)
{
if ((i >= 0) && (i < vector_length(v)))
return (vector_element(v, i));
out_of_range(sc, sc->vector_ref_symbol, int_two, wrap_integer1(sc, i),
(i < 0) ? its_negative_string : its_too_large_string);
return (v);
}
static s7_pointer vector_ref_p_pii(s7_scheme * sc, s7_pointer v, s7_int i1,
s7_int i2)
{
if ((!is_any_vector(v)) ||
(vector_rank(v) != 2) ||
(i1 < 0) || (i2 < 0) ||
(i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
return (g_vector_ref
(sc,
set_plist_3(sc, v, make_integer(sc, i1),
make_integer(sc, i2))));
return (vector_getter(v) (sc, v, i2 + (i1 * vector_offset(v, 0))));
}
static s7_pointer vector_ref_p_pii_direct(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2)
{
if ((i1 < 0) || (i2 < 0) ||
(i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
return (g_vector_ref
(sc,
set_plist_3(sc, v, make_integer(sc, i1),
make_integer(sc, i2))));
return (vector_element(v, i2 + (i1 * vector_offset(v, 0))));
}
/* this is specific to T_VECTOR */
static s7_pointer vector_ref_unchecked(s7_scheme * sc, s7_pointer v,
s7_int i)
{
if ((S7_DEBUGGING) && (!is_normal_vector(v)))
fprintf(stderr, "%s[%d]: vector is not T_VECTOR\n", __func__,
__LINE__);
return (vector_element(v, i));
}
static inline s7_pointer vector_ref_p_pp(s7_scheme * sc, s7_pointer vec,
s7_pointer ind)
{
s7_int index;
if ((!is_normal_vector(vec)) ||
(vector_rank(vec) != 1) || (!s7_is_integer(ind)))
return (g_vector_ref(sc, set_plist_2(sc, vec, ind)));
index = s7_integer_checked(sc, ind);
if ((index < 0) || (index >= vector_length(vec)))
return (out_of_range
(sc, sc->vector_ref_symbol, int_two, ind,
(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)
{
return (vector_ref_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_vector_ref_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer vec = car(args), i1, i2;
s7_int ix, iy;
if (!is_any_vector(vec))
return (g_vector_ref(sc, args));
if (vector_rank(vec) != 2)
return (g_vector_ref(sc, args));
i1 = cadr(args);
if (!s7_is_integer(i1))
return (g_vector_ref(sc, args));
i2 = caddr(args);
if (!s7_is_integer(i2))
return (g_vector_ref(sc, args));
ix = s7_integer_checked(sc, i1);
iy = s7_integer_checked(sc, i2);
if ((ix >= 0) &&
(iy >= 0) &&
(ix < vector_dimension(vec, 0)) &&
(iy < vector_dimension(vec, 1))) {
s7_int index;
index = (ix * vector_offset(vec, 0)) + iy; /* vector_offset(vec, 1) == 1 */
return (vector_getter(vec) (sc, vec, index));
}
return (g_vector_ref(sc, args));
}
static s7_pointer vector_ref_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if (args == 2)
return (sc->vector_ref_2);
return ((args == 3) ? sc->vector_ref_3 : f);
}
/* -------------------------------- vector-set! -------------------------------- */
static s7_pointer g_vector_set(s7_scheme * sc, s7_pointer args)
{
#define H_vector_set "(vector-set! v i ... value) sets the i-th element of vector v to value."
#define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol)
s7_pointer vec = car(args), val;
s7_int index;
if (!is_any_vector(vec))
return (method_or_bust
(sc, vec, sc->vector_set_symbol, args, T_VECTOR, 1));
if (is_immutable_vector(vec))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->vector_set_symbol, vec)));
if (vector_length(vec) == 0)
return (out_of_range
(sc, sc->vector_set_symbol, int_one, vec,
its_too_large_string));
if (vector_rank(vec) > 1) {
s7_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 = car(x);
if (!s7_is_integer(p))
return (method_or_bust
(sc, p, sc->vector_set_symbol, args, T_INTEGER,
i + 2));
n = s7_integer_checked(sc, p);
if ((n < 0) || (n >= vector_dimension(vec, i)))
return (out_of_range
(sc, sc->vector_set_symbol,
wrap_integer1(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 arguments for vector-set!: ~S", args));
if (i != vector_ndims(vec))
return (s7_wrong_number_of_args_error
(sc, "not enough arguments for vector-set!: ~S",
args));
/* since vector-ref can return a subvector (if not passed enough args), it might be interesting to
* also set a complete subvector via set!, but would that introduce ambiguity? Only copy the vector
* if at least one index is missing, and the value fits. It also makes error detection harder,
* but so does the current vector-ref handling. Can't decide...
* (define v (make-vector '(2 3) 0)) (vector-set! v 0 #(1 2 3)) -> error, but (vector-ref v 0) -> #(0 0 0)
* Other possible additions: complex-vector and string-vector.
*/
val = car(x);
} else {
s7_pointer p = cadr(args);
if (!s7_is_integer(p))
return (method_or_bust
(sc, p, sc->vector_set_symbol, args, T_INTEGER, 2));
index = s7_integer_checked(sc, p);
if ((index < 0) || (index >= vector_length(vec)))
return (out_of_range
(sc, sc->vector_set_symbol, int_two, 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));
if (!is_any_vector(car(sc->temp_cell_2)))
return (s7_wrong_number_of_args_error
(sc, "too many arguments for vector-set!: ~S",
args));
set_cdr(sc->temp_cell_2, cddr(args));
return (g_vector_set(sc, sc->temp_cell_2));
}
val = caddr(args);
}
if (is_typed_vector(vec)) {
if ((sc->safety < NO_SAFETY) || /* or == NO_SAFETY?? */
(typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) !=
sc->F)) {
vector_element(vec, index) = val;
return (val);
}
return (s7_wrong_type_arg_error
(sc, "vector-set!", 3, val,
make_type_name(sc, typed_vector_typer_name(sc, vec),
INDEFINITE_ARTICLE)));
}
vector_setter(vec) (sc, vec, index, val);
return (val);
}
static s7_pointer vector_set_p_pip(s7_scheme * sc, s7_pointer v, s7_int i,
s7_pointer p)
{
if ((!is_any_vector(v)) ||
(vector_rank(v) > 1) || (i < 0) || (i >= vector_length(v)))
return (g_vector_set
(sc, set_plist_3(sc, v, make_integer(sc, i), p)));
if (is_typed_vector(v))
return (typed_vector_setter(sc, v, i, p));
vector_setter(v) (sc, v, i, p);
return (p);
}
static s7_pointer vector_set_p_pip_unchecked(s7_scheme * sc, s7_pointer v,
s7_int i, s7_pointer p)
{
if ((i >= 0) && (i < vector_length(v)))
vector_element(v, i) = p;
else
out_of_range(sc, sc->vector_set_symbol, int_two,
wrap_integer1(sc, i),
(i < 0) ? its_negative_string : its_too_large_string);
return (p);
}
static s7_pointer vector_set_p_piip(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2, s7_pointer p)
{
if ((!is_any_vector(v)) ||
(vector_rank(v) != 2) ||
(i1 < 0) || (i2 < 0) ||
(i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
return (g_vector_set
(sc,
set_elist_4(sc, v, make_integer(sc, i1),
make_integer(sc, i2), p)));
if (is_typed_vector(v))
return (typed_vector_setter
(sc, v, i2 + (i1 * vector_offset(v, 0)), p));
vector_setter(v) (sc, v, i2 + (i1 * vector_offset(v, 0)), p);
return (p);
}
static s7_pointer vector_set_p_piip_direct(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2,
s7_pointer p)
{
/* normal untyped vector, rank == 2 */
if ((i1 < 0) || (i2 < 0) ||
(i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
return (g_vector_set
(sc,
set_elist_4(sc, v, make_integer(sc, i1),
make_integer(sc, i2), p)));
vector_element(v, i2 + (i1 * vector_offset(v, 0))) = p;
return (p);
}
static s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme * sc,
s7_pointer v, s7_int i,
s7_pointer p)
{
if ((i >= 0) && (i < vector_length(v)))
typed_vector_setter(sc, v, i, p);
else
out_of_range(sc, sc->vector_set_symbol, int_two,
wrap_integer1(sc, i),
(i < 0) ? its_negative_string : its_too_large_string);
return (p);
}
static s7_pointer typed_vector_set_p_piip_direct(s7_scheme * sc,
s7_pointer v, s7_int i1,
s7_int i2, s7_pointer p)
{
if ((i1 < 0) || (i2 < 0) ||
(i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
return (g_vector_set
(sc,
set_elist_4(sc, v, make_integer(sc, i1),
make_integer(sc, i2), p)));
return (typed_vector_setter
(sc, v, i2 + (i1 * vector_offset(v, 0)), p));
}
static s7_pointer vector_set_unchecked(s7_scheme * sc, s7_pointer v,
s7_int i, s7_pointer p)
{
vector_element(v, i) = p;
return (p);
}
static s7_pointer typed_vector_set_unchecked(s7_scheme * sc, s7_pointer v,
s7_int i, s7_pointer p)
{
typed_vector_setter(sc, v, i, p);
return (p);
}
static s7_pointer g_vector_set_3(s7_scheme * sc, s7_pointer args)
{
/* (vector-set! vector index value) */
s7_pointer ind, vec = car(args), val;
s7_int index;
if (!is_any_vector(vec))
return (g_vector_set(sc, args));
if (is_immutable_vector(vec))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->vector_set_symbol, vec)));
if (vector_rank(vec) > 1)
return (g_vector_set(sc, args));
ind = cadr(args);
if (!s7_is_integer(ind))
return (g_vector_set(sc, args));
index = s7_integer_checked(sc, ind);
if ((index < 0) || (index >= vector_length(vec)))
return (out_of_range
(sc, sc->vector_set_symbol, int_two,
wrap_integer1(sc, index),
(index <
0) ? its_negative_string : its_too_large_string));
val = caddr(args);
if (is_typed_vector(vec))
return (typed_vector_setter(sc, vec, index, val));
vector_setter(vec) (sc, vec, index, val);
return (val);
}
static s7_pointer vector_set_p_ppp(s7_scheme * sc, s7_pointer vec,
s7_pointer ind, s7_pointer val)
{
s7_int index;
if ((!is_normal_vector(vec)) || (vector_rank(vec) > 1))
return (g_vector_set(sc, set_plist_3(sc, vec, ind, val)));
if (is_immutable_vector(vec))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->vector_set_symbol, vec)));
if (!s7_is_integer(ind))
return (g_vector_set(sc, set_plist_3(sc, vec, ind, val)));
index = s7_integer_checked(sc, ind);
if ((index < 0) || (index >= vector_length(vec)))
return (out_of_range
(sc, sc->vector_set_symbol, int_two,
wrap_integer1(sc, index),
(index <
0) ? its_negative_string : its_too_large_string));
if (is_typed_vector(vec))
return (typed_vector_setter(sc, vec, index, val));
vector_element(vec, index) = val;
return (val);
}
static s7_pointer g_vector_set_4(s7_scheme * sc, s7_pointer args)
{
s7_pointer v = car(args), ip1 = cadr(args), ip2 = caddr(args), val;
s7_int i1, i2;
if ((!is_any_vector(v)) ||
(vector_rank(v) != 2) ||
(is_immutable(v)) ||
(!s7_is_integer(ip1)) || (!s7_is_integer(ip2)))
return (g_vector_set(sc, args));
i1 = s7_integer_checked(sc, ip1);
i2 = s7_integer_checked(sc, ip2);
if ((i1 < 0) || (i2 < 0) ||
(i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
return (g_vector_set(sc, args));
val = cadddr(args);
if (is_typed_vector(v))
return (typed_vector_setter
(sc, v, i2 + (i1 * vector_offset(v, 0)), val));
vector_setter(v) (sc, v, i2 + (i1 * vector_offset(v, 0)), val);
return (val);
}
static s7_pointer vector_set_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if (args == 3)
return (sc->vector_set_3);
return ((args == 4) ? sc->vector_set_4 : f);
}
/* -------------------------------- make-vector -------------------------------- */
static s7_int multivector_length(s7_scheme * sc, s7_pointer x,
s7_pointer caller)
{
s7_int len, dims;
s7_pointer y;
dims = s7_list_length(sc, x);
if (dims <= 0) /* 0 if circular, negative if dotted */
wrong_type_argument_with_type(sc, caller, 1, x,
a_proper_list_string);
if (dims > sc->max_vector_dimensions)
out_of_range(sc, caller, int_one, x, its_too_large_string);
for (len = 1, y = x; is_pair(y); y = cdr(y)) {
if (!s7_is_integer(car(y)))
wrong_type_argument(sc, caller, position_of(y, x), car(y),
T_INTEGER);
#if HAVE_OVERFLOW_CHECKS
if (multiply_overflow(len, s7_integer_checked(sc, car(y)), &len)) /* or better perhaps len > sc->max_vector_length */
out_of_range(sc, caller, wrap_integer1(sc, position_of(y, x)),
car(y), its_too_large_string);
#else
len *= s7_integer_checked(sc, car(y));
#endif
if (len < 0)
wrong_type_argument_with_type(sc, caller, position_of(y, x),
car(y),
a_non_negative_integer_string);
}
return (len);
}
static inline s7_pointer make_multivector(s7_scheme * sc, s7_pointer vec,
s7_pointer x)
{
vdims_t *v;
v = list_to_dims(sc, x);
vdims_original(v) = sc->F;
vector_set_dimension_info(vec, v);
add_multivector(sc, vec);
return (vec);
}
static s7_pointer g_make_vector_1(s7_scheme * sc, s7_pointer args,
s7_pointer caller)
{
s7_int len;
s7_pointer x = car(args), fill = sc->unspecified, vec, typf = sc->T;
int32_t result_type = T_VECTOR;
if (s7_is_integer(x)) {
len = s7_integer_checked(sc, x);
if (len < 0)
return (wrong_type_argument_with_type
(sc, caller, 1, x, a_non_negative_integer_string));
} else {
if (!(is_pair(x)))
return (method_or_bust_with_type
(sc, x, caller, args,
wrap_string(sc, "an integer or a list of integers",
32), 1));
if (!s7_is_integer(car(x)))
return (wrong_type_argument(sc, caller, 1, car(x), T_INTEGER));
len =
(is_null(cdr(x))) ? s7_integer_checked(sc,
car(x)) :
multivector_length(sc, x, caller);
}
if (is_pair(cdr(args))) {
fill = cadr(args);
if (caller == sc->make_int_vector_symbol)
result_type = T_INT_VECTOR;
else if (caller == sc->make_float_vector_symbol)
result_type = T_FLOAT_VECTOR;
else if (caller == sc->make_byte_vector_symbol)
result_type = T_BYTE_VECTOR;
if (is_pair(cddr(args))) {
typf = caddr(args);
if ((!is_c_function(typf)) &&
(!is_any_closure(typf)) && (typf != sc->T))
return (wrong_type_argument_with_type
(sc, caller, 3, typf,
wrap_string(sc,
"a built-in procedure, a closure or #t",
37)));
if (is_any_closure(typf)) {
if (!is_symbol(find_closure(sc, typf, closure_let(typf))))
return (wrong_type_argument_with_type
(sc, caller, 3, typf,
wrap_string(sc, "a named function", 16)));
/* the name is needed primarily by the error handler: "vector-set! argument 3, ..., is a ... but should be a <...>" */
} else if (is_c_function(typf)) {
if (typf == global_value(sc->is_float_symbol))
result_type = T_FLOAT_VECTOR;
else if (typf == global_value(sc->is_integer_symbol))
result_type = (WITH_GMP) ? T_VECTOR : T_INT_VECTOR;
else if (typf == global_value(sc->is_byte_symbol))
result_type = T_BYTE_VECTOR;
else {
s7_pointer sig;
if (!c_function_name(typf))
return (wrong_type_argument_with_type
(sc, caller, 3, typf,
wrap_string(sc, "a named procedure",
17)));
if (!c_function_marker(typf))
c_function_set_marker(typf, mark_vector_1);
if (!c_function_symbol(typf))
c_function_symbol(typf) =
make_symbol(sc, c_function_name(typf));
sig = c_function_signature(typf);
if ((sig != sc->pl_bt) &&
(is_pair(sig)) &&
((car(sig) != sc->is_boolean_symbol)
|| (cadr(sig) != sc->T) || (!is_null(cddr(sig)))))
return (wrong_type_argument_with_type
(sc, caller, 3, typf,
wrap_string(sc, "a boolean procedure",
19)));
}
}
}
}
/* before making the new vector, if fill is specified and the vector is typed, we have to check for a type error.
* otherwise we can end up with a vector whose elements are NULL, causing a segfault in the gc.
*/
if ((result_type == T_VECTOR) && /* don't put this after the make_vector_1! */
(!s7_is_boolean(typf)) &&
(s7_apply_function(sc, typf, set_plist_1(sc, fill)) == sc->F))
s7_wrong_type_arg_error(sc, "make-vector", 3, fill,
(is_c_function(typf)) ?
c_function_name(typf) :
symbol_name(find_closure
(sc, typf,
closure_let(typf))));
#if WITH_GMP
if ((is_big_number(fill)) && (result_type == T_VECTOR)) /* see comment in s7_vector_fill, this prefills with sc->nil */
vec = make_vector_1(sc, len, FILLED, result_type);
else
#endif
vec = make_vector_1(sc, len, NOT_FILLED, result_type);
if ((result_type == T_VECTOR) && (!s7_is_boolean(typf))) {
set_typed_vector(vec);
typed_vector_set_typer(vec, typf);
if ((is_c_function(typf)) &&
(c_function_has_simple_elements(typf)))
set_has_simple_elements(vec);
}
s7_vector_fill(sc, vec, fill);
if ((is_pair(x)) && (is_pair(cdr(x))))
return (make_multivector(sc, vec, x));
add_vector(sc, vec);
return (vec);
}
static s7_pointer g_make_vector(s7_scheme * sc, s7_pointer args)
{
#define H_make_vector "(make-vector len (value #<unspecified>) type) returns a vector of len elements initialized to value. \
To create a multidimensional vector, put the dimension bounds in a list (this is to avoid ambiguities such as \
(make-vector 1 2) where it's not clear whether the '2' is an initial value or a dimension size). (make-vector '(2 3) 1.0) \
returns a 2 dimensional vector of 6 total elements, all initialized to 1.0."
#define Q_make_vector s7_make_signature(sc, 4, sc->is_vector_symbol, \
s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, \
s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_boolean_symbol))
return (g_make_vector_1(sc, args, sc->make_vector_symbol));
}
/* -------------------------------- make-float-vector -------------------------------- */
static s7_pointer g_make_float_vector(s7_scheme * sc, s7_pointer args)
{
#define H_make_float_vector "(make-float-vector len (init 0.0)) returns a float-vector."
#define Q_make_float_vector s7_make_signature(sc, 3, sc->is_float_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_real_symbol)
s7_int len;
s7_pointer x, p = car(args);
block_t *arr;
if ((is_pair(cdr(args))) || (!s7_is_integer(p))) { /* (make-float-vector (bignum "3")) */
s7_pointer init;
if (is_pair(cdr(args))) {
init = cadr(args);
if (!is_real(init))
return (method_or_bust
(sc, init, sc->make_float_vector_symbol, args,
T_REAL, 2));
#if WITH_GMP
if (s7_is_bignum(init))
return (g_make_vector_1
(sc,
set_plist_2(sc, p, wrap_real2(sc, s7_real(init))),
sc->make_float_vector_symbol));
#endif
if (is_rational(init))
return (g_make_vector_1
(sc,
set_plist_2(sc, p,
wrap_real2(sc,
rational_to_double(sc,
init))),
sc->make_float_vector_symbol));
} else
init = real_zero;
if (s7_is_integer(p))
len = s7_integer_checked(sc, p);
else {
if (!is_pair(p))
return (method_or_bust_with_type
(sc, p, sc->make_float_vector_symbol, args,
wrap_string(sc,
"an integer or a list of integers",
32), 1));
len = multivector_length(sc, p, sc->make_float_vector_symbol);
}
x = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR);
float_vector_fill(sc, x, s7_real(init));
if (!s7_is_integer(p))
return (make_multivector(sc, x, p));
add_vector(sc, x);
return (x);
}
len = s7_integer_checked(sc, 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, int_one, p,
its_too_large_string));
arr = mallocate_vector(sc, len * sizeof(s7_double));
new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE);
vector_length(x) = len;
vector_block(x) = arr;
float_vector_floats(x) = (s7_double *) block_data(arr);
if (len > 0) {
if (STEP_8(len))
memclr64((void *) float_vector_floats(x),
len * sizeof(s7_double));
else
memclr((void *) float_vector_floats(x),
len * sizeof(s7_double));
}
vector_set_dimension_info(x, NULL);
vector_getter(x) = float_vector_getter;
vector_setter(x) = float_vector_setter;
add_vector(sc, x);
return (x);
}
/* -------------------------------- make-int-vector -------------------------------- */
static s7_pointer g_make_int_vector(s7_scheme * sc, s7_pointer args)
{
#define H_make_int_vector "(make-int-vector len (init 0)) returns an int-vector."
#define Q_make_int_vector s7_make_signature(sc, 3, sc->is_int_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_integer_symbol)
s7_int len;
s7_pointer x, p = car(args);
block_t *arr;
if ((is_pair(cdr(args))) || (!s7_is_integer(p))) {
s7_pointer init;
if (is_pair(cdr(args))) {
init = cadr(args);
if (!s7_is_integer(init))
return (method_or_bust
(sc, init, sc->make_int_vector_symbol, args,
T_INTEGER, 2));
} else
init = int_zero;
if (s7_is_integer(p))
len = s7_integer_checked(sc, p);
else {
if (!is_pair(p))
return (method_or_bust_with_type
(sc, p, sc->make_int_vector_symbol, args,
wrap_string(sc,
"an integer or a list of integers",
32), 1));
len = multivector_length(sc, p, sc->make_int_vector_symbol);
}
x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR);
int_vector_fill(sc, x, s7_integer_checked(sc, init));
if (!s7_is_integer(p))
return (make_multivector(sc, x, p));
add_vector(sc, x);
return (x);
}
len = s7_integer_checked(sc, 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, int_one, p,
its_too_large_string));
arr = mallocate_vector(sc, len * sizeof(s7_int));
new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE);
vector_length(x) = len;
vector_block(x) = arr;
int_vector_ints(x) = (s7_int *) block_data(arr);
if (len > 0) {
if (STEP_8(len))
memclr64((void *) int_vector_ints(x), len * sizeof(s7_int));
else
memclr((void *) int_vector_ints(x), len * sizeof(s7_int));
}
vector_set_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 make_int_vector_p_ii(s7_scheme * sc, s7_int len,
s7_int init)
{
s7_pointer x;
x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR);
int_vector_fill(sc, x, init);
add_vector(sc, x);
return (x);
}
/* -------------------------------- make-byte-vector -------------------------------- */
static s7_pointer g_make_byte_vector(s7_scheme * sc, s7_pointer args)
{
#define H_make_byte_vector "(make-byte-vector len (byte 0)) makes a byte-vector of length len filled with byte."
#define Q_make_byte_vector s7_make_signature(sc, 3, sc->is_byte_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_byte_symbol)
s7_int len = 0, ib = 0;
s7_pointer p = car(args), init;
if (!is_pair(p)) {
if (!s7_is_integer(p))
return (method_or_bust
(sc, p, sc->make_byte_vector_symbol, args, T_INTEGER,
1));
len = s7_integer_checked(sc, p);
if ((len < 0) || (len > sc->max_vector_length))
return (out_of_range
(sc, sc->make_byte_vector_symbol, int_one, p,
(len <
0) ? its_negative_string : its_too_large_string));
}
if (is_pair(cdr(args))) {
init = cadr(args);
if (!s7_is_integer(init))
return (method_or_bust
(sc, init, sc->make_byte_vector_symbol, args,
T_INTEGER, 2));
ib = s7_integer_checked(sc, init);
if ((ib < 0) || (ib > 255))
return (simple_wrong_type_argument_with_type
(sc, sc->make_byte_vector_symbol, init,
an_unsigned_byte_string));
} else
init = int_zero;
if (!s7_is_integer(p))
return (g_make_vector_1
(sc, set_plist_2(sc, p, init),
sc->make_byte_vector_symbol));
p = make_simple_byte_vector(sc, len);
if ((len > 0) && (is_pair(cdr(args))))
local_memset((void *) (byte_vector_bytes(p)), ib, len);
return (p);
}
static s7_pointer make_byte_vector_p_ii(s7_scheme * sc, s7_int len,
s7_int init)
{
s7_pointer p;
if ((len < 0) || (len > sc->max_vector_length))
return (out_of_range
(sc, sc->make_byte_vector_symbol, int_one,
wrap_integer1(sc, len),
(len < 0) ? its_negative_string : its_too_large_string));
if ((init < 0) || (init > 255))
return (simple_wrong_type_argument_with_type
(sc, sc->make_byte_vector_symbol, wrap_integer1(sc, init),
an_unsigned_byte_string));
p = make_simple_byte_vector(sc, len);
if (len > 0)
local_memset((void *) (byte_vector_bytes(p)), init, len);
return (p);
}
/* -------------------------------- vector? -------------------------------- */
static s7_pointer g_is_vector(s7_scheme * sc, s7_pointer args)
{
#define H_is_vector "(vector? obj) returns #t if obj is a vector"
#define Q_is_vector sc->pl_bt
check_boolean_method(sc, is_any_vector, sc->is_vector_symbol, args);
}
/* -------------------------------- vector-rank -------------------------------- */
s7_int s7_vector_rank(s7_pointer vect)
{
return ((s7_int) (vector_rank(vect)));
}
static s7_pointer g_vector_rank(s7_scheme * sc, s7_pointer args)
{
#define H_vector_rank "(vector-rank vect) returns the number of dimensions in vect"
#define Q_vector_rank s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol)
s7_pointer x = car(args);
if (!is_any_vector(x))
return (method_or_bust_one_arg
(sc, x, sc->vector_rank_symbol, args, T_VECTOR));
return (make_integer(sc, vector_rank(x)));
}
/* -------------------------------- vector-dimension -------------------------------- */
static s7_pointer g_vector_dimension(s7_scheme * sc, s7_pointer args)
{
#define H_vector_dimension "(vector-dimension vect n) returns the size of the n-th dimension (n is 0-based)"
#define Q_vector_dimension s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_vector_symbol, sc->is_integer_symbol)
s7_pointer v = car(args), np;
s7_int n;
if (!is_any_vector(v))
return (method_or_bust
(sc, v, sc->vector_dimension_symbol, args, T_VECTOR, 1));
np = cadr(args);
if (!s7_is_integer(np))
return (method_or_bust
(sc, v, sc->vector_dimension_symbol, args, T_INTEGER, 2));
n = s7_integer_checked(sc, np);
if ((n < 0) || (n >= vector_rank(v)))
return (s7_out_of_range_error
(sc, "vector-dimension", 2, np,
"must be between 0 and the vector-rank - 1"));
if (vector_has_dimension_info(v))
return (make_integer(sc, vector_dimension(v, n)));
return (make_integer(sc, vector_length(v)));
}
/* -------------------------------- vector-dimensions -------------------------------- */
static s7_pointer g_vector_dimensions(s7_scheme * sc, s7_pointer args)
{
#define H_vector_dimensions "(vector-dimensions vect) returns a list of vect's dimensions. 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 = car(args);
s7_int i;
if (!is_any_vector(x))
return (method_or_bust_one_arg
(sc, x, sc->vector_dimensions_symbol, args, T_VECTOR));
if (vector_rank(x) == 1)
return (list_1(sc, make_integer(sc, vector_length(x))));
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);
}
#define MULTIVECTOR_TOO_MANY_ELEMENTS -1
#define MULTIVECTOR_NOT_ENOUGH_ELEMENTS -2
static int32_t traverse_vector_data(s7_scheme * sc, s7_pointer vec,
s7_int flat_ref, s7_int dimension,
s7_int dimensions, s7_int * sizes,
s7_pointer lst)
{
/* we're filling vec, we're currently looking for element flat_ref,
* we're at ref in dimension of dimensions, where sizes gives the bounds, and lst is our data
* #3D(((1 2 3) (4 5 6)) ((7 8 9) (10 11 12)))
*/
s7_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);
}
}
return ((is_null(x)) ? flat_ref : MULTIVECTOR_TOO_MANY_ELEMENTS);
}
static s7_pointer reverse_in_place_unchecked(s7_scheme * sc,
s7_pointer term,
s7_pointer list)
{
s7_pointer p = list, result = term;
while (true) {
s7_pointer q;
LOOP_4(if (is_null(p)) return (result); q = cdr(p); set_cdr(p, result); result = p; p = q); /* return, not break because LOOP_4 is itself a do loop */
}
return (result);
}
static s7_pointer proper_list_reverse_in_place(s7_scheme * sc,
s7_pointer list)
{
return (reverse_in_place_unchecked(sc, sc->nil, list));
}
static s7_pointer multivector_error(s7_scheme * sc, const char *message,
s7_pointer data)
{
return (s7_error(sc, sc->read_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"reading constant vector, ~A: ~A",
31),
s7_make_string_wrapper(sc, message),
data)));
}
static s7_pointer g_multivector(s7_scheme * sc, s7_int dims,
s7_pointer data)
{
/* get the dimension bounds from data, make the new vector, fill it from data
* dims needs to be s7_int so we can at least give correct error messages.
*/
s7_pointer vec, x;
s7_int i, err, vec_loc;
s7_int *sizes;
/* (#2d((1 2 3) (4 5 6)) 0 0) -> 1
* (#2d((1 2 3) (4 5 6)) 1 1) -> 5
* (#3d(((1 2) (3 4)) ((5 6) (7 8))) 1 1 0) -> 7
* #3d(((1 2) (3 4)) ((5 6) (7))) -> error, #3d(((1 2) (3 4)) ((5 6) (7 8 9))), #3d(((1 2) (3 4)) (5 (7 8 9))) etc
* but a special case: #nd() is an n-dimensional empty vector
*/
if (dims <= 0) /* #0d(...) #2147483649D() [if dims is int32_t this is negative] */
return (s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer2(sc, dims), "must be 1 or more")); /* out_of_range uses integer1 */
if (dims > sc->max_vector_dimensions)
return (s7_out_of_range_error
(sc, "#nD(...) dimensions", 1, wrap_integer2(sc, dims),
"must be < (*s7* 'max-vector-dimensions)"));
sc->w = sc->nil;
if (is_null(data)) /* dims are already 0 (calloc above) */
return (g_make_vector
(sc,
set_plist_1(sc,
protected_make_list(sc, dims, int_zero))));
sizes = (s7_int *) Calloc(dims, sizeof(s7_int));
for (x = data, i = 0; i < dims; i++) {
sizes[i] = proper_list_length(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 (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 =
proper_list_reverse_in_place(sc,
sc->w)));
vec_loc = gc_protect_1(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 (multivector_error
(sc,
(err ==
MULTIVECTOR_TOO_MANY_ELEMENTS) ?
"found too many elements" : "not enough elements found",
data));
return (vec);
}
static s7_pointer g_int_multivector(s7_scheme * sc, s7_int dims,
s7_pointer data)
{
/* dims > 1, sc->value is a pair (not null) */
s7_pointer *src;
s7_int i, len;
sc->value = g_multivector(sc, dims, data);
src = (s7_pointer *) vector_elements(sc->value);
len = vector_length(sc->value);
for (i = 0; i < len; i++)
if (!is_t_integer(src[i]))
return (s7_wrong_type_arg_error
(sc, "#i(...)", i + 1, src[i], "an integer"));
sc->args =
g_make_vector_1(sc,
set_plist_2(sc,
g_vector_dimensions(sc,
set_plist_1(sc,
sc->value)),
int_zero), sc->make_int_vector_symbol);
return (s7_copy_1
(sc, sc->int_vector_symbol,
set_plist_2(sc, sc->value, sc->args)));
}
static s7_pointer g_byte_multivector(s7_scheme * sc, s7_int dims,
s7_pointer data)
{
/* dims > 1, sc->value is a pair (not null) */
s7_pointer *src;
s7_int i, len;
sc->value = g_multivector(sc, dims, data);
src = (s7_pointer *) vector_elements(sc->value);
len = vector_length(sc->value);
for (i = 0; i < len; i++)
if (!is_byte(src[i]))
return (s7_wrong_type_arg_error
(sc, "#u(...)", i + 1, src[i], "a byte"));
sc->args =
g_make_vector_1(sc,
set_plist_2(sc,
g_vector_dimensions(sc,
set_plist_1(sc,
sc->value)),
int_zero),
sc->make_byte_vector_symbol);
return (s7_copy_1
(sc, sc->byte_vector_symbol,
set_plist_2(sc, sc->value, sc->args)));
}
static s7_pointer g_float_multivector(s7_scheme * sc, s7_int dims,
s7_pointer data)
{
/* dims > 1, sc->value is a pair (not null) */
s7_pointer *src;
s7_int i, len;
sc->value = g_multivector(sc, dims, data);
src = (s7_pointer *) vector_elements(sc->value);
len = vector_length(sc->value);
for (i = 0; i < len; i++)
if (!is_real(src[i]))
return (s7_wrong_type_arg_error
(sc, "#r(...)", i + 1, src[i], "a real"));
sc->args =
g_make_vector_1(sc,
set_plist_2(sc,
g_vector_dimensions(sc,
set_plist_1(sc,
sc->value)),
real_zero),
sc->make_float_vector_symbol);
return (s7_copy_1
(sc, sc->float_vector_symbol,
set_plist_2(sc, sc->value, sc->args)));
}
static Vectorized s7_pointer s7_vector_copy_1(s7_scheme * sc,
s7_pointer old_vect)
{
s7_int i, len = vector_length(old_vect);
s7_pointer new_vect;
if (is_normal_vector(old_vect)) {
s7_pointer *src, *dst;
if ((is_typed_vector(old_vect)) && (len > 0)) { /* preserve the type info as well */
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)),
vector_element(old_vect, 0),
typed_vector_typer
(old_vect)));
else
new_vect =
g_make_vector(sc,
set_plist_3(sc, make_integer(sc, len),
vector_element(old_vect, 0),
typed_vector_typer
(old_vect)));
} else if (vector_rank(old_vect) > 1)
new_vect =
g_make_vector(sc,
set_plist_1(sc,
g_vector_dimensions(sc,
set_plist_1
(sc,
old_vect))));
else
new_vect = make_simple_vector(sc, len);
/* here and in vector-fill! we have a problem with bignums -- should new bignums be allocated? (copy_proper_list also) */
src = (s7_pointer *) vector_elements(old_vect);
dst = (s7_pointer *) vector_elements(new_vect);
for (i = len; i > 0; i--)
*dst++ = *src++;
return (new_vect);
}
if (is_float_vector(old_vect)) {
s7_double *src, *dst;
if (vector_rank(old_vect) > 1)
new_vect =
g_make_vector_1(sc,
set_plist_2(sc,
g_vector_dimensions(sc,
set_plist_1
(sc,
old_vect)),
real_zero),
sc->make_float_vector_symbol);
else
new_vect = make_simple_float_vector(sc, len);
src = (s7_double *) float_vector_floats(old_vect);
dst = (s7_double *) float_vector_floats(new_vect);
for (i = len; i > 0; i--)
*dst++ = *src++; /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */
return (new_vect);
}
if (is_int_vector(old_vect)) {
s7_int *src, *dst;
if (vector_rank(old_vect) > 1)
new_vect =
g_make_vector_1(sc,
set_plist_2(sc,
g_vector_dimensions(sc,
set_plist_1
(sc,
old_vect)),
int_zero),
sc->make_int_vector_symbol);
else
new_vect = make_simple_int_vector(sc, len);
src = (s7_int *) int_vector_ints(old_vect);
dst = (s7_int *) int_vector_ints(new_vect);
for (i = len; i > 0; i--)
*dst++ = *src++;
return (new_vect);
}
if (is_byte_vector(old_vect)) {
uint8_t *src, *dst;
if (vector_rank(old_vect) > 1)
new_vect =
g_make_vector_1(sc,
set_plist_2(sc,
g_vector_dimensions(sc,
set_plist_1
(sc,
old_vect)),
int_zero),
sc->make_byte_vector_symbol);
else
new_vect = make_simple_byte_vector(sc, len);
src = (uint8_t *) byte_vector_bytes(old_vect);
dst = (uint8_t *) byte_vector_bytes(new_vect);
for (i = len; i > 0; i--)
*dst++ = *src++;
return (new_vect);
}
return (NULL);
}
s7_pointer s7_vector_copy(s7_scheme * sc, s7_pointer old_vect)
{
return (s7_vector_copy_1(sc, old_vect));
}
static s7_pointer univect_ref(s7_scheme * sc, s7_pointer args,
s7_pointer caller, int32_t typ)
{
s7_pointer v = car(args), index;
s7_int ind;
if (type(v) != typ)
return (method_or_bust(sc, v, caller, args, typ, 1));
if (vector_rank(v) == 1) {
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust(sc, index, caller, args, T_INTEGER, 2));
ind = s7_integer_checked(sc, 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, int_two, cdr(args),
too_many_indices_string));
} else {
s7_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;
index = car(x);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, caller, args, T_INTEGER, i + 2));
n = s7_integer_checked(sc, index);
if ((n < 0) || (n >= vector_dimension(v, i)))
return (out_of_range
(sc, caller, wrap_integer1(sc, i + 2), index,
(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, int_two, cdr(args),
too_many_indices_string));
/* if not enough indices, return a subvector covering whatever is left */
if (i < vector_ndims(v))
return (subvector(sc, v, i, ind));
}
if (typ == T_FLOAT_VECTOR)
return (make_real(sc, float_vector(v, ind)));
return ((typ == T_INT_VECTOR) ? make_integer(sc,
int_vector(v,
ind)) :
small_int(byte_vector(v, ind)));
}
static s7_pointer univect_set(s7_scheme * sc, s7_pointer args,
s7_pointer caller, int32_t typ)
{
s7_pointer vec = car(args), val, index;
s7_int ind;
if (type(vec) != typ)
return (method_or_bust(sc, vec, caller, args, typ, 1));
if (is_immutable_vector(vec))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string, caller, vec)));
if (vector_rank(vec) > 1) {
s7_int i;
s7_pointer x;
ind = 0;
for (x = cdr(args), i = 0;
(is_not_null(cdr(x))) && (i < vector_ndims(vec));
x = cdr(x), i++) {
s7_int n;
index = car(x);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, caller, args, T_INTEGER, i + 2));
n = s7_integer_checked(sc, index);
if ((n < 0) || (n >= vector_dimension(vec, i)))
return (out_of_range
(sc, caller, wrap_integer1(sc, i + 2), index,
(n <
0) ? its_negative_string :
its_too_large_string));
ind += n * vector_offset(vec, i);
}
if (is_not_null(cdr(x)))
return (s7_wrong_number_of_args_error
(sc, "too many arguments: ~S", args));
if (i != vector_ndims(vec))
return (s7_wrong_number_of_args_error
(sc, "not enough arguments: ~S", args));
val = car(x);
} else {
s7_pointer p = cdr(args);
index = car(p);
if (!s7_is_integer(index))
return (method_or_bust(sc, index, caller, args, T_INTEGER, 2));
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= vector_length(vec)))
return (out_of_range
(sc, caller, int_two, index,
(ind <
0) ? its_negative_string : its_too_large_string));
if (is_not_null(cddr(p)))
return (s7_wrong_number_of_args_error
(sc, "too many arguments: ~S", args));
val = cadr(p);
}
if (typ == T_FLOAT_VECTOR) {
if (!is_real(val))
return (method_or_bust(sc, val, caller, args, T_REAL, 3));
float_vector(vec, ind) = s7_real(val);
} else if (typ == T_INT_VECTOR) {
if (!s7_is_integer(val))
return (method_or_bust(sc, val, caller, args, T_INTEGER, 3));
int_vector(vec, ind) = s7_integer_checked(sc, val);
} else {
if (!is_byte(val))
return (method_or_bust(sc, val, caller, args, T_INTEGER, 3));
byte_vector(vec, ind) = (uint8_t) s7_integer_checked(sc, val);
}
return (val);
}
/* -------------------------------- float-vector-ref -------------------------------- */
static s7_pointer g_float_vector_ref(s7_scheme * sc, s7_pointer args)
{
#define H_float_vector_ref "(float-vector-ref v ...) returns an element of the float-vector v."
#define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, s7_make_signature(sc, 2, sc->is_float_symbol, sc->is_float_vector_symbol), sc->is_float_vector_symbol, sc->is_integer_symbol)
return (univect_ref
(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
}
static inline s7_pointer float_vector_ref_p_pp(s7_scheme * sc,
s7_pointer v,
s7_pointer index)
{
s7_int ind;
if (!is_float_vector(v))
return (method_or_bust_pp
(sc, v, sc->float_vector_ref_symbol, v, index,
T_FLOAT_VECTOR, 1));
if (vector_rank(v) != 1)
return (univect_ref
(sc, set_plist_2(sc, v, index),
sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
if (!s7_is_integer(index))
return (method_or_bust_pp
(sc, index, sc->float_vector_ref_symbol, v, index,
T_INTEGER, 2));
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= vector_length(v)))
return (simple_out_of_range
(sc, sc->float_vector_ref_symbol, index,
(ind < 0) ? its_negative_string : its_too_large_string));
return (make_real(sc, float_vector(v, ind)));
}
static s7_pointer g_fv_ref_2(s7_scheme * sc, s7_pointer args)
{
return (float_vector_ref_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_fv_ref_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer fv = car(args), index;
s7_int ind1, ind2;
if (!is_float_vector(fv))
return (method_or_bust
(sc, fv, sc->float_vector_ref_symbol, args, T_FLOAT_VECTOR,
1));
if (vector_rank(fv) != 2)
return (univect_ref
(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->float_vector_ref_symbol, args, T_INTEGER,
2));
ind1 = s7_integer_checked(sc, index);
if ((ind1 < 0) || (ind1 >= vector_dimension(fv, 0)))
return (simple_out_of_range
(sc, sc->float_vector_ref_symbol, index,
(ind1 < 0) ? its_negative_string : its_too_large_string));
index = caddr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->float_vector_ref_symbol, args, T_INTEGER,
3));
ind2 = s7_integer_checked(sc, index);
if ((ind2 < 0) || (ind2 >= vector_dimension(fv, 1)))
return (simple_out_of_range
(sc, sc->float_vector_ref_symbol, index,
(ind2 < 0) ? its_negative_string : its_too_large_string));
ind1 = ind1 * vector_offset(fv, 0) + ind2;
return (make_real(sc, float_vector(fv, ind1)));
}
static inline s7_int ref_check_index(s7_scheme * sc, s7_pointer v,
s7_int i)
{
/* according to callgrind, it is faster to split out the bounds check */
if ((i < 0) || (i >= vector_length(v)))
out_of_range(sc, sc->float_vector_ref_symbol, int_two,
wrap_integer1(sc, i),
(i < 0) ? its_negative_string : its_too_large_string);
return (i);
}
static inline s7_double float_vector_ref_d_7pi(s7_scheme * sc,
s7_pointer v, s7_int i)
{
return (float_vector(v, ref_check_index(sc, v, i)));
}
static s7_pointer float_vector_ref_unchecked_p(s7_scheme * sc,
s7_pointer v, s7_int i)
{
return (make_real(sc, float_vector(v, i)));
}
static inline s7_double float_vector_ref_d_7pii(s7_scheme * sc,
s7_pointer v, s7_int i1,
s7_int i2)
{
if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->float_vector_ref_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->float_vector_ref_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
else
return (float_vector(v, i2 + (i1 * vector_offset(v, 0))));
return (0.0); /* I know... callgrind oddity */
}
static s7_double float_vector_ref_d_7piii(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2, s7_int i3)
{
if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->float_vector_ref_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->float_vector_ref_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
else if ((i3 < 0) || (i3 >= vector_dimension(v, 2)))
out_of_range(sc, sc->float_vector_ref_symbol, small_int(4),
wrap_integer1(sc, i3),
(i3 <
0) ? its_negative_string : its_too_large_string);
else
return (float_vector
(v,
i3 + (i2 * vector_offset(v, 1)) +
(i1 * vector_offset(v, 0))));
return (0.0);
}
static s7_pointer float_vector_ref_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : f));
}
/* -------------------------------- float-vector-set! -------------------------------- */
static s7_pointer g_float_vector_set(s7_scheme * sc, s7_pointer args)
{
#define H_float_vector_set "(float-vector-set! v i ... value) sets the i-th element of the float-vector v to value."
#define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, sc->is_real_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_real_at_end_symbol)
return (univect_set
(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR));
}
static s7_pointer g_fv_set_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer fv = car(args), index, value;
s7_int ind;
if (!is_float_vector(fv))
return (method_or_bust
(sc, fv, sc->float_vector_set_symbol, args, T_FLOAT_VECTOR,
1));
if (vector_rank(fv) != 1)
return (univect_set
(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR));
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->float_vector_set_symbol, args, T_INTEGER,
2));
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= vector_length(fv)))
return (simple_out_of_range
(sc, sc->float_vector_set_symbol, index,
(ind < 0) ? its_negative_string : its_too_large_string));
value = caddr(args);
if (!is_real(value))
return (method_or_bust
(sc, value, sc->float_vector_set_symbol, args, T_REAL, 3));
if (is_immutable_vector(fv))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->float_vector_set_symbol, fv)));
float_vector(fv, ind) = s7_real(value);
return (value);
}
static s7_pointer g_fv_set_unchecked(s7_scheme * sc, s7_pointer args)
{
s7_pointer fv, value = caddr(args);
s7_int ind;
if (!is_real(value))
return (wrong_type_argument
(sc, sc->float_vector_set_symbol, 3, value, T_REAL));
fv = car(args);
if (is_immutable_vector(fv))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->float_vector_set_symbol, fv)));
ind = s7_integer_checked(sc, cadr(args));
float_vector(fv, ind) = s7_real(value);
return (value);
}
static bool find_matching_ref(s7_scheme * sc, s7_pointer getter,
s7_pointer expr)
{
/* expr: (*set! v i val), val exists (i.e. args=3, so cddddr is null) */
s7_pointer v = cadr(expr), ind = caddr(expr);
if ((is_symbol(v)) && (!is_pair(ind))) {
s7_pointer val = cadddr(expr);
if (is_optimized(val)) { /* includes is_pair */
s7_pointer p;
for (p = val; is_pair(p); p = cdr(p))
if (is_pair(car(p))) {
s7_pointer ref = car(p);
if (((car(ref) == getter) &&
(is_proper_list_2(sc, cdr(ref))) &&
(cadr(ref) == v) &&
(caddr(ref) == ind)) ||
((car(ref) == v) &&
(is_proper_list_1(sc, cdr(ref))) &&
(cadr(ref) == ind)))
return (true);
}
}
}
return (false);
}
static s7_pointer float_vector_set_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if (args == 3)
return ((find_matching_ref(sc, sc->float_vector_ref_symbol, expr))
? sc->fv_set_unchecked : sc->fv_set_3);
return (f);
}
static s7_double float_vector_set_unchecked(s7_scheme * sc, s7_pointer v,
s7_int i, s7_double x)
{
float_vector(v, i) = x;
return (x);
}
static s7_int set_check_index(s7_scheme * sc, s7_pointer v, s7_int i)
{
if ((i < 0) || (i >= vector_length(v)))
out_of_range(sc, sc->float_vector_set_symbol, int_two,
wrap_integer1(sc, i),
(i < 0) ? its_negative_string : its_too_large_string);
return (i);
}
static s7_double float_vector_set_d_7pid(s7_scheme * sc, s7_pointer v,
s7_int i, s7_double x)
{
float_vector(v, (set_check_index(sc, v, i))) = x;
return (x);
}
static s7_double float_vector_set_d_7piid(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2,
s7_double x)
{
if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->float_vector_set_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else /* this looks dumb, but it makes callgrind much happier */
if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->float_vector_set_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
else
float_vector(v, i2 + (i1 * vector_offset(v, 0))) = x;
return (x);
}
static s7_double float_vector_set_d_7piiid(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2, s7_int i3,
s7_double x)
{
if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->float_vector_set_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->float_vector_set_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
else if ((i3 < 0) || (i3 >= vector_dimension(v, 2)))
out_of_range(sc, sc->float_vector_set_symbol, small_int(4),
wrap_integer1(sc, i3),
(i3 <
0) ? its_negative_string : its_too_large_string);
else
float_vector(v,
i3 + (i2 * vector_offset(v, 1)) +
(i1 * vector_offset(v, 0))) = x;
return (x);
}
static s7_pointer float_vector_set_unchecked_p(s7_scheme * sc,
s7_pointer v, s7_int i,
s7_pointer p)
{
float_vector(v, i) = real_to_double(sc, p, "float-vector-set!");
return (p);
}
/* -------------------------------- int-vector-ref -------------------------------- */
static s7_pointer g_int_vector_ref(s7_scheme * sc, s7_pointer args)
{
#define H_int_vector_ref "(int-vector-ref v ...) returns an element of the int-vector v."
#define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_int_vector_symbol), sc->is_int_vector_symbol, sc->is_integer_symbol)
return (univect_ref
(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR));
}
static s7_int int_vector_ref_unchecked(s7_scheme * sc, s7_pointer v,
s7_int i)
{
return (int_vector(v, i));
}
static s7_int int_vector_ref_i_7pi(s7_scheme * sc, s7_pointer v, s7_int i)
{
if ((i < 0) || (i >= vector_length(v)))
out_of_range(sc, sc->int_vector_ref_symbol, int_two,
wrap_integer1(sc, i),
(i < 0) ? its_negative_string : its_too_large_string);
else
return (int_vector(v, i));
return (0);
}
static s7_pointer int_vector_ref_unchecked_p(s7_scheme * sc, s7_pointer v,
s7_int i)
{
return (make_integer(sc, int_vector(v, i)));
}
static s7_int int_vector_ref_i_7pii(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2)
{
if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->int_vector_ref_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->int_vector_ref_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
else
return (int_vector(v, i2 + (i1 * vector_offset(v, 0))));
return (0);
}
static s7_int int_vector_ref_i_7piii(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2, s7_int i3)
{
if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->int_vector_ref_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->int_vector_ref_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
else if ((i3 < 0) || (i3 >= vector_dimension(v, 2)))
out_of_range(sc, sc->int_vector_ref_symbol, small_int(4),
wrap_integer1(sc, i3),
(i3 <
0) ? its_negative_string : its_too_large_string);
else
return (int_vector
(v,
i3 + (i2 * vector_offset(v, 1)) +
(i1 * vector_offset(v, 0))));
return (0);
}
static inline s7_pointer int_vector_ref_p_pp(s7_scheme * sc, s7_pointer v,
s7_pointer index)
{
s7_int ind;
if (!is_int_vector(v))
return (method_or_bust_pp
(sc, v, sc->int_vector_ref_symbol, v, index, T_INT_VECTOR,
1));
if (vector_rank(v) != 1)
return (univect_ref
(sc, set_plist_2(sc, v, index), sc->int_vector_ref_symbol,
T_INT_VECTOR));
if (!s7_is_integer(index))
return (method_or_bust_pp
(sc, index, sc->int_vector_ref_symbol, v, index, T_INTEGER,
2));
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= vector_length(v)))
return (simple_out_of_range
(sc, sc->int_vector_ref_symbol, index,
(ind < 0) ? its_negative_string : its_too_large_string));
return (make_integer(sc, int_vector(v, ind)));
}
static s7_pointer g_iv_ref_2(s7_scheme * sc, s7_pointer args)
{
return (int_vector_ref_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_iv_ref_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer iv = car(args), index;
s7_int ind1, ind2;
if (!is_int_vector(iv))
return (method_or_bust
(sc, iv, sc->int_vector_ref_symbol, args, T_INT_VECTOR,
1));
if (vector_rank(iv) != 2)
return (univect_ref
(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR));
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->int_vector_ref_symbol, args, T_INTEGER,
2));
ind1 = s7_integer_checked(sc, index);
if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0)))
return (simple_out_of_range
(sc, sc->int_vector_ref_symbol, index,
(ind1 < 0) ? its_negative_string : its_too_large_string));
index = caddr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->int_vector_ref_symbol, args, T_INTEGER,
3));
ind2 = s7_integer_checked(sc, index);
if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1)))
return (simple_out_of_range
(sc, sc->int_vector_ref_symbol, index,
(ind2 < 0) ? its_negative_string : its_too_large_string));
ind1 = ind1 * vector_offset(iv, 0) + ind2;
return (make_integer(sc, int_vector(iv, ind1)));
}
static s7_pointer int_vector_ref_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : f));
}
/* -------------------------------- int-vector-set! -------------------------------- */
static s7_pointer g_int_vector_set(s7_scheme * sc, s7_pointer args)
{
#define H_int_vector_set "(int-vector-set! v i ... value) sets the i-th element of the int-vector v to value."
#define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol)
return (univect_set
(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR));
}
static s7_int int_vector_set_unchecked(s7_scheme * sc, s7_pointer v,
s7_int i, s7_int x)
{
int_vector(v, i) = x;
return (x);
}
static s7_int int_vector_set_i_7pii(s7_scheme * sc, s7_pointer v, s7_int i,
s7_int x)
{
if ((i < 0) || (i >= vector_length(v)))
out_of_range(sc, sc->int_vector_set_symbol, int_two,
wrap_integer1(sc, i),
(i < 0) ? its_negative_string : its_too_large_string);
else
int_vector(v, i) = x;
return (x);
}
static s7_int int_vector_set_i_7piii(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2, s7_int i3)
{
if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->int_vector_set_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->int_vector_set_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
else
int_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3;
return (i3);
}
static s7_pointer int_vector_set_p_ppp(s7_scheme * sc, s7_pointer v,
s7_pointer index, s7_pointer val)
{
if ((is_int_vector(v)) && (vector_rank(v) == 1)
&& (!is_immutable_vector(v)) && (is_t_integer(index))
&& (is_t_integer(val))) {
s7_int i = integer(index);
if ((i < 0) || (i >= vector_length(v)))
out_of_range(sc, sc->int_vector_set_symbol, int_two, index,
(i <
0) ? its_negative_string : its_too_large_string);
else
int_vector(v, i) = integer(val);
} else {
if (!is_int_vector(v))
return (method_or_bust_ppp
(sc, v, sc->int_vector_set_symbol, v, index, val,
T_INT_VECTOR, 1));
if (vector_rank(v) != 1)
return (univect_set
(sc, set_plist_3(sc, v, index, val),
sc->int_vector_set_symbol, T_INT_VECTOR));
if (is_immutable_vector(v))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->int_vector_set_symbol, v)));
if (!s7_is_integer(index))
return (method_or_bust_ppp
(sc, index, sc->int_vector_set_symbol, v, index, val,
T_INTEGER, 2));
if (!s7_is_integer(val))
return (method_or_bust_ppp
(sc, val, sc->int_vector_set_symbol, v, index, val,
T_INTEGER, 3));
#if WITH_GMP
{
s7_int i = s7_integer_checked(sc, index);
if ((i < 0) || (i >= vector_length(v)))
out_of_range(sc, sc->int_vector_set_symbol, int_two, index,
(i <
0) ? its_negative_string :
its_too_large_string);
else
int_vector(v, i) = s7_integer_checked(sc, val);
}
#else
if (S7_DEBUGGING)
fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__);
#endif
}
return (val);
}
static s7_pointer int_vector_set_unchecked_p(s7_scheme * sc, s7_pointer v,
s7_int i, s7_pointer p)
{
if (!s7_is_integer(p))
s7_wrong_type_arg_error(sc, "int-vector-set!", 3, p, "an integer");
int_vector(v, i) = s7_integer_checked(sc, p);
return (p);
}
static s7_pointer g_iv_set_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer v = car(args), index, value;
s7_int ind;
if (!is_int_vector(v))
return (method_or_bust
(sc, v, sc->int_vector_set_symbol, args, T_INT_VECTOR, 1));
if (vector_rank(v) != 1)
return (univect_set
(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR));
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->int_vector_set_symbol, args, T_INTEGER,
2));
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= vector_length(v)))
return (simple_out_of_range
(sc, sc->int_vector_set_symbol, index,
(ind < 0) ? its_negative_string : its_too_large_string));
value = caddr(args);
if (!s7_is_integer(value))
return (method_or_bust
(sc, value, sc->int_vector_set_symbol, args, T_INTEGER,
3));
if (is_immutable_vector(v))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->int_vector_set_symbol, v)));
int_vector(v, ind) = s7_integer_checked(sc, value);
return (value);
}
static s7_pointer int_vector_set_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 3) ? sc->iv_set_3 : f);
}
/* -------------------------------- byte-vector-ref -------------------------------- */
static s7_pointer g_byte_vector_ref(s7_scheme * sc, s7_pointer args)
{
#define H_byte_vector_ref "(byte-vector-ref vect index) returns the byte at the index-th element of the byte-vector vect"
#define Q_byte_vector_ref s7_make_circular_signature(sc, 2, 3, s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_byte_vector_symbol), sc->is_byte_vector_symbol, sc->is_integer_symbol)
return (univect_ref
(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
}
static s7_int byte_vector_ref_i_7pi(s7_scheme * sc, s7_pointer p1,
s7_int i1)
{
if ((i1 < 0) || (i1 >= byte_vector_length(p1)))
out_of_range(sc, sc->byte_vector_ref_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else
return ((s7_int) ((byte_vector(p1, i1))));
return (0);
}
static s7_int byte_vector_ref_i_7pii(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2)
{
if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->byte_vector_ref_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->byte_vector_ref_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
else
return ((s7_int) byte_vector(v, i2 + (i1 * vector_offset(v, 0))));
return (0);
}
static s7_pointer byte_vector_ref_unchecked_p(s7_scheme * sc,
s7_pointer p1, s7_int i1)
{
return (small_int((byte_vector(p1, i1))));
}
static s7_int byte_vector_ref_unchecked(s7_scheme * sc, s7_pointer p1,
s7_int i1)
{
return (byte_vector(p1, i1));
}
static s7_pointer g_bv_ref_2(s7_scheme * sc, s7_pointer args)
{
s7_pointer v = car(args), index;
s7_int ind;
if (!is_byte_vector(v))
return (method_or_bust
(sc, v, sc->byte_vector_ref_symbol, args, T_BYTE_VECTOR,
1));
if (vector_rank(v) != 1)
return (univect_ref
(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->byte_vector_ref_symbol, args, T_INTEGER,
2));
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= vector_length(v)))
return (simple_out_of_range
(sc, sc->byte_vector_ref_symbol, index,
(ind < 0) ? its_negative_string : its_too_large_string));
return (make_integer(sc, byte_vector(v, ind)));
}
static s7_pointer g_bv_ref_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer iv = car(args), index;
s7_int ind1, ind2;
if (!is_byte_vector(iv))
return (method_or_bust
(sc, iv, sc->byte_vector_ref_symbol, args, T_BYTE_VECTOR,
1));
if (vector_rank(iv) != 2)
return (univect_ref
(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->byte_vector_ref_symbol, args, T_INTEGER,
2));
ind1 = s7_integer_checked(sc, index);
if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0)))
return (simple_out_of_range
(sc, sc->byte_vector_ref_symbol, index,
(ind1 < 0) ? its_negative_string : its_too_large_string));
index = caddr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->byte_vector_ref_symbol, args, T_INTEGER,
3));
ind2 = s7_integer_checked(sc, index);
if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1)))
return (simple_out_of_range
(sc, sc->byte_vector_ref_symbol, index,
(ind2 < 0) ? its_negative_string : its_too_large_string));
ind1 = ind1 * vector_offset(iv, 0) + ind2;
return (make_integer(sc, byte_vector(iv, ind1)));
}
static s7_pointer byte_vector_ref_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : f));
}
/* -------------------------------- byte-vector-set -------------------------------- */
static s7_pointer g_byte_vector_set(s7_scheme * sc, s7_pointer args)
{
#define H_byte_vector_set "(byte-vector-set! vect index byte) sets the index-th element of the byte-vector vect to the integer byte"
#define Q_byte_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol)
return (univect_set
(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR));
}
static s7_int byte_vector_set_i_7pii(s7_scheme * sc, s7_pointer p1,
s7_int i1, s7_int i2)
{
if (!is_byte_vector(p1))
simple_wrong_type_argument_with_type(sc,
sc->byte_vector_set_symbol,
p1, a_byte_vector_string);
else if ((i2 < 0) || (i2 > 255))
simple_wrong_type_argument_with_type(sc,
sc->byte_vector_set_symbol,
wrap_integer1(sc, i2),
an_unsigned_byte_string);
else if ((i1 < 0) || (i1 >= byte_vector_length(p1)))
simple_out_of_range(sc, sc->byte_vector_set_symbol,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string :
its_too_large_string);
byte_vector(p1, i1) = (uint8_t) i2;
return (i2);
}
static s7_int byte_vector_set_unchecked(s7_scheme * sc, s7_pointer p1,
s7_int i1, s7_int i2)
{
byte_vector(p1, i1) = (uint8_t) i2;
return (i2);
}
static s7_pointer byte_vector_set_unchecked_p(s7_scheme * sc,
s7_pointer p1, s7_int i1,
s7_pointer p2)
{
byte_vector(p1, i1) = (uint8_t) s7_integer_checked(sc, p2);
return (p2);
}
static s7_int byte_vector_set_i_7piii(s7_scheme * sc, s7_pointer v,
s7_int i1, s7_int i2, s7_int i3)
{
if ((i3 < 0) || (i3 > 255))
simple_wrong_type_argument_with_type(sc,
sc->byte_vector_set_symbol,
wrap_integer1(sc, i3),
an_unsigned_byte_string);
else if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
out_of_range(sc, sc->int_vector_set_symbol, int_two,
wrap_integer1(sc, i1),
(i1 <
0) ? its_negative_string : its_too_large_string);
else if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
out_of_range(sc, sc->int_vector_set_symbol, int_three,
wrap_integer1(sc, i2),
(i2 <
0) ? its_negative_string : its_too_large_string);
byte_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3;
return (i3);
}
static s7_pointer g_bv_set_3(s7_scheme * sc, s7_pointer args)
{
s7_pointer v = car(args), index, value;
s7_int ind, uval;
if (!is_byte_vector(v))
return (method_or_bust
(sc, v, sc->byte_vector_set_symbol, args, T_BYTE_VECTOR,
1));
if (vector_rank(v) != 1)
return (univect_set
(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR));
index = cadr(args);
if (!s7_is_integer(index))
return (method_or_bust
(sc, index, sc->byte_vector_set_symbol, args, T_INTEGER,
2));
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= vector_length(v)))
return (simple_out_of_range
(sc, sc->byte_vector_set_symbol, index,
(ind < 0) ? its_negative_string : its_too_large_string));
value = caddr(args);
if (!s7_is_integer(value))
return (method_or_bust
(sc, value, sc->byte_vector_set_symbol, args, T_INTEGER,
3));
uval = s7_integer_checked(sc, value);
if ((uval < 0) || (uval > 255))
simple_wrong_type_argument_with_type(sc,
sc->byte_vector_set_symbol,
value,
an_unsigned_byte_string);
if (is_immutable_vector(v))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->byte_vector_set_symbol, v)));
byte_vector(v, ind) = (uint8_t) uval;
return (value);
}
static s7_pointer byte_vector_set_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 3) ? sc->bv_set_3 : f);
}
/* -------------------------------------------------------------------------------- */
static bool c_function_is_ok(s7_scheme * sc, s7_pointer x)
{
s7_pointer p;
p = lookup_unexamined(sc, car(x)); /* lookup_global is usually slower (faster in Snd) */
if ((p == opt1_cfunc(x)) || ((p) && (is_any_c_function(p))
&& (c_function_class(p) ==
c_function_class(opt1_cfunc(x)))))
return (true);
sc->last_function = p;
return (false);
}
static bool cl_function_is_ok(s7_scheme * sc, s7_pointer x)
{
sc->last_function = lookup_unexamined(sc, car(x));
return (sc->last_function == opt1_cfunc(x));
}
static bool arglist_has_rest(s7_scheme * sc, s7_pointer args)
{
s7_pointer p;
for (p = args; is_pair(p); p = cdr(p))
if (car(p) == sc->key_rest_symbol)
return (true);
return (!is_null(p));
}
/* -------------------------------- sort! -------------------------------- */
static bool bool_optimize(s7_scheme * sc, s7_pointer expr);
static bool bool_optimize_nw(s7_scheme * sc, s7_pointer expr);
static bool cell_optimize(s7_scheme * sc, s7_pointer expr);
static void pc_fallback(s7_scheme * sc, int32_t new_pc)
{
sc->pc = new_pc;
}
static int32_t dbl_less(const void *f1, const void *f2)
{
if ((*((s7_double *) f1)) < (*((s7_double *) f2)))
return (-1);
return (((*((s7_double *) f1)) > (*((s7_double *) f2))) ? 1 : 0);
}
static int32_t int_less(const void *f1, const void *f2)
{
if ((*((s7_int *) f1)) < (*((s7_int *) f2)))
return (-1);
return (((*((s7_int *) f1)) > (*((s7_int *) f2))) ? 1 : 0);
}
static int32_t dbl_greater(const void *f1, const void *f2)
{
return (-dbl_less(f1, f2));
}
static int32_t int_greater(const void *f1, const void *f2)
{
return (-int_less(f1, f2));
}
static int32_t byte_less(const void *f1, const void *f2)
{
if ((*((uint8_t *) f1)) < (*((uint8_t *) f2)))
return (-1);
return (((*((uint8_t *) f1)) > (*((uint8_t *) f2))) ? 1 : 0);
}
static int32_t byte_greater(const void *f1, const void *f2)
{
return (-byte_less(f1, f2));
}
static int32_t dbl_less_2(const void *f1, const void *f2)
{
s7_double p1 = real(*((s7_pointer *) f1)), p2 =
real(*((s7_pointer *) f2));
if (p1 < p2)
return (-1);
return ((p1 > p2) ? 1 : 0);
}
static int32_t int_less_2(const void *f1, const void *f2)
{
s7_int p1 = integer(*((s7_pointer *) f1)), p2 =
integer(*((s7_pointer *) f2));
if (p1 < p2)
return (-1);
return ((p1 > p2) ? 1 : 0);
}
static int32_t dbl_greater_2(const void *f1, const void *f2)
{
return (-dbl_less_2(f1, f2));
}
static int32_t int_greater_2(const void *f1, const void *f2)
{
return (-int_less_2(f1, f2));
}
static int32_t str_less_2(const void *f1, const void *f2)
{
s7_pointer p1 = (*((s7_pointer *) f1)), p2 = (*((s7_pointer *) f2));
return (scheme_strcmp(p1, p2));
}
static int32_t str_greater_2(const void *f1, const void *f2)
{
return (-str_less_2(f1, f2));
}
static int32_t chr_less_2(const void *f1, const void *f2)
{
uint8_t p1 = character(*((s7_pointer *) f1)), p2 =
character(*((s7_pointer *) f2));
if (p1 < p2)
return (-1);
return ((p1 > p2) ? 1 : 0);
}
static int32_t chr_greater_2(const void *f1, const void *f2)
{
return (-chr_less_2(f1, f2));
}
#if MS_WINDOWS || defined(__APPLE__) || defined(__FreeBSD__)
struct sort_r_data {
void *arg;
int (*compar)(const void *a1, const void *a2, void *aarg);
};
static int sort_r_arg_swap(void *s, const void *aa, const void *bb)
{
struct sort_r_data *ss = (struct sort_r_data *) s;
return (ss->compar) (aa, bb, ss->arg);
}
#endif
/* qsort_r in Linux requires _GNU_SOURCE and is different from q_sort_r in FreeBSD, neither matches qsort_s in Windows
* this code tested only in Linux and the mac -- my virtualbox freebsd died, netbsd and openbsd run using fallback code.
*/
static void local_qsort_r(void *base, size_t nmemb, size_t size,
int (*compar)(const void *, const void *,
void *), void *arg)
{
#if (defined(__linux__)) && (defined(__GLIBC__)) /* __GLIBC__ because musl does not have qsort_r and has no way to detect it */
qsort_r(base, nmemb, size, compar, arg);
#else
#if defined(__APPLE__) || defined(__FreeBSD__) /* not in OpenBSD or NetBSD as far as I can tell */
struct sort_r_data tmp = { arg, compar };
qsort_r(base, nmemb, size, &tmp, &sort_r_arg_swap);
#else
#if MS_WINDOWS
struct sort_r_data tmp = { arg, compar };
qsort_s(base, nmemb, size, sort_r_arg_swap, &tmp);
#else
/* from the Net somewhere, by "Pete", about 25 times slower than libc's qsort_r in this context */
if (nmemb > 1) {
uint8_t *array, *i, *j, *k, *after;
size_t h, t;
array = (uint8_t *) base;
after = (uint8_t *) (nmemb * size + array);
nmemb /= 4;
h = nmemb + 1;
for (t = 1; nmemb != 0; nmemb /= 4)
t *= 2;
do {
size_t bytes = h * size;
i = bytes + array;
do {
j = i - bytes;
if (compar(j, i, arg) > 0) {
k = i;
do {
uint8_t *end, *p1 = j, *p2 = k;
end = p2 + size;
do {
uint8_t swap = *p1;
*p1++ = *p2;
*p2++ = swap;
} while (p2 != end);
if (bytes + array > j)
break;
k = j;
j -= bytes;
} while (compar(j, k, arg) > 0);
}
i += size;
} while (i != after);
t /= 2;
h = t * t - t * 3 / 2 + 1;
} while (t != 0);
}
#endif
#endif
#endif
}
static int32_t vector_sort(const void *v1, const void *v2, void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
return (((*(sc->sort_f))
(sc, (*(s7_pointer *) v1), (*(s7_pointer *) v2))) ? -1 : 1);
}
static int32_t vector_sort_lt(const void *v1, const void *v2, void *arg)
{ /* for qsort_r */
s7_pointer s1 = (*(s7_pointer *) v1), s2 = (*(s7_pointer *) v2);
if ((is_t_integer(s1)) && (is_t_integer(s2)))
return ((integer(s1) < integer(s2)) ? -1 : 1);
return ((lt_b_7pp((s7_scheme *) arg, s1, s2)) ? -1 : 1);
}
static int32_t vector_car_sort(const void *v1, const void *v2, void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
s7_pointer a = (*(s7_pointer *) v1), b = (*(s7_pointer *) v2);
a = (is_pair(a)) ? car(a) : g_car(sc, set_plist_1(sc, a));
b = (is_pair(b)) ? car(b) : g_car(sc, set_plist_1(sc, b));
return (((*(sc->sort_f)) (sc, a, b)) ? -1 : 1);
}
static int32_t vector_cdr_sort(const void *v1, const void *v2, void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
s7_pointer a = (*(s7_pointer *) v1), b = (*(s7_pointer *) v2);
a = (is_pair(a)) ? cdr(a) : g_cdr(sc, set_plist_1(sc, a));
b = (is_pair(b)) ? cdr(b) : g_cdr(sc, set_plist_1(sc, b));
return (((*(sc->sort_f)) (sc, a, b)) ? -1 : 1);
}
static int32_t opt_bool_sort(const void *v1, const void *v2, void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); /* first slot in curlet */
slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); /* second slot in curlet */
return ((sc->sort_fb(sc->sort_o)) ? -1 : 1);
}
static int32_t opt_bool_sort_0(const void *v1, const void *v2, void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); /* first slot in curlet */
slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); /* second slot in curlet */
return ((sc->sort_fb(sc->sort_o)) ? -1 : 1);
}
static int32_t opt_bool_sort_p(const void *v1, const void *v2, void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
slot_set_value(sc->sort_v1, (*(s7_pointer *) v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *) v2));
return ((sc->opts[0]->v[O_WRAP].fp(sc->opts[0]) == sc->F) ? 1 : -1);
}
#define SORT_O1 1
static inline int32_t begin_bool_sort_bp(s7_scheme * sc, const void *v1,
const void *v2, bool int_expr)
{
s7_int i;
opt_info *top = sc->opts[0], *o;
slot_set_value(sc->sort_v1, (*(s7_pointer *) v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *) v2));
for (i = 0; i < sc->sort_body_len - 1; i++) {
o = top->v[SORT_O1 + i].o1;
o->v[0].fp(o);
}
o = top->v[SORT_O1 + i].o1;
if (int_expr)
return ((o->v[0].fb(o)) ? -1 : 1);
return ((o->v[0].fp(o) != sc->F) ? -1 : 1);
}
static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2,
void *arg)
{
return (begin_bool_sort_bp((s7_scheme *) arg, v1, v2, true));
}
static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2,
void *arg)
{
return (begin_bool_sort_bp((s7_scheme *) arg, v1, v2, false));
}
static int32_t opt_begin_bool_sort_b2(const void *v1, const void *v2,
void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
opt_info *top = sc->opts[0], *o;
slot_set_value(sc->sort_v1, (*(s7_pointer *) v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *) v2));
o = top->v[SORT_O1].o1;
o->v[0].fp(o);
o = top->v[SORT_O1 + 1].o1;
return ((o->v[0].fb(o)) ? -1 : 1);
}
static int32_t closure_sort(const void *v1, const void *v2, void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
slot_set_value(sc->sort_v1, (*(s7_pointer *) v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *) v2));
push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code);
sc->code = sc->sort_body; /* this should be ok because we checked in advance that it is a safe closure (no sort! for example) */
eval(sc, sc->sort_op);
return ((sc->value != sc->F) ? -1 : 1);
}
static int32_t closure_sort_begin(const void *v1, const void *v2,
void *arg)
{
s7_scheme *sc = (s7_scheme *) arg;
slot_set_value(sc->sort_v1, (*(s7_pointer *) v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *) v2));
push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code);
push_stack_no_args(sc, OP_BEGIN_NO_HOOK, T_Pair(sc->sort_begin));
sc->code = sc->sort_body;
eval(sc, sc->sort_op);
return ((sc->value != sc->F) ? -1 : 1);
}
static s7_b_7pp_t s7_b_7pp_function(s7_pointer f);
static opt_info *alloc_opo(s7_scheme * sc);
static s7_pointer g_sort(s7_scheme * sc, s7_pointer args)
{
#define H_sort "(sort! sequence less?) sorts a sequence using the function 'less?' to compare elements."
#define Q_sort s7_make_signature(sc, 3, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_procedure_symbol)
s7_pointer data = car(args), lessp, lx;
s7_int len = 0, n, k;
int32_t(*sort_func) (const void *v1, const void *v2, void *arg);
s7_pointer *elements;
/* both the intermediate vector (if any) and the current args pointer need GC protection,
* but it is a real bother to unprotect args at every return statement, so I'll use temp3
*/
sc->temp3 = args; /* this is needed but maybe insufficient... if sort is semisafe, we should protect the args, not the list: use OP_GC_PROTECT? */
if (is_null(data)) {
/* (apply sort! () #f) should be an error I think */
lessp = cadr(args);
if (type(lessp) < T_CONTINUATION)
return (method_or_bust_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);
}
if (is_immutable(data))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string, sc->sort_symbol,
data)));
if (!is_sequence(data))
return (wrong_type_argument_with_type
(sc, sc->sort_symbol, 1, data, a_sequence_string));
lessp = cadr(args);
if (type(lessp) <= T_GOTO)
return (wrong_type_argument_with_type
(sc, sc->sort_symbol, 2, lessp,
a_normal_procedure_string));
if (!s7_is_aritable(sc, lessp, 2))
return (wrong_type_argument_with_type
(sc, sc->sort_symbol, 2, lessp, an_eq_func_string));
sort_func = NULL;
sc->sort_f = NULL;
if ((is_c_function(lessp)) && (is_safe_procedure(lessp))) { /* (sort! a <) */
s7_pointer 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,
wrap_string(sc,
"sort! function should return a boolean",
38)));
sc->sort_f = s7_b_7pp_function(lessp);
if (sc->sort_f)
sort_func =
(sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort;
} else {
if (is_closure(lessp)) {
s7_pointer expr = car(closure_body(lessp)), largs =
closure_args(lessp);
if ((is_pair(largs)) && /* closure args not a symbol, etc */
(!arglist_has_rest(sc, largs))) {
if ((is_null(cdr(closure_body(lessp)))) &&
(is_optimized(expr)) &&
(is_safe_c_op(optimize_op(expr))) &&
/* since (sort seq (lambda (a b) ...)) can't return a "safe closure" (the hop bit is off in
* optimize in this case, for some arcane reason), the optimized expression won't be hop_safe,
* but that is irrelevant at this point -- if c_function_is_ok, we're good to go.
*/
((op_has_hop(expr)) || ((is_global(car(expr))) && /* (sort! x (lambda (car y) (car x)...))! */
(c_function_is_ok(sc, expr))))) {
int32_t orig_data = optimize_op(expr);
s7_pointer lp;
set_optimize_op(expr, optimize_op(expr) | 1);
if ((optimize_op(expr) == HOP_SAFE_C_SS) &&
(car(largs) == cadr(expr)) &&
(cadr(largs) == caddr(expr))) {
lp = lookup(sc, car(expr));
sc->sort_f = s7_b_7pp_function(lp);
if (sc->sort_f) {
sort_func =
(sc->sort_f ==
lt_b_7pp) ? vector_sort_lt : vector_sort;
lessp = lp;
}
} else
if ((optimize_op(expr) == HOP_SAFE_C_opSq_opSq) &&
((caadr(expr) == sc->car_symbol)
|| (caadr(expr) == sc->cdr_symbol))
&& (caadr(expr) == caaddr(expr))
&& (car(largs) == cadadr(expr))
&& (cadr(largs) == cadaddr(expr))) {
lp = lookup(sc, car(expr));
sc->sort_f = s7_b_7pp_function(lp);
if (sc->sort_f) {
sort_func =
((caadr(expr) ==
sc->car_symbol) ? vector_car_sort :
vector_cdr_sort);
lessp = lp;
}
}
set_optimize_op(expr, orig_data);
}
if (!sort_func) {
s7_pointer init_val, old_e = sc->curlet;
if (is_float_vector(data))
init_val = real_zero;
else
init_val = ((is_int_vector(data))
|| (is_byte_vector(data))) ? int_zero :
sc->F;
sc->curlet =
make_let_with_two_slots(sc, closure_let(lessp),
car(largs), init_val,
cadr(largs), init_val);
sc->sort_body = expr;
sc->sort_v1 = let_slots(sc->curlet);
sc->sort_v2 = next_slot(let_slots(sc->curlet));
if (is_null(cdr(closure_body(lessp)))) {
if (!no_bool_opt(closure_body(lessp))) {
s7_pfunc sf1;
sf1 =
s7_bool_optimize(sc, closure_body(lessp));
if (sf1) {
if (sc->opts[0]->v[0].fb == p_to_b)
sort_func = opt_bool_sort_p;
else {
sc->sort_o = sc->opts[0];
sc->sort_fb = sc->sort_o->v[0].fb;
sort_func =
(sc->pc ==
1) ? opt_bool_sort_0 :
opt_bool_sort;
}
} else
set_no_bool_opt(closure_body(lessp));
}
} else {
sc->sort_body_len =
s7_list_length(sc, closure_body(lessp));
if (sc->sort_body_len < (NUM_VUNIONS - SORT_O1)) {
s7_pointer p;
int32_t ctr;
opt_info *top;
sc->pc = 0;
top = alloc_opo(sc);
for (ctr = SORT_O1, p = closure_body(lessp);
is_pair(cdr(p)); ctr++, p = cdr(p)) {
top->v[ctr].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
break;
}
if (is_null(cdr(p))) {
int32_t start = sc->pc;
top->v[ctr].o1 = sc->opts[start];
if (bool_optimize_nw(sc, p))
sort_func =
(sc->sort_body_len ==
2) ? opt_begin_bool_sort_b2 :
opt_begin_bool_sort_b;
else {
pc_fallback(sc, start);
if (cell_optimize(sc, p))
sort_func = opt_begin_bool_sort_p;
}
}
}
}
if (!sort_func)
set_curlet(sc, old_e);
}
if ((!sort_func) && (is_safe_closure(lessp))) { /* no embedded sort! or call/cc, etc */
sc->curlet =
make_let_with_two_slots(sc, closure_let(lessp),
car(largs), sc->F,
cadr(largs), sc->F);
sc->sort_body = car(closure_body(lessp));
sc->sort_begin = cdr(closure_body(lessp));
sort_func =
(is_null(sc->sort_begin)) ? closure_sort :
closure_sort_begin;
sc->sort_op =
(is_syntactic_pair(sc->sort_body)) ? (opcode_t)
optimize_op(sc->sort_body) : (opcode_t) OP_EVAL;
sc->sort_v1 = let_slots(sc->curlet);
sc->sort_v2 = next_slot(let_slots(sc->curlet));
}
}
}
}
switch (type(data)) {
case T_PAIR:
len = s7_list_length(sc, data); /* 0 here == infinite */
if (len <= 0)
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"sort! argument 1 should be a proper list: ~S",
44), data)));
if (len < 2)
return (data);
if (sort_func) {
s7_int i;
s7_pointer vec, p;
vec = g_vector(sc, data);
s7_gc_protect_via_stack(sc, vec);
elements = s7_vector_elements(vec);
sc->v = vec;
local_qsort_r((void *) elements, len, sizeof(s7_pointer),
sort_func, (void *) sc);
for (p = data, i = 0; i < len; i++, p = cdr(p)) {
if (is_immutable(p))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->sort_symbol, data)));
set_car(p, elements[i]);
}
sc->v = sc->nil;
unstack(sc); /* not pop_stack! */
return (data);
}
push_stack(sc, OP_SORT_PAIR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original list and func */
set_car(args, g_vector(sc, data));
break;
case T_BYTE_VECTOR:
case T_STRING:
{
s7_int i;
s7_pointer vec;
uint8_t *chrs;
if (is_string(data)) {
len = string_length(data);
chrs = (uint8_t *) string_value(data);
} else {
len = byte_vector_length(data);
chrs = byte_vector_bytes(data);
}
if (len < 2)
return (data);
if (is_c_function(lessp)) {
if (((is_string(data)) && (sc->sort_f == char_lt_b_7pp)) ||
((is_byte_vector(data)) && (sc->sort_f == lt_b_7pp))) {
qsort((void *) chrs, len, sizeof(uint8_t), byte_less);
return (data);
}
if (((is_string(data)) && (sc->sort_f == char_gt_b_7pp)) ||
((is_byte_vector(data)) && (sc->sort_f == gt_b_7pp))) {
qsort((void *) chrs, len, sizeof(uint8_t),
byte_greater);
return (data);
}
}
vec = make_simple_vector(sc, len);
s7_gc_protect_via_stack(sc, vec);
elements = s7_vector_elements(vec);
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 (sort_func) {
sc->v = vec;
local_qsort_r((void *) elements, len, sizeof(s7_pointer),
sort_func, (void *) sc);
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]);
sc->v = sc->nil;
unstack(sc); /* not pop_stack! */
return (data);
}
unstack(sc); /* not pop_stack! */
push_stack(sc, OP_SORT_STRING_END,
cons_unchecked(sc, data, lessp), sc->code);
set_car(args, vec);
}
break;
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
{
s7_int i;
s7_pointer vec;
len = vector_length(data);
if (len < 2)
return (data);
if (is_c_function(lessp)) {
if (sc->sort_f == lt_b_7pp) {
if (is_float_vector(data))
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 (sc->sort_f == gt_b_7pp) {
if (is_float_vector(data))
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);
}
}
/* currently we have to make the ordinary vector here even if not sf1
* 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 make_real|integer below can cause a GC at any time during that loop,
* and the GC mark process expects the vector to have an s7_pointer at every element.
*/
add_vector(sc, vec);
s7_gc_protect_via_stack(sc, vec);
elements = s7_vector_elements(vec);
if (is_float_vector(data))
for (i = 0; i < len; i++)
elements[i] = make_real(sc, float_vector(data, i));
else
for (i = 0; i < len; i++)
elements[i] = make_integer(sc, int_vector(data, i));
if (sort_func) {
sc->v = vec;
local_qsort_r((void *) elements, len, sizeof(s7_pointer),
sort_func, (void *) sc);
if (is_float_vector(data))
for (i = 0; i < len; i++)
float_vector(data, i) = real(elements[i]);
else
for (i = 0; i < len; i++)
int_vector(data, i) = integer(elements[i]);
sc->v = sc->nil;
unstack(sc);
return (data);
}
unstack(sc);
set_car(args, vec);
push_stack(sc, OP_SORT_VECTOR_END, cons_unchecked(sc, data, lessp), sc->code); /* save and gc protect the original homogeneous vector and func */
}
break;
case T_VECTOR:
len = vector_length(data);
if (len < 2)
return (data);
if (sort_func) {
int32_t typ;
s7_pointer *els = s7_vector_elements(data);
typ = type(els[0]);
if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING)
|| (typ == T_CHARACTER)) {
s7_int i;
for (i = 1; i < len; i++)
if (type(els[i]) != typ) {
typ = T_FREE;
break;
}
}
if ((sc->sort_f == lt_b_7pp) || (sc->sort_f == gt_b_7pp)) {
if (typ == T_INTEGER) {
qsort((void *) els, len, sizeof(s7_pointer),
((sc->sort_f ==
lt_b_7pp) ? int_less_2 : int_greater_2));
return (data);
}
if (typ == T_REAL) {
qsort((void *) els, len, sizeof(s7_pointer),
((sc->sort_f ==
lt_b_7pp) ? dbl_less_2 : dbl_greater_2));
return (data);
}
}
if ((typ == T_STRING) && ((sc->sort_f == string_lt_b_7pp)
|| (sc->sort_f == string_gt_b_7pp))) {
qsort((void *) els, len, sizeof(s7_pointer),
((sc->sort_f ==
string_lt_b_7pp) ? str_less_2 : str_greater_2));
return (data);
}
if ((typ == T_CHARACTER) && ((sc->sort_f == char_lt_b_7pp)
|| (sc->sort_f == char_gt_b_7pp))) {
qsort((void *) els, len, sizeof(s7_pointer),
((sc->sort_f =
char_lt_b_7pp) ? chr_less_2 : chr_greater_2));
return (data);
}
local_qsort_r((void *) s7_vector_elements(data), len,
sizeof(s7_pointer), sort_func, (void *) sc);
return (data);
}
break;
default:
return (method_or_bust_with_type
(sc, data, sc->sort_symbol, args, a_sequence_string, 1));
}
n = len - 1;
k = (n / 2) + 1;
lx = s7_make_vector(sc, (sc->safety == NO_SAFETY) ? 4 : 6);
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 > NO_SAFETY) {
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);
sc->v = sc->nil;
return (sc->F);
/* if the comparison function waffles, sort! can hang: (sort! '(1 2 3) (lambda (a b) (= a b)))
* set 'safety to 1 to add a check for this loop, but the "safe" procedures are direct, so unchecked.
*/
}
/* these are for the eval sort -- sort a vector, then if necessary put that data into the original sequence */
static s7_pointer vector_into_list(s7_scheme * sc, s7_pointer vect,
s7_pointer lst)
{
s7_pointer p;
s7_pointer *elements = vector_elements(vect);
s7_int i, len = vector_length(vect);
for (i = 0, p = lst; i < len; i++, p = cdr(p)) {
if (is_immutable(p))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->sort_symbol, lst)));
set_car(p, elements[i]);
}
return (lst);
}
static s7_pointer vector_into_fi_vector(s7_pointer source, s7_pointer dest)
{
s7_pointer *elements = vector_elements(source);
s7_int i, len = vector_length(source);
if (is_float_vector(dest)) {
s7_double *flts = float_vector_floats(dest);
for (i = 0; i < len; i++)
flts[i] = real(elements[i]);
} else {
s7_int *ints = int_vector_ints(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 = vector_elements(vect);
s7_int i, len = vector_length(vect);
uint8_t *str;
if (is_byte_vector(dest)) {
str = (uint8_t *) byte_vector_bytes(dest);
for (i = 0; i < len; i++)
str[i] = (uint8_t) integer(elements[i]);
} else {
str = (uint8_t *) string_value(dest);
for (i = 0; i < len; i++)
str[i] = character(elements[i]);
}
return (dest);
}
#define SORT_N integer(vector_element(sc->code, 0))
#define SORT_K integer(vector_element(sc->code, 1))
#define SORT_J integer(vector_element(sc->code, 2))
#define SORT_K1 integer(vector_element(sc->code, 3))
#define SORT_CALLS integer(vector_element(sc->code, 4))
#define SORT_STOP integer(vector_element(sc->code, 5))
#define SORT_DATA(K) vector_element(car(sc->args), K)
#define SORT_LESSP cadr(sc->args)
static s7_pointer op_heapsort(s7_scheme * sc)
{
s7_int n = SORT_N, j, k = SORT_K1;
s7_pointer lx;
if ((n == k) || (k > ((s7_int) (n / 2)))) /* k == n == 0 is the first case */
return (sc->code);
if (sc->safety > NO_SAFETY) {
SORT_CALLS++;
if (SORT_CALLS > SORT_STOP)
eval_error_any(sc, sc->out_of_range_symbol,
"sort! is caught in an infinite loop, comparison: ~S",
51, SORT_LESSP);
}
j = 2 * k;
SORT_J = j;
if (j < n) {
push_stack_direct(sc, OP_SORT1);
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;
sc->value = sc->T; /* for eval */
} else
sc->value = sc->F;
return (NULL);
}
static bool op_sort1(s7_scheme * sc)
{
s7_int j = SORT_J, k = SORT_K1;
s7_pointer lx;
if (is_true(sc, sc->value)) {
j = j + 1;
SORT_J = j;
}
push_stack_direct(sc, OP_SORT2);
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;
return (false);
}
static bool op_sort2(s7_scheme * sc)
{
s7_int j = SORT_J, k = SORT_K1;
if (is_true(sc, sc->value)) {
s7_pointer lx;
lx = SORT_DATA(j);
SORT_DATA(j) = SORT_DATA(k);
SORT_DATA(k) = lx;
} else
return (true);
SORT_K1 = SORT_J;
return (false);
}
static bool op_sort(s7_scheme * sc)
{
/* coming in sc->args is sort args (data less?), sc->code = #(n k 0 ...)
* here we call the inner loop until k <= 0 [the local k! -- this is tricky because scheme passes args by value]
*/
s7_int k = SORT_K;
if (k > 0) {
SORT_K = k - 1;
SORT_K1 = k - 1;
push_stack_direct(sc, OP_SORT);
return (false);
}
return (true);
}
static bool op_sort3(s7_scheme * sc)
{
s7_int n = SORT_N;
s7_pointer lx;
if (n <= 0) {
sc->value = car(sc->args);
return (true);
}
lx = SORT_DATA(0);
SORT_DATA(0) = SORT_DATA(n);
SORT_DATA(n) = lx;
SORT_N = n - 1;
SORT_K1 = 0;
push_stack_direct(sc, OP_SORT3);
return (false);
}
/* -------- hash tables -------- */
static void free_hash_table(s7_scheme * sc, s7_pointer table)
{
hash_entry_t **entries = hash_table_elements(table);
if (hash_table_entries(table) > 0) {
s7_int i, 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 = hash_entry_next(p);
liberate_block(sc, p);
}
for (p = entries[i]; p; p = n) {
n = hash_entry_next(p);
liberate_block(sc, p);
}
}
}
liberate(sc, hash_table_block(table));
}
static hash_entry_t *make_hash_entry(s7_scheme * sc, s7_pointer key,
s7_pointer value, s7_int raw_hash)
{
hash_entry_t *p;
p = (hash_entry_t *) mallocate_block(sc);
hash_entry_key(p) = key;
hash_entry_set_value(p, value);
hash_entry_set_raw_hash(p, raw_hash);
return (p);
}
/* -------------------------------- hash-table? -------------------------------- */
bool s7_is_hash_table(s7_pointer p)
{
return (is_hash_table(p));
}
static s7_pointer g_is_hash_table(s7_scheme * sc, s7_pointer args)
{
#define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table"
#define Q_is_hash_table sc->pl_bt
check_boolean_method(sc, is_hash_table, sc->is_hash_table_symbol,
args);
}
/* -------------------------------- hash-table-entries -------------------------------- */
static s7_pointer g_hash_table_entries(s7_scheme * sc, s7_pointer args)
{
#define H_hash_table_entries "(hash-table-entries obj) returns the number of entries in the hash-table obj"
#define Q_hash_table_entries s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol)
if (!is_hash_table(car(args)))
return (method_or_bust_one_arg
(sc, car(args), sc->hash_table_entries_symbol, args,
T_HASH_TABLE));
return (make_integer(sc, hash_table_entries(car(args))));
}
static s7_int hash_table_entries_i_7p(s7_scheme * sc, s7_pointer p)
{
if (!is_hash_table(p))
return (integer
(method_or_bust_one_arg_p
(sc, p, sc->hash_table_entries_symbol, T_HASH_TABLE)));
return (hash_table_entries(p));
}
/* ---------------- hash map and equality tables ---------------- */
/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? string-ci=? char=? char-ci=? (default=equal?) */
#define hash_loc(Sc, Table, Key) (*(hash_table_mapper(Table)[type(Key)]))(Sc, Table, Key)
static hash_map_t eq_hash_map[NUM_TYPES];
static hash_map_t string_eq_hash_map[NUM_TYPES];
static hash_map_t char_eq_hash_map[NUM_TYPES];
static hash_map_t closure_hash_map[NUM_TYPES];
static hash_map_t equivalent_hash_map[NUM_TYPES];
static hash_map_t c_function_hash_map[NUM_TYPES];
#if (!WITH_PURE_S7)
static hash_map_t string_ci_eq_hash_map[NUM_TYPES];
static hash_map_t char_ci_eq_hash_map[NUM_TYPES];
#endif
/* also default_hash_map */
/* ---------------- hash-code ---------------- */
/* eqfunc handling which will require other dummy tables */
static s7_pointer make_dummy_hash_table(s7_scheme * sc)
{
s7_pointer table; /* make the absolute minimal hash-table that can support hash-code */
table = (s7_pointer) Calloc(1, sizeof(s7_cell));
set_type_bit(table, T_IMMUTABLE | T_HASH_TABLE | T_UNHEAP);
hash_table_mapper(table) = default_hash_map;
return (table);
}
s7_int s7_hash_code(s7_scheme * sc, s7_pointer obj, s7_pointer eqfunc)
{
return (default_hash_map[type(obj)]
(sc, sc->dummy_equal_hash_table, obj));
}
static s7_pointer g_hash_code(s7_scheme * sc, s7_pointer args)
{
#define H_hash_code "(hash-code obj (eqfunc)) returns an integer suitable for use as a hash code for obj."
#define Q_hash_code s7_make_signature(sc, 3, sc->is_integer_symbol, sc->T, sc->T)
s7_pointer obj = car(args);
return (make_integer
(sc,
default_hash_map[type(obj)] (sc, sc->dummy_equal_hash_table,
obj)));
}
static bool (*equals[NUM_TYPES])(s7_scheme * sc, s7_pointer x,
s7_pointer y, shared_info_t * ci);
static bool (*equivalents[NUM_TYPES])(s7_scheme * sc, s7_pointer x,
s7_pointer y, shared_info_t * ci);
static hash_entry_t *(*default_hash_checks[NUM_TYPES])(s7_scheme * sc,
s7_pointer table,
s7_pointer key);
static hash_entry_t *(*equal_hash_checks[NUM_TYPES])(s7_scheme * sc,
s7_pointer table,
s7_pointer key);
/* ---------------- hash empty ---------------- */
static hash_entry_t *hash_empty(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (sc->unentry);
}
/* ---------------- hash syntax ---------------- */
static s7_int hash_map_syntax(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (pointer_map(syntax_symbol(key)));
}
static hash_entry_t *hash_equal_syntax(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int loc;
loc = hash_loc(sc, table, key) & hash_table_mask(table);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if ((is_syntax(hash_entry_key(x))) && (syntax_symbol(hash_entry_key(x)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */
return (x);
return (sc->unentry);
}
/* ---------------- hash symbols ---------------- */
static s7_int hash_map_symbol(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (pointer_map(key));
}
static hash_entry_t *hash_symbol(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
for (x =
hash_table_element(table,
pointer_map(key) & hash_table_mask(table)); x;
x = hash_entry_next(x))
if (key == hash_entry_key(x))
return (x);
return (sc->unentry);
}
/* ---------------- hash numbers ---------------- */
static s7_int hash_float_location(s7_double x)
{
return (((is_NaN(x)) || (is_inf(x))) ? 0 : (s7_int) floor(fabs(x)));
}
static s7_int hash_map_int(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (s7_int_abs(integer(key)));
}
static s7_int hash_map_real(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (hash_float_location(real(key)));
}
static s7_int hash_map_complex(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (hash_float_location(real_part(key)));
}
static s7_int hash_map_ratio(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
/* if numerator is -9223372036854775808, s7_int_abs overflows -- need to divide, then abs: -9223372036854775808/3: -3074457345618258602 3074457345618258602
* (s7_int)floorl(fabsl(fraction(key))) is no good here, 3441313796169221281/1720656898084610641: 1 2 (in valgrind),
* floor ratio is 1: (- (* 2 1720656898084610641) 3441313796169221281) -> 1
* or (gmp:) 1.999999999999999999418826611445214136431E0, so the floorl(fabsl) version is wrong
*/
return (s7_int_abs(numerator(key) / denominator(key)));
}
#if WITH_GMP
static s7_int hash_map_big_int(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
/* may need to use quotient here */
mpz_abs(sc->mpz_1, big_integer(key));
return (mpz_get_si(sc->mpz_1)); /* returns the bits that fit */
}
static s7_int hash_map_big_ratio(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
mpq_abs(sc->mpq_1, big_ratio(key));
mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_1), mpq_denref(sc->mpq_1));
return (mpz_get_si(sc->mpz_1));
}
static s7_int hash_map_big_real_1(s7_scheme * sc, s7_pointer table,
mpfr_t key)
{
if ((mpfr_nan_p(key)) || (mpfr_inf_p(key)))
return (0);
mpfr_abs(sc->mpfr_1, key, MPFR_RNDN);
/* mpfr_get_si returns most-positive-int if > 2^63! luckily there aren't any more of these */
mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); /* floor not round */
return (mpz_get_si(sc->mpz_1));
}
static s7_int hash_map_big_real(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (hash_map_big_real_1(sc, table, big_real(key)));
}
static s7_int hash_map_big_complex(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (hash_map_big_real_1(sc, table, mpc_realref(big_complex(key))));
}
#endif
static hash_entry_t *find_number_in_bin(s7_scheme * sc, hash_entry_t * bin,
s7_pointer key)
{
s7_double old_eps;
bool (*equiv)(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci);
old_eps = sc->equivalent_float_epsilon;
equiv = equivalents[type(key)];
sc->equivalent_float_epsilon = sc->hash_table_float_epsilon;
for (; bin; bin = hash_entry_next(bin))
if (equiv(sc, key, hash_entry_key(bin), NULL)) {
sc->equivalent_float_epsilon = old_eps;
return (bin);
}
sc->equivalent_float_epsilon = old_eps;
return (NULL);
}
static hash_entry_t *hash_number_equivalent(s7_scheme * sc,
s7_pointer table,
s7_pointer key)
{
/* for equivalent? and =, kind of complicated because two bins can be involved if the key is close to an integer */
#if WITH_GMP
/* first try loc from hash_loc, then get key-floor(key) [with abs], and check against
* epsilon: diff < eps call find big in bin-1, diff > 1.0-eps call same in bin+1
*/
s7_int loc, loc1, hash_mask = hash_table_mask(table), hash_loc;
hash_entry_t *i1;
loc = hash_loc(sc, table, key);
hash_loc = loc & hash_mask;
i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key);
if (i1)
return (i1);
if (is_real(key)) {
s7_pointer res;
res = any_real_to_mpfr(sc, key, sc->mpfr_1);
if (res)
return (sc->unentry);
} else if (is_t_complex(key))
mpfr_set_d(sc->mpfr_1, real_part(key), MPFR_RNDN);
else
mpfr_set(sc->mpfr_1, mpc_realref(big_complex(key)), MPFR_RNDN);
/* mpfr_1 is big_real, so we can use hash_loc of big_real (and can ignore NaN's): */
mpfr_abs(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
mpfr_add_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon,
MPFR_RNDN);
mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD);
loc1 = mpz_get_si(sc->mpz_1);
if (loc1 != loc) {
if (loc1 == hash_table_mask(table))
loc1 = 0;
hash_loc = loc1 & hash_mask;
i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc),
key);
return ((i1) ? i1 : sc->unentry);
}
mpfr_sub_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon,
MPFR_RNDN);
mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD);
loc1 = mpz_get_si(sc->mpz_1);
if (loc1 != loc) {
if (loc1 < 0)
loc1 = hash_table_mask(table);
hash_loc = loc1 & hash_mask;
i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc),
key);
if (i1)
return (i1);
}
return (sc->unentry);
#else
s7_int iprobe, loc;
s7_double bin_dist, fprobe, keyval;
hash_entry_t *i1;
keyval = (is_real(key)) ? s7_real(key) : real_part(key);
fprobe = fabs(keyval);
iprobe = (s7_int) floor(fprobe);
loc = iprobe & hash_table_mask(table);
i1 = find_number_in_bin(sc, hash_table_element(table, loc), key);
if (i1)
return (i1);
bin_dist = fprobe - iprobe;
if (bin_dist <= sc->hash_table_float_epsilon) /* maybe closest is below iprobe, key+eps>iprobe but key maps to iprobe-1 */
i1 = find_number_in_bin(sc,
hash_table_element(table,
(loc >
0) ? loc -
1 :
hash_table_mask(table)),
key);
else if (bin_dist >= (1.0 - sc->hash_table_float_epsilon))
i1 = find_number_in_bin(sc,
hash_table_element(table,
(loc <
hash_table_mask(table))
? loc + 1 : 0), key);
return ((i1) ? i1 : sc->unentry);
#endif
}
static hash_entry_t *hash_int(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
#if WITH_GMP
if ((is_t_integer(key)) || (is_t_big_integer(key)))
#else
if (is_t_integer(key))
#endif
{
s7_int loc, hash_mask = hash_table_mask(table), kv;
hash_entry_t *x;
#if WITH_GMP
kv = (is_t_integer(key)) ? integer(key) :
mpz_get_si(big_integer(key));
#else
kv = integer(key);
#endif
loc = s7_int_abs(kv) & hash_mask;
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
#if WITH_GMP
if (is_t_integer(hash_entry_key(x))) {
if (integer(hash_entry_key(x)) == kv)
return (x);
} else
if ((is_t_big_integer(hash_entry_key(x))) &&
(mpz_get_si(big_integer(hash_entry_key(x))) == kv))
return (x);
#else
if (integer(hash_entry_key(x)) == kv)
return (x);
#endif
}
return (sc->unentry);
}
static hash_entry_t *hash_float(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
/* if a hash-table has only t_real keys, its checker is hash_float, but we might use a t_big_real key */
#if WITH_GMP
if ((is_t_real(key)) || (is_t_big_real(key)))
#else
if (is_t_real(key))
#endif
{
s7_double keyval;
s7_int loc, hash_mask;
hash_entry_t *x;
#if WITH_GMP
if (is_t_real(key)) {
keyval = real(key);
if (is_NaN(keyval))
return (sc->unentry);
} else {
if (mpfr_nan_p(big_real(key)))
return (sc->unentry);
keyval = mpfr_get_d(big_real(key), MPFR_RNDN);
}
#else
keyval = real(key);
if (is_NaN(keyval))
return (sc->unentry);
#endif
hash_mask = hash_table_mask(table);
loc = hash_float_location(keyval) & hash_mask;
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) {
if ((is_t_real(hash_entry_key(x))) &&
(keyval == real(hash_entry_key(x))))
return (x);
#if WITH_GMP
if ((is_t_big_real(hash_entry_key(x))) &&
(mpfr_cmp_d(big_real(hash_entry_key(x)), keyval) == 0) &&
(!mpfr_nan_p(big_real(hash_entry_key(x)))))
return (x);
#endif
}
}
return (sc->unentry);
}
static hash_entry_t *hash_num_eq(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int hash_mask = hash_table_mask(table), loc;
loc = hash_loc(sc, table, key) & hash_mask;
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (num_eq_b_7pp(sc, key, hash_entry_key(x)))
return (x);
return (sc->unentry);
}
static hash_entry_t *hash_real_num_eq(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
#if WITH_GMP
if ((is_t_real(key)) && (is_NaN(real(key))))
return (sc->unentry);
if ((is_t_big_real(key)) && (mpfr_nan_p(big_real(key))))
return (sc->unentry);
return (hash_num_eq(sc, table, key));
#else
return ((is_NaN(s7_real(key))) ? sc->unentry :
hash_num_eq(sc, table, key));
#endif
}
static hash_entry_t *hash_complex_num_eq(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
#if WITH_GMP
if ((is_t_complex(key))
&& ((is_NaN(real_part(key))) || (is_NaN(imag_part(key)))))
return (sc->unentry);
if ((is_t_big_complex(key))
&& ((mpfr_nan_p(mpc_realref(big_complex(key))))
|| (mpfr_nan_p(mpc_imagref(big_complex(key))))))
return (sc->unentry);
return (hash_num_eq(sc, table, key));
#else
return (((is_NaN(real_part(key)))
|| (is_NaN(imag_part(key)))) ? sc->unentry : hash_num_eq(sc,
table,
key));
#endif
}
static hash_entry_t *hash_number_num_eq(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
if (is_number(key)) {
#if (!WITH_GMP)
hash_entry_t *x;
s7_int hash_mask = hash_table_mask(table);
hash_map_t map;
map = hash_table_mapper(table)[type(key)];
if (hash_table_checker(table) == hash_int) { /* surely by far the most common case? only ints */
s7_int keyi = integer(key), loc;
loc = map(sc, table, key) & hash_mask;
for (x = hash_table_element(table, loc); x;
x = hash_entry_next(x))
if (keyi == integer(hash_entry_key(x))) /* not in gmp, hash_int as eq_func, what else can key be but t_integer? */
return (x);
} else
#endif
return ((is_real(key)) ? hash_real_num_eq(sc, table, key) :
hash_complex_num_eq(sc, table, key));
}
return (sc->unentry);
}
/* ---------------- hash characters ---------------- */
static s7_int hash_map_char(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (character(key));
}
static hash_entry_t *hash_char(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
if (is_character(key)) {
/* return(hash_eq(sc, table, key));
* but I think if we get here at all, we have to be using default_hash_checks|maps -- see hash_symbol above.
*/
hash_entry_t *x;
s7_int loc;
loc = character(key) & hash_table_mask(table);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (key == hash_entry_key(x))
return (x);
}
return (sc->unentry);
}
#if (!WITH_PURE_S7)
static s7_int hash_map_ci_char(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (upper_character(key));
}
static hash_entry_t *hash_ci_char(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
if (is_character(key)) {
hash_entry_t *x;
s7_int hash_mask = hash_table_mask(table), loc;
loc = hash_loc(sc, table, key) & hash_mask;
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (upper_character(key) == upper_character(hash_entry_key(x)))
return (x);
}
return (sc->unentry);
}
#endif
/* ---------------- hash strings ---------------- */
static s7_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 uint8_t *) string_value(key),
string_length(key));
return (string_hash(key));
}
static hash_entry_t *hash_string(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
if (is_string(key)) {
hash_entry_t *x;
s7_int key_len = string_length(key), hash_mask;
uint64_t hash;
const char *key_str = string_value(key);
if (string_hash(key) == 0)
string_hash(key) =
raw_string_hash((const uint8_t *) string_value(key),
string_length(key));
hash = string_hash(key);
hash_mask = hash_table_mask(table);
if (key_len <= 8) {
for (x = hash_table_element(table, hash & hash_mask); x;
x = hash_entry_next(x))
if ((hash == string_hash(hash_entry_key(x)))
&& (key_len == string_length(hash_entry_key(x))))
return (x);
} else
for (x = hash_table_element(table, hash & hash_mask); x;
x = hash_entry_next(x))
if ((hash == string_hash(hash_entry_key(x))) && (key_len == string_length(hash_entry_key(x))) && /* these are scheme strings, so we can't assume 0=end of string */
(strings_are_equal_with_length
(key_str, string_value(hash_entry_key(x)), key_len)))
return (x);
}
return (sc->unentry);
}
#if (!WITH_PURE_S7)
static s7_int hash_map_ci_string(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
s7_int len = string_length(key);
return ((len ==
0) ? 0 : (len +
(uppers[(int32_t) (string_value(key)[0])] << 4)));
}
static hash_entry_t *hash_ci_string(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
if (is_string(key)) {
hash_entry_t *x;
s7_int hash, hash_mask = hash_table_mask(table);
hash = hash_map_ci_string(sc, table, key);
for (x = hash_table_element(table, hash & hash_mask); x;
x = hash_entry_next(x))
if (scheme_strequal_ci(key, hash_entry_key(x)))
return (x);
}
return (sc->unentry);
}
#endif
/* ---------------- hash eq? ---------------- */
static s7_int hash_map_nil(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (type(key));
}
static s7_int hash_map_eq(s7_scheme * sc, s7_pointer table, s7_pointer key)
{
return (pointer_map(key));
}
static hash_entry_t *hash_eq(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
/* explicit eq? as hash equality func or (for example) symbols as keys */
hash_entry_t *x;
s7_int loc, hash_mask = hash_table_mask(table);
loc = pointer_map(key) & hash_mask; /* hash_map_eq */
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (key == hash_entry_key(x))
return (x);
return (sc->unentry);
}
/* ---------------- hash eqv? ---------------- */
static hash_entry_t *hash_eqv(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int loc, hash_mask = hash_table_mask(table);
loc = hash_loc(sc, table, key) & hash_mask;
if (is_number(key)) {
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (numbers_are_eqv(sc, key, hash_entry_key(x)))
return (x);
} else
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (s7_is_eqv(sc, key, hash_entry_key(x)))
return (x);
return (sc->unentry);
}
/* ---------------- hash equal? ---------------- */
static s7_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 equivalent?, 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 s7_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 (s7_int_abs(int_vector(key, 0)));
return (vector_length(key) + s7_int_abs(int_vector(key, 0)) + s7_int_abs(int_vector(key, 1))); /* overflow is ok here (in + or abs), I guess (as long as it's consistent) */
}
static s7_int hash_map_byte_vector(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
if (byte_vector_length(key) == 0)
return (0);
if (byte_vector_length(key) == 1)
return ((s7_int) byte_vector(key, 0));
return (byte_vector_length(key) + byte_vector(key, 0) +
byte_vector(key, 1));
}
static s7_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(key, 0)));
return (vector_length(key) +
hash_float_location(float_vector(key, 0)) +
hash_float_location(float_vector(key, 1)));
}
static s7_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))); /* see above */
}
static s7_int hash_map_closure(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
s7_pointer old_e, args, body, f = hash_table_procedures_mapper(table);
if (f == sc->unused)
s7_error(sc, make_symbol(sc, "hash-map-recursion"),
set_elist_1(sc,
wrap_string(sc,
"hash-table map function called recursively",
42)));
gc_protect_via_stack(sc, f);
hash_table_set_procedures_mapper(table, sc->unused);
old_e = sc->curlet;
args = closure_args(f);
body = closure_body(f);
sc->curlet =
make_let_with_slot(sc, closure_let(f),
(is_symbol(car(args))) ? car(args) : caar(args),
key);
push_stack_direct(sc, OP_EVAL_DONE);
if (is_pair(cdr(body)))
push_stack_no_args(sc, sc->begin_op, cdr(body));
sc->code = car(body);
eval(sc, OP_EVAL);
unstack(sc);
hash_table_set_procedures_mapper(table, f);
set_curlet(sc, old_e);
if (!s7_is_integer(sc->value))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"hash-table map function should return an integer: ~S",
52), sc->value));
return (integer(sc->value));
}
static s7_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;
s7_int slots;
if ((key == sc->rootlet) || (!tis_slot(let_slots(key))))
return (0);
slot = let_slots(key);
if (!tis_slot(next_slot(slot))) {
if (is_sequence(slot_value(slot))) /* avoid loop if cycles */
return (pointer_map(slot_symbol(slot)));
return (pointer_map(slot_symbol(slot)) +
hash_loc(sc, table, slot_value(slot)));
}
slots = 0;
for (; tis_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); tis_slot(slot); slot = next_slot(slot))
clear_match_symbol(slot_symbol(slot));
if (slots != 1)
return (slots);
slot = let_slots(key);
if (is_sequence(slot_value(slot))) /* avoid loop if cycles */
return (pointer_map(slot_symbol(slot)));
return (pointer_map(slot_symbol(slot)) +
hash_loc(sc, table, slot_value(slot)));
}
static hash_entry_t *hash_equal_eq(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int loc;
loc = hash_loc(sc, table, key) & hash_table_mask(table);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (hash_entry_key(x) == key)
return (x);
return (sc->unentry);
}
static hash_entry_t *hash_equal_integer(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int loc, keyint = integer(key);
loc = s7_int_abs(keyint) & hash_table_mask(table); /* hash_loc -> hash_map_integer */
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) {
if ((is_t_integer(hash_entry_key(x))) &&
(keyint == integer(hash_entry_key(x))))
return (x);
#if WITH_GMP
if ((is_t_big_integer(hash_entry_key(x))) &&
(mpz_cmp_si(big_integer(hash_entry_key(x)), keyint) == 0))
return (x);
#endif
}
return (sc->unentry);
}
static hash_entry_t *hash_equal_ratio(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int loc, keynum = numerator(key), keyden = denominator(key);
loc = s7_int_abs(keynum / keyden) & hash_table_mask(table); /* hash_loc -> hash_map_ratio */
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) {
if ((is_t_ratio(hash_entry_key(x))) &&
(keynum == numerator(hash_entry_key(x))) &&
(keyden == denominator(hash_entry_key(x))))
return (x);
#if WITH_GMP
if ((is_t_big_ratio(hash_entry_key(x))) &&
(keynum ==
mpz_get_si(mpq_numref(big_ratio(hash_entry_key(x)))))
&& (keyden ==
mpz_get_si(mpq_denref(big_ratio(hash_entry_key(x))))))
return (x);
#endif
}
return (sc->unentry);
}
static hash_entry_t *hash_equal_real(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int loc;
s7_double keydbl = real(key);
if (is_NaN(keydbl))
return (sc->unentry);
loc = hash_float_location(keydbl) & hash_table_mask(table);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) {
if ((is_t_real(hash_entry_key(x))) &&
(keydbl == real(hash_entry_key(x))))
return (x);
#if WITH_GMP
if ((is_t_big_real(hash_entry_key(x))) &&
(mpfr_cmp_d(big_real(hash_entry_key(x)), keydbl) == 0) &&
(!mpfr_nan_p(big_real(hash_entry_key(x)))))
return (x);
#endif
}
return (sc->unentry);
}
static hash_entry_t *hash_equal_complex(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int loc;
s7_double keyrl = real_part(key), keyim = imag_part(key);
#if WITH_GMP
if ((is_NaN(keyrl)) || (is_NaN(keyim)))
return (sc->unentry);
#endif
loc = hash_float_location(keyrl) & hash_table_mask(table);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) {
if ((is_t_complex(hash_entry_key(x))) &&
(keyrl == real_part(hash_entry_key(x))) &&
(keyim == imag_part(hash_entry_key(x))))
return (x);
#if WITH_GMP
if ((is_t_big_complex(hash_entry_key(x))) &&
(mpfr_cmp_d(mpc_realref(big_complex(hash_entry_key(x))), keyrl)
== 0)
&&
(mpfr_cmp_d(mpc_imagref(big_complex(hash_entry_key(x))), keyim)
== 0)
&& (!mpfr_nan_p(mpc_realref(big_complex(hash_entry_key(x)))))
&& (!mpfr_nan_p(mpc_imagref(big_complex(hash_entry_key(x))))))
return (x);
#endif
}
return (sc->unentry);
}
static hash_entry_t *hash_equal_any(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int hash, loc;
bool (*equal)(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci);
equal = equals[type(key)];
hash = hash_loc(sc, table, key);
loc = hash & hash_table_mask(table);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (hash_entry_raw_hash(x) == hash)
if (equal(sc, key, hash_entry_key(x), NULL))
return (x);
return (sc->unentry);
}
/* ---------------- hash c_functions ---------------- */
static s7_int hash_map_c_function(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
s7_function f = c_function_call(hash_table_procedures_mapper(table));
set_car(sc->t1_1, key);
return (integer(f(sc, sc->t1_1)));
}
static hash_entry_t *hash_c_function(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int hash, loc, hash_mask = hash_table_mask(table);
s7_function f = c_function_call(hash_table_procedures_checker(table));
hash = hash_loc(sc, table, key);
loc = hash & hash_mask;
set_car(sc->t2_1, key);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (hash_entry_raw_hash(x) == hash) {
set_car(sc->t2_2, hash_entry_key(x));
if (is_true(sc, f(sc, sc->t2_1)))
return (x);
}
return (sc->unentry);
}
static int32_t len_upto_8(s7_pointer p)
{
s7_pointer x;
int32_t i; /* unrolling this loop saves 10-15% */
for (i = 0, x = p; (is_pair(x)) && (i < 8); i++, x = cdr(x));
return (i);
}
static s7_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
* with stats like symbols/pairs/constants at top level, then use those to spread it out over all the locs.
*/
s7_pointer p1;
s7_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;
}
loc = (loc << 3) | len_upto_8(key);
return (loc);
}
static hash_entry_t *hash_closure(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int hash, loc, hash_mask = hash_table_mask(table);
s7_pointer args, body, old_e = sc->curlet, f =
hash_table_procedures_checker(table);
hash = hash_loc(sc, table, key);
loc = hash & hash_mask;
args = closure_args(f); /* in lambda* case, car/cadr(args) can be lists */
body = closure_body(f);
sc->curlet = make_let_with_two_slots(sc, closure_let(f),
(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 = hash_entry_next(x))
if (hash_entry_raw_hash(x) == hash) {
slot_set_value(next_slot(let_slots(sc->curlet)),
hash_entry_key(x));
push_stack_direct(sc, OP_EVAL_DONE);
if (is_pair(cdr(body)))
push_stack_no_args(sc, sc->begin_op, cdr(body));
sc->code = car(body);
eval(sc, OP_EVAL);
if (is_true(sc, sc->value)) {
set_curlet(sc, old_e);
return (x);
}
}
set_curlet(sc, old_e);
return (sc->unentry);
}
static hash_entry_t *hash_equal(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return ((*(equal_hash_checks[type(key)])) (sc, table, key));
}
/* ---------------- hash equivalent? ---------------- */
static hash_entry_t *hash_equivalent(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
hash_entry_t *x;
s7_int hash, loc;
if (is_number(key)) {
if (!is_nan_b_7p(sc, key))
return (hash_number_equivalent(sc, table, key));
for (x = hash_table_element(table, 0); x; x = hash_entry_next(x)) /* NaN is mapped to 0 */
if (is_nan_b_7p(sc, hash_entry_key(x))) /* all NaN's are the same to equivalent? */
return (x);
return (sc->unentry);
}
hash = hash_loc(sc, table, key);
loc = hash & hash_table_mask(table);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if (hash_entry_key(x) == key)
return (x);
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if ((hash_entry_raw_hash(x) == hash) &&
(s7_is_equivalent(sc, hash_entry_key(x), key)))
return (x);
return (sc->unentry);
}
/* -------------------------------- make-hash-table -------------------------------- */
s7_pointer s7_make_hash_table(s7_scheme * sc, s7_int size)
{
s7_pointer table;
block_t *els;
/* size is rounded up to the next power of 2 */
if (size < 2)
size = 2;
else if ((size & (size - 1)) != 0) { /* already 2^n ? */
if ((size & (size + 1)) != 0) { /* already 2^n - 1 ? */
size--;
size |= (size >> 1);
size |= (size >> 2);
size |= (size >> 4);
size |= (size >> 8);
size |= (size >> 16);
size |= (size >> 32);
}
size++;
}
els = (block_t *) callocate(sc, size * sizeof(hash_entry_t *));
new_cell(sc, table, T_HASH_TABLE | T_SAFE_PROCEDURE);
hash_table_mask(table) = size - 1;
hash_table_set_block(table, els);
hash_table_elements(table) = (hash_entry_t **) (block_data(els));
if (!hash_table_elements(table))
s7_error(sc, make_symbol(sc, "memory-error"),
set_elist_2(sc,
wrap_string(sc,
"hash-table not allocated! size: ~D bytes",
40), wrap_integer1(sc,
size *
sizeof
(hash_entry_t
*))));
hash_table_checker(table) = hash_empty;
hash_table_mapper(table) = default_hash_map;
hash_table_entries(table) = 0;
hash_table_set_procedures(table, sc->nil);
add_hash_table(sc, table);
return (table);
}
static bool compatible_types(s7_scheme * sc, s7_pointer eq_type,
s7_pointer value_type)
{
if (eq_type == sc->T)
return (true);
if (eq_type == value_type)
return (true);
if (eq_type == sc->is_number_symbol) /* only = among built-ins, so other cases aren't needed */
return ((value_type == sc->is_integer_symbol) ||
(value_type == sc->is_real_symbol) ||
(value_type == sc->is_complex_symbol) ||
(value_type == sc->is_rational_symbol));
return (false);
}
static s7_pointer g_is_equal(s7_scheme * sc, s7_pointer args);
static s7_pointer g_is_equivalent(s7_scheme * sc, s7_pointer args);
static s7_pointer type_name_string(s7_scheme * sc, s7_pointer arg);
static s7_pointer g_make_hash_table_1(s7_scheme * sc, s7_pointer args,
s7_pointer caller)
{
#define H_make_hash_table "(make-hash-table (size 8) eq-func typer) returns a new hash table. eq-func is the function \
used to check equality of keys; it usually defaults to equal?. typer sets the types of the keys and values that are allowed \
in the table; it is a cons, defaulting to (cons #t #t) which means any types are allowed.\n"
#define Q_make_hash_table s7_make_signature(sc, 4, sc->is_hash_table_symbol, sc->is_integer_symbol, \
s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \
s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol))
s7_int size = sc->default_hash_table_length;
if (is_not_null(args)) {
s7_pointer p = car(args);
if (!s7_is_integer(p))
return (method_or_bust(sc, p, caller, args, T_INTEGER, 1));
size = s7_integer_checked(sc, p);
if (size <= 0) /* we need s7_int here to catch (make-hash-table most-negative-fixnum) etc */
return (simple_out_of_range
(sc, caller, p,
wrap_string(sc, "should be a positive integer", 28)));
if ((size > sc->max_vector_length) || (size >= (1LL << 32LL)))
return (simple_out_of_range
(sc, caller, p, its_too_large_string));
if (is_not_null(cdr(args))) {
s7_pointer ht, proc, dproc = sc->nil;
ht = s7_make_hash_table(sc, size);
/* check for typers */
if (is_pair(cddr(args))) {
s7_pointer typers = caddr(args);
if (is_pair(typers)) {
s7_pointer keyp = car(typers), valp = cdr(typers);
if ((keyp != sc->T) || (valp != sc->T)) { /* one of them is a type checker */
if (((keyp != sc->T) && (!is_c_function(keyp))
&& (!is_any_closure(keyp)))
|| ((valp != sc->T) && (!is_c_function(valp))
&& (!is_any_closure(valp))))
return (wrong_type_argument_with_type
(sc, caller, 3, typers,
wrap_string(sc,
"(key-type . value-type)",
23)));
if ((keyp != sc->T)
&& (!s7_is_aritable(sc, keyp, 1)))
return (wrong_type_argument_with_type
(sc, caller, 3, keyp,
wrap_string(sc,
"a function of 1 argument",
24)));
dproc = cons_unchecked(sc, sc->T, sc->T);
hash_table_set_procedures(ht, dproc);
hash_table_set_key_typer(dproc, keyp);
hash_table_set_value_typer(dproc, valp);
if (is_c_function(keyp)) {
if (!c_function_name(keyp))
return (wrong_type_argument_with_type
(sc, caller, 3, keyp,
wrap_string(sc,
"a named procedure",
17)));
if (c_function_has_simple_elements(keyp))
set_has_simple_keys(ht);
if (!c_function_symbol(keyp))
c_function_symbol(keyp) =
make_symbol(sc, c_function_name(keyp));
if (symbol_type(c_function_symbol(keyp)) !=
T_FREE)
set_has_hash_key_type(ht);
/* c_function_marker is not currently used in this context */
/* now a consistency check for eq-func and key type */
proc = cadr(args);
if (is_c_function(proc)) {
s7_pointer eq_sig;
eq_sig = c_function_signature(proc);
if ((eq_sig) &&
(is_pair(eq_sig)) &&
(is_pair(cdr(eq_sig))) &&
(!compatible_types
(sc, cadr(eq_sig),
c_function_symbol(keyp))))
return (wrong_type_argument_with_type
(sc, caller, 2, proc,
wrap_string(sc,
"a function that matches the key type function",
45)));
}
} else
if ((is_any_closure(keyp)) &&
(!is_symbol
(find_closure
(sc, keyp, closure_let(keyp)))))
return (wrong_type_argument_with_type
(sc, caller, 3, keyp,
wrap_string(sc, "a named function",
16)));
if ((valp != sc->T)
&& (!s7_is_aritable(sc, valp, 1)))
return (wrong_type_argument_with_type
(sc, caller, 3, valp,
wrap_string(sc,
"a function of 1 argument",
24)));
if (is_c_function(valp)) {
if (!c_function_name(valp))
return (wrong_type_argument_with_type
(sc, caller, 3, valp,
wrap_string(sc,
"a named procedure",
17)));
if (c_function_has_simple_elements(valp))
set_has_simple_values(ht);
if (!c_function_symbol(valp))
c_function_symbol(valp) =
make_symbol(sc, c_function_name(valp));
if (symbol_type(c_function_symbol(valp)) !=
T_FREE)
set_has_hash_value_type(ht);
} else
if ((is_any_closure(valp)) &&
(!is_symbol
(find_closure
(sc, valp, closure_let(valp)))))
return (wrong_type_argument_with_type
(sc, caller, 3, valp,
wrap_string(sc, "a named function",
16)));
set_typed_hash_table(ht);
}
} else if (typers != sc->F)
return (wrong_type_argument_with_type
(sc, caller, 3, typers,
wrap_string(sc, "(key-type . value-type)",
23)));
}
/* check eq_func */
proc = cadr(args);
if (is_c_function(proc)) {
hash_set_chosen(ht);
if (!s7_is_aritable(sc, proc, 2))
return (wrong_type_argument_with_type
(sc, caller, 2, proc, an_eq_func_string));
if (c_function_call(proc) == g_is_equal) {
hash_table_checker(ht) = hash_equal;
return (ht);
}
if (c_function_call(proc) == g_is_equivalent) {
hash_table_checker(ht) = hash_equivalent;
hash_table_mapper(ht) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */
return (ht);
}
if (c_function_call(proc) == g_is_eq) {
hash_table_checker(ht) = hash_eq;
hash_table_mapper(ht) = eq_hash_map;
return (ht);
}
if (c_function_call(proc) == g_strings_are_equal) {
hash_table_checker(ht) = hash_string;
hash_table_mapper(ht) = string_eq_hash_map;
return (ht);
}
#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;
return (ht);
}
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;
return (ht);
}
#endif
if (c_function_call(proc) == g_chars_are_equal) {
hash_table_checker(ht) = hash_char;
hash_table_mapper(ht) = char_eq_hash_map;
return (ht);
}
if (c_function_call(proc) == g_num_eq) {
if ((is_typed_hash_table(ht)) &&
(hash_table_key_typer(ht) ==
global_value(sc->is_integer_symbol)))
hash_table_checker(ht) = hash_int;
else
hash_table_checker(ht) = hash_number_num_eq;
return (ht);
}
if (c_function_call(proc) == g_is_eqv) {
hash_table_checker(ht) = hash_eqv;
return (ht);
}
return (s7_error(sc, sc->out_of_range_symbol,
set_elist_2(sc,
wrap_string(sc,
"make-hash-table argument 2, ~S, is not a built-in function it can handle",
72), proc)));
}
/* proc not c_function */
else {
if (is_pair(proc)) {
s7_pointer checker = car(proc), mapper =
cdr(proc), sig;
hash_set_chosen(ht);
if (!((is_any_c_function(checker)) ||
(is_any_closure(checker))))
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"~A: first entry of type info, ~A, is ~A, but should be a function",
65),
caller, checker,
type_name_string(sc,
checker))));
if (!((is_any_c_function(mapper))
|| (is_any_closure(mapper))))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"~A: second entry of type info, ~A, is ~A, but should be a function",
66), caller,
mapper, type_name_string(sc,
mapper))));
if (!(s7_is_aritable(sc, checker, 2)))
return (wrong_type_argument_with_type
(sc, caller, 2, checker,
wrap_string(sc,
"a function of 2 arguments",
25)));
if (!(s7_is_aritable(sc, mapper, 1)))
return (wrong_type_argument_with_type
(sc, caller, 2, mapper,
wrap_string(sc,
"a function of 1 argument",
24)));
if (is_any_c_function(checker)) {
sig = c_function_signature(checker);
if ((sig) &&
(is_pair(sig)) &&
(car(sig) != sc->is_boolean_symbol))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"make-hash-table checker function, ~S, should return a boolean value",
67),
checker));
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))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"make-hash-table mapper function, ~S, should return an integer",
61), mapper));
hash_table_mapper(ht) = c_function_hash_map;
} else
hash_table_mapper(ht) = closure_hash_map;
if (is_null(dproc))
hash_table_set_procedures(ht, proc); /* only place this is newly set (as opposed to preserved in copy) */
else {
set_car(dproc, car(proc));
set_cdr(dproc, cdr(proc));
}
return (ht);
}
return ((proc ==
sc->F) ? ht : wrong_type_argument_with_type(sc,
caller,
2,
proc,
wrap_string
(sc,
"a cons of two functions",
23)));
}
}
}
return (s7_make_hash_table(sc, size));
}
static s7_pointer g_make_hash_table(s7_scheme * sc, s7_pointer args)
{
return (g_make_hash_table_1(sc, args, sc->make_hash_table_symbol));
}
/* -------------------------------- make-weak-hash-table -------------------------------- */
static s7_pointer g_make_weak_hash_table(s7_scheme * sc, s7_pointer args)
{
#define H_make_weak_hash_table "(make-weak-hash-table (size 8) eq-func typers) returns a new weak hash table"
#define Q_make_weak_hash_table s7_make_signature(sc, 4, sc->is_weak_hash_table_symbol, sc->is_integer_symbol, \
s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \
s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol))
s7_pointer table;
table = g_make_hash_table_1(sc, args, sc->make_weak_hash_table_symbol);
set_weak_hash_table(table);
weak_hash_iters(table) = 0;
return (table);
}
/* -------------------------------- weak-hash-table? -------------------------------- */
static s7_pointer g_is_weak_hash_table(s7_scheme * sc, s7_pointer args)
{
#define H_is_weak_hash_table "(weak-hash-table? obj) returns #t if obj is a weak hash-table"
#define Q_is_weak_hash_table sc->pl_bt
#define is_weak_hash(p) ((is_hash_table(p)) && (is_weak_hash_table(p)))
check_boolean_method(sc, is_weak_hash, sc->is_weak_hash_table_symbol,
args);
}
static void init_hash_maps(void)
{
int32_t i;
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
closure_hash_map[i] = hash_map_closure;
c_function_hash_map[i] = hash_map_c_function;
eq_hash_map[i] = hash_map_eq;
equal_hash_checks[i] = hash_equal_any;
default_hash_checks[i] = hash_equal;
}
default_hash_map[T_CHARACTER] = hash_map_char;
default_hash_map[T_SYMBOL] = hash_map_symbol;
default_hash_map[T_SYNTAX] = hash_map_syntax;
default_hash_map[T_STRING] = hash_map_string;
default_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector;
default_hash_map[T_HASH_TABLE] = hash_map_hash_table;
default_hash_map[T_VECTOR] = hash_map_vector;
default_hash_map[T_INT_VECTOR] = hash_map_int_vector;
default_hash_map[T_FLOAT_VECTOR] = hash_map_float_vector;
default_hash_map[T_LET] = hash_map_let;
default_hash_map[T_PAIR] = hash_map_pair;
default_hash_map[T_INTEGER] = hash_map_int;
default_hash_map[T_RATIO] = hash_map_ratio;
default_hash_map[T_REAL] = hash_map_real;
default_hash_map[T_COMPLEX] = hash_map_complex;
#if WITH_GMP
default_hash_map[T_BIG_INTEGER] = hash_map_big_int;
default_hash_map[T_BIG_RATIO] = hash_map_big_ratio;
default_hash_map[T_BIG_REAL] = hash_map_big_real;
default_hash_map[T_BIG_COMPLEX] = hash_map_big_complex;
#endif
string_eq_hash_map[T_STRING] = hash_map_string;
string_eq_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector;
char_eq_hash_map[T_CHARACTER] = hash_map_char;
#if (!WITH_PURE_S7)
string_ci_eq_hash_map[T_STRING] = hash_map_ci_string;
char_ci_eq_hash_map[T_CHARACTER] = hash_map_ci_char;
#endif
for (i = 0; i < NUM_TYPES; i++)
equivalent_hash_map[i] = default_hash_map[i];
equal_hash_checks[T_SYNTAX] = hash_equal_syntax;
equal_hash_checks[T_SYMBOL] = hash_equal_eq;
equal_hash_checks[T_CHARACTER] = hash_equal_eq;
equal_hash_checks[T_INTEGER] = hash_equal_integer;
equal_hash_checks[T_RATIO] = hash_equal_ratio;
equal_hash_checks[T_REAL] = hash_equal_real;
equal_hash_checks[T_COMPLEX] = hash_equal_complex;
default_hash_checks[T_STRING] = hash_string;
default_hash_checks[T_INTEGER] = hash_int;
default_hash_checks[T_REAL] = hash_float;
default_hash_checks[T_SYMBOL] = hash_symbol;
default_hash_checks[T_CHARACTER] = hash_char;
}
static void resize_hash_table(s7_scheme * sc, s7_pointer table)
{
s7_int hash_mask, loc, i, old_size, new_size;
hash_entry_t **new_els, **old_els;
block_t *np;
s7_pointer dproc = hash_table_procedures(table); /* new block_t so we need to pass this across */
s7_int entries = hash_table_entries(table);
old_size = hash_table_mask(table) + 1;
new_size = old_size * 4;
hash_mask = new_size - 1;
np = (block_t *) callocate(sc, new_size * sizeof(hash_entry_t *));
new_els = (hash_entry_t **) (block_data(np));
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 = hash_entry_next(x);
loc = hash_entry_raw_hash(x) & hash_mask;
hash_entry_next(x) = new_els[loc];
new_els[loc] = x;
}
}
liberate(sc, hash_table_block(table));
hash_table_set_block(table, np);
hash_table_elements(table) = new_els;
hash_table_mask(table) = hash_mask; /* was new_size - 1 14-Jun-21 */
hash_table_set_procedures(table, dproc);
hash_table_entries(table) = entries;
}
/* -------------------------------- hash-table-ref -------------------------------- */
s7_pointer s7_hash_table_ref(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return (hash_entry_value
((*hash_table_checker(table)) (sc, table, key)));
}
static s7_pointer g_hash_table_ref(s7_scheme * sc, s7_pointer args)
{
#define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table"
#define Q_hash_table_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T)
s7_pointer table = car(args), nt;
if (!is_hash_table(table))
return (method_or_bust
(sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE,
1));
nt = s7_hash_table_ref(sc, table, cadr(args));
if (is_null(cddr(args))) /* implicit args */
return (nt);
if (nt == sc->F) /* need the error here, not in implicit_index because table should be in the error message, not nt */
return (s7_error
(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, table, args)));
return (implicit_index(sc, nt, cddr(args))); /* 9-Jan-19 */
}
static s7_pointer g_hash_table_ref_2(s7_scheme * sc, s7_pointer args)
{
s7_pointer table = car(args);
if (!is_hash_table(table))
return (method_or_bust
(sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE,
1));
return (hash_entry_value
((*hash_table_checker(table)) (sc, table, cadr(args))));
}
static s7_pointer hash_table_ref_p_pp(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
if (!is_hash_table(table))
return (method_or_bust
(sc, table, sc->hash_table_ref_symbol,
set_plist_2(sc, table, key), T_HASH_TABLE, 1));
return (hash_entry_value
((*hash_table_checker(table)) (sc, table, key)));
}
static bool op_implicit_hash_table_ref_a(s7_scheme * sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
if (!is_hash_table(s)) {
sc->last_function = s;
return (false);
}
sc->value = s7_hash_table_ref(sc, s, fx_call(sc, cdr(sc->code)));
return (true);
}
static s7_pointer hash_table_ref_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if (args == 2) {
s7_pointer key = caddr(expr);
if ((is_pair(key)) && (car(key) == sc->substring_symbol)
&& (is_global(sc->substring_symbol)))
set_c_function(key, sc->substring_uncopied);
return (sc->hash_table_ref_2);
}
return (f);
}
/* -------------------------------- hash-table-set! -------------------------------- */
static s7_pointer remove_from_hash_table(s7_scheme * sc, s7_pointer table,
s7_pointer key, hash_entry_t * p)
{
hash_entry_t *x;
s7_int hash_mask, loc;
if (p == sc->unentry)
return (sc->F);
hash_mask = hash_table_mask(table);
loc = hash_entry_raw_hash(p) & hash_mask;
x = hash_table_element(table, loc);
if (x == p)
hash_table_element(table, loc) = hash_entry_next(x);
else {
hash_entry_t *y;
for (y = x, x = hash_entry_next(x); x;
y = x, x = hash_entry_next(x))
if (x == p) {
hash_entry_next(y) = hash_entry_next(x);
break;
}
}
hash_table_entries(table)--;
if ((hash_table_entries(table) == 0) &&
(!hash_table_checker_locked(table))) {
hash_table_checker(table) = hash_empty;
hash_clear_chosen(table);
}
liberate_block(sc, x);
return (sc->F);
}
static void cull_weak_hash_table(s7_scheme * sc, s7_pointer table)
{
if (hash_table_entries(table) > 0) {
s7_int i, len = hash_table_mask(table) + 1;
hash_entry_t **entries = hash_table_elements(table);
for (i = 0; i < len; i++) {
hash_entry_t *xp, *nxp, *lxp = entries[i];
for (xp = entries[i]; xp; xp = nxp) {
nxp = hash_entry_next(xp);
if (is_free_and_clear(hash_entry_key(xp))) {
if (xp == entries[i]) {
entries[i] = nxp;
lxp = nxp;
} else
hash_entry_next(lxp) = nxp;
liberate_block(sc, xp);
hash_table_entries(table)--;
if (hash_table_entries(table) == 0) {
if (!hash_table_checker_locked(table)) {
hash_table_checker(table) = hash_empty;
hash_clear_chosen(table);
}
return;
}
} else
lxp = xp;
}
}
}
}
static void hash_table_set_checker(s7_pointer table, uint8_t typ)
{
if (hash_table_checker(table) != default_hash_checks[typ]) {
if (hash_table_checker(table) == hash_empty)
hash_table_checker(table) = default_hash_checks[typ];
else {
hash_table_checker(table) = hash_equal;
hash_set_chosen(table);
}
}
}
static s7_pointer hash_table_typer_symbol(s7_scheme * sc, s7_pointer typer)
{
if (typer == sc->T)
return (sc->T);
return ((is_c_function(typer)) ? c_function_symbol(typer) :
find_closure(sc, typer, closure_let(typer)));
}
static const char *hash_table_typer_name(s7_scheme * sc, s7_pointer typer)
{
return ((is_c_function(typer)) ? c_function_name(typer) :
symbol_name(find_closure(sc, typer, closure_let(typer))));
}
static void check_hash_types(s7_scheme * sc, s7_pointer table,
s7_pointer key, s7_pointer value)
{
if (has_hash_key_type(table)) { /* symbol_type and c_function_symbol exist and symbol_type is not T_FREE */
if ((uint8_t)
symbol_type(c_function_symbol(hash_table_key_typer(table))) !=
type(key))
s7_wrong_type_arg_error(sc, "hash-table-set! key", 2, key,
make_type_name(sc,
hash_table_typer_name
(sc,
hash_table_key_typer
(table)),
INDEFINITE_ARTICLE));
} else {
s7_pointer kf = hash_table_key_typer(table);
if (kf != sc->T) {
s7_pointer type_ok;
if (is_c_function(kf))
type_ok = c_function_call(kf) (sc, set_plist_1(sc, key));
else
type_ok = s7_apply_function(sc, kf, set_plist_1(sc, key));
if (type_ok == sc->F)
s7_wrong_type_arg_error(sc, "hash-table-set! key", 2, key,
make_type_name(sc,
hash_table_typer_name
(sc,
hash_table_key_typer
(table)),
INDEFINITE_ARTICLE));
}
}
if (has_hash_value_type(table)) {
if ((uint8_t)
symbol_type(c_function_symbol(hash_table_value_typer(table)))
!= type(value))
s7_wrong_type_arg_error(sc, "hash-table-set! value", 3, value,
make_type_name(sc,
hash_table_typer_name
(sc,
hash_table_value_typer
(table)),
INDEFINITE_ARTICLE));
} else {
s7_pointer vf = hash_table_value_typer(table);
if (vf != sc->T) {
s7_pointer type_ok;
if (is_c_function(vf))
type_ok = c_function_call(vf) (sc, set_plist_1(sc, value));
else
type_ok =
s7_apply_function(sc, vf, set_plist_1(sc, value));
if (type_ok == sc->F)
s7_wrong_type_arg_error(sc, "hash-table-set! value", 3,
value, make_type_name(sc,
hash_table_typer_name
(sc,
hash_table_value_typer
(table)),
INDEFINITE_ARTICLE));
}
}
}
s7_pointer s7_hash_table_set(s7_scheme * sc, s7_pointer table,
s7_pointer key, s7_pointer value)
{
s7_int hash_mask, loc;
hash_entry_t *p, *x;
if (value == sc->F)
return (remove_from_hash_table
(sc, table, key,
(*hash_table_checker(table)) (sc, table, key)));
if ((is_typed_hash_table(table)) && (sc->safety >= NO_SAFETY))
check_hash_types(sc, table, key, value);
x = (*hash_table_checker(table)) (sc, table, key);
if (x != sc->unentry) {
hash_entry_set_value(x, T_Pos(value));
return (value);
}
/* hash_entry_raw_hash(x) can save the hash_loc from the lookup operations, but at some added complexity in
* all the preceding code. This saves about 5% compute time best case in this function.
*/
if (!hash_chosen(table))
hash_table_set_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_checker etc */
else
/* check type -- raise error if incompatible with eq func set by make-hash-table */
if (hash_table_checker(table) == hash_number_num_eq) {
if (!is_number(key))
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
wrap_string(sc,
"hash-table-set! key ~S, is ~A, but the hash-table's key function is =",
69), key,
type_name_string(sc, key))));
} else if (hash_table_checker(table) == hash_eq) {
if (is_number(key)) /* (((type(key) >= T_INTEGER) && (type(key) < T_C_MACRO)) || (type(key) == T_PAIR)), but we might want eq? */
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
wrap_string(sc,
"hash-table-set! key ~S, is ~A, but the hash-table's key function is eq?",
71), key,
type_name_string(sc, key))));
} else
#if WITH_PURE_S7
if (((hash_table_checker(table) == hash_string)
&& (!is_string(key)))
|| ((hash_table_checker(table) == hash_char)
&& (!is_character(key))))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A",
70), key, type_name_string(sc,
key),
(hash_table_checker(table) ==
hash_string) ? sc->
string_eq_symbol : sc->char_eq_symbol)));
#else
if ((((hash_table_checker(table) == hash_string)
|| (hash_table_checker(table) == hash_ci_string))
&& (!is_string(key)))
|| (((hash_table_checker(table) == hash_char)
|| (hash_table_checker(table) == hash_ci_char))
&& (!is_character(key))))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A",
70), key, type_name_string(sc,
key),
(hash_table_checker(table) ==
hash_string) ? sc->string_eq_symbol
: ((hash_table_checker(table) ==
hash_ci_string) ? sc->string_ci_eq_symbol
: ((hash_table_checker(table) ==
hash_char) ? sc->
char_eq_symbol :
sc->char_ci_eq_symbol)))));
#endif
p = mallocate_block(sc);
hash_entry_key(p) = key;
hash_entry_set_value(p, T_Pos(value));
hash_entry_set_raw_hash(p, hash_loc(sc, table, key));
hash_mask = hash_table_mask(table);
loc = hash_entry_raw_hash(p) & hash_mask;
hash_entry_next(p) = hash_table_element(table, loc);
hash_table_element(table, loc) = p;
hash_table_entries(table)++;
if (hash_table_entries(table) > hash_mask)
resize_hash_table(sc, table);
return (value);
}
static s7_pointer g_hash_table_set(s7_scheme * sc, s7_pointer args)
{
#define H_hash_table_set "(hash-table-set! table key value) sets the value associated with key in the hash table to value"
#define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->is_hash_table_symbol, sc->T, sc->T)
s7_pointer table = car(args);
if (!is_mutable_hash_table(table))
return (mutable_method_or_bust
(sc, table, sc->hash_table_set_symbol, args, T_HASH_TABLE,
1));
return (s7_hash_table_set(sc, table, cadr(args), caddr(args)));
}
static s7_pointer hash_table_set_p_ppp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2, s7_pointer p3)
{
if (!is_mutable_hash_table(p1)) /* is_hash_table(p1) is here */
return (mutable_method_or_bust_ppp
(sc, p1, sc->hash_table_set_symbol, p1, p2, p3,
T_HASH_TABLE, 1));
return (s7_hash_table_set(sc, p1, p2, p3));
}
static s7_pointer hash_table_set_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if ((args == 3) && (optimize_op(expr) == HOP_SSA_DIRECT)) { /* a tedious experiment... */
/* this could be HOP_FX_C_SSA if no SSA_DIRECT */
s7_pointer val = cadddr(expr);
if ((is_pair(val)) && (car(val) == sc->add_symbol)
&& (is_proper_list_3(sc, val)) && ((cadr(val) == int_one)
|| (caddr(val) == int_one))) {
s7_pointer add1;
add1 = (cadr(val) == int_one) ? caddr(val) : cadr(val);
if ((is_pair(add1)) && (car(add1) == sc->or_symbol)
&& (is_proper_list_3(sc, add1))
&& (caddr(add1) == int_zero)) {
s7_pointer or1 = cadr(add1);
if ((is_pair(or1))
&& (car(or1) == sc->hash_table_ref_symbol)
&& (is_proper_list_3(sc, or1))
&& (cadr(or1) == cadr(expr))
&& (caddr(or1) == caddr(expr)))
/* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) -- ssa_direct and hop_safe_c_ss */
set_optimize_op(expr, HOP_HASH_TABLE_INCREMENT);
}
}
}
return (f);
}
/* -------------------------------- hash-table -------------------------------- */
static inline s7_pointer hash_table_add(s7_scheme * sc, s7_pointer table,
s7_pointer key, s7_pointer value)
{
s7_int hash, hash_mask, loc;
hash_entry_t *x, *p;
if (!hash_chosen(table))
hash_table_set_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_checker etc */
hash_mask = hash_table_mask(table);
hash = hash_loc(sc, table, key);
loc = hash & hash_mask;
for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
if ((hash_entry_raw_hash(x) == hash) &&
(s7_is_equal(sc, hash_entry_key(x), key)))
return (value);
p = mallocate_block(sc);
hash_entry_key(p) = key;
hash_entry_set_value(p, T_Pos(value));
hash_entry_set_raw_hash(p, hash);
hash_entry_next(p) = hash_table_element(table, loc);
hash_table_element(table, loc) = p;
hash_table_entries(table)++;
if (hash_table_entries(table) > hash_mask)
resize_hash_table(sc, table);
return (value);
}
static s7_pointer g_hash_table(s7_scheme * sc, s7_pointer args)
{
#define H_hash_table "(hash-table ...) returns a hash-table containing the symbol/value pairs passed as its arguments. \
That is, (hash-table 'a 1 'b 2) returns a new hash-table with the two key/value pairs preinstalled."
#define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->T)
s7_int len;
s7_pointer ht;
len = proper_list_length(args);
if (len & 1)
return (s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_2(sc,
wrap_string(sc,
"hash-table got an odd number of arguments: ~S",
45), args)));
len /= 2;
ht = s7_make_hash_table(sc,
(len >
sc->
default_hash_table_length) ? len :
sc->default_hash_table_length);
if (len > 0) {
s7_pointer x, y;
for (x = args, y = cdr(args); is_pair(x);
x = cddr(x), y = unchecked_cdr(cdr(y)))
if (car(y) != sc->F)
hash_table_add(sc, ht, car(x), car(y));
}
return (ht);
}
static s7_pointer g_hash_table_2(s7_scheme * sc, s7_pointer args)
{
s7_pointer ht;
ht = s7_make_hash_table(sc, sc->default_hash_table_length);
if (cadr(args) != sc->F)
hash_table_add(sc, ht, car(args), cadr(args));
return (ht);
}
/* -------------------------------- weak-hash-table -------------------------------- */
static s7_pointer g_weak_hash_table(s7_scheme * sc, s7_pointer args)
{
#define H_weak_hash_table "(weak-hash-table ...) returns a weak-hash-table containing the symbol/value pairs passed as its arguments. \
That is, (weak-hash-table 'a 1 'b 2) returns a new weak-hash-table with the two key/value pairs preinstalled."
#define Q_weak_hash_table Q_hash_table
s7_pointer table;
table = g_hash_table(sc, args);
set_weak_hash_table(table);
weak_hash_iters(table) = 0;
return (table);
}
static s7_pointer hash_table_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
return ((args == 2) ? sc->hash_table_2 : f);
}
static void check_old_hash(s7_scheme * sc, s7_pointer old_hash,
s7_pointer new_hash, s7_int start, s7_int end)
{
s7_int i, count = 0, old_len = hash_table_mask(old_hash) + 1;
hash_entry_t **old_lists = hash_table_elements(old_hash);
hash_entry_t *x;
for (i = 0; i < old_len; i++)
for (x = old_lists[i]; x; x = hash_entry_next(x)) {
if (count >= end)
return;
if (count >= start)
check_hash_types(sc, new_hash, hash_entry_key(x),
hash_entry_value(x));
}
}
static s7_pointer hash_table_copy(s7_scheme * sc, s7_pointer old_hash,
s7_pointer new_hash, s7_int start,
s7_int end)
{
s7_int i, old_len, new_mask, count = 0;
hash_entry_t **old_lists, **new_lists;
hash_entry_t *x, *p;
if ((is_typed_hash_table(new_hash)) &&
(sc->safety >= NO_SAFETY) &&
((!is_typed_hash_table(old_hash)) ||
(hash_table_key_typer(old_hash) != hash_table_key_typer(new_hash))
|| (hash_table_value_typer(old_hash) !=
hash_table_value_typer(new_hash))))
check_old_hash(sc, old_hash, new_hash, start, end);
old_len = hash_table_mask(old_hash) + 1;
new_mask = 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);
if (hash_chosen(old_hash))
hash_set_chosen(new_hash);
if ((start == 0) && (end >= hash_table_entries(old_hash))) {
for (i = 0; i < old_len; i++)
for (x = old_lists[i]; x; x = hash_entry_next(x)) {
s7_int loc;
loc = hash_entry_raw_hash(x) & new_mask;
p = make_hash_entry(sc, hash_entry_key(x),
hash_entry_value(x),
hash_entry_raw_hash(x));
hash_entry_next(p) = new_lists[loc];
new_lists[loc] = p;
}
hash_table_entries(new_hash) = hash_table_entries(old_hash);
return (new_hash);
}
for (i = 0; i < old_len; i++)
for (x = old_lists[i]; x; x = hash_entry_next(x)) {
if (count >= end) {
hash_table_entries(new_hash) = end - start;
return (new_hash);
}
if (count >= start) {
s7_int loc;
loc = hash_entry_raw_hash(x) & new_mask;
p = make_hash_entry(sc, hash_entry_key(x),
hash_entry_value(x),
hash_entry_raw_hash(x));
hash_entry_next(p) = 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 (we're copying old_hash into the existing, non-empty new_hash) */
for (i = 0; i < old_len; i++)
for (x = old_lists[i]; x; x = hash_entry_next(x)) {
if (count >= end)
return (new_hash);
if (count >= start) {
hash_entry_t *y;
y = (*hash_table_checker(new_hash)) (sc, new_hash,
hash_entry_key(x));
if (y != sc->unentry)
hash_entry_set_value(y, hash_entry_value(x));
else {
s7_int loc;
loc = hash_entry_raw_hash(x) & new_mask;
p = make_hash_entry(sc, hash_entry_key(x),
hash_entry_value(x),
hash_entry_raw_hash(x));
hash_entry_next(p) = new_lists[loc];
new_lists[loc] = p;
hash_table_entries(new_hash)++;
if (!hash_chosen(new_hash))
hash_table_set_checker(new_hash,
type(hash_entry_key(x)));
}
}
count++;
}
return (new_hash);
}
static s7_pointer hash_table_fill(s7_scheme * sc, s7_pointer args)
{
s7_pointer val, table = car(args);
if (is_immutable(table))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string, sc->fill_symbol,
table)));
val = cadr(args);
if (hash_table_entries(table) > 0) {
s7_int len;
hash_entry_t **entries = hash_table_elements(table);
len = hash_table_mask(table) + 1; /* minimum len is 2 (see s7_make_hash_table) */
if (val == sc->F) { /* hash-table-ref returns #f if it can't find a key, so val == #f here means empty the table */
hash_entry_t **hp = entries, **hn;
hash_entry_t *p;
hn = (hash_entry_t **) (hp + len);
for (; hp < hn; hp++) {
if (*hp) {
p = *hp;
while (hash_entry_next(p))
p = hash_entry_next(p);
hash_entry_next(p) = sc->block_lists[BLOCK_LIST];
sc->block_lists[BLOCK_LIST] = *hp;
}
hp++;
if (*hp) {
p = *hp;
while (hash_entry_next(p))
p = hash_entry_next(p);
hash_entry_next(p) = sc->block_lists[BLOCK_LIST];
sc->block_lists[BLOCK_LIST] = *hp;
}
}
if (len >= 8)
memclr64(entries, len * sizeof(hash_entry_t *));
else
memclr(entries, len * sizeof(hash_entry_t *));
if (!hash_table_checker_locked(table)) {
hash_table_checker(table) = hash_empty;
hash_clear_chosen(table);
}
hash_table_entries(table) = 0;
} else {
s7_int i;
hash_entry_t *x;
if ((is_typed_hash_table(table)) &&
(((is_c_function(hash_table_value_typer(table))) &&
(c_function_call(hash_table_value_typer(table))
(sc, set_plist_1(sc, val)) == sc->F))
|| ((is_any_closure(hash_table_value_typer(table)))
&&
(s7_apply_function
(sc, hash_table_value_typer(table),
set_plist_1(sc, val)) == sc->F))))
s7_wrong_type_arg_error(sc, "fill!", 2, val,
make_type_name(sc,
hash_table_typer_name
(sc,
hash_table_value_typer
(table)),
INDEFINITE_ARTICLE));
for (i = 0; i < len; i++)
for (x = entries[i]; x; x = hash_entry_next(x))
hash_entry_set_value(x, 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)
{
s7_int i, len = hash_table_mask(old_hash) + 1;
s7_pointer new_hash;
hash_entry_t **old_lists = hash_table_elements(old_hash);
s7_int gc_loc;
new_hash = s7_make_hash_table(sc, len);
gc_loc = gc_protect_1(sc, new_hash);
/* I don't think the original hash functions can make any sense in general, so ignore them */
for (i = 0; i < len; i++) {
hash_entry_t *x;
for (x = old_lists[i]; x; x = hash_entry_next(x))
s7_hash_table_set(sc, new_hash, hash_entry_value(x),
hash_entry_key(x));
}
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,
int32_t args, s7_pointer expr, bool ops)
{
return (f);
}
static void s7_function_set_class(s7_scheme * sc, s7_pointer f,
s7_pointer base_f)
{
c_function_class(f) = c_function_class(base_f);
c_function_set_base(f, base_f);
}
static s7_pointer make_function(s7_scheme * sc, const char *name,
s7_function f, s7_int req, s7_int opt,
bool rst, const char *doc, s7_pointer x,
c_proc_t * ptr)
{
uint32_t ftype = T_C_FUNCTION;
if (req == 0) {
if (rst)
ftype = T_C_ANY_ARGS_FUNCTION;
else if (opt != 0)
ftype = T_C_OPT_ARGS_FUNCTION;
} else if (rst)
ftype = T_C_RST_ARGS_FUNCTION;
set_full_type(x, ftype);
c_function_data(x) = ptr;
c_function_call(x) = f; /* f is T_App 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);
c_function_documentation(x) =
(doc) ? make_permanent_c_string(sc, doc) : NULL;
c_function_signature(x) = sc->F;
c_function_required_args(x) = req;
c_function_optional_args(x) = opt; /* T_C_FUNCTION_STAR type may be set later, so T_Fst not usable here */
c_function_all_args(x) = (rst) ? MAX_ARITY : req + opt;
c_function_class(x) = ++sc->f_class;
c_function_chooser(x) = fallback_chooser;
c_function_opt_data(x) = NULL;
c_function_marker(x) = NULL;
c_function_symbol(x) = NULL;
return (x);
}
static s7_pointer s7_lambda(s7_scheme * sc, s7_function f,
s7_int required_args, s7_int optional_args,
bool rest_arg)
{
/* same as s7_make_function but the new function is not global and permanent; it can be GC'd */
s7_pointer fnc;
block_t *block;
new_cell(sc, fnc, T_PAIR); /* just a place-holder, make_function will set its type and return it */
block = mallocate(sc, sizeof(c_proc_t));
fnc =
make_function(sc, "#<c-function>", f, required_args, optional_args,
rest_arg, NULL, fnc, (c_proc_t *) block_data(block));
c_function_block(fnc) = block;
add_lambda(sc, fnc);
return (fnc);
}
static c_proc_t *alloc_permanent_function(s7_scheme * sc)
{
#define ALLOC_FUNCTION_SIZE 128
if (sc->alloc_function_k == ALLOC_FUNCTION_SIZE) {
sc->alloc_function_cells =
(c_proc_t *) malloc(ALLOC_FUNCTION_SIZE * sizeof(c_proc_t));
add_saved_pointer(sc, sc->alloc_function_cells);
sc->alloc_function_k = 0;
}
return (&(sc->alloc_function_cells[sc->alloc_function_k++]));
}
s7_pointer s7_make_function(s7_scheme * sc, const char *name,
s7_function f, s7_int required_args,
s7_int optional_args, bool rest_arg,
const char *doc)
{
s7_pointer x;
x = alloc_pointer(sc);
x = make_function(sc, name, f, required_args, optional_args, rest_arg,
doc, x, alloc_permanent_function(sc));
unheap(sc, x);
return (x);
}
s7_pointer s7_make_safe_function(s7_scheme * sc, const char *name,
s7_function f, s7_int required_args,
s7_int optional_args, bool rest_arg,
const char *doc)
{
s7_pointer p;
p = s7_make_function(sc, name, f, required_args, optional_args,
rest_arg, doc);
set_type_bit(p, T_SAFE_PROCEDURE);
return (p);
}
s7_pointer s7_make_typed_function(s7_scheme * sc, const char *name,
s7_function f, s7_int required_args,
s7_int optional_args, bool rest_arg,
const char *doc, s7_pointer signature)
{
s7_pointer func;
func =
s7_make_function(sc, name, f, required_args, optional_args,
rest_arg, doc);
set_type_bit(func, T_SAFE_PROCEDURE);
if (signature)
c_function_signature(func) = signature;
return (func);
}
/* -------------------------------- procedure? -------------------------------- */
bool s7_is_procedure(s7_pointer x)
{
return (is_procedure(x));
}
static s7_pointer g_is_procedure(s7_scheme * sc, s7_pointer args)
{
#define H_is_procedure "(procedure? obj) returns #t if obj is a procedure"
#define Q_is_procedure sc->pl_bt
return (make_boolean(sc, is_procedure(car(args))));
}
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)
{
return ((has_closure_let(p)) ? closure_body(p) : sc->nil);
}
s7_pointer s7_closure_let(s7_scheme * sc, s7_pointer p)
{
return ((has_closure_let(p)) ? closure_let(p) : sc->nil);
}
s7_pointer s7_closure_args(s7_scheme * sc, s7_pointer p)
{
return ((has_closure_let(p)) ? closure_args(p) : sc->nil);
}
/* -------------------------------- procedure-source -------------------------------- */
static s7_pointer procedure_type_to_symbol(s7_scheme * sc, int32_t type)
{
switch (type) {
case T_CLOSURE:
return (sc->lambda_symbol);
case T_CLOSURE_STAR:
return (sc->lambda_star_symbol);
case T_MACRO:
return (sc->macro_symbol);
case T_MACRO_STAR:
return (sc->macro_star_symbol);
case T_BACRO:
return (sc->bacro_symbol);
case T_BACRO_STAR:
return (sc->bacro_star_symbol);
default:
if (S7_DEBUGGING)
fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__,
type);
}
return (sc->lambda_symbol);
}
static s7_pointer g_procedure_source(s7_scheme * sc, s7_pointer args)
{
#define H_procedure_source "(procedure-source func) tries to return the definition of func"
#define Q_procedure_source s7_make_signature(sc, 2, sc->is_list_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
/* make it look like a scheme-level lambda */
s7_pointer p = car(args);
if (is_symbol(p)) {
if ((symbol_ctr(p) == 0)
|| ((p = s7_symbol_value(sc, p)) == sc->undefined))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"procedure-source arg, '~S, is unbound",
37), car(args))));
}
if ((is_c_function(p)) || (is_c_macro(p)))
return (sc->nil);
check_method(sc, p, sc->procedure_source_symbol, set_plist_1(sc, p));
if (has_closure_let(p)) {
s7_pointer body = closure_body(p);
/* perhaps if this function has been removed from the heap, it would be better to use copy_body (as in s7_copy)? */
if (is_safe_closure_body(body))
clear_safe_closure_body(body);
return (append_in_place
(sc,
list_2(sc, procedure_type_to_symbol(sc, type(p)),
closure_args(p)), body));
}
if (!is_procedure(p))
return (simple_wrong_type_argument_with_type
(sc, sc->procedure_source_symbol, p,
a_procedure_or_a_macro_string));
return (sc->nil);
}
/* -------------------------------- *current-function* -------------------------------- */
static s7_pointer g_function(s7_scheme * sc, s7_pointer args)
{
#define H_function "(*function* e) returns the current function in e"
#define Q_function s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol)
s7_pointer e, sym, fname, fval;
if (is_null(args)) {
for (e = sc->curlet; is_let(e); e = let_outlet(e))
if ((is_funclet(e)) || (is_maclet(e)))
break;
} else {
e = car(args);
if (!is_let(e))
return (simple_wrong_type_argument
(sc, sc->_function__symbol, e, T_LET));
if (e == sc->rootlet)
return (sc->F);
if (!((is_funclet(e)) || (is_maclet(e))))
e = let_outlet(e);
}
if ((e == sc->rootlet) || (!is_let(e)))
return (sc->F);
if (!((is_funclet(e)) || (is_maclet(e))))
return (sc->F);
/* for C-defined things like hooks and dilambda, let_file and let_line are 0 */
if ((is_null(args)) || (is_null(cdr(args)))) {
if ((has_let_file(e)) &&
(let_file(e) <= (s7_int) sc->file_names_top) &&
(let_line(e) > 0))
return (list_3
(sc, funclet_function(e), sc->file_names[let_file(e)],
make_integer(sc, let_line(e))));
return (funclet_function(e));
}
sym = cadr(args);
if (!is_symbol(sym))
return (simple_wrong_type_argument
(sc, sc->_function__symbol, sym, T_SYMBOL));
if (is_keyword(sym))
sym = keyword_symbol(sym);
fname = funclet_function(e);
fval = s7_symbol_local_value(sc, fname, e);
if (sym == sc->name_symbol)
return (fname);
if (sym == sc->signature_symbol)
return (s7_signature(sc, fval));
if (sym == sc->arity_symbol)
return (s7_arity(sc, fval));
if (sym == sc->documentation_symbol)
return (s7_make_string(sc, s7_documentation(sc, fval)));
if (sym == sc->value_symbol)
return (fval);
if ((sym == sc->line_symbol) && (has_let_file(e)))
return (make_integer(sc, let_line(e)));
if ((sym == sc->file_symbol) && (has_let_file(e)))
return (sc->file_names[let_file(e)]);
if (sym == make_symbol(sc, "funclet"))
return (e);
if (sym == make_symbol(sc, "source"))
return (g_procedure_source(sc, set_plist_1(sc, fval)));
if ((sym == make_symbol(sc, "arglist"))
&& ((is_any_closure(fval)) || (is_any_macro(fval))))
return (closure_args(fval));
return (sc->F);
}
/* -------------------------------- funclet -------------------------------- */
s7_pointer s7_funclet(s7_scheme * sc, s7_pointer p)
{
return ((has_closure_let(p)) ? closure_let(p) : sc->rootlet);
}
static s7_pointer g_funclet(s7_scheme * sc, s7_pointer args)
{
#define H_funclet "(funclet func) tries to return a function's definition environment"
#define Q_funclet s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \
s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_symbol_symbol))
s7_pointer p = car(args), e;
if (is_symbol(p)) {
if ((symbol_ctr(p) == 0)
|| ((p = s7_symbol_value(sc, p)) == sc->undefined))
return (s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args)))); /* not p here */
}
check_method(sc, p, sc->funclet_symbol, args);
if (!((is_any_procedure(p)) || (is_c_object(p))))
return (simple_wrong_type_argument_with_type
(sc, sc->funclet_symbol, p,
a_procedure_or_a_macro_string));
e = find_let(sc, p);
if ((is_null(e)) && (!is_c_object(p))) /* why this complication? */
return (sc->rootlet);
return (e);
}
s7_pointer s7_define_function(s7_scheme * sc, const char *name,
s7_function fnc, s7_int required_args,
s7_int optional_args, bool rest_arg,
const char *doc)
{
s7_pointer func, 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, s7_int required_args,
s7_int optional_args, bool rest_arg,
const char *doc)
{
/* returns (string->symbol name), not the c_proc_t func */
s7_pointer func, 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, s7_int required_args,
s7_int optional_args, bool rest_arg,
const char *doc, s7_pointer signature)
{
/* returns (string->symbol name), not the c_proc_t func */
s7_pointer func, 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);
c_function_set_marker(func, NULL);
return (sym);
}
static s7_pointer define_bool_function(s7_scheme * sc, const char *name,
s7_function fnc,
s7_int optional_args,
const char *doc,
s7_pointer signature,
int32_t sym_to_type,
void (*marker)(s7_pointer p,
s7_int top),
bool simple,
s7_function bool_setter)
{
s7_pointer func, sym, bfunc;
func =
s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc,
signature);
sym = make_symbol(sc, name);
s7_define(sc, sc->nil, sym, func);
if (sym_to_type != T_FREE)
symbol_set_type(sym, sym_to_type);
c_function_symbol(func) = sym;
c_function_set_marker(func, marker);
if (simple)
c_function_set_has_simple_elements(func);
c_function_set_bool_setter(func, bfunc =
s7_make_function(sc, name, bool_setter, 2,
0, false, NULL));
c_function_set_has_bool_setter(func);
c_function_set_setter(bfunc, func);
set_is_bool_function(bfunc);
return (sym);
}
s7_pointer s7_define_unsafe_typed_function(s7_scheme * sc,
const char *name,
s7_function fnc,
s7_int required_args,
s7_int optional_args,
bool rest_arg, const char *doc,
s7_pointer signature)
{
/* returns (string->symbol name), not the c_proc_t func */
s7_pointer func, 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_semisafe_typed_function(s7_scheme * sc,
const char *name,
s7_function fnc,
s7_int required_args,
s7_int optional_args,
bool rest_arg,
const char *doc,
s7_pointer signature)
{
s7_pointer func, sym;
func =
s7_make_function(sc, name, fnc, required_args, optional_args,
rest_arg, doc);
if (signature)
c_function_signature(func) = signature;
set_is_semisafe(func);
sym = make_symbol(sc, name);
s7_define(sc, sc->nil, sym, func);
return (sym);
}
s7_pointer s7_make_function_star(s7_scheme * sc, const char *name,
s7_function fnc, const char *arglist,
const char *doc)
{
s7_pointer func, local_args;
char *internal_arglist;
s7_int len, n_args;
s7_int gc_loc;
s7_pointer *names, *defaults;
block_t *b;
len = safe_strlen(arglist);
b = mallocate(sc, len + 4);
internal_arglist = (char *) block_data(b);
internal_arglist[0] = '\'';
internal_arglist[1] = '(';
memcpy((void *) (internal_arglist + 2), (void *) arglist, len);
internal_arglist[len + 2] = ')';
internal_arglist[len + 3] = '\0';
/* catstrs_direct(internal_arglist, "'(", arglist, ")", (const char *)NULL); */
local_args = s7_eval_c_string(sc, internal_arglist);
gc_loc = gc_protect_1(sc, local_args);
liberate(sc, b);
n_args = s7_list_length(sc, local_args);
if (n_args < 0) {
s7_warn(sc, 256,
"%s rest argument is not supported in C-side define*: %s\n",
name, arglist);
n_args = -n_args;
}
func = s7_make_function(sc, name, fnc, 0, n_args, false, doc);
if (n_args > 0) {
s7_pointer p;
s7_int i;
set_full_type(func, T_C_FUNCTION_STAR | T_UNHEAP); /* unheap from s7_make_function */
c_function_call_args(func) = NULL;
names = (s7_pointer *) Malloc(n_args * sizeof(s7_pointer));
add_saved_pointer(sc, names);
c_function_arg_names(func) = names;
defaults = (s7_pointer *) Malloc(n_args * sizeof(s7_pointer));
add_saved_pointer(sc, defaults);
c_function_arg_defaults(func) = defaults;
c_func_set_simple_defaults(func);
/* (define* (f :allow-other-keys) 32) -> :allow-other-keys can't be the only parameter: (:allow-other-keys) */
for (p = local_args, i = 0; i < n_args; p = cdr(p), i++) {
s7_pointer arg = car(p);
if (arg == sc->key_allow_other_keys_symbol) {
if (is_not_null(cdr(p)))
s7_warn(sc, 256,
"%s :allow-other-keys should be the last parameter: %s\n",
name, arglist);
if (p == local_args)
s7_warn(sc, 256,
"%s :allow-other-keys can't be the only parameter: %s\n",
name, arglist);
c_function_set_allow_other_keys(func); /* local_args is local, so it can't carry the bit */
n_args--;
c_function_optional_args(func) = n_args;
c_function_all_args(func) = n_args; /* apparently not counting keywords */
} else if (is_pair(arg)) { /* there is a default */
names[i] = symbol_to_keyword(sc, car(arg));
defaults[i] = cadr(arg);
s7_remove_from_heap(sc, cadr(arg));
if ((is_pair(defaults[i])) ||
(is_normal_symbol(defaults[i]))) {
c_func_clear_simple_defaults(func);
mark_function[T_C_FUNCTION_STAR] = mark_c_proc_star;
}
} else {
if (arg == sc->key_rest_symbol)
s7_warn(sc, 256,
"%s :rest is not supported in C-side define*: %s\n",
name, arglist);
names[i] = symbol_to_keyword(sc, arg);
defaults[i] = sc->F;
}
}
} else
set_full_type(func, T_C_FUNCTION | T_UNHEAP);
s7_gc_unprotect_at(sc, gc_loc);
return (func);
}
s7_pointer s7_make_safe_function_star(s7_scheme * sc, const char *name,
s7_function fnc, const char *arglist,
const char *doc)
{
s7_pointer func;
func = s7_make_function_star(sc, name, fnc, arglist, doc);
set_full_type(func, full_type(func) | T_SAFE_PROCEDURE); /* don't step on the c_func_has_simple_defaults flag */
if (is_c_function_star(func)) /* thunk -> c_function */
c_function_call_args(func) =
permanent_list(sc, c_function_optional_args(func));
return (func);
}
static void define_function_star_1(s7_scheme * sc, const char *name,
s7_function fnc, const char *arglist,
const char *doc, bool safe,
s7_pointer signature)
{
s7_pointer func, sym;
if (safe)
func = s7_make_safe_function_star(sc, name, fnc, arglist, doc);
else
func = s7_make_function_star(sc, name, fnc, arglist, doc);
sym = make_symbol(sc, name);
s7_define(sc, sc->nil, sym, func);
if (signature)
c_function_signature(func) = signature;
}
void s7_define_function_star(s7_scheme * sc, const char *name,
s7_function fnc, const char *arglist,
const char *doc)
{
define_function_star_1(sc, name, fnc, arglist, doc, false, NULL);
}
void s7_define_safe_function_star(s7_scheme * sc, const char *name,
s7_function fnc, const char *arglist,
const char *doc)
{
define_function_star_1(sc, name, fnc, arglist, doc, true, NULL);
}
void s7_define_typed_function_star(s7_scheme * sc, const char *name,
s7_function fnc, const char *arglist,
const char *doc, s7_pointer signature)
{
define_function_star_1(sc, name, fnc, arglist, doc, true, signature);
}
s7_pointer s7_define_macro(s7_scheme * sc, const char *name,
s7_function fnc, s7_int required_args,
s7_int optional_args, bool rest_arg,
const char *doc)
{
s7_pointer func, sym;
func =
s7_make_function(sc, name, fnc, required_args, optional_args,
rest_arg, doc);
set_full_type(func, T_C_MACRO | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */
sym = make_symbol(sc, name);
s7_define(sc, sc->nil, sym, func);
return (sym);
}
/* -------------------------------- macro? -------------------------------- */
bool s7_is_macro(s7_scheme * sc, s7_pointer x)
{
return (is_any_macro(x));
}
static bool is_macro_b(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 sc->pl_bt
check_boolean_method(sc, is_any_macro, sc->is_macro_symbol, args);
}
static s7_pointer s7_macroexpand(s7_scheme * sc, s7_pointer mac,
s7_pointer args)
{
if (!s7_is_proper_list(sc, args))
s7_error(sc, sc->syntax_error_symbol,
set_elist_2(sc,
wrap_string(sc,
"improper list of arguments: ~S",
30), args));
push_stack_direct(sc, OP_FLUSH_VALUES);
sc->code = mac;
sc->args = args;
sc->curlet = make_let(sc, closure_let(sc->code));
eval(sc, OP_APPLY_LAMBDA);
return (sc->value);
}
/* -------------------------------- documentation -------------------------------- */
const char *s7_documentation(s7_scheme * sc, s7_pointer x)
{
s7_pointer val;
if (is_symbol(x)) {
if (is_keyword(x))
return (NULL);
if (symbol_has_help(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));
if (is_syntax(x))
return (syntax_documentation(x));
val = funclet_entry(sc, x, sc->local_documentation_symbol);
if ((val) && (is_string(val)))
return (string_value(val));
return (NULL);
}
static s7_pointer g_documentation(s7_scheme * sc, s7_pointer args)
{
#define H_documentation "(documentation obj) returns obj's documentation string"
#define Q_documentation s7_make_signature(sc, 2, sc->is_string_symbol, sc->T) /* should (documentation 1) be an error? */
s7_pointer p = car(args);
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);
}
/* (documentation func) should act like (documentation abs) -- available without (openlet (funclet func)) or (openlet func)
* so we check that case ahead of time here, rather than going through check_method which does not
* call find_let unless has_active_methods(sc, func). Adding T_HAS_METHODS to all closures causes other troubles.
*/
if (has_closure_let(p)) {
s7_pointer func;
func = funclet_entry(sc, p, sc->documentation_symbol);
if (func)
return (call_method(sc, p, func, args));
}
/* it would be neat if this would work (define x (let ((+documentation+ "hio")) (vector 1 2 3))) (documentation x) */
check_method(sc, p, sc->documentation_symbol, args);
return (s7_make_string(sc, s7_documentation(sc, p)));
}
const char *s7_set_documentation(s7_scheme * sc, s7_pointer sym,
const char *new_doc)
{
if (is_keyword(sym))
return (NULL);
if (is_symbol(sym)) {
symbol_set_has_help(sym);
symbol_set_help(sym, copy_string(new_doc));
}
return (new_doc);
}
/* -------------------------------- help -------------------------------- */
const char *s7_help(s7_scheme * sc, s7_pointer obj)
{
if (is_syntax(obj))
return (syntax_documentation(obj));
if (is_symbol(obj)) {
/* here look for name */
if (s7_documentation(sc, obj))
return (s7_documentation(sc, obj));
obj = s7_symbol_value(sc, obj);
}
if (is_any_procedure(obj))
return (s7_documentation(sc, obj));
if (obj == sc->s7_let)
return
("*s7* is a let that gives access to s7's internal state: e.g. (*s7* 'print-length)");
/* if is string, apropos? (can scan symbol table) */
return (NULL);
}
static s7_pointer g_help(s7_scheme * sc, s7_pointer args)
{
#define H_help "(help obj) returns obj's documentation"
#define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T)
const char *doc;
check_method(sc, car(args), sc->help_symbol, args);
doc = s7_help(sc, car(args));
return ((doc) ? s7_make_string(sc, doc) : sc->F);
}
/* -------------------------------- signature -------------------------------- */
static void init_signatures(s7_scheme * sc)
{
sc->string_signature =
s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol,
sc->is_integer_symbol);
sc->byte_vector_signature =
s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol,
sc->is_byte_vector_symbol,
sc->is_integer_symbol);
sc->vector_signature =
s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol,
sc->is_integer_symbol);
sc->float_vector_signature =
s7_make_circular_signature(sc, 2, 3, sc->is_float_symbol,
sc->is_float_vector_symbol,
sc->is_integer_symbol);
sc->int_vector_signature =
s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol,
sc->is_int_vector_symbol,
sc->is_integer_symbol);
sc->c_object_signature =
s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol,
sc->T);
sc->let_signature =
s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_let_symbol,
sc->is_symbol_symbol);
sc->hash_table_signature =
s7_make_circular_signature(sc, 2, 3, sc->T,
sc->is_hash_table_symbol, sc->T);
sc->pair_signature =
s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol,
sc->is_integer_symbol);
}
static s7_pointer g_signature(s7_scheme * sc, s7_pointer args)
{
#define H_signature "(signature obj) returns obj's signature"
#define Q_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T)
s7_pointer p = car(args);
switch (type(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:
case T_C_MACRO:
return ((s7_pointer) c_function_signature(p));
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
case T_CLOSURE:
case T_CLOSURE_STAR:
{
s7_pointer func;
func = funclet_entry(sc, p, sc->local_signature_symbol);
if (func)
return (func);
func = funclet_entry(sc, p, sc->signature_symbol);
return ((func) ? call_method(sc, p, func, args) : sc->F);
}
case T_VECTOR:
if (vector_length(p) == 0)
return (sc->F); /* sig () is #f so sig #() should be #f */
if (!is_typed_vector(p))
return (sc->vector_signature);
{
s7_pointer lst;
lst =
list_3(sc, typed_vector_typer_symbol(sc, p),
sc->is_vector_symbol, sc->is_integer_symbol);
set_cdddr(lst, cddr(lst));
return (lst);
}
case T_FLOAT_VECTOR:
return ((vector_length(p) ==
0) ? sc->F : sc->float_vector_signature);
case T_INT_VECTOR:
return ((vector_length(p) ==
0) ? sc->F : sc->int_vector_signature);
case T_BYTE_VECTOR:
return ((vector_length(p) ==
0) ? sc->F : sc->byte_vector_signature);
case T_PAIR:
return (sc->pair_signature);
case T_STRING:
return (sc->string_signature);
case T_HASH_TABLE:
if (is_typed_hash_table(p))
return (list_3(sc,
hash_table_typer_symbol(sc,
hash_table_value_typer
(p)),
sc->is_hash_table_symbol,
hash_table_typer_symbol(sc,
hash_table_key_typer
(p))));
return (sc->hash_table_signature);
case T_ITERATOR:
p = iterator_sequence(p);
if ((is_hash_table(p)) || (is_let(p))) /* cons returned -- would be nice to include the car/cdr types if known */
return (list_1(sc, sc->is_pair_symbol));
p = g_signature(sc, set_plist_1(sc, p));
return (list_1(sc, (is_pair(p)) ? car(p) : sc->T));
case T_C_OBJECT:
check_method(sc, p, sc->signature_symbol, args);
return (sc->c_object_signature);
case T_LET:
check_method(sc, p, sc->signature_symbol, args);
return (sc->let_signature);
case T_SYMBOL:
/* this used to get the symbol's value and call g_signature on that */
{
s7_pointer slot;
slot = lookup_slot_from(p, sc->curlet);
if ((is_slot(slot)) && (slot_has_setter(slot))) {
s7_pointer setter;
setter = slot_setter(slot);
p = g_signature(sc, set_plist_1(sc, setter));
if (is_pair(p))
return (list_1(sc, car(p)));
}
}
break;
default:
break;
}
return (sc->F);
}
s7_pointer s7_signature(s7_scheme * sc, s7_pointer func)
{
return (g_signature(sc, set_plist_1(sc, func)));
}
/* -------------------------------- dynamic-wind -------------------------------- */
static s7_pointer closure_or_f(s7_scheme * sc, s7_pointer 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);
return ((caar(body) == sc->quote_symbol) ? sc->F : p);
}
static s7_pointer make_baffled_closure(s7_scheme * sc, s7_pointer inp)
{
/* for dynamic-wind to protect initial and final functions from call/cc */
s7_pointer nclo, let;
nclo = make_closure(sc, sc->nil, closure_body(inp), type(inp), 0);
let = make_let_slowly(sc, closure_let(inp)); /* let_outlet(let) = closure_let(inp) */
set_baffle_let(let);
set_let_baffle_key(let, sc->baffle_ctr++);
closure_set_let(nclo, let);
return (nclo);
}
static bool is_dwind_thunk(s7_scheme * sc, s7_pointer x)
{
switch (type(x)) {
case T_MACRO:
case T_BACRO:
case T_CLOSURE:
case T_MACRO_STAR:
case T_BACRO_STAR:
case T_CLOSURE_STAR:
return (is_null(closure_args(x))); /* this is the case that does not match is_aritable -- it could be loosened -- arity=0 below would need fixup */
case T_C_RST_ARGS_FUNCTION:
case T_C_FUNCTION:
return ((c_function_required_args(x) <= 0)
&& (c_function_all_args(x) >= 0));
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
case T_C_FUNCTION_STAR:
return (c_function_all_args(x) >= 0);
case T_C_MACRO:
return ((c_macro_required_args(x) <= 0)
&& (c_macro_all_args(x) >= 0));
case T_GOTO:
case T_CONTINUATION:
return (true);
}
return (x == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */
}
static s7_pointer g_dynamic_wind_unchecked(s7_scheme * sc, s7_pointer args)
{
s7_pointer p, inp, outp;
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));
inp = dynamic_wind_in(p);
if ((is_any_closure(inp)) && (!is_safe_closure(inp))) /* wrap this use of inp in a with-baffle */
dynamic_wind_in(p) = make_baffled_closure(sc, inp);
outp = dynamic_wind_out(p);
if ((is_any_closure(outp)) && (!is_safe_closure(outp)))
dynamic_wind_out(p) = make_baffled_closure(sc, outp);
/* 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 (inp != 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);
}
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)
if (!is_dwind_thunk(sc, car(args)))
return (method_or_bust_with_type
(sc, car(args), sc->dynamic_wind_symbol, args,
a_thunk_string, 1));
if (!is_thunk(sc, cadr(args)))
return (method_or_bust_with_type
(sc, cadr(args), sc->dynamic_wind_symbol, args,
a_thunk_string, 2));
if (!is_dwind_thunk(sc, caddr(args)))
return (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.
*/
return (g_dynamic_wind_unchecked(sc, args));
}
static bool is_lambda(s7_scheme * sc, s7_pointer sym)
{
return ((sym == sc->lambda_symbol) && (symbol_id(sym) == 0)); /* do we need (!sc->in_with_let) ? */
/* symbol_id=0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */
}
static bool is_ok_thunk(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(arg)) &&
(is_lambda(sc, car(arg))) &&
(is_pair(cdr(arg))) &&
(is_null(cadr(arg))) &&
(is_pair(cddr(arg))) && (s7_is_proper_list(sc, cddr(arg))));
}
static s7_pointer dynamic_wind_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr,
bool ops)
{
if ((args == 3) &&
((is_ok_thunk(sc, cadr(expr))) || (cadr(expr) == sc->F)) &&
(is_ok_thunk(sc, caddr(expr))) &&
((is_ok_thunk(sc, cadddr(expr))) || (cadddr(expr) == sc->F)))
return (sc->dynamic_wind_unchecked);
return (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();
store_jump_info(sc);
set_jump_info(sc, DYNAMIC_WIND_SET_JUMP);
if (jump_loc != NO_JUMP) {
if (jump_loc != ERROR_JUMP)
eval(sc, sc->cur_op);
} else {
push_stack_direct(sc, OP_EVAL_DONE);
sc->args = sc->nil;
new_cell(sc, p, T_DYNAMIC_WIND);
dynamic_wind_in(p) = T_Pos(init);
dynamic_wind_body(p) = T_Pos(body);
dynamic_wind_out(p) = T_Pos(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);
}
/* -------------------------------- c-object? -------------------------------- */
bool s7_is_c_object(s7_pointer p)
{
return (is_c_object(p));
}
static s7_pointer g_is_c_object(s7_scheme * sc, s7_pointer args)
{
#define H_is_c_object "(c-object? obj) returns #t is obj is a c-object."
#define Q_is_c_object sc->pl_bt
s7_pointer obj = car(args);
if (is_c_object(obj))
return (sc->T);
if (!has_active_methods(sc, obj))
return (sc->F);
return (apply_boolean_method(sc, obj, sc->is_c_object_symbol));
}
/* -------------------------------- c-object-type -------------------------------- */
static void fallback_free(void *value)
{
}
static void fallback_mark(void *value)
{
}
static s7_pointer apply_error(s7_scheme * sc, s7_pointer obj,
s7_pointer args);
static s7_pointer fallback_ref(s7_scheme * sc, s7_pointer args)
{
return (apply_error(sc, car(args), cdr(args)));
}
static s7_pointer fallback_set(s7_scheme * sc, s7_pointer args)
{
return (eval_error(sc, "attempt to set ~S?", 18, car(args)));
}
static s7_pointer fallback_length(s7_scheme * sc, s7_pointer obj)
{
return (sc->F);
}
s7_int s7_c_object_type(s7_pointer obj)
{
return ((is_c_object(obj)) ? c_object_type(obj) : -1);
}
static s7_pointer g_c_object_type(s7_scheme * sc, s7_pointer args)
{
#define H_c_object_type "(c-object-type obj) returns the c_object's type tag."
#define Q_c_object_type s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_c_object_symbol)
s7_pointer p = car(args);
if (is_c_object(p))
return (make_integer(sc, c_object_type(p))); /* this is the c_object_types table index = tag */
return (method_or_bust
(sc, p, sc->c_object_type_symbol, args, T_C_OBJECT, 0));
}
static s7_pointer g_c_object_set(s7_scheme * sc, s7_pointer args)
{ /* called in c_object_set_function */
s7_pointer obj = car(args);
if (!is_c_object(obj))
return (simple_wrong_type_argument
(sc, make_symbol(sc, "c-object-set!"), obj, T_C_OBJECT));
return ((*(c_object_set(sc, obj))) (sc, args));
}
s7_int s7_make_c_type(s7_scheme * sc, const char *name)
{
s7_int tag;
c_object_t *c_type;
tag = sc->num_c_object_types++;
if (tag >= sc->c_object_types_size) {
if (sc->c_object_types_size == 0) {
sc->c_object_types_size = 8;
sc->c_object_types =
(c_object_t **) Calloc(sc->c_object_types_size,
sizeof(c_object_t *));
} else {
sc->c_object_types_size = tag + 8;
sc->c_object_types =
(c_object_t **) Realloc((void *) (sc->c_object_types),
sc->c_object_types_size *
sizeof(c_object_t *));
}
}
c_type = (c_object_t *) Calloc(1, sizeof(c_object_t));
sc->c_object_types[tag] = c_type;
c_type->type = tag;
c_type->scheme_name = s7_make_permanent_string(sc, name);
c_type->getter = sc->F;
c_type->setter = sc->F;
c_type->free = fallback_free;
c_type->mark = fallback_mark;
c_type->ref = fallback_ref;
c_type->set = fallback_set;
c_type->outer_type = T_C_OBJECT;
c_type->length = fallback_length;
/* all other fields are NULL */
return (tag);
}
void s7_c_type_set_free(s7_scheme * sc, s7_int tag,
void (*gc_free)(void *value))
{
sc->c_object_types[tag]->free = gc_free;
}
void s7_c_type_set_mark(s7_scheme * sc, s7_int tag,
void (*mark)(void *value))
{
sc->c_object_types[tag]->mark = mark;
}
void s7_c_type_set_equal(s7_scheme * sc, s7_int tag,
bool (*equal)(void *value1, void *value2))
{
sc->c_object_types[tag]->eql = equal;
}
void s7_c_type_set_gc_free(s7_scheme * sc, s7_int tag,
s7_pointer(*gc_free) (s7_scheme * sc,
s7_pointer obj))
{
sc->c_object_types[tag]->gc_free = gc_free;
}
void s7_c_type_set_gc_mark(s7_scheme * sc, s7_int tag,
s7_pointer(*gc_mark) (s7_scheme * sc,
s7_pointer obj))
{
sc->c_object_types[tag]->gc_mark = gc_mark;
}
void s7_c_type_set_is_equal(s7_scheme * sc, s7_int tag,
s7_pointer(*is_equal) (s7_scheme * sc,
s7_pointer args))
{
sc->c_object_types[tag]->equal = is_equal;
}
void s7_c_type_set_set(s7_scheme * sc, s7_int tag,
s7_pointer(*set) (s7_scheme * sc, s7_pointer args))
{
sc->c_object_types[tag]->set = set;
}
void s7_c_type_set_length(s7_scheme * sc, s7_int tag,
s7_pointer(*length) (s7_scheme * sc,
s7_pointer args))
{
sc->c_object_types[tag]->length = length;
}
void s7_c_type_set_copy(s7_scheme * sc, s7_int tag,
s7_pointer(*copy) (s7_scheme * sc,
s7_pointer args))
{
sc->c_object_types[tag]->copy = copy;
}
void s7_c_type_set_fill(s7_scheme * sc, s7_int tag,
s7_pointer(*fill) (s7_scheme * sc,
s7_pointer args))
{
sc->c_object_types[tag]->fill = fill;
}
void s7_c_type_set_reverse(s7_scheme * sc, s7_int tag,
s7_pointer(*reverse) (s7_scheme * sc,
s7_pointer args))
{
sc->c_object_types[tag]->reverse = reverse;
}
void s7_c_type_set_to_list(s7_scheme * sc, s7_int tag,
s7_pointer(*to_list) (s7_scheme * sc,
s7_pointer args))
{
sc->c_object_types[tag]->to_list = to_list;
}
void s7_c_type_set_to_string(s7_scheme * sc, s7_int tag,
s7_pointer(*to_string) (s7_scheme * sc,
s7_pointer args))
{
sc->c_object_types[tag]->to_string = to_string;
}
void s7_c_type_set_is_equivalent(s7_scheme * sc, s7_int tag,
s7_pointer(*is_equivalent) (s7_scheme *
sc,
s7_pointer
args))
{
sc->c_object_types[tag]->equivalent = is_equivalent;
}
void s7_c_type_set_ref(s7_scheme * sc, s7_int tag,
s7_pointer(*ref) (s7_scheme * sc, s7_pointer args))
{
sc->c_object_types[tag]->ref = ref;
if (sc->c_object_types[tag]->ref != fallback_ref)
sc->c_object_types[tag]->outer_type =
(T_C_OBJECT | T_SAFE_PROCEDURE);
}
void s7_c_type_set_getter(s7_scheme * sc, s7_int tag, s7_pointer getter)
{
if ((S7_DEBUGGING) && (!is_c_function(getter)))
fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__,
__LINE__, getter);
sc->c_object_types[tag]->getter = getter;
}
void s7_c_type_set_setter(s7_scheme * sc, s7_int tag, s7_pointer setter)
{
if ((S7_DEBUGGING) && (!is_c_function(setter)))
fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__,
__LINE__, setter);
sc->c_object_types[tag]->setter = setter;
}
void *s7_c_object_value(s7_pointer obj)
{
return (c_object_value(obj));
}
void *s7_c_object_value_checked(s7_pointer obj, s7_int type)
{
if ((is_c_object(obj)) && (c_object_type(obj) == type))
return (c_object_value(obj));
return (NULL);
}
static s7_pointer make_c_object_with_let(s7_scheme * sc, s7_int type,
void *value, s7_pointer let,
bool with_gc)
{
s7_pointer x;
new_cell(sc, x, sc->c_object_types[type]->outer_type);
/* c_object_info(x) = &(sc->c_object_types[type]); */
/* that won't work because c_object_types can move when it is realloc'd and the old stuff is freed by realloc
* and since we're checking (for example) ref_2 existence as not null, we can't use a table of c_object_t's!
* Using mallocate (s7_make_c_object_with_data) is faster, but not enough to warrant the code.
*/
c_object_type(x) = type;
c_object_value(x) = value;
c_object_set_let(x, (let == sc->rootlet) ? sc->nil : let);
c_object_s7(x) = sc;
if (with_gc)
add_c_object(sc, x);
return (x);
}
s7_pointer s7_make_c_object_with_let(s7_scheme * sc, s7_int type,
void *value, s7_pointer let)
{
return (make_c_object_with_let(sc, type, value, let, true));
}
s7_pointer s7_make_c_object(s7_scheme * sc, s7_int type, void *value)
{
return (make_c_object_with_let(sc, type, value, sc->nil, true));
}
s7_pointer s7_make_c_object_without_gc(s7_scheme * sc, s7_int type,
void *value)
{
return (make_c_object_with_let(sc, type, value, sc->nil, false));
}
s7_pointer s7_c_object_let(s7_pointer obj)
{
return (c_object_let(obj));
}
s7_pointer s7_c_object_set_let(s7_scheme * sc, s7_pointer obj,
s7_pointer e)
{
if ((!is_immutable(obj)) && (is_let(e)))
c_object_set_let(obj, (e == sc->rootlet) ? sc->nil : e);
return (e);
}
static s7_pointer c_object_length(s7_scheme * sc, s7_pointer obj)
{
if (c_object_len(sc, obj))
return ((*(c_object_len(sc, obj))) (sc, set_clist_1(sc, obj)));
return (eval_error(sc, "attempt to get length of ~S?", 28, obj));
}
static s7_int c_object_length_to_int(s7_scheme * sc, s7_pointer obj)
{
if (c_object_len(sc, obj)) {
s7_pointer res;
res = (*(c_object_len(sc, obj))) (sc, set_clist_1(sc, obj));
if (s7_is_integer(res))
return (s7_integer_checked(sc, res));
}
return (-1);
}
static s7_pointer copy_c_object(s7_scheme * sc, s7_pointer args)
{
s7_pointer obj = car(args);
check_method(sc, obj, sc->copy_symbol, args);
if (c_object_copy(sc, obj))
return ((*(c_object_copy(sc, obj))) (sc, args));
return (eval_error(sc, "attempt to copy ~S?", 19, obj));
}
static s7_pointer c_object_type_to_let(s7_scheme * sc, s7_pointer cobj)
{
return (g_local_inlet(sc, 4,
sc->name_symbol, c_object_scheme_name(sc, cobj),
sc->setter_symbol,
(c_object_set(sc, cobj) !=
fallback_set) ? sc->
c_object_set_function : sc->F));
/* should we make new wrappers every time this is called? or save the let somewhere and reuse it? */
}
static void apply_c_object(s7_scheme * sc)
{ /* -------- applicable c_object -------- */
sc->value =
(*(c_object_ref(sc, sc->code))) (sc,
set_ulist_1(sc, sc->code,
sc->args));
set_car(sc->u1_1, sc->F);
}
static bool op_implicit_c_object_ref_a(s7_scheme * sc)
{
s7_pointer c;
c = lookup_checked(sc, car(sc->code));
if (!is_c_object(c)) {
sc->last_function = c;
return (false);
}
set_car(sc->t2_2, fx_call(sc, cdr(sc->code)));
set_car(sc->t2_1, c); /* fx_call above might use sc->t2* */
sc->value = (*(c_object_ref(sc, c))) (sc, sc->t2_1);
return (true);
}
/* -------- dilambda -------- */
s7_pointer s7_dilambda_with_environment(s7_scheme * sc, s7_pointer envir,
const char *name,
s7_pointer(*getter) (s7_scheme *
sc,
s7_pointer
args),
s7_int get_req_args,
s7_int get_opt_args,
s7_pointer(*setter) (s7_scheme *
sc,
s7_pointer
args),
s7_int set_req_args,
s7_int set_opt_args,
const char *documentation)
{
s7_pointer get_func, set_func;
char *internal_set_name;
s7_int len;
if (!name)
return (sc->F);
len = 16 + safe_strlen(name);
internal_set_name = (char *) Malloc(len);
internal_set_name[0] = '\0';
catstrs_direct(internal_set_name, "[set-", name, "]",
(const char *) NULL);
add_saved_pointer(sc, internal_set_name);
get_func =
s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args,
false, documentation);
s7_define(sc, envir, 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_dilambda(s7_scheme * sc,
const char *name,
s7_pointer(*getter) (s7_scheme * sc,
s7_pointer args),
s7_int get_req_args, s7_int get_opt_args,
s7_pointer(*setter) (s7_scheme * sc,
s7_pointer args),
s7_int set_req_args, s7_int set_opt_args,
const char *documentation)
{
return (s7_dilambda_with_environment
(sc, sc->nil, name, getter, get_req_args, get_opt_args, setter,
set_req_args, set_opt_args, documentation));
}
s7_pointer s7_typed_dilambda(s7_scheme * sc,
const char *name,
s7_pointer(*getter) (s7_scheme * sc,
s7_pointer args),
s7_int get_req_args, s7_int get_opt_args,
s7_pointer(*setter) (s7_scheme * sc,
s7_pointer args),
s7_int set_req_args, s7_int set_opt_args,
const char *documentation, s7_pointer get_sig,
s7_pointer set_sig)
{
s7_pointer get_func, 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);
}
static void op_set_dilambda_p(s7_scheme * sc)
{
push_stack_no_args(sc, OP_SET_DILAMBDA_P_1, cdr(sc->code));
sc->code = caddr(sc->code);
}
static void op_set_dilambda(s7_scheme * sc)
{ /* ([set!] (dilambda-setter g) s) */
sc->code = cdr(sc->code);
sc->value = cadr(sc->code);
if (is_symbol(sc->value))
sc->value = lookup_checked(sc, sc->value);
}
static void op_set_dilambda_sa_a(s7_scheme * sc)
{
s7_pointer code = cdr(sc->code), obj, func, setter;
func = lookup(sc, caar(code));
obj = lookup(sc, cadar(code));
setter = closure_setter(func);
sc->curlet =
update_let_with_two_slots(sc, closure_let(setter), obj,
fx_call(sc, cdr(code)));
sc->value = fx_call(sc, closure_body(setter));
}
/* -------------------------------- dilambda? -------------------------------- */
bool s7_is_dilambda(s7_pointer obj)
{
switch (type(obj)) {
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
case T_CLOSURE:
case T_CLOSURE_STAR:
return (is_any_procedure(closure_setter_or_map_list(obj))); /* type >= T_CLOSURE (excludes goto/continuation) */
case T_C_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
case T_C_OPT_ARGS_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
case T_C_FUNCTION_STAR:
return (is_any_procedure(c_function_setter(obj)));
case T_C_MACRO:
return (is_any_procedure(c_macro_setter(obj)));
}
return (false);
}
static s7_pointer g_is_dilambda(s7_scheme * sc, s7_pointer args)
{
#define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter."
#define Q_is_dilambda sc->pl_bt
check_boolean_method(sc, s7_is_dilambda, sc->is_dilambda_symbol, args);
}
/* -------------------------------- dilambda -------------------------------- */
static s7_pointer g_dilambda(s7_scheme * sc, s7_pointer args)
{
#define H_dilambda "(dilambda getter setter) sets getter's setter to be setter."
#define Q_dilambda s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->is_procedure_symbol)
s7_pointer getter = car(args), setter;
if (!is_any_procedure(getter))
return (wrong_type_argument_with_type
(sc, sc->dilambda_symbol, 1, getter,
a_procedure_or_a_macro_string));
setter = cadr(args);
if (!is_any_procedure(setter))
return (wrong_type_argument_with_type
(sc, sc->dilambda_symbol, 2, setter,
a_procedure_or_a_macro_string));
s7_set_setter(sc, getter, setter);
return (getter);
}
/* -------------------------------- arity -------------------------------- */
static s7_pointer closure_arity_to_cons(s7_scheme * sc, s7_pointer x,
s7_pointer x_args)
{
/* x_args is unprocessed -- it is exactly the list as used in the closure[*] definition */
int32_t len;
if (is_symbol(x_args)) /* any number of args is ok */
return (cons(sc, int_zero, max_arity));
if (closure_arity_unknown(x))
closure_set_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 (cons(sc, make_integer(sc, -len), max_arity));
return (cons(sc, make_integer(sc, len), 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_set_arity(x, 0);
else if ((is_symbol(args)) || (allows_other_keys(args)))
closure_set_arity(x, -1);
else {
s7_pointer p;
int32_t i;
for (i = 0, p = args; is_pair(p); i++, p = cdr(p)) { /* is_pair(p) so (f1 a . b) will end with b not null */
s7_pointer arg = car(p);
if (arg == sc->key_rest_symbol)
break;
}
closure_set_arity(x, ((is_null(p)) ? i : -1)); /* see below */
}
}
}
static s7_pointer closure_star_arity_to_cons(s7_scheme * sc, s7_pointer x,
s7_pointer x_args)
{
closure_star_arity_1(sc, x, x_args);
return ((closure_arity(x) == -1) ? cons(sc, int_zero,
max_arity) : cons(sc, int_zero,
make_integer
(sc,
closure_arity
(x))));
}
static int32_t closure_arity_to_int(s7_scheme * sc, s7_pointer x)
{
/* not lambda* here */
if (closure_arity_unknown(x)) {
int32_t i;
s7_pointer b;
for (i = 0, b = closure_args(x); is_pair(b); i++, b = cdr(b)) {
};
if (is_null(b))
closure_set_arity(x, i);
else {
if (i == 0)
return (-1);
closure_set_arity(x, -i);
}
}
return (closure_arity(x));
}
static int32_t 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 (cons
(sc, make_integer(sc, c_function_required_args(x)),
make_integer(sc, c_function_all_args(x))));
case T_C_ANY_ARGS_FUNCTION:
case T_C_FUNCTION_STAR:
return (cons
(sc, int_zero, make_integer(sc, c_function_all_args(x))));
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 (cons
(sc, make_integer(sc, c_macro_required_args(x)),
make_integer(sc, c_macro_all_args(x))));
case T_GOTO:
case T_CONTINUATION:
return (cons(sc, int_zero, max_arity));
case T_STRING:
return ((string_length(x) == 0) ? sc->F : cons(sc, int_one,
int_one));
case T_LET:
return (cons(sc, int_one, int_one));
case T_C_OBJECT:
check_method(sc, x, sc->arity_symbol, set_plist_1(sc, x));
return ((is_safe_procedure(x)) ? cons(sc, int_zero, max_arity) :
sc->F);
case T_VECTOR:
if (vector_length(x) == 0)
return (sc->F);
if (has_simple_elements(x))
return (cons(sc, int_one, make_integer(sc, vector_rank(x))));
return (cons(sc, int_one, max_arity));
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_BYTE_VECTOR:
return ((vector_length(x) == 0) ? sc->F : cons(sc, int_one,
make_integer(sc,
vector_rank
(x))));
case T_PAIR:
case T_HASH_TABLE:
return (cons(sc, int_one, max_arity));
case T_ITERATOR:
return (cons(sc, int_zero, int_zero));
case T_SYNTAX:
return (cons
(sc, small_int(syntax_min_args(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 s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T)
/* check_method(sc, p, sc->arity_symbol, args); */
return (s7_arity(sc, car(args)));
}
/* -------------------------------- aritable? -------------------------------- */
static bool closure_is_aritable(s7_scheme * sc, s7_pointer x,
s7_pointer x_args, int32_t args)
{
/* x_args is unprocessed -- it is exactly the list as used in the closure definition */
s7_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_set_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, int32_t 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, s7_int args)
{
switch (type(x)) {
case T_C_RST_ARGS_FUNCTION:
case T_C_FUNCTION:
return ((c_function_required_args(x) <= args) &&
(c_function_all_args(x) >= args));
case T_C_OPT_ARGS_FUNCTION: /* any/opt req args == 0 */
case T_C_ANY_ARGS_FUNCTION:
case T_C_FUNCTION_STAR:
return (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 ((c_macro_required_args(x) <= args) &&
(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:
{
s7_pointer func;
if ((has_active_methods(sc, x)) &&
((func =
find_method_with_let(sc, x,
sc->is_aritable_symbol)) !=
sc->undefined))
return (call_method
(sc, x, func,
set_plist_2(sc, x,
make_integer(sc, args))) != sc->F);
return (is_safe_procedure(x));
}
case T_VECTOR:
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_BYTE_VECTOR:
return ((args > 0) && (vector_length(x) > 0) && /* (#() 0) -> error */
(args <= vector_rank(x)));
case T_LET:
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 = cadr(args);
s7_int num;
if (!s7_is_integer(n)) /* remember gmp case! */
return (method_or_bust
(sc, n, sc->is_aritable_symbol, args, T_INTEGER, 2));
num = s7_integer_checked(sc, n);
if (num < 0)
return (out_of_range
(sc, sc->is_aritable_symbol, int_two, n,
its_negative_string));
if (num > MAX_ARITY)
num = MAX_ARITY;
return (make_boolean(sc, s7_is_aritable(sc, car(args), num)));
}
static bool is_aritable_b_7pp(s7_scheme * sc, s7_pointer f, s7_pointer i)
{
return (g_is_aritable(sc, set_plist_2(sc, f, i)) != sc->F);
}
static int32_t arity_to_int(s7_scheme * sc, s7_pointer x)
{
int32_t args;
switch (type(x)) {
case T_C_OPT_ARGS_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
case T_C_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
case T_C_FUNCTION_STAR:
return (c_function_all_args(x));
case T_MACRO:
case T_BACRO:
case T_CLOSURE:
args = closure_arity_to_int(sc, x);
return ((args < 0) ? MAX_ARITY : args);
case T_MACRO_STAR:
case T_BACRO_STAR:
case T_CLOSURE_STAR:
args = closure_star_arity_to_int(sc, x);
return ((args < 0) ? MAX_ARITY : args);
case T_C_MACRO:
return (c_macro_all_args(x));
case T_C_OBJECT:
return (MAX_ARITY);
/* do vectors et al make sense here? */
}
return (-1);
}
/* -------------------------------- sequence? -------------------------------- */
static s7_pointer g_is_sequence(s7_scheme * sc, s7_pointer args)
{
#define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)"
#define Q_is_sequence sc->pl_bt
check_boolean_method(sc, is_simple_sequence, sc->is_sequence_symbol,
args);
}
static bool is_sequence_b(s7_pointer p)
{
return (is_simple_sequence(p));
}
/* -------------------------------- setter ------------------------------------------------ */
static s7_pointer b_simple_setter(s7_scheme * sc, int typer,
s7_pointer args)
{
if (type(cadr(args)) == typer)
return (cadr(args));
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_5(sc,
wrap_string(sc,
"set! ~S, ~S is ~A but should be ~A",
34), car(args), cadr(args),
sc->prepackaged_type_names[type
(cadr(args))],
sc->prepackaged_type_names[typer])));
}
static s7_pointer b_is_symbol_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_SYMBOL, args));
}
static s7_pointer b_is_syntax_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_SYNTAX, args));
}
static s7_pointer b_is_let_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_LET, args));
}
static s7_pointer b_is_iterator_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_ITERATOR, args));
}
static s7_pointer b_is_c_pointer_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_C_POINTER, args));
}
static s7_pointer b_is_input_port_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_INPUT_PORT, args));
}
static s7_pointer b_is_output_port_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_OUTPUT_PORT, args));
}
static s7_pointer b_is_eof_object_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_EOF, args));
}
static s7_pointer b_is_random_state_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_RANDOM_STATE, args));
}
static s7_pointer b_is_char_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_CHARACTER, args));
}
static s7_pointer b_is_string_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_STRING, args));
}
static s7_pointer b_is_float_vector_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_FLOAT_VECTOR, args));
}
static s7_pointer b_is_int_vector_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_INT_VECTOR, args));
}
static s7_pointer b_is_byte_vector_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_BYTE_VECTOR, args));
}
static s7_pointer b_is_hash_table_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_HASH_TABLE, args));
}
static s7_pointer b_is_continuation_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_CONTINUATION, args));
}
static s7_pointer b_is_null_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_NIL, args));
}
static s7_pointer b_is_pair_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_PAIR, args));
}
static s7_pointer b_is_boolean_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_BOOLEAN, args));
}
static s7_pointer b_is_undefined_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_UNDEFINED, args));
}
static s7_pointer b_is_unspecified_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_UNSPECIFIED, args));
}
static s7_pointer b_is_c_object_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_C_OBJECT, args));
}
static s7_pointer b_is_goto_setter(s7_scheme * sc, s7_pointer args)
{
return (b_simple_setter(sc, T_GOTO, args));
}
#define b_setter(sc, typer, args, str, len) \
do { \
if (typer(cadr(args))) \
return(cadr(args)); \
return(s7_error(sc, sc->wrong_type_arg_symbol, \
set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), \
car(args), cadr(args), sc->prepackaged_type_names[type(cadr(args))], wrap_string(sc, str, len)))); \
} while (0)
static s7_pointer b_is_number_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, s7_is_complex, args, "a number", 8);
}
static s7_pointer b_is_complex_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, s7_is_complex, args, "a number", 8);
}
static s7_pointer b_is_gensym_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_gensym, args, "a gensym", 8);
}
static s7_pointer b_is_keyword_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_keyword, args, "a keyword", 9);
}
static s7_pointer b_is_openlet_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, has_methods, args, "an open let", 11);
}
static s7_pointer b_is_macro_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_any_macro, args, "a macro", 7);
}
static s7_pointer b_is_integer_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, s7_is_integer, args, "an integer", 10);
}
static s7_pointer b_is_byte_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_byte, args, "an unsigned byte", 16);
}
static s7_pointer b_is_real_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_real, args, "a real", 6);
}
static s7_pointer b_is_float_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_t_real, args, "a float", 7);
}
static s7_pointer b_is_rational_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_rational, args, "a rational", 10);
}
static s7_pointer b_is_list_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_list, args, "a list", 6);
}
static s7_pointer b_is_vector_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_any_vector, args, "a vector", 8);
}
static s7_pointer b_is_procedure_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_any_procedure, args, "a procedure", 11);
}
static s7_pointer b_is_dilambda_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, s7_is_dilambda, args, "a dilambda", 10);
}
static s7_pointer b_is_sequence_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_sequence, args, "a sequence", 10);
}
static s7_pointer b_is_subvector_setter(s7_scheme * sc, s7_pointer args)
{
b_setter(sc, is_subvector, args, "a subvector", 11);
}
static s7_pointer b_is_weak_hash_table_setter(s7_scheme * sc,
s7_pointer args)
{
b_setter(sc, is_weak_hash_table, args, "a weak hash-table", 17);
}
static s7_pointer b_is_proper_list_setter(s7_scheme * sc, s7_pointer args)
{
if (s7_is_proper_list(sc, car(args)))
return (cadr(args));
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_5(sc,
wrap_string(sc,
"set! ~S, ~S is ~A but should be ~A",
34), car(args), cadr(args),
sc->prepackaged_type_names[type
(cadr(args))],
wrap_string(sc, "a proper list", 13))));
}
static s7_pointer g_setter(s7_scheme * sc, s7_pointer args)
{
#define H_setter "(setter obj let) returns the setter associated with obj"
#define Q_setter s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->T, sc->is_let_symbol)
s7_pointer p = car(args), e;
if (is_pair(cdr(args))) {
e = cadr(args);
if (!((is_let(e)) || (e == sc->rootlet) || (e == sc->nil)))
return (wrong_type_argument
(sc, sc->setter_symbol, 2, e, T_LET));
} else
e = sc->curlet;
switch (type(p)) {
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
case T_CLOSURE:
case T_CLOSURE_STAR:
if (is_any_procedure(closure_setter(p))) /* setter already known */
return (closure_setter(p));
if (!closure_no_setter(p)) {
s7_pointer f;
f = funclet_entry(sc, p, sc->local_setter_symbol); /* look for +setter+, save value as closure_setter(p) */
if (f) {
if (f == sc->F) {
closure_set_no_setter(p);
return (sc->F);
}
if (!is_any_procedure(f))
return (s7_wrong_type_arg_error
(sc, "setter", 0, p,
"a procedure or a reasonable facsimile thereof"));
closure_set_setter(p, f);
return (f);
}
/* we used to search for setter here, but that can find the built-in setter causing an infinite loop (maybe check for that??) */
closure_set_no_setter(p);
}
return (sc->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:
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_C_OBJECT:
check_method(sc, p, sc->setter_symbol, args);
return ((c_object_set(sc, p) == fallback_set) ? sc->F : sc->c_object_set_function); /* for example ((setter obj) obj 0 1.0) if s7test block */
/* this could wrap the setter as an s7_function giving p's class-name etc */
case T_LET:
check_method(sc, p, sc->setter_symbol, args);
return (global_value(sc->let_set_symbol));
case T_ITERATOR: /* (set! (iter) val) doesn't fit the other setters */
return ((is_any_closure(iterator_sequence(p))) ?
closure_setter(iterator_sequence(p)) : sc->F);
case T_PAIR:
return (global_value(sc->list_set_symbol));
case T_HASH_TABLE:
return (global_value(sc->hash_table_set_symbol));
case T_STRING:
return (global_value(sc->string_set_symbol));
case T_BYTE_VECTOR:
return (global_value(sc->byte_vector_set_symbol));
case T_VECTOR:
return (global_value(sc->vector_set_symbol));
case T_INT_VECTOR:
return (global_value(sc->int_vector_set_symbol));
case T_FLOAT_VECTOR:
return (global_value(sc->float_vector_set_symbol));
case T_SLOT:
return ((slot_has_setter(p)) ? slot_setter(p) : sc->F);
case T_SYMBOL: /* (setter symbol let) */
{
s7_pointer sym = car(args), slot, setter;
if (is_keyword(sym))
return (sc->F);
if ((e == sc->rootlet) || (e == sc->nil))
slot = global_slot(sym);
else {
s7_pointer old_e = sc->curlet;
set_curlet(sc, e);
slot = lookup_slot_from(sym, sc->curlet);
set_curlet(sc, old_e);
}
if ((!is_slot(slot)) || (!slot_has_setter(slot)))
return (sc->F);
setter = slot_setter(slot);
if (is_bool_function(setter))
return (c_function_setter(setter));
return (setter);
}
}
return (s7_wrong_type_arg_error
(sc, "setter", 0, p, "something that might have a setter"));
}
s7_pointer s7_setter(s7_scheme * sc, s7_pointer obj)
{
return (g_setter(sc, set_plist_1(sc, obj)));
}
/* -------------------------------- set-setter -------------------------------- */
static void protect_setter(s7_scheme * sc, s7_pointer sym, s7_pointer acc)
{
s7_int loc;
if (sc->protected_setters_size == sc->protected_setters_loc) {
s7_int i, new_size, size = sc->protected_setters_size;
block_t *ob, *nb;
new_size = 2 * size;
ob = vector_block(sc->protected_setters);
nb = reallocate(sc, ob, new_size * sizeof(s7_pointer));
block_info(nb) = NULL;
vector_block(sc->protected_setters) = nb;
vector_elements(sc->protected_setters) =
(s7_pointer *) block_data(nb);
vector_length(sc->protected_setters) = new_size;
ob = vector_block(sc->protected_setter_symbols);
nb = reallocate(sc, ob, new_size * sizeof(s7_pointer));
vector_block(sc->protected_setter_symbols) = nb;
vector_elements(sc->protected_setter_symbols) =
(s7_pointer *) block_data(nb);
vector_length(sc->protected_setter_symbols) = new_size;
for (i = size; i < new_size; i++) {
vector_element(sc->protected_setters, i) = sc->unused;
vector_element(sc->protected_setter_symbols, i) = sc->unused;
}
sc->protected_setters_size = new_size;
}
loc = sc->protected_setters_loc++;
vector_element(sc->protected_setters, loc) = acc;
vector_element(sc->protected_setter_symbols, loc) = sym;
}
static s7_pointer g_set_setter(s7_scheme * sc, s7_pointer args)
{
s7_pointer p = car(args), setter;
if (is_symbol(p)) {
s7_pointer sym = p, func, slot;
if (is_keyword(sym))
return (s7_wrong_type_arg_error
(sc, "set! setter", 1, sym,
"a normal symbol (a keyword can't be set)"));
if (is_pair(cddr(args))) {
s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */
func = caddr(args);
if ((e == sc->rootlet) || (e == sc->nil))
slot = global_slot(sym);
else {
if (!is_let(e))
return (s7_wrong_type_arg_error
(sc, "set! setter", 2, e, "a let"));
slot = lookup_slot_from(sym, e);
}
} else {
slot = lookup_slot_from(sym, sc->curlet); /* (set! (setter 'x) (lambda (s v) ...)) */
func = cadr(args);
}
if (!is_slot(slot))
return (sc->F);
if (func != sc->F) {
if (sym == sc->setter_symbol)
return (immutable_object_error
(sc,
set_elist_2(sc,
wrap_string(sc,
"can't set (setter setter) to ~S",
31), func)));
if (!is_any_procedure(func)) /* disallow continuation/goto here */
return (s7_wrong_type_arg_error
(sc, "set! setter", 3, func, "a function or #f"));
if ((!is_c_function(func))
|| (!c_function_has_bool_setter(func))) {
if (s7_is_aritable(sc, func, 3))
set_has_let_arg(func);
else if (!s7_is_aritable(sc, func, 2))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"setter function, ~A, should take 2 or 3 arguments",
49), func)));
}
}
if (slot == global_slot(sym))
s7_set_setter(sc, sym, func); /* special GC protection for global vars */
else
slot_set_setter(slot, func); /* func might be #f */
if (func != sc->F) {
slot_set_has_setter(slot);
symbol_set_has_setter(sym);
}
return (func);
}
if (p == sc->s7_let)
return (s7_wrong_type_arg_error
(sc, "set! setter", 1, p, "something other than *s7*"));
setter = cadr(args);
if (setter != sc->F) {
if (!is_any_procedure(setter))
return (s7_wrong_type_arg_error
(sc, "set! setter", 2, setter, "a procedure or #f"));
if (arity_to_int(sc, setter) < 1) /* we need at least an arg for the set! value */
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"setter function, ~A, should take at least 1 argument",
52), 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);
if (setter == sc->F)
closure_set_no_setter(p);
break;
case T_C_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
case T_C_OPT_ARGS_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
case T_C_FUNCTION_STAR:
if (p == global_value(sc->setter_symbol))
return (immutable_object_error
(sc,
set_elist_2(sc,
wrap_string(sc,
"can't set (setter setter) to ~S",
31), setter)));
c_function_set_setter(p, setter);
if ((is_any_closure(setter)) || (is_any_macro(setter)))
add_setter(sc, p, setter);
break;
case T_C_MACRO:
c_macro_set_setter(p, setter);
if ((is_any_closure(setter)) || (is_any_macro(setter)))
add_setter(sc, p, setter);
break;
default: /* (set! (setter 4) ...) or p==continuation etc */
return (s7_wrong_type_arg_error
(sc, "set! setter", 1, p,
"a normal procedure or a macro"));
}
return (setter);
}
s7_pointer s7_set_setter(s7_scheme * sc, s7_pointer p, s7_pointer setter)
{
if (is_symbol(p)) {
if (slot_has_setter(global_slot(p))) {
s7_int index;
for (index = 0; index < sc->protected_setters_loc; index++)
if (vector_element(sc->protected_setter_symbols, index) ==
p) {
s7_pointer old_func;
old_func =
vector_element(sc->protected_setters, index);
if ((is_any_procedure(old_func)) && /* i.e. not #f! */
(is_immutable(old_func)))
return (setter);
vector_element(sc->protected_setters, index) = setter;
slot_set_setter(global_slot(p), setter);
if ((setter != sc->F)
&& (s7_is_aritable(sc, setter, 3)))
set_has_let_arg(setter);
return (setter);
}
}
if (setter != sc->F) {
slot_set_has_setter(global_slot(p));
symbol_set_has_setter(p);
protect_setter(sc, p, setter);
slot_set_setter(global_slot(p), setter);
if (s7_is_aritable(sc, setter, 3))
set_has_let_arg(setter);
return (setter);
}
slot_set_setter(global_slot(p), setter);
return (setter);
}
return (g_set_setter(sc, set_plist_2(sc, p, setter)));
}
/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix))
* so set setter before use!
*/
static s7_pointer call_c_function_setter(s7_scheme * sc, s7_pointer func,
s7_pointer symbol,
s7_pointer new_value)
{
if (has_let_arg(func)) {
set_car(sc->t3_1, symbol);
set_car(sc->t3_2, new_value);
set_car(sc->t3_3, sc->curlet);
return (c_function_call(func) (sc, sc->t3_1));
}
set_car(sc->t2_1, symbol);
set_car(sc->t2_2, new_value);
return (c_function_call(func) (sc, sc->t2_1));
}
static s7_pointer call_setter(s7_scheme * sc, s7_pointer slot,
s7_pointer new_value)
{ /* see also op_set1 */
s7_pointer func = slot_setter(slot);
if (!is_any_procedure(func))
return (new_value);
if (is_c_function(func))
return (call_c_function_setter
(sc, func, slot_symbol(slot), new_value));
push_stack_direct(sc, OP_EVAL_DONE);
sc->args =
(has_let_arg(func)) ? list_3(sc, slot_symbol(slot), new_value,
sc->curlet) : list_2(sc,
slot_symbol
(slot),
new_value);
/* safe lists here are much slower -- the setters are called more often for some reason (see tset.scm) */
sc->code = func;
eval(sc, OP_APPLY);
return (sc->value);
}
static s7_pointer bind_symbol_with_setter(s7_scheme * sc, opcode_t op,
s7_pointer symbol,
s7_pointer new_value)
{
s7_pointer func;
func = g_setter(sc, set_plist_2(sc, symbol, sc->curlet));
if (!is_any_procedure(func))
return (new_value);
if (is_c_function(func))
return (call_c_function_setter(sc, func, symbol, new_value));
sc->args =
(has_let_arg(func)) ? list_3(sc, symbol, new_value,
sc->curlet) : list_2(sc, symbol,
new_value);
push_stack_direct(sc, op);
sc->code = func;
return (sc->no_value); /* this means the setter in set! needs to goto APPLY to get the new value */
}
/* -------------------------------- hooks -------------------------------- */
s7_pointer s7_hook_functions(s7_scheme * sc, s7_pointer hook)
{
return (s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook)));
}
s7_pointer s7_hook_set_functions(s7_scheme * sc, s7_pointer hook,
s7_pointer functions)
{
if (is_list(functions))
s7_let_set(sc, closure_let(hook), sc->body_symbol, functions);
return (functions);
}
/* -------------------------------- eq? eqv? equal? equivalent? -------------------------------- */
bool s7_is_eq(s7_pointer obj1, s7_pointer obj2)
{
return ((obj1 == obj2) || /* so floats and NaNs might be eq? but not eqv? */
((is_unspecified(obj1)) && (is_unspecified(obj2)))); /* this is needed because this function is used by s7_b_pp */
}
static s7_pointer is_eq_p_pp(s7_scheme * sc, s7_pointer obj1,
s7_pointer obj2)
{
return (make_boolean(sc, ((obj1 == obj2)
|| ((is_unspecified(obj1))
&& (is_unspecified(obj2))))));
}
static s7_pointer g_is_eq(s7_scheme * sc, s7_pointer args)
{
#define H_is_eq "(eq? obj1 obj2) returns #t if obj1 is eq to (the same object as) obj2"
#define Q_is_eq sc->pcl_bt
return (make_boolean(sc, ((car(args) == cadr(args)) ||
((is_unspecified(car(args)))
&& (is_unspecified(cadr(args)))))));
/* (eq? (apply apply apply values '(())) #<unspecified>) should return #t */
}
bool s7_is_eqv(s7_scheme * sc, s7_pointer a, s7_pointer b)
{
#if WITH_GMP
if ((is_big_number(a)) || (is_big_number(b)))
return (big_numbers_are_eqv(sc, a, b));
#endif
if (type(a) != type(b))
return (false);
if ((a == b) && (!is_number(a))) /* if a is NaN, a == b doesn't mean (eqv? a b) */
return (true); /* a == b means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */
if (is_number(a))
return (numbers_are_eqv(sc, 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 sc->pcl_bt
return (make_boolean(sc, s7_is_eqv(sc, car(args), cadr(args))));
}
static s7_pointer is_eqv_p_pp(s7_scheme * sc, s7_pointer obj1,
s7_pointer obj2)
{
return (make_boolean(sc, s7_is_eqv(sc, obj1, obj2)));
}
static bool floats_are_equivalent_1(s7_scheme * sc, s7_double x,
s7_double y, s7_double eps)
{
s7_double diff;
if (x == y)
return (true);
diff = fabs(x - y);
if (diff <= eps)
return (true);
return (((is_NaN(x)) || (is_NaN(y))) && ((is_NaN(x)) && (is_NaN(y))));
}
static bool floats_are_equivalent(s7_scheme * sc, s7_double x, s7_double y)
{
return (floats_are_equivalent_1
(sc, x, y, sc->equivalent_float_epsilon));
}
#if WITH_GMP
static bool big_floats_are_equivalent(s7_scheme * sc, mpfr_t x, mpfr_t y)
{
/* protect mpfr_1 */
if ((mpfr_nan_p(x)) || (mpfr_nan_p(y)))
return ((mpfr_nan_p(x)) && (mpfr_nan_p(y)));
mpfr_sub(sc->mpfr_3, x, y, MPFR_RNDN);
mpfr_abs(sc->mpfr_3, sc->mpfr_3, MPFR_RNDN);
return (mpfr_cmp_d(sc->mpfr_3, sc->equivalent_float_epsilon) <= 0);
}
#endif
static bool eq_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return (x == y);
}
static bool symbol_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (x == y)
return (true);
if (!is_normal_symbol(y))
return (false); /* (equivalent? ''(1) '(1)) */
return ((is_slot(global_slot(x))) && /* the optimizer can replace the original symbol with its own */
(is_syntax(global_value(x))) &&
(is_slot(global_slot(y))) &&
(is_syntax(global_value(y))) &&
(syntax_symbol(global_value(x)) ==
syntax_symbol(global_value(y))));
}
static bool unspecified_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return (is_unspecified(y));
}
static bool undefined_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (x == y)
return (true);
if ((!is_undefined(y))
|| (undefined_name_length(x) != undefined_name_length(y)))
return (false);
return (safe_strcmp(undefined_name(x), undefined_name(y)));
}
static bool is_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return ((*(equals[type(x)])) (sc, x, y, ci));
}
static bool is_equivalent_1(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return ((*(equivalents[type(x)])) (sc, x, y, ci));
}
static bool c_pointer_equivalent(s7_scheme * sc, s7_pointer x,
s7_pointer y, shared_info_t * ci)
{
shared_info_t *nci = ci;
if (x == y)
return (true);
if (!s7_is_c_pointer(y))
return (false);
if (c_pointer(x) != c_pointer(y))
return (false);
if (c_pointer_type(x) != c_pointer_type(y)) {
if (!nci)
nci = new_shared_info(sc);
if (!is_equivalent_1
(sc, c_pointer_type(x), c_pointer_type(y), nci))
return (false);
}
if (c_pointer_info(x) != c_pointer_info(y)) {
if (!nci)
nci = new_shared_info(sc);
if (!is_equivalent_1
(sc, c_pointer_info(x), c_pointer_info(y), nci))
return (false);
}
return (true);
}
static bool c_pointer_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
shared_info_t *nci = ci;
if (x == y)
return (true);
if (!s7_is_c_pointer(y))
return (false);
if (c_pointer(x) != c_pointer(y))
return (false);
if (c_pointer_type(x) != c_pointer_type(y)) {
if (!nci)
nci = new_shared_info(sc);
if (!is_equal_1(sc, c_pointer_type(x), c_pointer_type(y), nci))
return (false);
}
if (c_pointer_info(x) != c_pointer_info(y)) {
if (!nci)
nci = new_shared_info(sc);
if (!is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci))
return (false);
}
return (true);
}
static bool string_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return ((is_string(y)) && (scheme_strings_are_equal(x, y)));
}
static bool syntax_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return ((is_syntax(y)) && (syntax_symbol(x) == syntax_symbol(y)));
}
static bool port_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return (x == y);
}
static bool port_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (x == y)
return (true);
if (type(x) != type(y))
return (false);
if ((port_is_closed(x)) && (port_is_closed(y)))
return (true);
if ((port_is_closed(x)) || (port_is_closed(y)))
return (false); /* if either is closed, port_port (below) might be null */
if (port_type(x) != port_type(y))
return (false);
switch (port_type(x)) {
case STRING_PORT:
return ((port_position(x) == port_position(y)) &&
(port_data_size(x) == port_data_size(y)) &&
(local_strncmp
((const char *) port_data(x), (const char *) port_data(y),
(is_input_port(x)) ? port_data_size(x) :
port_position(x))));
case FILE_PORT:
return ((is_input_port(x)) &&
(port_position(x) == port_position(y)) &&
(local_strncmp
((const char *) port_filename(x),
(const char *) port_filename(y),
port_filename_length(x))));
case FUNCTION_PORT:
if (is_input_port(x))
return (port_input_function(x) == port_input_function(y));
return (port_output_function(x) == port_output_function(y));
}
return (false);
}
static void add_shared_ref(shared_info_t * ci, s7_pointer x, int32_t ref_x)
{
/* called only in equality check, not printer */
if (ci->top == ci->size)
enlarge_shared_info(ci);
set_collected(x);
ci->objs[ci->top] = x;
ci->refs[ci->top++] = ref_x;
}
static Inline bool equal_ref(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
/* here we know x and y are pointers to the same type of structure */
int32_t ref_y;
ref_y = (is_collected(y)) ? peek_shared_ref_1(ci, y) : 0;
if (is_collected(x)) {
int32_t ref_x;
ref_x = peek_shared_ref_1(ci, x);
if (ref_y != 0)
return (ref_x == ref_y); /* this is a change from the macro version 16-Jan-20 -- only true returns from the caller */
/* try to harmonize the new guy -- there can be more than one structure equal to the current one */
if (ref_x != 0)
add_shared_ref(ci, y, ref_x);
} else if (ref_y != 0)
add_shared_ref(ci, x, ref_y);
else {
/* assume neither x nor y is in the table, and that they should share a ref value, called only in equality check, not printer. */
if (ci->top >= ci->size2)
enlarge_shared_info(ci);
set_collected(x);
set_collected(y);
ci->objs[ci->top] = x;
ci->refs[ci->top++] = ++ci->ref;
ci->objs[ci->top] = y;
ci->refs[ci->top++] = ci->ref;
}
return (false);
}
static bool c_objects_are_equal(s7_scheme * sc, s7_pointer a, s7_pointer b,
shared_info_t * ci)
{
s7_pointer(*to_list) (s7_scheme * sc, s7_pointer args);
shared_info_t *nci = ci;
s7_pointer pa, pb;
if (a == b)
return (true);
if (!is_c_object(b))
return (false);
if (c_object_type(a) != c_object_type(b))
return (false);
if (c_object_equal(sc, a))
return (((*(c_object_equal(sc, a))) (sc, set_plist_2(sc, a, b))) !=
sc->F);
if (c_object_eql(sc, a))
return ((*(c_object_eql(sc, a)))
(c_object_value(a), c_object_value(b)));
to_list = c_object_to_list(sc, a);
if (!to_list)
return (false);
if (ci) {
if (equal_ref(sc, a, b, ci))
return (true); /* and nci == ci above */
} else
nci = new_shared_info(sc);
for (pa = to_list(sc, set_plist_1(sc, a)), pb =
to_list(sc, set_plist_1(sc, b)); is_pair(pa) && (is_pair(pb));
pa = cdr(pa), pb = cdr(pb))
if (!(is_equal_1(sc, car(pa), car(pb), nci)))
return (false);
return (pa == pb); /* presumably both are nil if successful */
}
#define check_equivalent_method(Sc, X, Y) \
do { \
if (has_active_methods(sc, X)) \
{ \
s7_pointer equal_func; \
equal_func = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \
if (equal_func != Sc->undefined) \
return(s7_boolean(Sc, call_method(Sc, X, equal_func, set_plist_2(Sc, X, Y)))); \
}} \
while (0)
static bool c_objects_are_equivalent(s7_scheme * sc, s7_pointer x,
s7_pointer y, shared_info_t * ci)
{
check_equivalent_method(sc, x, y);
if (c_object_equivalent(sc, x))
return (((*(c_object_equivalent(sc, x)))
(sc, set_plist_2(sc, x, y))) != sc->F);
return (c_objects_are_equal(sc, x, y, ci));
}
static bool hash_table_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci, bool equivalent)
{
hash_entry_t **lists;
s7_int i, len;
shared_info_t *nci = ci;
hash_check_t hf;
bool (*eqf)(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci);
if (x == y)
return (true);
if (!is_hash_table(y)) {
if (equivalent)
check_equivalent_method(sc, y, x);
return (false);
}
if ((ci) && (equal_ref(sc, x, y, ci)))
return (true);
if (hash_table_entries(x) != hash_table_entries(y))
return (false);
if (hash_table_entries(x) == 0)
return (true);
if ((!equivalent)
&& ((hash_table_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);
eqf = (equivalent) ? is_equivalent_1 : is_equal_1;
hf = hash_table_checker(y);
if ((hf != hash_equal) && (hf != hash_equivalent)) {
for (i = 0; i < len; i++) {
hash_entry_t *p;
for (p = lists[i]; p; p = hash_entry_next(p)) {
hash_entry_t *y_val;
y_val = hf(sc, y, hash_entry_key(p));
if (y_val == sc->unentry)
return (false);
if (!eqf
(sc, hash_entry_value(p), hash_entry_value(y_val),
nci))
return (false);
}
}
/* if we get here, every key/value in x has a corresponding key/value in y, and the number of entries match,
* so surely the tables are equal??
* if ci not null or hash-table-checker is equal/eqivalent, can't use hf?
*/
return (true);
}
/* we need to protect the current shared_info data (nci) here so the current hash_table_checker won't work --
* outside equal?/eqivalent? they can safely assume that they can start a new shared_info process.
*/
for (i = 0; i < len; i++) {
hash_entry_t *p;
for (p = lists[i]; p; p = hash_entry_next(p)) {
hash_entry_t *xe;
s7_int hash, loc;
s7_pointer key = hash_entry_key(p);
hash = hash_loc(sc, y, key);
loc = hash & hash_table_mask(y);
for (xe = hash_table_element(y, loc); xe;
xe = hash_entry_next(xe))
if (hash_entry_raw_hash(xe) == hash)
if (eqf(sc, hash_entry_key(xe), key, nci))
break;
if (!xe)
return (false);
if (!eqf(sc, hash_entry_value(p), hash_entry_value(xe), nci))
return (false);
}
}
return (true);
}
static bool hash_table_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return (hash_table_equal_1(sc, x, y, ci, false));
}
static bool hash_table_equivalent(s7_scheme * sc, s7_pointer x,
s7_pointer y, shared_info_t * ci)
{
return (hash_table_equal_1(sc, x, y, ci, true));
}
static bool slots_match(s7_scheme * sc, s7_pointer px, s7_pointer y,
shared_info_t * nci)
{
s7_pointer ey, py;
for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey))
for (py = let_slots(ey); tis_slot(py); py = next_slot(py))
if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */
return (is_equal_1
(sc, slot_value(px), slot_value(py), nci));
return (false);
}
static bool slots_equivalent_match(s7_scheme * sc, s7_pointer px,
s7_pointer y, shared_info_t * nci)
{
s7_pointer ey, py;
for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey))
for (py = let_slots(ey); tis_slot(py); py = next_slot(py))
if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */
return (is_equivalent_1
(sc, slot_value(px), slot_value(py), nci));
return (false);
}
static bool let_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci, bool equivalent)
{
s7_pointer ex, ey, px, py;
shared_info_t *nci = ci;
int32_t x_len, y_len;
if (!is_let(y))
return (false);
if ((x == sc->rootlet) || (y == sc->rootlet))
return (false);
if ((ci) && (equal_ref(sc, x, y, ci)))
return (true);
clear_symbol_list(sc);
for (x_len = 0, ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex))
for (px = let_slots(ex); tis_slot(px); px = next_slot(px))
if (!symbol_is_in_list(sc, slot_symbol(px))) {
add_symbol_to_list(sc, slot_symbol(px));
x_len++;
}
for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey))
for (py = let_slots(ey); tis_slot(py); py = next_slot(py))
if (!symbol_is_in_list(sc, slot_symbol(py))) /* symbol in y, not in x */
return (false);
for (y_len = 0, ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey))
for (py = let_slots(ey); tis_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(T_Lid(ex)); ex = let_outlet(ex))
for (px = let_slots(ex); tis_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 (((!equivalent) && (!slots_match(sc, px, y, nci))) ||
((equivalent)
&& (!slots_equivalent_match(sc, px, y, nci))))
return (false);
}
return (true);
}
static bool let_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
/* 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. */
return ((x == y) || (let_equal_1(sc, x, y, ci, false)));
}
/* what should these do if there are setters? */
static bool let_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (x == y)
return (true);
if (!is_global(sc->is_equivalent_symbol)) {
check_equivalent_method(sc, x, y);
check_equivalent_method(sc, y, x);
}
return (let_equal_1(sc, x, y, ci, true));
}
static bool closure_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (x == y)
return (true);
if (type(x) != type(y))
return (false);
if ((has_active_methods(sc, x)) && (has_active_methods(sc, y))) {
s7_pointer equal_func;
equal_func = find_method(sc, closure_let(x), sc->is_equal_symbol);
if (equal_func != sc->undefined)
return (s7_boolean
(sc,
call_method(sc, x, equal_func,
set_plist_2(sc, x, y))));
}
return (false);
}
static bool closure_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (x == y)
return (true);
if (type(x) != type(y))
return (false);
if (has_active_methods(sc, y))
check_equivalent_method(sc, x, y);
/* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y))
* because locally defined constant functions on the second pass find the outer let.
*/
return ((is_equivalent_1(sc, closure_args(x), closure_args(y), ci)) &&
(is_equivalent_1(sc, closure_body(x), closure_body(y), ci)));
}
static bool pair_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
s7_pointer px, py;
if (x == y)
return (true);
if (!is_pair(y))
return (false);
if (!ci)
ci = new_shared_info(sc);
else if (equal_ref(sc, x, y, ci))
return (true);
if (!is_equal_1(sc, car(x), car(y), ci))
return (false);
for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py));
px = cdr(px), py = cdr(py)) {
if (!is_equal_1(sc, car(px), car(py), ci))
return (false);
if (equal_ref(sc, px, py, ci))
return (true);
}
return ((px == py) || (is_equal_1(sc, px, py, ci)));
}
static bool pair_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
s7_pointer px, py;
if (x == y)
return (true);
if (!is_pair(y)) {
check_equivalent_method(sc, y, x);
return (false);
}
if (!ci)
ci = new_shared_info(sc);
else if (equal_ref(sc, x, y, ci))
return (true);
if (!is_equivalent_1(sc, car(x), car(y), ci))
return (false);
for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py));
px = cdr(px), py = cdr(py)) {
if (!is_equivalent_1(sc, car(px), car(py), ci))
return (false);
if (equal_ref(sc, px, py, ci))
return (true);
}
return ((px == py) || ((is_equivalent_1(sc, px, py, ci))));
}
static bool vector_rank_match(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
s7_int x_dims;
s7_int j;
if (!vector_has_dimension_info(x))
return ((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1));
x_dims = vector_ndims(x);
if (x_dims == 1)
return ((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1));
if ((!vector_has_dimension_info(y)) || (x_dims != vector_ndims(y)))
return (false);
for (j = 0; j < x_dims; j++)
if (vector_dimension(x, j) != vector_dimension(y, j))
return (false);
return (true);
}
static bool iv_meq(s7_int * ex, s7_int * ey, s7_int len)
{
s7_int i = 0, left = len - 8;
while (i <= left)
LOOP_8(if (ex[i] != ey[i]) return (false); i++);
for (; i < len; i++)
if (ex[i] != ey[i])
return (false);
return (true);
}
static bool byte_vector_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
s7_int i, len = vector_length(x);
uint8_t *xp = byte_vector_bytes(x), *yp = byte_vector_bytes(y);
for (i = 0; i < len; i++)
if (xp[i] != yp[i])
return (false);
return (true);
}
static bool biv_meq(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
s7_int i, len = vector_length(x);
uint8_t *xp;
s7_int *yp;
if (len != vector_length(y))
return (false);
xp = byte_vector_bytes(x);
yp = int_vector_ints(y);
for (i = 0; i < len; i++)
if ((s7_int) (xp[i]) != yp[i])
return (false);
return (true);
}
#define base_vector_equal(sc, x, y) \
do { \
if (x == y) return(true); \
len = vector_length(x); \
if (len != vector_length(y)) return(false); \
if (!vector_rank_match(sc, x, y)) return(false); \
if (len == 0) return(true); \
} while (0)
static bool vector_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
s7_int i, len;
shared_info_t *nci = ci;
if (!is_any_vector(y))
return (false);
base_vector_equal(sc, x, y);
if (type(x) != type(y)) {
if ((is_int_vector(x)) && (is_byte_vector(y)))
return (biv_meq(sc, y, x, NULL));
if ((is_byte_vector(x)) && (is_int_vector(y)))
return (biv_meq(sc, x, y, NULL));
for (i = 0; i < len; i++)
if (!is_equal_1(sc, vector_getter(x) (sc, x, i), vector_getter(y) (sc, y, i), NULL)) /* this could be greatly optimized */
return (false);
return (true);
}
if (!has_simple_elements(x)) {
if (ci) {
if (equal_ref(sc, x, y, ci))
return (true);
} else
nci = new_shared_info(sc);
}
for (i = 0; i < len; i++)
if (!
(is_equal_1
(sc, vector_element(x, i), vector_element(y, i), nci)))
return (false);
return (true);
}
static bool byte_vector_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
s7_int len;
if (!is_byte_vector(y))
return (vector_equal(sc, x, y, ci));
base_vector_equal(sc, x, y);
return (byte_vector_equal_1(sc, x, y));
}
static bool int_vector_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
s7_int len;
if (!is_int_vector(y))
return (vector_equal(sc, x, y, ci));
base_vector_equal(sc, x, y);
return (iv_meq(int_vector_ints(x), int_vector_ints(y), len));
}
static bool float_vector_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
s7_int i, len;
if (!is_float_vector(y))
return (vector_equal(sc, x, y, ci));
base_vector_equal(sc, x, y);
for (i = 0; i < len; i++) {
s7_double z;
z = float_vector(x, i);
if ((is_NaN(z)) || (z != float_vector(y, i)))
return (false);
}
return (true);
}
static bool vector_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
/* if this is split like vector_equal above, remember it is called by iterator_equal_1 below */
s7_int i, len;
shared_info_t *nci = ci;
if (x == y)
return (true);
if (!is_any_vector(y)) {
check_equivalent_method(sc, y, x);
return (false);
}
len = vector_length(x);
if (len != vector_length(y))
return (false);
if (len == 0)
return (true);
if (!vector_rank_match(sc, x, y))
return (false);
if (type(x) != type(y)) {
/* (equivalent? (make-int-vector 3 0) (make-vector 3 0)) -> #t
* (equivalent? (make-float-vector 3 1.0) (vector 1 1 1)) -> #t
*/
if ((is_int_vector(x)) && (is_byte_vector(y)))
return (biv_meq(sc, y, x, NULL));
if ((is_byte_vector(x)) && (is_int_vector(y)))
return (biv_meq(sc, x, y, NULL));
for (i = 0; i < len; i++)
if (!is_equivalent_1(sc, vector_getter(x) (sc, x, i), vector_getter(y) (sc, y, i), NULL)) /* this could be greatly optimized */
return (false);
return (true);
}
if (is_float_vector(x)) {
s7_double *arr1 = float_vector_floats(x), *arr2 =
float_vector_floats(y);
s7_double fudge = sc->equivalent_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++)
if (!floats_are_equivalent(sc, arr1[i], arr2[i]))
return (false);
return (true);
}
if (is_int_vector(x))
return (iv_meq(int_vector_ints(x), int_vector_ints(y), len));
if (is_byte_vector(x))
return (byte_vector_equal_1(sc, x, y));
if (!has_simple_elements(x)) {
if (ci) {
if (equal_ref(sc, x, y, ci))
return (true);
} else
nci = new_shared_info(sc);
}
for (i = 0; i < len; i++)
if (!
(is_equivalent_1
(sc, vector_element(x, i), vector_element(y, i), nci)))
return (false);
return (true);
}
static bool iterator_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci, bool equivalent)
{
s7_pointer x_seq, y_seq, xs, ys;
if (x == y)
return (true);
if (!is_iterator(y))
return (false);
x_seq = iterator_sequence(x);
y_seq = iterator_sequence(y);
switch (type(x_seq)) {
case T_STRING:
return ((is_string(y_seq)) &&
(iterator_position(x) == iterator_position(y)) &&
(iterator_length(x) == iterator_length(y)) &&
(string_equal(sc, x_seq, y_seq, ci)));
case T_VECTOR:
case T_INT_VECTOR:
case T_BYTE_VECTOR:
case T_FLOAT_VECTOR:
return ((is_any_vector(y_seq)) &&
(iterator_position(x) == iterator_position(y)) &&
(iterator_length(x) == iterator_length(y)) &&
((equivalent) ? (vector_equivalent(sc, x_seq, y_seq, ci)) :
((is_normal_vector(x_seq))
? (vector_equal(sc, x_seq, y_seq, ci))
: ((is_float_vector(x_seq))
? (float_vector_equal(sc, x_seq, y_seq, ci))
: ((is_int_vector(x_seq))
? (int_vector_equal(sc, x_seq, y_seq, ci))
: (byte_vector_equal(sc, x_seq, y_seq, ci)))))));
/* iterator_next is a function (pair_iterate, iterator_finished etc) */
case T_PAIR:
if (iterator_next(x) != iterator_next(y))
return (false); /* even if seqs are equal, one might be at end */
if (equivalent) {
if (!pair_equivalent(sc, x_seq, y_seq, ci))
return (false);
} else if (!pair_equal(sc, x_seq, y_seq, ci))
return (false);
for (xs = x_seq, ys = y_seq; is_pair(xs) && is_pair(ys);
xs = cdr(xs), ys = cdr(ys))
if (xs == iterator_current(x))
return (ys == iterator_current(y));
return (is_null(xs) && is_null(ys));
case T_NIL: /* (make-iterator #()) works, so () should too */
return (is_null(y_seq)); /* perhaps for equivalent case, check position in y as well as pair(seq(y))? */
case T_C_OBJECT:
if ((is_c_object(y_seq)) &&
(iterator_position(x) == iterator_position(y)) &&
(iterator_length(x) == iterator_length(y))) {
if (equivalent)
return (c_objects_are_equivalent(sc, x_seq, y_seq, ci));
return (c_objects_are_equal(sc, x_seq, y_seq, ci));
}
return (false);
case T_LET:
if (!is_let(y_seq))
return (false);
if (iterator_next(x) != iterator_next(y))
return (false);
if (x_seq == sc->rootlet)
return (iterator_position(x) == iterator_position(y)); /* y_seq must also be sc->rootlet since nexts are the same (rootlet_iterate) */
if (equivalent) {
if (!let_equivalent(sc, x_seq, y_seq, ci))
return (false);
} else if (!let_equal(sc, x_seq, y_seq, ci))
return (false);
for (xs = let_slots(x_seq), ys = let_slots(y_seq);
tis_slot(xs) && tis_slot(ys);
xs = next_slot(xs), ys = next_slot(ys))
if (xs == iterator_current_slot(x))
return (ys == iterator_current_slot(y));
return (is_slot_end(xs) && is_slot_end(ys));
case T_HASH_TABLE:
if (!is_hash_table(y_seq))
return (false);
if (hash_table_entries(x_seq) != hash_table_entries(y_seq))
return (false);
if (hash_table_entries(x_seq) == 0)
return (true);
if (iterator_position(x) != iterator_position(y))
return (false);
if (!equivalent)
return (hash_table_equal(sc, x_seq, y_seq, ci));
return (hash_table_equivalent(sc, x_seq, y_seq, ci));
case T_CLOSURE:
case T_CLOSURE_STAR:
return (x_seq == y_seq); /* or closure_equal/equivalent? */
default:
break;
}
return (false);
}
static bool iterator_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return (iterator_equal_1(sc, x, y, ci, false));
}
static bool iterator_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
return (iterator_equal_1(sc, x, y, ci, true));
}
#if WITH_GMP
static bool big_integer_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
/* (equal? 1 1.0) -> #f */
if (is_t_big_integer(y))
return (mpz_cmp(big_integer(x), big_integer(y)) == 0);
return ((is_t_integer(y))
&& (mpz_cmp_si(big_integer(x), integer(y)) == 0));
}
static bool big_ratio_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (is_t_big_ratio(y))
return (mpq_equal(big_ratio(x), big_ratio(y)));
if (is_t_ratio(y))
return ((numerator(y) == mpz_get_si(mpq_numref(big_ratio(x)))) &&
(denominator(y) == mpz_get_si(mpq_denref(big_ratio(x)))));
return (false);
}
static bool big_real_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (is_t_big_real(y))
return (mpfr_equal_p(big_real(x), big_real(y)));
if (is_t_real(y)) {
if (mpfr_nan_p(big_real(x)))
return (false);
return ((!is_NaN(real(y))) &&
(mpfr_cmp_d(big_real(x), real(y)) == 0));
}
return (false);
}
static bool big_complex_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if ((mpfr_nan_p(mpc_realref(big_complex(x))))
|| (mpfr_nan_p(mpc_imagref(big_complex(x)))))
return (false);
if (is_t_big_complex(y))
return ((!mpfr_nan_p(mpc_realref(big_complex(y)))) &&
(!mpfr_nan_p(mpc_imagref(big_complex(y)))) &&
(mpc_cmp(big_complex(x), big_complex(y)) == 0));
if (is_t_complex(y))
return ((!is_NaN(real_part(y))) &&
(!is_NaN(imag_part(y))) &&
(mpfr_cmp_d(mpc_realref(big_complex(x)), real_part(y)) ==
0)
&& (mpfr_cmp_d(mpc_imagref(big_complex(x)), imag_part(y))
== 0));
return (false);
}
#endif
static bool integer_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (is_t_integer(y))
return (integer(x) == integer(y));
#if WITH_GMP
if (is_t_big_integer(y))
return (mpz_cmp_si(big_integer(y), integer(x)) == 0);
#endif
return (false);
}
/* apparently ratio_equal is predefined in g++ -- name collision on mac */
static bool fraction_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (is_t_ratio(y))
return ((numerator(x) == numerator(y)) &&
(denominator(x) == denominator(y)));
#if WITH_GMP
if (is_t_big_ratio(y))
return ((numerator(x) == mpz_get_si(mpq_numref(big_ratio(y)))) &&
(denominator(x) == mpz_get_si(mpq_denref(big_ratio(y)))));
#endif
return (false);
}
static bool real_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (is_t_real(y))
return (real(x) == real(y));
#if WITH_GMP
if (is_t_big_real(y))
return ((!is_NaN(real(x))) &&
(!mpfr_nan_p(big_real(y))) &&
(mpfr_cmp_d(big_real(y), real(x)) == 0));
#endif
return (false);
}
static bool complex_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
if (is_t_complex(y))
return ((real_part(x) == real_part(y)) &&
(imag_part(x) == imag_part(y)));
#if WITH_GMP
if (is_t_big_complex(y)) {
if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) ||
(mpfr_nan_p(mpc_realref(big_complex(y))))
|| (mpfr_nan_p(mpc_imagref(big_complex(y)))))
return (false);
return ((mpfr_cmp_d(mpc_realref(big_complex(y)), real_part(x)) ==
0)
&& (mpfr_cmp_d(mpc_imagref(big_complex(y)), imag_part(x))
== 0));
}
#endif
return (false);
}
#if WITH_GMP
static bool big_integer_or_ratio_equivalent(s7_scheme * sc, s7_pointer x,
s7_pointer y,
shared_info_t * ci,
bool int_case)
{
if (int_case)
mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
else
mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
switch (type(y)) {
case T_INTEGER:
if (int_case)
return (mpz_cmp_si(big_integer(x), integer(y)) == 0);
mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_RATIO:
mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_REAL:
mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_COMPLEX:
mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN);
if (!big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2))
return (false);
if (is_NaN(imag_part(y)))
return (false);
mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN);
return (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0);
case T_BIG_INTEGER:
if (int_case)
return (mpz_cmp(big_integer(x), big_integer(y)) == 0);
mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_BIG_REAL:
return (big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
case T_BIG_COMPLEX:
if (big_floats_are_equivalent
(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) {
if (mpfr_nan_p(mpc_imagref(big_complex(y))))
return (false);
mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon,
MPFR_RNDN);
return (mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <=
0);
}
}
return (false);
}
static bool big_integer_equivalent(s7_scheme * sc, s7_pointer x,
s7_pointer y, shared_info_t * ci)
{
return (big_integer_or_ratio_equivalent(sc, x, y, ci, true));
}
static bool big_ratio_equivalent(s7_scheme * sc, s7_pointer x,
s7_pointer y, shared_info_t * ci)
{
return (big_integer_or_ratio_equivalent(sc, x, y, ci, false));
}
static bool big_real_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
switch (type(y)) {
case T_INTEGER:
mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
case T_RATIO:
mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
case T_REAL:
mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
case T_COMPLEX:
mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN);
if (!big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2))
return (false);
if (is_NaN(imag_part(y)))
return (false);
mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN);
return (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0);
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
case T_BIG_REAL:
return (big_floats_are_equivalent(sc, big_real(x), big_real(y)));
case T_BIG_COMPLEX:
if (big_floats_are_equivalent
(sc, big_real(x), mpc_realref(big_complex(y)))) {
if (mpfr_nan_p(mpc_imagref(big_complex(y))))
return (false);
mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon,
MPFR_RNDN);
return (mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <=
0);
}
}
return (false);
}
static bool big_complex_equivalent(s7_scheme * sc, s7_pointer x,
s7_pointer y, shared_info_t * ci)
{
mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN);
switch (type(y)) {
case T_INTEGER:
mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN);
return ((big_floats_are_equivalent
(sc, mpc_realref(big_complex(x)), sc->mpfr_2))
&&
(big_floats_are_equivalent
(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
case T_RATIO:
mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN);
return ((big_floats_are_equivalent
(sc, mpc_realref(big_complex(x)), sc->mpfr_2))
&&
(big_floats_are_equivalent
(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
case T_REAL:
mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN);
return ((big_floats_are_equivalent
(sc, mpc_realref(big_complex(x)), sc->mpfr_2))
&&
(big_floats_are_equivalent
(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
case T_COMPLEX:
mpfr_set_d(sc->mpfr_1, imag_part(y), MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN);
return ((big_floats_are_equivalent
(sc, mpc_realref(big_complex(x)), sc->mpfr_2))
&&
(big_floats_are_equivalent
(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN);
return ((big_floats_are_equivalent
(sc, mpc_realref(big_complex(x)), sc->mpfr_2))
&&
(big_floats_are_equivalent
(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
case T_BIG_RATIO:
mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
return ((big_floats_are_equivalent
(sc, mpc_realref(big_complex(x)), sc->mpfr_2))
&&
(big_floats_are_equivalent
(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
case T_BIG_REAL:
return ((big_floats_are_equivalent
(sc, mpc_realref(big_complex(x)), big_real(y)))
&&
(big_floats_are_equivalent
(sc, mpc_imagref(big_complex(x)), sc->mpfr_1)));
case T_BIG_COMPLEX:
return ((big_floats_are_equivalent
(sc, mpc_realref(big_complex(x)),
mpc_realref(big_complex(y))))
&&
(big_floats_are_equivalent
(sc, mpc_imagref(big_complex(x)),
mpc_imagref(big_complex(y)))));
}
return (false);
}
static bool both_floats_are_equivalent(s7_scheme * sc, s7_pointer y)
{
if (!big_floats_are_equivalent
(sc, sc->mpfr_1, mpc_realref(big_complex(y))))
return (false);
if (mpfr_nan_p(mpc_imagref(big_complex(y))))
return (false);
mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN);
return (mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0);
}
#endif
static bool integer_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
switch (type(y)) {
case T_INTEGER:
return (integer(x) == integer(y));
case T_RATIO:
return (floats_are_equivalent
(sc, (double) integer(x), fraction(y)));
case T_REAL:
return (floats_are_equivalent(sc, (double) integer(x), real(y)));
case T_COMPLEX:
return ((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) &&
(floats_are_equivalent
(sc, (double) integer(x), real_part(y))));
#if WITH_GMP
case T_BIG_INTEGER:
return (mpz_cmp_si(big_integer(y), integer(x)) == 0);
case T_BIG_RATIO:
mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_BIG_REAL:
mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
case T_BIG_COMPLEX:
mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
return (both_floats_are_equivalent(sc, y));
#endif
}
return (false);
}
static bool fraction_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
switch (type(y)) {
case T_INTEGER:
return (floats_are_equivalent
(sc, (double) fraction(x), integer(y)));
case T_RATIO:
return (floats_are_equivalent
(sc, (double) fraction(x), fraction(y)));
case T_REAL:
return (floats_are_equivalent(sc, (double) fraction(x), real(y)));
case T_COMPLEX:
return ((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) &&
(floats_are_equivalent(sc, fraction(x), real_part(y))));
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, fraction(x), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN);
mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_BIG_REAL:
mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
case T_BIG_COMPLEX:
mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN);
return (both_floats_are_equivalent(sc, y));
#endif
}
return (false);
}
static bool real_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
switch (type(y)) {
case T_INTEGER:
return (floats_are_equivalent(sc, real(x), integer(y)));
case T_RATIO:
return (floats_are_equivalent(sc, real(x), fraction(y)));
case T_REAL:
return (floats_are_equivalent(sc, real(x), real(y)));
case T_COMPLEX:
return ((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) &&
(floats_are_equivalent(sc, real(x), real_part(y))));
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
case T_BIG_REAL:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
case T_BIG_COMPLEX:
mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
return (both_floats_are_equivalent(sc, y));
#endif
}
return (false);
}
static bool complex_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
switch (type(y)) {
case T_INTEGER:
return ((floats_are_equivalent(sc, real_part(x), integer(y))) &&
(floats_are_equivalent(sc, imag_part(x), 0.0)));
case T_RATIO:
return ((floats_are_equivalent(sc, real_part(x), fraction(y))) &&
(floats_are_equivalent(sc, imag_part(x), 0.0)));
case T_REAL:
return ((floats_are_equivalent(sc, real_part(x), real(y))) &&
(floats_are_equivalent(sc, imag_part(x), 0.0)));
case T_COMPLEX:
return ((floats_are_equivalent(sc, real_part(x), real_part(y))) &&
(floats_are_equivalent(sc, imag_part(x), imag_part(y))));
#if WITH_GMP
case T_BIG_INTEGER:
mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, real_part(x), MPFR_RNDN);
return ((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) &&
(floats_are_equivalent(sc, imag_part(x), 0.0)));
case T_BIG_RATIO:
mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN);
mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
return ((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) &&
(floats_are_equivalent(sc, imag_part(x), 0.0)));
case T_BIG_REAL:
mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN);
return ((big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))) &&
(floats_are_equivalent(sc, imag_part(x), 0.0)));
case T_BIG_COMPLEX:
mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN);
mpfr_set_d(sc->mpfr_2, imag_part(x), MPFR_RNDN);
return ((big_floats_are_equivalent
(sc, sc->mpfr_1, mpc_realref(big_complex(y))))
&&
(big_floats_are_equivalent
(sc, sc->mpfr_2, mpc_imagref(big_complex(y)))));
#endif
}
return (false);
}
static bool rng_equal(s7_scheme * sc, s7_pointer x, s7_pointer y,
shared_info_t * ci)
{
#if WITH_GMP
return (x == y);
#else
return ((x == y) ||
((is_random_state(y)) &&
(random_seed(x) == random_seed(y)) &&
(random_carry(x) == random_carry(y))));
#endif
}
static void init_equals(void)
{
int32_t i;
for (i = 0; i < NUM_TYPES; i++) {
equals[i] = eq_equal;
equivalents[i] = eq_equal;
}
equals[T_SYMBOL] = eq_equal;
equals[T_C_POINTER] = c_pointer_equal;
equals[T_UNSPECIFIED] = unspecified_equal;
equals[T_UNDEFINED] = undefined_equal;
equals[T_STRING] = string_equal;
equals[T_SYNTAX] = syntax_equal;
equals[T_C_OBJECT] = c_objects_are_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] = int_vector_equal;
equals[T_BYTE_VECTOR] = byte_vector_equal;
equals[T_FLOAT_VECTOR] = float_vector_equal;
equals[T_INTEGER] = integer_equal;
equals[T_RATIO] = fraction_equal;
equals[T_REAL] = real_equal;
equals[T_COMPLEX] = complex_equal;
#if WITH_GMP
equals[T_BIG_INTEGER] = big_integer_equal;
equals[T_BIG_RATIO] = big_ratio_equal;
equals[T_BIG_REAL] = big_real_equal;
equals[T_BIG_COMPLEX] = big_complex_equal;
#endif
equivalents[T_SYMBOL] = symbol_equivalent;
equivalents[T_C_POINTER] = c_pointer_equivalent;
equivalents[T_UNSPECIFIED] = unspecified_equal;
equivalents[T_UNDEFINED] = undefined_equal;
equivalents[T_STRING] = string_equal;
equivalents[T_SYNTAX] = syntax_equal;
equivalents[T_C_OBJECT] = c_objects_are_equivalent;
equivalents[T_RANDOM_STATE] = rng_equal;
equivalents[T_ITERATOR] = iterator_equivalent;
equivalents[T_INPUT_PORT] = port_equivalent;
equivalents[T_OUTPUT_PORT] = port_equivalent;
equivalents[T_MACRO] = closure_equivalent;
equivalents[T_MACRO_STAR] = closure_equivalent;
equivalents[T_BACRO] = closure_equivalent;
equivalents[T_BACRO_STAR] = closure_equivalent;
equivalents[T_CLOSURE] = closure_equivalent;
equivalents[T_CLOSURE_STAR] = closure_equivalent;
equivalents[T_HASH_TABLE] = hash_table_equivalent;
equivalents[T_LET] = let_equivalent;
equivalents[T_PAIR] = pair_equivalent;
equivalents[T_VECTOR] = vector_equivalent;
equivalents[T_INT_VECTOR] = vector_equivalent;
equivalents[T_FLOAT_VECTOR] = vector_equivalent;
equivalents[T_BYTE_VECTOR] = vector_equivalent;
equivalents[T_INTEGER] = integer_equivalent;
equivalents[T_RATIO] = fraction_equivalent;
equivalents[T_REAL] = real_equivalent;
equivalents[T_COMPLEX] = complex_equivalent;
#if WITH_GMP
equivalents[T_BIG_INTEGER] = big_integer_equivalent;
equivalents[T_BIG_RATIO] = big_ratio_equivalent;
equivalents[T_BIG_REAL] = big_real_equivalent;
equivalents[T_BIG_COMPLEX] = big_complex_equivalent;
#endif
}
bool s7_is_equal(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
return ((*(equals[type(x)])) (sc, x, y, NULL));
}
bool s7_is_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
return ((*(equivalents[type(x)])) (sc, x, y, NULL));
}
static s7_pointer g_is_equal(s7_scheme * sc, s7_pointer args)
{
#define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2"
#define Q_is_equal sc->pcl_bt
return (make_boolean(sc, is_equal_1(sc, car(args), cadr(args), NULL)));
}
static s7_pointer g_is_equivalent(s7_scheme * sc, s7_pointer args)
{
#define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2."
#define Q_is_equivalent sc->pcl_bt
return (make_boolean
(sc, is_equivalent_1(sc, car(args), cadr(args), NULL)));
}
static s7_pointer is_equal_p_pp(s7_scheme * sc, s7_pointer a, s7_pointer b)
{
return ((is_equal_1(sc, a, b, NULL)) ? sc->T : sc->F);
}
static s7_pointer is_equivalent_p_pp(s7_scheme * sc, s7_pointer a,
s7_pointer b)
{
return ((is_equivalent_1(sc, a, b, NULL)) ? sc->T : sc->F);
}
/* ---------------------------------------- length, copy, fill ---------------------------------------- */
static s7_pointer s7_length(s7_scheme * sc, s7_pointer lst);
static s7_pointer(*length_functions[256]) (s7_scheme * sc, s7_pointer obj);
static s7_pointer any_length(s7_scheme * sc, s7_pointer obj)
{
return (sc->F);
}
static s7_pointer pair_length(s7_scheme * sc, s7_pointer a)
{
s7_int i = 0;
s7_pointer slow = a, fast = a; /* we know a is a pair, don't start with fast = cdr(a)! else if a len = 3, we never match */
while (true) {
LOOP_4(fast = cdr(fast); i++; if (!is_pair(fast))
return (make_integer(sc, (is_null(fast)) ? i : -i)));
slow = cdr(slow);
if (fast == slow)
return (real_infinity);
}
return (real_infinity);
}
static s7_pointer nil_length(s7_scheme * sc, s7_pointer lst)
{
return (int_zero);
}
static s7_pointer v_length(s7_scheme * sc, s7_pointer v)
{
return (make_integer(sc, vector_length(v)));
}
static s7_pointer str_length(s7_scheme * sc, s7_pointer v)
{
return (make_integer(sc, string_length(v)));
}
static s7_pointer bv_length(s7_scheme * sc, s7_pointer v)
{
return (make_integer(sc, byte_vector_length(v)));
}
static s7_pointer h_length(s7_scheme * sc, s7_pointer lst)
{
return (make_integer(sc, hash_table_mask(lst) + 1));
}
static s7_pointer iter_length(s7_scheme * sc, s7_pointer lst)
{
return (s7_length(sc, iterator_sequence(lst)));
}
static s7_pointer c_obj_length(s7_scheme * sc, s7_pointer lst)
{
if (!is_global(sc->length_symbol))
check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst));
return (c_object_length(sc, lst));
}
static s7_pointer lt_length(s7_scheme * sc, s7_pointer lst)
{
if (!is_global(sc->length_symbol))
check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst));
return (make_integer(sc, let_length(sc, lst)));
}
static s7_pointer fnc_length(s7_scheme * sc, s7_pointer lst)
{
return ((has_active_methods(sc, lst)) ?
make_integer(sc, closure_length(sc, lst)) : sc->F);
}
static s7_pointer ip_length(s7_scheme * sc, s7_pointer port)
{
if (port_is_closed(port))
return (sc->F); /* or 0? */
if (is_string_port(port))
return (make_integer(sc, port_data_size(port))); /* length of string we're reading */
#if (!MS_WINDOWS)
if (is_file_port(port)) {
long cur_pos, len;
cur_pos = ftell(port_file(port));
fseek(port_file(port), 0, SEEK_END);
len = ftell(port_file(port));
rewind(port_file(port));
fseek(port_file(port), cur_pos, SEEK_SET);
return (make_integer(sc, len));
}
#endif
return (sc->F);
}
static s7_pointer op_length(s7_scheme * sc, s7_pointer port)
{
if (port_is_closed(port))
return (sc->F); /* or 0? */
return ((is_string_port(port)) ? make_integer(sc, port_position(port)) : sc->F); /* length of string we've written */
}
static void init_length_functions(void)
{
int32_t i;
for (i = 0; i < 256; i++)
length_functions[i] = any_length;
length_functions[T_NIL] = nil_length;
length_functions[T_PAIR] = pair_length;
length_functions[T_VECTOR] = v_length;
length_functions[T_FLOAT_VECTOR] = v_length;
length_functions[T_INT_VECTOR] = v_length;
length_functions[T_STRING] = str_length;
length_functions[T_BYTE_VECTOR] = bv_length;
length_functions[T_ITERATOR] = iter_length;
length_functions[T_HASH_TABLE] = h_length;
length_functions[T_C_OBJECT] = c_obj_length;
length_functions[T_LET] = lt_length;
length_functions[T_CLOSURE] = fnc_length;
length_functions[T_CLOSURE_STAR] = fnc_length;
length_functions[T_INPUT_PORT] = ip_length;
length_functions[T_OUTPUT_PORT] = op_length;
}
static s7_pointer s7_length(s7_scheme * sc, s7_pointer lst)
{
return ((*length_functions[unchecked_type(lst)]) (sc, lst));
}
static s7_pointer g_length(s7_scheme * sc, s7_pointer args)
{
#define H_length "(length obj) returns the length of obj, which can be a list, vector, string, input-port, or hash-table. \
The length of a dotted list does not include the final cdr, and is returned as a negative number. A circular \
list has infinite length. Length of anything else returns #f."
#define Q_length s7_make_signature(sc, 2, s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_infinite_symbol, sc->not_symbol), sc->T)
return ((*length_functions[unchecked_type(car(args))])
(sc, car(args)));
}
/* -------------------------------- copy -------------------------------- */
static s7_pointer string_setter(s7_scheme * sc, s7_pointer str, s7_int loc,
s7_pointer val)
{
if (is_character(val)) {
string_value(str)[loc] = s7_character(val);
return (val);
}
set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not a character", 25));
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 (chars[(uint8_t) (string_value(str)[loc])]); /* cast needed else (copy (string (integer->char 255))...) is trouble */
}
static s7_pointer c_object_setter(s7_scheme * sc, s7_pointer obj,
s7_int loc, s7_pointer val)
{
set_car(sc->t3_1, obj);
set_car(sc->t3_2, make_integer(sc, loc));
set_car(sc->t3_3, val);
return ((*(c_object_set(sc, obj))) (sc, sc->t3_1));
}
static s7_pointer c_object_getter(s7_scheme * sc, s7_pointer obj,
s7_int loc)
{
return ((*(c_object_ref(sc, obj)))
(sc, set_plist_2(sc, obj, make_integer(sc, loc))));
}
static s7_pointer let_setter(s7_scheme * sc, s7_pointer e, s7_int loc,
s7_pointer val)
{
/* loc is irrelevant here, val has to be of the form (cons symbol value)
* if symbol is already in e, its value is changed, otherwise a new slot is added to e
*/
if (is_pair(val)) {
s7_pointer sym = car(val);
if (is_symbol(sym)) {
s7_pointer slot;
if (is_keyword(sym))
sym = keyword_symbol(sym); /* else make_slot will mark the keyword as local confusing odd_bits etc */
slot = slot_in_let(sc, e, sym);
if (is_slot(slot))
checked_slot_set_value(sc, slot, cdr(val));
else
add_slot_checked_with_id(sc, e, sym, cdr(val));
return (cdr(val));
}
}
set_car(sc->elist_3,
wrap_string(sc, "~S: ~S is not (cons symbol value)", 33));
set_caddr(sc->elist_3, val);
return (s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3));
}
static s7_pointer hash_table_setter(s7_scheme * sc, s7_pointer e,
s7_int loc, s7_pointer val)
{
/* loc is irrelevant here, e is the hash-table, val has to be of the form (cons key value)
* if key is already in e, its value is changed, otherwise a new slot is added to e
*/
if (is_pair(val))
return (s7_hash_table_set(sc, e, car(val), cdr(val)));
set_car(sc->elist_3,
wrap_string(sc, "~S: ~S is not (cons key value)", 30));
set_caddr(sc->elist_3, val);
return (s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3));
}
static s7_pointer copy_source_no_dest(s7_scheme * sc, s7_pointer caller,
s7_pointer source, s7_pointer args)
{
s7_pointer dest;
switch (type(source)) {
case T_STRING:
return (make_string_with_length
(sc, string_value(source), string_length(source)));
case T_C_OBJECT:
return (copy_c_object(sc, args));
case T_RANDOM_STATE:
return (rng_copy(sc, args));
case T_HASH_TABLE: /* this has to copy nearly everything */
{
s7_int gc_loc;
s7_pointer new_hash;
new_hash = s7_make_hash_table(sc, hash_table_mask(source) + 1);
gc_loc = gc_protect_1(sc, new_hash);
hash_table_checker(new_hash) = hash_table_checker(source);
if (hash_chosen(source))
hash_set_chosen(new_hash);
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));
if (is_typed_hash_table(source)) {
set_typed_hash_table(new_hash);
if (has_simple_keys(source))
set_has_simple_keys(new_hash);
if (has_simple_values(source))
set_has_simple_values(new_hash);
}
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 let and points to outer lets */
case T_CLOSURE:
case T_CLOSURE_STAR:
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
check_method(sc, source, sc->copy_symbol, args);
return (copy_closure(sc, source));
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
case T_BYTE_VECTOR:
return (s7_vector_copy(sc, source)); /* "shallow" copy */
case T_PAIR: /* top level only, as in the other cases, checks for circles */
return (copy_any_list(sc, source));
case T_INTEGER:
new_cell(sc, dest, T_INTEGER);
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_number(sc, big_complex(source)));
#endif
case T_C_POINTER:
dest =
s7_make_c_pointer_with_type(sc, c_pointer(source),
c_pointer_type(source),
c_pointer_info(source));
c_pointer_weak1(dest) = c_pointer_weak1(source);
c_pointer_weak2(dest) = c_pointer_weak2(source);
return (dest);
}
return (source);
}
static s7_pointer copy_p_p(s7_scheme * sc, s7_pointer source)
{
return (copy_source_no_dest
(sc, sc->copy_symbol, source, set_plist_1(sc, source)));
}
static s7_pointer copy_to_same_type(s7_scheme * sc, s7_pointer dest,
s7_pointer source, s7_int dest_start,
s7_int dest_end, s7_int source_start)
{
/* types equal, but not a let (handled in s7_copy_1), returns NULL if not copied here */
s7_int i, j, source_len = dest_end - dest_start;
switch (type(source)) {
case T_PAIR:
{
s7_pointer pd, ps;
for (ps = source, i = 0; i < source_start; i++)
ps = cdr(ps);
for (pd = dest, i = 0; i < dest_start; i++)
pd = cdr(pd);
for (; (i < dest_end) && is_pair(ps) && is_pair(pd);
i++, ps = cdr(ps), pd = cdr(pd))
set_car(pd, car(ps));
return (dest);
}
case T_VECTOR:
if (is_typed_vector(dest)) {
s7_pointer *els = vector_elements(source);
for (i = source_start, j = dest_start; j < dest_end; i++, j++)
typed_vector_setter(sc, dest, j, els[i]); /* types are equal, so source is a normal vector */
} else
memcpy((void *) ((vector_elements(dest)) + dest_start),
(void *) ((vector_elements(source)) + source_start),
source_len * sizeof(s7_pointer));
return (dest);
case T_INT_VECTOR:
memcpy((void *) ((int_vector_ints(dest)) + dest_start),
(void *) ((int_vector_ints(source)) + source_start),
source_len * sizeof(s7_int));
return (dest);
case T_FLOAT_VECTOR:
memcpy((void *) ((float_vector_floats(dest)) + dest_start),
(void *) ((float_vector_floats(source)) + source_start),
source_len * sizeof(s7_double));
return (dest);
case T_BYTE_VECTOR:
if (is_string(dest))
memcpy((void *) (string_value(dest) + dest_start),
(void *) ((byte_vector_bytes(source)) + source_start),
source_len * sizeof(uint8_t));
else
memcpy((void *) (byte_vector_bytes(dest) + dest_start),
(void *) ((byte_vector_bytes(source)) + source_start),
source_len * sizeof(uint8_t));
return (dest);
case T_STRING:
if (is_string(dest))
memcpy((void *) (string_value(dest) + dest_start),
(void *) ((string_value(source)) + source_start),
source_len);
else
memcpy((void *) (byte_vector_bytes(dest) + dest_start),
(void *) ((string_value(source)) + source_start),
source_len);
return (dest);
case T_C_OBJECT:
{
s7_pointer mi, mj;
s7_int gc_loc1, gc_loc2;
s7_pointer(*cref) (s7_scheme * sc, s7_pointer args);
s7_pointer(*cset) (s7_scheme * sc, s7_pointer args);
mi = make_mutable_integer(sc, 0);
mj = make_mutable_integer(sc, 0);
gc_loc1 = gc_protect_1(sc, mi);
gc_loc2 = gc_protect_1(sc, mj);
cref = c_object_ref(sc, source);
cset = c_object_set(sc, dest);
for (i = source_start, j = dest_start; i < dest_end; i++, j++) {
integer(mi) = i;
integer(mj) = j;
set_car(sc->t2_1, source);
set_car(sc->t2_2, mi);
set_car(sc->t3_3, cref(sc, sc->t2_1));
set_car(sc->t3_1, dest);
set_car(sc->t3_2, mj);
cset(sc, sc->t3_1);
}
s7_gc_unprotect_at(sc, gc_loc1);
s7_gc_unprotect_at(sc, gc_loc2);
free_cell(sc, mi);
free_cell(sc, mj);
return (dest);
}
case T_LET:
return (NULL);
case T_HASH_TABLE:
{
s7_pointer p;
p = hash_table_copy(sc, source, dest, source_start,
source_start + source_len);
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;
hash_set_chosen(dest);
}
}
return (p);
}
default:
return (dest);
}
return (NULL);
}
static s7_pointer s7_copy_1(s7_scheme * sc, s7_pointer caller,
s7_pointer args)
{
#define H_copy "(copy obj) returns a copy of obj, (copy src dest) copies src into dest, (copy src dest start end) copies src from start to end."
/* #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol) */
/* this is not right when c-object types are handled in lint -- a generator or Snd object need not consider itself a sequence,
* but it can provide a copy method. So, I think I'll just use #t
*/
#define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->T, sc->T, sc->is_integer_symbol)
s7_pointer source = car(args), 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;
if (is_null(cdr(args))) /* (copy obj) */
return (copy_source_no_dest(sc, caller, source, args));
dest = T_Pos(cadr(args));
if ((dest == sc->key_readable_symbol) && (!is_pair(source)))
return (s7_error
(sc, sc->out_of_range_symbol,
set_elist_1(sc,
wrap_string(sc,
"copy argument 2, :readable, only works if the source is a pair",
62))));
if ((is_immutable(dest)) && (dest != sc->key_readable_symbol) && (dest != sc->nil)) /* error_hook copies with cadr(args) :readable, so it's currently NULL */
return (s7_wrong_type_arg_error(sc, symbol_name(caller), 2, dest, "a mutable object")); /* so this segfaults if not checking for :readable */
have_indices = (is_pair(cddr(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 */
if (have_indices) /* it seems to me that the start/end args here don't make any sense so... */
return (s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc,
wrap_string(sc,
"~S: start/end indices make no sense with :readable: ~S",
54), caller,
args)));
return (copy_body(sc, source));
}
end = s7_list_length(sc, source);
if (end == 0)
end = circular_list_entries(source);
else if (end < 0)
end = -end;
break;
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
case T_BYTE_VECTOR:
get = vector_getter(source);
end = vector_length(source);
break;
case T_STRING:
get = string_getter;
end = string_length(source);
break;
case T_HASH_TABLE:
if (source == dest)
return (dest);
end = hash_table_entries(source);
break;
case T_C_OBJECT:
if (c_object_copy(sc, source)) {
s7_pointer x;
x = (*(c_object_copy(sc, source))) (sc, args);
if (x == dest)
return (dest);
}
check_method(sc, source, sc->copy_symbol, args);
get = c_object_getter;
end = c_object_length_to_int(sc, source);
break;
case T_LET:
if (source == dest)
return (dest);
check_method(sc, source, sc->copy_symbol, args);
if (source == sc->rootlet)
return (wrong_type_argument_with_type
(sc, caller, 1, source,
wrap_string(sc, "a sequence other than the rootlet",
33)));
if ((!have_indices) && (is_let(dest)) && (dest != sc->s7_let)) {
s7_pointer slot;
if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */
for (slot = let_slots(source); tis_slot(slot);
slot = next_slot(slot))
s7_make_slot(sc, dest, slot_symbol(slot),
slot_value(slot));
else if ((has_let_fallback(source))
&& (has_let_fallback(dest))) {
for (slot = let_slots(source); tis_slot(slot);
slot = next_slot(slot))
if ((slot_symbol(slot) != sc->let_ref_fallback_symbol)
&& (slot_symbol(slot) !=
sc->let_set_fallback_symbol))
add_slot_checked_with_id(sc, dest,
slot_symbol(slot),
slot_value(slot));
} else
for (slot = let_slots(source); tis_slot(slot);
slot = next_slot(slot))
add_slot_checked_with_id(sc, dest, slot_symbol(slot),
slot_value(slot));
return (dest);
}
end = let_length(sc, source);
break;
case T_NIL:
end = 0;
if (is_sequence(dest))
break;
default:
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17),
caller, source, dest)));
}
start = 0;
if (have_indices) {
s7_pointer p;
p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end);
if (p != sc->unused)
return (p);
}
if ((start == 0) && (source == dest))
return (dest);
source_len = end - start;
if (source_len == 0) {
if (!is_sequence(dest))
return (wrong_type_argument_with_type
(sc, caller, 2, dest, a_sequence_string));
return (dest);
}
switch (type(dest)) {
case T_PAIR:
dest_len = source_len;
break;
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_BYTE_VECTOR:
set = vector_setter(dest);
dest_len = vector_length(dest);
break;
case T_VECTOR:
set =
(is_typed_vector(dest)) ? typed_vector_setter :
vector_setter(dest);
dest_len = vector_length(dest);
break;
case T_STRING:
set = string_setter;
dest_len = string_length(dest);
set_cadr(sc->elist_3, caller); /* for possible error handling in string_setter */
break;
case T_HASH_TABLE:
set = hash_table_setter;
dest_len = source_len;
set_cadr(sc->elist_3, caller); /* for possible error handling in hash_table_setter */
break;
case T_C_OBJECT:
/* if source or dest is c_object, call its copy function before falling back on the get/set functions */
if (c_object_copy(sc, dest)) {
s7_pointer x;
x = (*(c_object_copy(sc, dest))) (sc, args);
if (x == dest)
return (dest);
}
set = c_object_setter;
dest_len = c_object_length_to_int(sc, dest);
break;
case T_LET:
if ((dest == sc->rootlet) || (dest == sc->s7_let))
return (wrong_type_argument_with_type
(sc, caller, 2, dest,
wrap_string(sc,
"a sequence other than the rootlet or *s7*",
41)));
set = let_setter;
dest_len = source_len; /* grows via set, so dest_len isn't relevant */
set_cadr(sc->elist_3, caller); /* for possible error handling in let_setter */
break;
case T_NIL:
return (sc->nil);
default:
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17),
caller, source, dest)));
}
if (dest_len == 0)
return (dest);
/* end is source_len if not set explicitly */
if (dest_len < source_len) {
end = dest_len + start;
source_len = dest_len;
}
if ((source != dest) &&
((type(source) == type(dest)) ||
((is_string_or_byte_vector(source)) &&
(is_string_or_byte_vector(dest))))) {
s7_pointer res;
res = copy_to_same_type(sc, dest, source, 0, source_len, start);
if (res)
return (res);
}
switch (type(source)) {
case T_PAIR:
{
s7_pointer p = source;
if (start > 0)
for (i = 0; i < start; i++)
p = cdr(p);
/* dest won't be a pair here if source != dest -- the pair->pair case was caught above */
if (source == dest) { /* here start != 0 (see above) */
s7_pointer dp;
for (dp = source, i = start; i < end;
i++, p = cdr(p), dp = cdr(dp))
set_car(dp, car(p));
} else if (is_string(dest)) {
char *dst = string_value(dest);
for (i = start, j = 0; i < end; i++, j++, p = cdr(p)) {
if (!is_character(car(p)))
return (simple_wrong_type_argument
(sc, caller, car(p), T_CHARACTER));
dst[j] = character(car(p));
}
} else
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?
*/
if (source == sc->s7_let) { /* *s7* */
s7_pointer iter;
s7_int gc_loc;
iter = s7_make_iterator(sc, sc->s7_let);
gc_loc = s7_gc_protect(sc, iter);
for (i = 0; i < start; i++) {
s7_iterate(sc, iter);
if (iterator_is_at_end(iter)) {
s7_gc_unprotect_at(sc, gc_loc);
return (dest);
}
}
if (is_pair(dest)) { /* (append '(1) *s7* ()) */
s7_pointer p;
for (i = start, p = dest; (i < end) && (is_pair(p));
i++, p = cdr(p)) {
s7_pointer val;
val = s7_iterate(sc, iter);
if (iterator_is_at_end(iter))
break;
set_car(p, val);
}
} else
for (i = start, j = 0; i < end; i++, j++) {
s7_pointer val;
val = s7_iterate(sc, iter);
if (iterator_is_at_end(iter))
break;
set(sc, dest, j, val);
}
s7_gc_unprotect_at(sc, gc_loc);
} else {
/* source and dest can't be rootlet (checked above), dest also can't be *s7* */
s7_pointer slot = let_slots(source);
for (i = 0; i < start; i++)
slot = next_slot(slot);
if (is_pair(dest)) {
s7_pointer p;
for (i = start, p = dest; (i < end) && (is_pair(p));
i++, p = cdr(p), slot = next_slot(slot))
set_car(p,
cons(sc, slot_symbol(slot), slot_value(slot)));
} else if (is_let(dest)) {
if ((has_let_fallback(source)) && (has_let_fallback(dest))) {
for (slot = let_slots(source); tis_slot(slot);
slot = next_slot(slot))
if ((slot_symbol(slot) !=
sc->let_ref_fallback_symbol)
&& (slot_symbol(slot) !=
sc->let_set_fallback_symbol))
add_slot_checked_with_id(sc, dest,
slot_symbol(slot),
slot_value(slot));
} else
for (i = start; i < end; i++, slot = next_slot(slot))
add_slot_checked_with_id(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:
{
s7_int loc = -1, skip = start;
hash_entry_t **elements = hash_table_elements(source);
hash_entry_t *x = NULL;
while (skip > 0) {
while (!x)
x = elements[++loc];
skip--;
x = hash_entry_next(x);
}
if (is_pair(dest)) {
s7_pointer p;
for (i = start, p = dest; (i < end) && (is_pair(p));
i++, p = cdr(p)) {
while (!x)
x = elements[++loc];
set_car(p,
cons(sc, hash_entry_key(x),
hash_entry_value(x)));
x = hash_entry_next(x);
}
} else if (is_let(dest)) {
for (i = start; i < end; i++) {
s7_pointer symbol;
while (!x)
x = elements[++loc];
symbol = hash_entry_key(x);
if (!is_symbol(symbol))
return (simple_wrong_type_argument
(sc, caller, symbol, T_SYMBOL));
if (is_constant_symbol(sc, symbol))
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"~A into ~A: ~A is a constant",
28),
caller, dest,
symbol)));
if ((symbol != sc->let_ref_fallback_symbol)
&& (symbol != sc->let_set_fallback_symbol))
add_slot_checked_with_id(sc, dest, symbol,
hash_entry_value(x));
x = hash_entry_next(x);
}
} else
for (i = start, j = 0; i < end; i++, j++) {
while (!x)
x = elements[++loc];
set(sc, dest, j,
cons(sc, hash_entry_key(x), hash_entry_value(x)));
x = hash_entry_next(x);
}
return (dest);
}
case T_VECTOR:
{
s7_pointer *vals = vector_elements(source);
if (is_float_vector(dest)) {
s7_double *dst = float_vector_floats(dest);
for (i = start, j = 0; i < end; i++, j++)
dst[j] = real_to_double(sc, vals[i], "copy");
return (dest);
}
if (is_int_vector(dest)) {
s7_int *dst = int_vector_ints(dest);
for (i = start, j = 0; i < end; i++, j++) {
if (!s7_is_integer(vals[i]))
return (simple_wrong_type_argument
(sc, caller, vals[i], T_INTEGER));
dst[j] = s7_integer_checked(sc, vals[i]);
}
return (dest);
}
if (is_string(dest)) {
char *dst = string_value(dest);
for (i = start, j = 0; i < end; i++, j++) {
if (!is_character(vals[i]))
return (simple_wrong_type_argument
(sc, caller, vals[i], T_CHARACTER));
dst[j] = character(vals[i]);
}
return (dest);
}
if (is_byte_vector(dest)) {
uint8_t *dst = (uint8_t *) byte_vector_bytes(dest);
for (i = start, j = 0; i < end; i++, j++) {
s7_int byte;
if (!s7_is_integer(vals[i]))
return (simple_wrong_type_argument_with_type
(sc, caller, vals[i],
an_unsigned_byte_string));
byte = s7_integer_checked(sc, vals[i]);
if ((byte >= 0) && (byte < 256))
dst[j] = (uint8_t) byte;
else
return (simple_wrong_type_argument_with_type
(sc, caller, vals[i],
an_unsigned_byte_string));
}
return (dest);
}
}
break;
case T_FLOAT_VECTOR:
{
s7_double *src = float_vector_floats(source);
if (is_int_vector(dest)) {
s7_int *dst = int_vector_ints(dest);
for (i = start, j = 0; i < end; i++, j++)
dst[j] = (s7_int) (src[i]);
return (dest);
}
if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) {
s7_pointer *dst = vector_elements(dest);
for (i = start, j = 0; i < end; i++, j++) {
dst[j++] = make_real(sc, src[i++]);
if (i == end)
break;
dst[j] = make_real_unchecked(sc, src[i]);
}
return (dest);
}
}
break;
case T_INT_VECTOR:
{
s7_int *src = int_vector_ints(source);
if (is_float_vector(dest)) {
s7_double *dst = float_vector_floats(dest);
for (i = start, j = 0; i < end; i++, j++)
dst[j] = (s7_double) (src[i]);
return (dest);
}
if ((is_normal_vector(dest)) && (!is_typed_vector(dest)))
/* this could check that the typer is integer? (similarly elsewhere):
* (typed_vector_typer(dest) != global_value(sc->is_integer_symbol)) ?
*/
{
s7_pointer *dst = vector_elements(dest);
for (i = start, j = 0; i < end; i++, j++)
dst[j] = make_integer(sc, src[i]);
return (dest);
}
if (is_string(dest)) {
for (i = start, j = 0; i < end; i++, j++) {
if ((src[i] < 0) || (src[i] > 255))
return (out_of_range
(sc, caller, int_one,
wrap_integer1(sc, src[i]),
an_unsigned_byte_string));
string_value(dest)[j] = (uint8_t) (src[i]);
}
return (dest);
}
if (is_byte_vector(dest)) {
for (i = start, j = 0; i < end; i++, j++) {
if ((src[i] < 0) || (src[i] > 255))
return (out_of_range
(sc, caller, int_one,
wrap_integer1(sc, src[i]),
an_unsigned_byte_string));
byte_vector(dest, j) = (uint8_t) (src[i]);
}
return (dest);
}
}
break;
case T_BYTE_VECTOR:
if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) {
s7_pointer *dst = vector_elements(dest);
for (i = start, j = 0; i < end; i++, j++)
dst[j] =
make_integer(sc, (s7_int) (byte_vector(source, i)));
return (dest);
}
if (is_int_vector(dest)) {
s7_int *els = int_vector_ints(dest);
for (i = start, j = 0; i < end; i++, j++)
els[j] = (s7_int) ((uint8_t) (byte_vector(source, i)));
return (dest);
}
if (is_float_vector(dest)) {
s7_double *els = float_vector_floats(dest);
for (i = start, j = 0; i < end; i++, j++)
els[j] = (s7_double) ((uint8_t) (byte_vector(source, i)));
return (dest);
}
break;
case T_STRING:
if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) {
s7_pointer *dst = vector_elements(dest);
for (i = start, j = 0; i < end; i++, j++)
dst[j] = chars[(uint8_t) string_value(source)[i]];
return (dest);
}
if (is_int_vector(dest)) {
s7_int *els = int_vector_ints(dest);
for (i = start, j = 0; i < end; i++, j++)
els[j] = (s7_int) ((uint8_t) (string_value(source)[i]));
return (dest);
}
if (is_float_vector(dest)) {
s7_double *els = float_vector_floats(dest);
for (i = start, j = 0; i < end; i++, j++)
els[j] = (s7_double) ((uint8_t) (string_value(source)[i]));
return (dest);
}
break;
}
if (is_pair(dest)) {
s7_pointer p;
if (is_float_vector(source)) {
s7_double *els = float_vector_floats(source);
for (i = start, p = dest; (i < end) && (is_pair(p));
i++, p = cdr(p))
set_car(p, make_real(sc, els[i]));
} else if (is_int_vector(source)) {
s7_int *els = int_vector_ints(source);
for (i = start, p = dest; (i < end) && (is_pair(p));
i++, p = cdr(p))
set_car(p, make_integer(sc, els[i]));
} else
for (i = start, p = dest; (i < end) && (is_pair(p));
i++, p = cdr(p))
set_car(p, get(sc, source, i));
} else /* if source == dest here, we're moving data backwards, so this is safe in either case */
for (i = start, j = 0; i < end; i++, j++)
set(sc, dest, j, get(sc, source, i));
/* some choices probably should raise an error, but don't:
* (copy (make-hash-table) "1") ; nothing to copy (empty hash table), so no error
*/
return (dest);
}
s7_pointer s7_copy(s7_scheme * sc, s7_pointer args)
{
return (s7_copy_1(sc, sc->copy_symbol, args));
}
#define g_copy s7_copy
/* -------------------------------- reverse -------------------------------- */
s7_pointer s7_reverse(s7_scheme * sc, s7_pointer a)
{ /* just pairs */
/* reverse list -- produce new list (other code assumes this function does not return the original!) */
s7_pointer x, p;
if (is_null(a))
return (a);
if (!is_pair(cdr(a)))
return ((is_null(cdr(a))) ? list_1(sc, car(a)) : cons(sc, cdr(a), car(a))); /* don't return 'a' itself */
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_unchecked(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 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 = car(args), np = sc->nil;
sc->temp3 = p;
switch (type(p)) {
case T_NIL:
return (sc->nil);
case T_PAIR:
return (s7_reverse(sc, p));
case T_STRING:
{
char *dest, *end, *source = string_value(p);
s7_int len = string_length(p);
end = (char *) (source + len);
np = make_empty_string(sc, len, '\0');
dest = (char *) (string_value(np) + len);
while (source < end)
*(--dest) = *source++;
}
break;
case T_BYTE_VECTOR:
{
uint8_t *dest, *end, *source = byte_vector_bytes(p);
s7_int len = byte_vector_length(p);
end = (uint8_t *) (source + len);
np = make_simple_byte_vector(sc, len);
dest = (uint8_t *) (byte_vector_bytes(np) + len);
while (source < end)
*(--dest) = *source++;
}
break;
case T_INT_VECTOR:
{
s7_int *dest, *end, *source = int_vector_ints(p);
s7_int len = vector_length(p);
end = (s7_int *) (source + len);
if (vector_rank(p) > 1)
np = g_make_vector_1(sc,
set_plist_2(sc,
g_vector_dimensions(sc,
set_plist_1
(sc,
p)),
int_zero),
sc->make_int_vector_symbol);
else
np = make_simple_int_vector(sc, len);
dest = (s7_int *) (int_vector_ints(np) + len);
while (source < end)
*(--dest) = *source++;
}
break;
case T_FLOAT_VECTOR:
{
s7_double *dest, *end, *source = float_vector_floats(p);
s7_int len = vector_length(p);
end = (s7_double *) (source + len);
if (vector_rank(p) > 1)
np = g_make_vector_1(sc,
set_plist_2(sc,
g_vector_dimensions(sc,
set_plist_1
(sc,
p)),
real_zero),
sc->make_float_vector_symbol);
else
np = make_simple_float_vector(sc, len);
dest = (s7_double *) (float_vector_floats(np) + len);
while (source < end)
*(--dest) = *source++;
}
break;
case T_VECTOR:
{
s7_pointer *dest, *end, *source = vector_elements(p);
s7_int len = vector_length(p);
end = (s7_pointer *) (source + len);
if (vector_rank(p) > 1)
np = g_make_vector(sc,
set_plist_1(sc,
g_vector_dimensions(sc,
set_plist_1
(sc,
p))));
else
np = make_simple_vector(sc, 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(sc, p))
return ((*(c_object_reverse(sc, p))) (sc, args));
eval_error(sc, "attempt to reverse ~S?", 22, p);
case T_LET:
check_method(sc, p, sc->reverse_symbol, args);
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't reverse let: ~S", 21),
p)));
default:
return (method_or_bust_with_type_one_arg
(sc, p, sc->reverse_symbol, args, a_sequence_string));
}
return (np);
}
static s7_pointer any_list_reverse_in_place(s7_scheme * sc,
s7_pointer term,
s7_pointer list)
{
s7_pointer p, result;
if (is_null(list))
return (term);
p = list;
result = term;
while (true) {
s7_pointer q = cdr(p);
if (is_null(q)) {
set_cdr(p, result);
return (p);
}
if ((is_pair(q)) && (!is_immutable_pair(q))) {
set_cdr(p, result);
result = p;
p = q;
} else
return (sc->nil); /* improper or immutable */
}
return (result);
}
static s7_pointer g_reverse_in_place(s7_scheme * sc, s7_pointer args)
{
#define H_reverse_in_place "(reverse! lst) reverses lst in place"
#define Q_reverse_in_place Q_reverse
s7_pointer p = car(args);
switch (type(p)) {
case T_NIL:
return (sc->nil);
case T_PAIR:
{
s7_pointer np;
if (is_immutable_pair(p))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->reverseb_symbol, p)));
np = any_list_reverse_in_place(sc, sc->nil, p);
if (is_null(np))
return (s7_wrong_type_arg_error
(sc, "reverse!", 1, car(args),
"a mutable, proper list"));
return (np);
}
/* (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);}
* immutable check is needed else (reverse! (catch #t 1 cons)) clobbers sc->wrong_type_arg_info
*/
case T_BYTE_VECTOR:
case T_STRING:
{
s7_int len;
uint8_t *bytes;
if (is_immutable(p))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->reverseb_symbol, p)));
if (is_string(p)) {
len = string_length(p);
bytes = (uint8_t *) string_value(p);
} else {
len = byte_vector_length(p);
bytes = byte_vector_bytes(p);
}
if (len < 2)
return (p);
#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */
/* this code (from StackOverflow) is much faster: */
if ((len & 0x1f) == 0) {
#include <byteswap.h>
uint32_t *dst = (uint32_t *) (bytes + len - 4);
uint32_t *src = (uint32_t *) bytes;
while (src < dst) {
uint32_t a, b;
LOOP_4(a = *src;
b = *dst;
*src++ = bswap_32(b); *dst-- = bswap_32(a));
}
} else
#endif
{
char *s1 = (char *) bytes, *s2;
s2 = (char *) (s1 + len - 1);
while (s1 < s2) {
char c;
c = *s1;
*s1++ = *s2;
*s2-- = c;
}
}}
break;
case T_INT_VECTOR:
{
s7_int len = vector_length(p);
s7_int *s1, *s2;
if (is_immutable_vector(p))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->reverseb_symbol, p)));
if (len < 2)
return (p);
s1 = int_vector_ints(p);
s2 = (s7_int *) (s1 + len - 1);
if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center ints unreversed */
while (s1 < s2) {
s7_int c;
LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c);
} else
while (s1 < s2) {
s7_int c;
c = *s1;
*s1++ = *s2;
*s2-- = c;
}
}
break;
case T_FLOAT_VECTOR:
{
s7_int len = vector_length(p);
s7_double *s1, *s2;
if (is_immutable_vector(p))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->reverseb_symbol, p)));
if (len < 2)
return (p);
s1 = float_vector_floats(p);
s2 = (s7_double *) (s1 + len - 1);
if ((len & 0xf) == 0)
while (s1 < s2) {
s7_double c;
LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c);
} else
while (s1 < s2) {
s7_double c;
c = *s1;
*s1++ = *s2;
*s2-- = c;
}
}
break;
case T_VECTOR:
{
s7_int len = vector_length(p);
s7_pointer *s1, *s2;
if (is_immutable_vector(p))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->reverseb_symbol, p)));
if (len < 2)
return (p);
s1 = vector_elements(p);
s2 = (s7_pointer *) (s1 + len - 1);
if ((len & 0xf) == 0)
while (s1 < s2) {
s7_pointer c;
LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c);
} else
while (s1 < s2) {
s7_pointer c;
c = *s1;
*s1++ = *s2;
*s2-- = c;
}
}
break;
default:
if (is_immutable(p)) {
if (is_simple_sequence(p))
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string,
sc->reverseb_symbol, p)));
return (simple_wrong_type_argument_with_type
(sc, sc->reverseb_symbol, p, a_sequence_string));
}
if ((is_simple_sequence(p)) && (!has_active_methods(sc, p)))
return (simple_wrong_type_argument_with_type
(sc, sc->reverseb_symbol, p,
wrap_string(sc, "a vector, string, or list", 25)));
return (method_or_bust_with_type_one_arg_p
(sc, p, sc->reverseb_symbol, a_sequence_string));
}
return (p);
}
/* -------------------------------- fill! -------------------------------- */
static s7_pointer pair_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 = car(args), val, p;
s7_int i, start = 0, end, len;
#if WITH_HISTORY
if ((is_immutable_pair(obj)) && (obj != sc->eval_history1)
&& (obj != sc->eval_history2))
#else
if (is_immutable_pair(obj))
#endif
return (immutable_object_error
(sc,
set_elist_3(sc, immutable_error_string, sc->fill_symbol,
obj)));
if (obj == global_value(sc->features_symbol))
return (s7_error
(sc, sc->out_of_range_symbol,
set_elist_1(sc,
wrap_string(sc, "can't fill! *features*",
22))));
if (obj == global_value(sc->libraries_symbol))
return (s7_error
(sc, sc->out_of_range_symbol,
set_elist_1(sc,
wrap_string(sc, "can't fill! *libraries*",
23))));
val = cadr(args);
len = s7_list_length(sc, obj);
end = len;
if (end < 0)
end = -end;
else {
if (end == 0)
end = 123123123;
}
if (!is_null(cddr(args))) {
p = start_and_end(sc, sc->fill_symbol, args, 3, cddr(args), &start,
&end);
if (p != sc->unused)
return (p);
if (start == end)
return (val);
}
if (len > 0) {
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 = car(args);
switch (type(p)) {
case T_STRING:
return (g_string_fill_1(sc, sc->fill_symbol, args)); /* redundant type check here and below */
case T_BYTE_VECTOR:
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
return (g_vector_fill_1(sc, sc->fill_symbol, args));
case T_PAIR:
return (pair_fill(sc, args));
case T_NIL:
if (!is_null(cddr(args))) /* (fill! () 1 21 #\a)? */
eval_error(sc, "fill! () ... includes indices: ~S?", 34,
cddr(args));
return (cadr(args)); /* this parallels the empty vector case */
case T_HASH_TABLE:
return (hash_table_fill(sc, args));
case T_LET:
check_method(sc, p, sc->fill_symbol, args);
return (let_fill(sc, args));
case T_C_OBJECT:
check_method(sc, p, sc->fill_symbol, args);
if (c_object_fill(sc, p)) /* default is NULL (s7_make_c_type) */
return ((*(c_object_fill(sc, p))) (sc, args));
eval_error(sc, "attempt to fill ~S?", 19, 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
*/
/* -------------------------------- append -------------------------------- */
static s7_int sequence_length(s7_scheme * sc, s7_pointer lst)
{
switch (type(lst)) {
case T_PAIR:
{
s7_int len;
len = s7_list_length(sc, lst);
return ((len == 0) ? -1 : len);
}
case T_NIL:
return (0);
case T_BYTE_VECTOR:
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 = c_object_length(sc, lst);
if (s7_is_integer(x))
return (s7_integer_checked(sc, x));
}
}
return (-1);
}
static s7_int total_sequence_length(s7_scheme * sc, s7_pointer args,
s7_pointer caller, uint8_t typ)
{
s7_pointer p;
s7_int i, len = 0;
for (i = 1, p = args; is_pair(p); p = cdr(p), i++) {
s7_pointer seq = car(p);
s7_int n;
n = sequence_length(sc, seq);
if ((n > 0) && (typ != T_FREE) && ((type(seq) == T_HASH_TABLE) || /* can't append hash-tables (no obvious meaning to the operation) */
((type(seq) == T_LET) && /* similarly for lets, unless this is a mock-string or something similar */
((!has_active_methods(sc, seq))
||
(find_method(sc, seq, caller)
== sc->undefined))))) {
wrong_type_argument(sc, caller, i, seq, typ);
return (0);
}
if (n < 0) {
wrong_type_argument_with_type(sc, caller, i, seq,
(is_pair(seq)) ?
a_proper_list_string :
a_sequence_string);
return (0);
}
len += n;
}
return (len);
}
static s7_pointer vector_append(s7_scheme * sc, s7_pointer args,
uint8_t typ, s7_pointer caller)
{
s7_pointer new_vec, p, pargs;
s7_pointer *v_elements = NULL;
s7_double *fv_elements = NULL;
s7_int *iv_elements = NULL;
uint8_t *byte_elements = NULL;
s7_int i, len;
s7_gc_protect_via_stack(sc, args);
len =
total_sequence_length(sc, args, caller,
(typ ==
T_VECTOR) ? T_FREE : ((typ ==
T_FLOAT_VECTOR) ?
T_REAL : T_INTEGER));
if (len > sc->max_vector_length) {
unstack(sc);
return (s7_error(sc, sc->out_of_range_symbol,
set_elist_4(sc,
wrap_string(sc,
"~S new vector length, ~D, is larger than (*s7* 'max-vector-length): ~D",
70), caller,
wrap_integer1(sc, len),
wrap_integer2(sc,
sc->max_vector_length))));
}
new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? FILLED : NOT_FILLED, typ); /* might hit GC in loop below so we can't use NOT_FILLED here (??) */
add_vector(sc, new_vec);
if (len == 0) {
unstack(sc);
return (new_vec);
}
if (typ == T_VECTOR)
v_elements = vector_elements(new_vec);
else if (typ == T_FLOAT_VECTOR)
fv_elements = float_vector_floats(new_vec);
else if (typ == T_INT_VECTOR)
iv_elements = int_vector_ints(new_vec);
else
byte_elements = byte_vector_bytes(new_vec);
pargs = list_2(sc, sc->F, new_vec); /* car set below */
push_stack_no_let(sc, OP_GC_PROTECT, new_vec, pargs);
for (i = 0, p = args; is_pair(p); p = cdr(p)) { /* in-place copy by goofing with new_vec's elements pointer */
s7_int n;
s7_pointer x = car(p);
n = sequence_length(sc, x);
if (n > 0) {
vector_length(new_vec) = n;
set_car(pargs, x);
s7_copy_1(sc, caller, pargs); /* not set_plist_2 here! */
vector_length(new_vec) = 0; /* so GC doesn't march off the end */
i += n;
if (typ == T_VECTOR)
vector_elements(new_vec) = (s7_pointer *) (v_elements + i);
else if (typ == T_FLOAT_VECTOR)
float_vector_floats(new_vec) =
(s7_double *) (fv_elements + i);
else if (typ == T_INT_VECTOR)
int_vector_ints(new_vec) = (s7_int *) (iv_elements + i);
else
byte_vector_bytes(new_vec) =
(uint8_t *) (byte_elements + i);
}
}
unstack(sc);
/* free_cell(sc, pargs); *//* this is trouble if any arg is openlet with append method -- e.g. block */
if (typ == T_VECTOR)
vector_elements(new_vec) = v_elements;
else if (typ == T_FLOAT_VECTOR)
float_vector_floats(new_vec) = fv_elements;
else if (typ == T_INT_VECTOR)
int_vector_ints(new_vec) = iv_elements;
else
byte_vector_bytes(new_vec) = byte_elements;
vector_length(new_vec) = len;
unstack(sc);
return (new_vec);
}
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);
push_stack_no_let(sc, OP_GC_PROTECT, args, new_hash);
for (p = args; is_pair(p); p = cdr(p))
s7_copy_1(sc, sc->append_symbol,
set_plist_2(sc, car(p), new_hash));
set_plist_2(sc, sc->nil, sc->nil);
unstack(sc);
return (new_hash);
}
static s7_pointer let_append(s7_scheme * sc, s7_pointer args)
{
s7_pointer new_let, p, e = car(args);
check_method(sc, e, sc->append_symbol, args);
s7_gc_protect_via_stack(sc, args);
new_let = make_let_slowly(sc, sc->nil);
for (p = args; is_pair(p); p = cdr(p))
s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(p), new_let));
set_plist_2(sc, sc->nil, sc->nil);
unstack(sc);
return (new_let);
}
static s7_pointer g_append(s7_scheme * sc, s7_pointer args)
{
#define H_append "(append ...) returns its argument sequences appended into one sequence"
#define Q_append s7_make_circular_signature(sc, 0, 1, sc->T)
if (is_null(args))
return (sc->nil); /* (append) -> () */
if (is_null(cdr(args)))
return (car(args)); /* (append <anything>) -> <anything> */
sc->value = args;
args = copy_proper_list(sc, args); /* copied since other args might invoke methods */
sc->value = args;
switch (type(car(args))) {
case T_NIL:
case T_PAIR:
return (g_list_append(sc, args));
case T_STRING:
return (g_string_append_1(sc, args, sc->append_symbol));
case T_HASH_TABLE:
return (hash_table_append(sc, args));
case T_LET:
return (let_append(sc, args));
case T_VECTOR:
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_BYTE_VECTOR:
return (vector_append
(sc, args, type(car(args)), sc->append_symbol));
default:
check_method(sc, car(args), sc->append_symbol, args);
}
return (wrong_type_argument_with_type(sc, sc->append_symbol, 1, car(args), a_sequence_string)); /* (append 1 0) */
}
static s7_pointer append_p_ppp(s7_scheme * sc, s7_pointer p1,
s7_pointer p2, s7_pointer p3)
{
return (g_append(sc, set_plist_3(sc, p1, p2, p3)));
}
s7_pointer s7_append(s7_scheme * sc, s7_pointer a, s7_pointer b)
{
if (is_pair(a)) {
s7_pointer q, p, np, op;
if ((!is_pair(b)) && (!is_null(b)))
return (g_list_append(sc, list_2(sc, a, b)));
q = list_1(sc, car(a));
sc->y = q;
for (op = a, p = cdr(a), np = q; (is_pair(p)) && (p != op);
p = cdr(p), np = cdr(np), op = cdr(op)) {
set_cdr(np, list_1_unchecked(sc, car(p)));
p = cdr(p);
np = cdr(np);
if (!is_pair(p))
break;
set_cdr(np, list_1(sc, car(p)));
}
if (!is_null(p))
return (wrong_type_argument_with_type
(sc, sc->append_symbol, 1, a, a_proper_list_string));
set_cdr(np, b);
sc->y = sc->nil;
return (q);
}
if (is_null(a))
return (b);
return (g_append(sc, set_plist_2(sc, a, b)));
}
static s7_pointer g_append_2(s7_scheme * sc, s7_pointer args)
{
return (s7_append(sc, car(args), cadr(args)));
}
static s7_pointer append_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args == 2)
return (sc->append_2);
return (f);
}
/* -------------------------------- object->let -------------------------------- */
static s7_pointer byte_vector_to_list(s7_scheme * sc, const uint8_t * str,
s7_int len)
{
s7_int i;
s7_pointer p;
if (len == 0)
return (sc->nil);
check_free_heap_size(sc, len);
sc->w = sc->nil;
for (i = len - 1; i >= 0; i--)
sc->w = cons_unchecked(sc, small_int((uint32_t) (str[i])), sc->w);
p = sc->w;
sc->w = sc->nil;
return (p);
}
static s7_pointer hash_table_to_list(s7_scheme * sc, s7_pointer obj)
{
s7_pointer x, iterator;
if (hash_table_entries(obj) <= 0)
return (sc->nil);
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; /* free_cell(sc, iterator); *//* 16-Nov-18 but then 18-Dec-18 got free cell that was iterator */
return (x);
}
static s7_pointer iterator_to_list(s7_scheme * sc, s7_pointer obj)
{
s7_pointer result = sc->nil, p = NULL;
s7_int results = 0;
while (true) {
s7_pointer val;
val = s7_iterate(sc, obj);
if ((val == ITERATOR_END) && (iterator_is_at_end(obj))) {
sc->temp8 = sc->nil;
return (result);
}
if (sc->safety > NO_SAFETY) {
results++;
if (results > 10000) {
s7_warn(sc, 256,
"iterator is creating a very long list!\n");
results = S7_INT32_MIN;
}
}
if (val != sc->no_value) {
if (is_null(result)) {
if (is_multiple_value(val)) {
result = multiple_value(val);
clear_multiple_value(val);
for (p = result; is_pair(cdr(p)); p = cdr(p));
} else {
result = list_1(sc, val);
p = result;
}
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, list_1(sc, val));
p = cdr(p);
}
}
}
}
static s7_pointer c_obj_to_list(s7_scheme * sc, s7_pointer obj)
{ /* "c_object_to_list" is the ->list method mentioned below */
int64_t i, len;
s7_pointer x, z, zc, result;
s7_int gc_z;
if (c_object_to_list(sc, obj))
return ((*(c_object_to_list(sc, obj))) (sc, set_plist_1(sc, obj)));
x = c_object_length(sc, obj);
if (s7_is_integer(x))
len = s7_integer_checked(sc, 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_2_unchecked(sc, obj, zc = make_mutable_integer(sc, 0));
gc_z = gc_protect_1(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)) {
integer(zc) = i;
set_car(x, (*(c_object_ref(sc, obj))) (sc, 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);
}
static s7_pointer object_to_list(s7_scheme * sc, s7_pointer obj)
{
/* used only in format_to_port_1 and (map values ...) */
switch (type(obj)) {
case T_STRING:
return (string_to_list(sc, string_value(obj), string_length(obj)));
case T_BYTE_VECTOR:
return (byte_vector_to_list
(sc, byte_vector_bytes(obj), byte_vector_length(obj)));
case T_HASH_TABLE:
return (hash_table_to_list(sc, obj));
case T_ITERATOR:
return (iterator_to_list(sc, obj));
case T_C_OBJECT:
return (c_obj_to_list(sc, obj));
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
return (s7_vector_to_list(sc, obj));
case T_LET:
#if (!WITH_PURE_S7)
check_method(sc, obj, sc->let_to_list_symbol,
set_plist_1(sc, obj));
#endif
return (s7_let_to_list(sc, obj));
}
return (obj);
}
static s7_pointer symbol_to_let(s7_scheme * sc, s7_pointer obj)
{
s7_pointer let;
let = g_local_inlet(sc, 4, sc->value_symbol, obj,
sc->type_symbol,
(is_keyword(obj)) ? sc->is_keyword_symbol
: ((is_gensym(obj)) ? sc->is_gensym_symbol :
sc->is_symbol_symbol));
if (!is_keyword(obj)) {
s7_pointer val;
s7_int gc_loc;
gc_loc = gc_protect_1(sc, let);
if (!sc->current_value_symbol)
sc->current_value_symbol = make_symbol(sc, "current-value");
val = s7_symbol_value(sc, obj);
s7_varlet(sc, let, sc->current_value_symbol, val);
s7_varlet(sc, let, sc->setter_symbol,
g_setter(sc, set_plist_1(sc, obj)));
s7_varlet(sc, let, sc->mutable_symbol,
s7_make_boolean(sc, !is_immutable_symbol(obj)));
if (!is_undefined(val)) {
const char *doc;
doc = s7_documentation(sc, obj);
if (doc)
s7_varlet(sc, let, sc->local_documentation_symbol,
s7_make_string(sc, doc));
}
s7_gc_unprotect_at(sc, gc_loc);
}
return (let);
}
static s7_pointer random_state_to_let(s7_scheme * sc, s7_pointer obj)
{
#if WITH_GMP
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_random_state_symbol));
#else
if (!sc->seed_symbol) {
sc->seed_symbol = make_symbol(sc, "seed");
sc->carry_symbol = make_symbol(sc, "carry");
}
return (g_local_inlet(sc, 8, sc->value_symbol, obj,
sc->type_symbol, sc->is_random_state_symbol,
sc->seed_symbol, make_integer(sc,
random_seed(obj)),
sc->carry_symbol, make_integer(sc,
random_carry
(obj))));
#endif
}
static s7_pointer vector_to_let(s7_scheme * sc, s7_pointer obj)
{
s7_pointer let;
s7_int gc_loc;
if (!sc->dimensions_symbol)
sc->dimensions_symbol = make_symbol(sc, "dimensions");
if (!sc->original_vector_symbol)
sc->original_vector_symbol = make_symbol(sc, "original-vector");
let = g_local_inlet(sc, 10, sc->value_symbol, obj,
sc->type_symbol, (is_subvector(obj)) ? cons(sc,
sc->is_subvector_symbol,
s7_type_of
(sc,
subvector_vector
(obj)))
: s7_type_of(sc, obj), sc->size_symbol,
s7_length(sc, obj), sc->dimensions_symbol,
g_vector_dimensions(sc, set_plist_1(sc, obj)),
sc->mutable_symbol, s7_make_boolean(sc,
!is_immutable_vector
(obj)));
gc_loc = gc_protect_1(sc, let);
if (is_subvector(obj)) {
s7_int pos = 0;
switch (type(obj)) { /* correct type matters here: gcc 10.2 with -O2 segfaults otherwise, cast to intptr_t has a similar role in earlier gcc's */
case T_VECTOR:
pos = (s7_int) ((intptr_t)
(vector_elements(obj) -
vector_elements(subvector_vector(obj))));
break;
case T_INT_VECTOR:
pos = (s7_int) ((intptr_t)
(int_vector_ints(obj) -
int_vector_ints(subvector_vector(obj))));
break;
case T_FLOAT_VECTOR:
pos = (s7_int) ((intptr_t)
(float_vector_floats(obj) -
float_vector_floats(subvector_vector(obj))));
break;
case T_BYTE_VECTOR:
pos = (s7_int) ((intptr_t)
(byte_vector_bytes(obj) -
byte_vector_bytes(subvector_vector(obj))));
break;
}
s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos));
s7_varlet(sc, let, sc->original_vector_symbol,
subvector_vector(obj));
}
if (is_typed_vector(obj))
s7_varlet(sc, let, sc->signature_symbol,
g_signature(sc, set_plist_1(sc, obj)));
s7_gc_unprotect_at(sc, gc_loc);
return (let);
}
static s7_pointer hash_table_to_let(s7_scheme * sc, s7_pointer obj)
{
s7_pointer let;
s7_int gc_loc;
if (!sc->entries_symbol) {
sc->entries_symbol = make_symbol(sc, "entries");
sc->locked_symbol = make_symbol(sc, "locked");
sc->weak_symbol = make_symbol(sc, "weak");
}
let = g_local_inlet(sc, 12, sc->value_symbol, obj,
sc->type_symbol, sc->is_hash_table_symbol,
sc->size_symbol, s7_length(sc, obj),
sc->entries_symbol, make_integer(sc,
hash_table_entries
(obj)),
sc->locked_symbol, s7_make_boolean(sc,
hash_table_checker_locked
(obj)),
sc->mutable_symbol, s7_make_boolean(sc,
!is_immutable
(obj)));
gc_loc = gc_protect_1(sc, let);
if (is_weak_hash_table(obj))
s7_varlet(sc, let, sc->weak_symbol, sc->T);
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, sc->function_symbol, sc->is_eq_symbol);
else if (hash_table_checker(obj) == hash_eqv)
s7_varlet(sc, let, sc->function_symbol, sc->is_eqv_symbol);
else if ((hash_table_checker(obj) == hash_equal) ||
(hash_table_checker(obj) == hash_empty))
s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol);
else if (hash_table_checker(obj) == hash_equivalent)
s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol);
else if ((hash_table_checker(obj) == hash_number_num_eq) ||
(hash_table_checker(obj) == hash_int) ||
(hash_table_checker(obj) == hash_float))
s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol);
else if (hash_table_checker(obj) == hash_string)
s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol);
else if (hash_table_checker(obj) == hash_char)
s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol);
#if (!WITH_PURE_S7)
else if (hash_table_checker(obj) == hash_ci_char)
s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol);
else if (hash_table_checker(obj) == hash_ci_string)
s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol);
#endif
if (is_typed_hash_table(obj))
s7_varlet(sc, let, sc->signature_symbol,
g_signature(sc, set_plist_1(sc, obj)));
s7_gc_unprotect_at(sc, gc_loc);
return (let);
}
static s7_pointer iterator_to_let(s7_scheme * sc, s7_pointer obj)
{
s7_pointer let, seq;
s7_int gc_loc;
if (!sc->at_end_symbol) {
sc->at_end_symbol = make_symbol(sc, "at-end");
sc->sequence_symbol = make_symbol(sc, "sequence");
}
seq = iterator_sequence(obj);
let = g_local_inlet(sc, 8, sc->value_symbol, obj,
sc->type_symbol, sc->is_iterator_symbol,
sc->at_end_symbol, s7_make_boolean(sc,
iterator_is_at_end
(obj)),
sc->sequence_symbol, iterator_sequence(obj));
gc_loc = gc_protect_1(sc, let);
if (is_pair(seq))
s7_varlet(sc, let, sc->size_symbol, s7_length(sc, seq));
else if (is_hash_table(seq))
s7_varlet(sc, let, sc->size_symbol,
make_integer(sc, hash_table_entries(seq)));
else
s7_varlet(sc, let, sc->size_symbol, s7_length(sc, obj));
if ((is_string(seq)) ||
(is_any_vector(seq)) ||
(seq == sc->rootlet) || (is_c_object(seq)) || (is_hash_table(seq)))
s7_varlet(sc, let, sc->position_symbol,
make_integer(sc, iterator_position(obj)));
else if (is_pair(seq))
s7_varlet(sc, let, sc->position_symbol, iterator_current(obj));
s7_gc_unprotect_at(sc, gc_loc);
return (let);
}
static s7_pointer let_to_let(s7_scheme * sc, s7_pointer obj)
{
/* how to handle setters?
* (display (let ((e (let ((i 0)) (set! (setter 'i) integer?) (curlet)))) (object->let e))):
* "(inlet 'value (inlet 'i 0) 'type let? 'length 1 'open #f 'outlet () 'immutable? #f)"
*/
s7_pointer let;
s7_int gc_loc;
if (!sc->open_symbol) {
sc->open_symbol = make_symbol(sc, "open");
sc->alias_symbol = make_symbol(sc, "alias");
}
let = g_local_inlet(sc, 12, sc->value_symbol, obj,
sc->type_symbol, sc->is_let_symbol,
sc->size_symbol, s7_length(sc, obj),
sc->open_symbol, s7_make_boolean(sc,
has_methods(obj)),
sc->outlet_symbol,
(obj == sc->rootlet) ? sc->nil : let_outlet(obj),
sc->mutable_symbol, s7_make_boolean(sc,
!is_immutable
(obj)));
gc_loc = gc_protect_1(sc, let);
if (obj == sc->rootlet)
s7_varlet(sc, let, sc->alias_symbol, sc->rootlet_symbol);
else if (obj == sc->owlet) /* this can't happen, I think -- owlet is always copied first */
s7_varlet(sc, let, sc->alias_symbol, sc->owlet_symbol);
else if (is_funclet(obj)) {
s7_varlet(sc, let, sc->function_symbol, funclet_function(obj));
if ((has_let_file(obj)) &&
(let_file(obj) <= (s7_int) sc->file_names_top) &&
(let_line(obj) > 0) && (let_line(obj) < 1000000)) {
s7_varlet(sc, let, sc->file_symbol,
sc->file_names[let_file(obj)]);
s7_varlet(sc, let, sc->line_symbol,
make_integer(sc, let_line(obj)));
}
} else if (obj == sc->s7_let) {
s7_pointer iter;
s7_int gc_loc1;
iter = s7_make_iterator(sc, obj);
gc_loc1 = s7_gc_protect(sc, iter);
while (true) {
s7_pointer x;
x = s7_iterate(sc, iter);
if (iterator_is_at_end(iter))
break;
s7_varlet(sc, let, car(x), cdr(x));
}
s7_gc_unprotect_at(sc, gc_loc1);
}
if (has_active_methods(sc, obj)) {
s7_pointer func;
func = find_method(sc, obj, sc->object_to_let_symbol);
if (func != sc->undefined)
call_method(sc, obj, func, set_plist_2(sc, obj, let));
}
s7_gc_unprotect_at(sc, gc_loc);
return (let);
}
static s7_pointer c_object_to_let(s7_scheme * sc, s7_pointer obj)
{
s7_pointer let, clet;
s7_int gc_loc;
if (!sc->class_symbol) {
sc->class_symbol = make_symbol(sc, "class");
sc->c_object_length_symbol = make_symbol(sc, "c-object-length");
sc->c_object_ref_symbol = make_symbol(sc, "c-object-ref");
sc->c_object_let_symbol = make_symbol(sc, "c-object-let");
sc->c_object_set_symbol = make_symbol(sc, "c-object-set!");
sc->c_object_copy_symbol = make_symbol(sc, "c-object-copy");
sc->c_object_fill_symbol = make_symbol(sc, "c-object-fill!");
sc->c_object_reverse_symbol = make_symbol(sc, "c-object-reverse");
sc->c_object_to_list_symbol = make_symbol(sc, "c-object->list");
sc->c_object_to_string_symbol =
make_symbol(sc, "c-object->string");
}
clet = c_object_let(obj);
let = g_local_inlet(sc, 10, sc->value_symbol, obj,
sc->type_symbol, sc->is_c_object_symbol,
sc->c_object_type_symbol, make_integer(sc,
c_object_type
(obj)),
sc->c_object_let_symbol, clet, sc->class_symbol,
c_object_type_to_let(sc, obj));
gc_loc = gc_protect_1(sc, let);
/* not sure these are useful */
if (c_object_len(sc, obj)) /* c_object_length is the object length, not the procedure */
s7_varlet(sc, let, sc->c_object_length_symbol,
s7_lambda(sc, c_object_len(sc, obj), 1, 0, false));
if (c_object_ref(sc, obj))
s7_varlet(sc, let, sc->c_object_ref_symbol,
s7_lambda(sc, c_object_ref(sc, obj), 1, 0, true));
if (c_object_set(sc, obj))
s7_varlet(sc, let, sc->c_object_set_symbol,
s7_lambda(sc, c_object_set(sc, obj), 2, 0, true));
if (c_object_copy(sc, obj))
s7_varlet(sc, let, sc->c_object_copy_symbol,
s7_lambda(sc, c_object_copy(sc, obj), 1, 0, true));
if (c_object_fill(sc, obj))
s7_varlet(sc, let, sc->c_object_fill_symbol,
s7_lambda(sc, c_object_fill(sc, obj), 1, 0, true));
if (c_object_reverse(sc, obj))
s7_varlet(sc, let, sc->c_object_reverse_symbol,
s7_lambda(sc, c_object_reverse(sc, obj), 1, 0, true));
if (c_object_to_list(sc, obj))
s7_varlet(sc, let, sc->c_object_to_list_symbol,
s7_lambda(sc, c_object_to_list(sc, obj), 1, 0, true));
if (c_object_to_string(sc, obj))
s7_varlet(sc, let, sc->c_object_to_string_symbol,
s7_lambda(sc, c_object_to_string(sc, obj), 1, 1, false));
if ((is_let(clet)) &&
((has_active_methods(sc, clet)) || (has_active_methods(sc, obj))))
{
s7_pointer func;
func = find_method(sc, clet, sc->object_to_let_symbol);
if (func != sc->undefined)
call_method(sc, clet, func, set_plist_2(sc, obj, let));
}
s7_gc_unprotect_at(sc, gc_loc);
return (let);
}
static s7_pointer port_to_let(s7_scheme * sc, s7_pointer obj)
{ /* note the underbars! */
s7_pointer let;
s7_int gc_loc;
if (!sc->data_symbol) {
sc->data_symbol = make_symbol(sc, "data");
sc->port_type_symbol = make_symbol(sc, "port-type");
sc->closed_symbol = make_symbol(sc, "closed");
sc->file_info_symbol = make_symbol(sc, "file-info");
}
let = g_local_inlet(sc, 10, sc->value_symbol, obj,
/* obj as 'value means it will say "(closed)" when subsequently the let is displayed */
sc->type_symbol,
(is_input_port(obj)) ? sc->is_input_port_symbol :
sc->is_output_port_symbol, sc->port_type_symbol,
(is_string_port(obj)) ? sc->string_symbol
: ((is_file_port(obj)) ? sc->file_symbol :
sc->function_symbol), sc->closed_symbol,
s7_make_boolean(sc, port_is_closed(obj)),
sc->mutable_symbol, s7_make_boolean(sc,
!is_immutable_port
(obj)));
gc_loc = gc_protect_1(sc, let);
if (is_file_port(obj)) {
s7_varlet(sc, let, sc->file_symbol,
g_port_filename(sc, set_plist_1(sc, obj)));
if (is_input_port(obj))
s7_varlet(sc, let, sc->line_symbol,
g_port_line_number(sc, set_plist_1(sc, obj)));
#if (!MS_WINDOWS)
if ((!port_is_closed(obj)) && (obj != sc->standard_error)
&& (obj != sc->standard_input)
&& (obj != sc->standard_output)) {
struct stat sb;
s7_varlet(sc, let, sc->file_symbol,
make_integer(sc, fileno(port_file(obj))));
if (fstat(fileno(port_file(obj)), &sb) != -1) {
char c1[64], c2[64], str[512];
int bytes;
strftime(c1, 64, "%a %d-%b-%Y %H:%M",
localtime(&sb.st_atime));
strftime(c2, 64, "%a %d-%b-%Y %H:%M",
localtime(&sb.st_mtime));
bytes =
snprintf(str, 512,
"mode: #o%d, links: %ld, owner uid: %d gid: %d, size: %ld bytes, last file access: %s, last file modification: %s",
sb.st_mode, (long) sb.st_nlink,
(int) sb.st_uid, (int) sb.st_gid,
(long) sb.st_size, c1, c2);
s7_varlet(sc, let, sc->file_info_symbol,
make_string_with_length(sc, (const char *) str,
bytes));
}
}
#endif
}
if ((is_string_port(obj)) && /* file port might not have a data buffer */
(port_data(obj)) && (port_data_size(obj) > 0)) {
s7_varlet(sc, let, sc->size_symbol,
make_integer(sc, port_data_size(obj)));
s7_varlet(sc, let, sc->position_symbol,
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, sc->data_symbol,
make_string_with_length(sc,
(const char *) port_data(obj),
((port_position(obj)) >
16) ? 16 : port_position(obj)));
}
if (is_function_port(obj))
s7_varlet(sc, let, sc->function_symbol,
(is_input_port(obj)) ? port_input_scheme_function(obj) :
port_output_scheme_function(obj));
s7_gc_unprotect_at(sc, gc_loc);
return (let);
}
static s7_pointer closure_to_let(s7_scheme * sc, s7_pointer obj)
{
s7_pointer let, sig;
const char *doc;
s7_int gc_loc;
if (!sc->source_symbol)
sc->source_symbol = make_symbol(sc, "source");
let = g_local_inlet(sc, 8, sc->value_symbol, obj,
sc->type_symbol,
(is_t_procedure(obj)) ? sc->is_procedure_symbol :
sc->is_macro_symbol, sc->arity_symbol, s7_arity(sc,
obj),
sc->mutable_symbol, s7_make_boolean(sc,
!is_immutable
(obj)));
gc_loc = gc_protect_1(sc, let);
sig = s7_signature(sc, obj);
if (is_pair(sig))
s7_varlet(sc, let, sc->local_signature_symbol, sig);
doc = s7_documentation(sc, obj);
if (doc)
s7_varlet(sc, let, sc->local_documentation_symbol,
s7_make_string(sc, doc));
if (is_let(closure_let(obj))) {
s7_pointer flet;
flet = closure_let(obj);
if ((has_let_file(flet)) &&
(let_file(flet) <= (s7_int) sc->file_names_top) &&
(let_line(flet) > 0)) {
s7_varlet(sc, let, sc->file_symbol,
sc->file_names[let_file(flet)]);
s7_varlet(sc, let, sc->line_symbol,
make_integer(sc, let_line(flet)));
}
}
if (closure_setter(obj) != sc->F)
s7_varlet(sc, let, sc->local_setter_symbol, closure_setter(obj));
s7_varlet(sc, let, sc->source_symbol,
append_in_place(sc,
list_2(sc,
procedure_type_to_symbol(sc,
type(obj)),
closure_args(obj)),
closure_body(obj)));
s7_gc_unprotect_at(sc, gc_loc);
return (let);
}
static s7_pointer c_pointer_to_let(s7_scheme * sc, s7_pointer obj)
{
/* c_pointer_info can be a let and might have an object->let method (see c_object below) */
if (!sc->c_type_symbol) {
sc->c_type_symbol = make_symbol(sc, "c-type");
sc->info_symbol = make_symbol(sc, "info");
}
if (!sc->pointer_symbol)
sc->pointer_symbol = make_symbol(sc, "pointer");
return (g_local_inlet(sc, 10, sc->value_symbol, obj,
sc->type_symbol, sc->is_c_pointer_symbol,
sc->pointer_symbol, make_integer(sc,
(s7_int) ((intptr_t) c_pointer(obj))), sc->c_type_symbol, c_pointer_type(obj), sc->info_symbol, c_pointer_info(obj)));
}
static s7_pointer c_function_to_let(s7_scheme * sc, s7_pointer obj)
{
s7_pointer let, sig;
const char *doc;
s7_int gc_loc;
let = g_local_inlet(sc, 8, sc->value_symbol, obj,
sc->type_symbol,
(is_t_procedure(obj)) ? sc->is_procedure_symbol :
sc->is_macro_symbol, sc->arity_symbol, s7_arity(sc,
obj),
sc->mutable_symbol, s7_make_boolean(sc,
!is_immutable
(obj)));
gc_loc = gc_protect_1(sc, let);
sig = c_function_signature(obj);
if (is_pair(sig))
s7_varlet(sc, let, sc->local_signature_symbol, sig);
doc = s7_documentation(sc, obj);
if (doc)
s7_varlet(sc, let, sc->local_documentation_symbol,
s7_make_string(sc, doc));
if (c_function_setter(obj) != sc->F) /* c_macro_setter is the same underlying field */
s7_varlet(sc, let, sc->local_setter_symbol,
c_function_setter(obj));
s7_gc_unprotect_at(sc, gc_loc);
return (let);
}
static s7_pointer goto_to_let(s7_scheme * sc, s7_pointer obj)
{
/* there's room in s7_cell to store the procedure, but we would have to mark it (goto escapes, context GC'd) */
if (!sc->active_symbol) {
sc->active_symbol = make_symbol(sc, "active");
sc->goto_symbol = make_symbol(sc, "goto?");
}
if (is_symbol(call_exit_name(obj)))
return (g_local_inlet
(sc, 8, sc->value_symbol, obj, sc->type_symbol,
sc->goto_symbol, sc->active_symbol, s7_make_boolean(sc,
call_exit_active
(obj)),
sc->name_symbol, call_exit_name(obj)));
return (g_local_inlet
(sc, 6, sc->value_symbol, obj, sc->type_symbol,
sc->goto_symbol, sc->active_symbol, s7_make_boolean(sc,
call_exit_active
(obj))));
}
static s7_pointer object_to_let_p_p(s7_scheme * sc, s7_pointer obj)
{
switch (type(obj)) {
case T_NIL:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_null_symbol));
case T_UNSPECIFIED:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_unspecified_symbol));
case T_UNDEFINED:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_undefined_symbol));
case T_EOF:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_eof_object_symbol));
case T_BOOLEAN:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_boolean_symbol));
case T_CHARACTER:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_char_symbol));
case T_SYMBOL:
return (symbol_to_let(sc, obj));
case T_RANDOM_STATE:
return (random_state_to_let(sc, obj));
case T_GOTO:
return (goto_to_let(sc, obj));
case T_C_POINTER:
return (c_pointer_to_let(sc, obj));
case T_ITERATOR:
return (iterator_to_let(sc, obj));
case T_HASH_TABLE:
return (hash_table_to_let(sc, obj));
case T_LET:
return (let_to_let(sc, obj));
case T_C_OBJECT:
return (c_object_to_let(sc, obj));
case T_INTEGER:
case T_BIG_INTEGER:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_integer_symbol));
case T_RATIO:
case T_BIG_RATIO:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_rational_symbol));
case T_REAL:
case T_BIG_REAL:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_real_symbol));
case T_COMPLEX:
case T_BIG_COMPLEX:
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_complex_symbol));
case T_STRING:
return (g_local_inlet(sc, 8, sc->value_symbol, obj,
sc->type_symbol, sc->is_string_symbol,
sc->size_symbol, str_length(sc, obj),
sc->mutable_symbol, s7_make_boolean(sc,
!is_immutable_string
(obj))));
case T_PAIR:
return (g_local_inlet(sc, 6, sc->value_symbol, obj,
sc->type_symbol, sc->is_pair_symbol,
sc->size_symbol, pair_length(sc, obj)));
case T_SYNTAX:
return (g_local_inlet(sc, 6, sc->value_symbol, obj,
sc->type_symbol, sc->is_syntax_symbol,
sc->documentation_symbol, s7_make_string(sc,
syntax_documentation
(obj))));
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_BYTE_VECTOR:
case T_VECTOR:
return (vector_to_let(sc, obj));
case T_CONTINUATION: /* perhaps include the continuation-key */
if (is_symbol(continuation_name(obj)))
return (g_local_inlet
(sc, 6, sc->value_symbol, obj, sc->type_symbol,
sc->is_continuation_symbol, sc->name_symbol,
continuation_name(obj)));
return (g_local_inlet
(sc, 4, sc->value_symbol, obj, sc->type_symbol,
sc->is_continuation_symbol));
case T_INPUT_PORT:
case T_OUTPUT_PORT:
return (port_to_let(sc, obj));
case T_CLOSURE:
case T_CLOSURE_STAR:
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
return (closure_to_let(sc, obj));
case T_C_MACRO:
case T_C_FUNCTION_STAR:
case T_C_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
case T_C_OPT_ARGS_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
return (c_function_to_let(sc, obj));
default:
return (sc->F);
}
return (sc->F);
}
static s7_pointer g_object_to_let(s7_scheme * sc, s7_pointer args)
{
#define H_object_to_let "(object->let obj) returns a let (namespace) describing obj."
#define Q_object_to_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->T)
return (object_to_let_p_p(sc, car(args)));
}
/* ---------------- stacktrace ---------------- */
static s7_pointer stacktrace_find_caller(s7_scheme * sc, s7_pointer e)
{
if ((is_let(e)) && (e != sc->rootlet))
return (((is_funclet(e))
|| (is_maclet(e))) ? funclet_function(e) :
stacktrace_find_caller(sc, let_outlet(e)));
return (sc->F);
}
static bool stacktrace_find_let(s7_scheme * sc, int64_t loc, s7_pointer e)
{
return ((loc > 0) &&
((stack_let(sc->stack, loc) == e) ||
(stacktrace_find_let(sc, loc - 4, e))));
}
static int64_t stacktrace_find_error_hook_quit(s7_scheme * sc)
{
int64_t i;
for (i = current_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, int64_t loc)
{
return ((let_outlet(sc->owlet) == sc->curlet) ||
(stacktrace_find_let(sc, loc * 4, let_outlet(sc->owlet))) ||
(stacktrace_find_error_hook_quit(sc) > 0));
}
static bool stacktrace_error_hook_function(s7_scheme * sc, s7_pointer sym)
{
if (is_symbol(sym)) {
s7_pointer 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, s7_int code_cols,
s7_int total_cols, s7_int notes_start_col,
bool as_comment, int32_t depth)
{
if (is_symbol(code)) {
if ((!symbol_is_in_list(sc, code)) &&
(!is_slot(global_slot(code)))) {
s7_pointer val;
add_symbol_to_list(sc, code);
val = s7_symbol_local_value(sc, code, e);
if ((val) && (val != sc->undefined) && (!is_any_macro(val))) {
int32_t typ;
typ = type(val);
if (typ < T_CONTINUATION) {
char *objstr, *str;
s7_pointer objp;
const char *spaces;
s7_int new_note_len, notes_max, spaces_len;
bool new_notes_line = false, old_short_print =
sc->short_print;
s7_int old_len = sc->print_length, objlen;
spaces =
" ";
spaces_len = 80;
if (notes_start_col < 0)
notes_start_col = 50;
if (notes_start_col > total_cols)
notes_start_col = 0;
notes_max = total_cols - notes_start_col;
sc->short_print = true;
if (sc->print_length > 4)
sc->print_length = 4;
objp = s7_object_to_string(sc, val, true);
objstr = string_value(objp);
objlen = string_length(objp);
if ((objlen > notes_max) && (notes_max > 5)) {
objstr[notes_max - 4] = '.';
objstr[notes_max - 3] = '.';
objstr[notes_max - 2] = '.';
objstr[notes_max - 1] = '\0';
objlen = notes_max;
}
sc->short_print = old_short_print;
sc->print_length = old_len;
new_note_len = symbol_name_length(code) + 3 + objlen;
/* we want to append this much info to the notes, but does it need a new line? */
if (notes_start_col < code_cols)
new_notes_line = true;
else if (notes) {
char *last_newline;
s7_int cur_line_len;
last_newline = strrchr(notes, (int) '\n'); /* returns ptr to end if none = nil if not found? */
cur_line_len =
(last_newline) ? (strlen(notes) -
strlen(last_newline)) :
strlen(notes);
new_notes_line =
((cur_line_len + new_note_len) > notes_max);
}
if (new_notes_line) {
new_note_len +=
(4 + notes_start_col +
((notes) ? strlen(notes) : 0));
str = (char *) Malloc(new_note_len); /* str[0] = '\0'; */
catstrs_direct(str,
(notes) ? notes : "",
"\n",
(as_comment) ? "; " : "",
(spaces_len >=
notes_start_col) ? (char *) (spaces
+
spaces_len
-
notes_start_col)
: "", (as_comment) ? "" : " ; ",
symbol_name(code), ": ", objstr,
(const char *) NULL);
} else {
new_note_len += ((notes) ? strlen(notes) : 0) + 4;
str = (char *) Malloc(new_note_len); /* str[0] = '\0'; */
catstrs_direct(str,
(notes) ? notes : "",
(notes) ? ", " : " ; ",
symbol_name(code),
": ", objstr, (const char *) NULL);
}
if (notes)
free(notes);
return (str);
}
}
}
return (notes);
}
if ((is_pair(code)) && (s7_list_length(sc, code) > 0) && (depth < 32)) {
notes =
stacktrace_walker(sc, car(code), e, notes, code_cols,
total_cols, notes_start_col, as_comment,
depth + 1);
return (stacktrace_walker
(sc, cdr(code), e, notes, code_cols, total_cols,
notes_start_col, as_comment, depth + 2));
}
return (notes);
}
static block_t *stacktrace_add_func(s7_scheme * sc, s7_pointer f,
s7_pointer code, char *errstr,
char *notes, s7_int code_max,
bool as_comment)
{
s7_int newlen, errlen;
char *newstr, *str;
block_t *newp, *b;
errlen = strlen(errstr);
if ((is_symbol(f)) && (f != car(code))) {
newlen = symbol_name_length(f) + errlen + 10;
newp = mallocate(sc, newlen);
newstr = (char *) block_data(newp);
/* newstr[0] = '\0'; */
errlen =
catstrs_direct(newstr, symbol_name(f), ": ", errstr,
(const char *) NULL);
} else {
newlen = errlen + 8;
newp = mallocate(sc, newlen);
newstr = (char *) block_data(newp);
/* newstr[0] = '\0'; */
if ((errlen > 2) && (errstr[2] == '('))
errlen =
catstrs_direct(newstr, " ", errstr, (const char *) NULL);
else {
memcpy((void *) newstr, (void *) errstr, errlen);
newstr[errlen] = '\0';
}}
newlen = code_max + 8 + ((notes) ? strlen(notes) : 0);
b = mallocate(sc, newlen);
str = (char *) block_data(b);
/* str[0] = '\0'; */
if (errlen >= code_max) {
newstr[code_max - 4] = '.';
newstr[code_max - 3] = '.';
newstr[code_max - 2] = '.';
newstr[code_max - 1] = '\0';
catstrs_direct(str, (as_comment) ? "; " : "", newstr,
(notes) ? notes : "", "\n", (const char *) NULL);
} else {
/* send out newstr, pad with spaces to code_max, then notes */
s7_int len;
len =
catstrs_direct(str, (as_comment) ? "; " : "", newstr,
(const char *) NULL);
if (notes) {
s7_int i;
for (i = len; i < code_max - 1; i++)
str[i] = ' ';
str[i] = '\0';
catstrs(str, newlen, notes, "\n", (char *) NULL);
} else
catstrs(str, newlen, "\n", (char *) NULL);
}
liberate(sc, newp);
return (b);
}
static s7_pointer stacktrace_1(s7_scheme * sc, s7_int frames_max,
s7_int code_cols, s7_int total_cols,
s7_int notes_start_col, bool as_comment)
{
char *str = NULL;
block_t *strp = NULL;
int64_t loc, top, frames = 0;
clear_symbol_list(sc);
top = (sc->stack_end - sc->stack_start) / 4; /* (*s7* 'stack_top), not current_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)) && (!tree_is_cyclic(sc, err_code))) {
char *notes = NULL;
s7_pointer current_let, f, errstr;
errstr = s7_object_to_string(sc, err_code, false);
current_let = let_outlet(sc->owlet);
f = stacktrace_find_caller(sc, current_let); /* this is a symbol */
if ((is_let(current_let)) && (current_let != sc->rootlet))
notes =
stacktrace_walker(sc, err_code, current_let, NULL,
code_cols, total_cols,
notes_start_col, as_comment, 0);
strp =
stacktrace_add_func(sc, f, err_code, string_value(errstr),
notes, code_cols, as_comment);
str = (char *) block_data(strp);
}
/* 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;
s7_int true_loc = (loc + 1) * 4 - 1;
code = stack_code(sc->stack, true_loc);
if ((is_pair(code)) && (!tree_is_cyclic(sc, code))) {
s7_pointer codep;
codep = s7_object_to_string(sc, code, false);
if (string_length(codep) > 0) {
char *codestr = string_value(codep);
if ((!local_strcmp(codestr, "(result)")) &&
(!local_strcmp(codestr, "(#f)")) &&
(!strstr(codestr, "(stacktrace)")) &&
(!strstr(codestr, "(stacktrace "))) {
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, *catstr;
block_t *newp, *catp;
s7_int newlen;
frames++;
if (frames > frames_max)
return (block_to_string
(sc, strp, safe_strlen((char *)
block_data
(strp))));
if ((is_let(e)) && (e != sc->rootlet))
notes =
stacktrace_walker(sc, code, e, NULL,
code_cols, total_cols,
notes_start_col,
as_comment, 0);
newp =
stacktrace_add_func(sc, f, code, codestr,
notes, code_cols,
as_comment);
newstr = (char *) block_data(newp);
if ((notes) && (notes != newstr) && (is_let(e))
&& (e != sc->rootlet))
free(notes);
newlen =
strlen(newstr) + 1 + ((str) ? strlen(str) : 0);
catp = mallocate(sc, newlen);
catstr = (char *) block_data(catp);
catstrs_direct(catstr, (str) ? str : "", newstr,
(const char *) NULL);
liberate(sc, newp);
if (strp)
liberate(sc, strp);
strp = catp;
str = (char *) block_data(strp);
}
}
}
}
}
return ((strp) ?
block_to_string(sc, strp,
safe_strlen((char *) block_data(strp))) :
nil_string);
}
s7_pointer s7_stacktrace(s7_scheme * sc)
{
return (stacktrace_1(sc, 30, 45, 80, 45, false));
}
static s7_pointer g_stacktrace(s7_scheme * sc, s7_pointer args)
{
#define H_stacktrace "(stacktrace (max-frames 30) (code-cols 50) (total-cols 80) (note-col 50) as-comment) returns \
a stacktrace as a string. Each line has two portions, the code being evaluated and a note giving \
the value of local variables in that code. The first argument sets how many lines are displayed. \
The next three arguments set the length and layout of those lines. 'as-comment' if #t causes each \
line to be preceded by a semicolon."
#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;
if (!is_null(args)) {
if (!s7_is_integer(car(args)))
return (method_or_bust
(sc, car(args), sc->stacktrace_symbol, args, T_INTEGER,
1));
max_frames = s7_integer_checked(sc, 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)))
return (wrong_type_argument
(sc, sc->stacktrace_symbol, 2, car(args),
T_INTEGER));
code_cols = s7_integer_checked(sc, car(args));
if ((code_cols <= 8) || (code_cols > 1024))
code_cols = 50;
args = cdr(args);
if (!is_null(args)) {
if (!s7_is_integer(car(args)))
return (wrong_type_argument
(sc, sc->stacktrace_symbol, 3, car(args),
T_INTEGER));
total_cols = s7_integer_checked(sc, 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)))
return (wrong_type_argument
(sc, sc->stacktrace_symbol, 4, car(args),
T_INTEGER));
notes_start_col = s7_integer_checked(sc, 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)))
return (wrong_type_argument
(sc, sc->stacktrace_symbol, 5,
car(args), T_BOOLEAN));
as_comment = s7_boolean(sc, car(args));
}
}
}
}
}
return (stacktrace_1
(sc, max_frames, code_cols, total_cols, notes_start_col,
as_comment));
}
/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */
s7_pointer s7_add_to_history(s7_scheme * sc, s7_pointer entry)
{
#if WITH_HISTORY
set_current_code(sc, entry);
#endif
return (entry);
}
s7_pointer s7_history(s7_scheme * sc)
{
#if WITH_HISTORY
if (sc->cur_code == sc->history_sink)
return (sc->old_cur_code);
#endif
return (sc->cur_code);
}
bool s7_history_enabled(s7_scheme * sc)
{
#if WITH_HISTORY
return (sc->cur_code != sc->history_sink);
#else
return (false);
#endif
}
bool s7_set_history_enabled(s7_scheme * sc, bool enabled)
{
#if WITH_HISTORY
bool old_enabled;
old_enabled = (sc->cur_code == sc->history_sink);
if (enabled) /* this needs to restore the old cur_code (saving its position in the history_buffer) */
sc->cur_code = sc->old_cur_code;
else if (sc->cur_code != sc->history_sink) {
sc->old_cur_code = sc->cur_code;
sc->cur_code = sc->history_sink;
}
return (old_enabled);
#else
return (false);
#endif
}
#if WITH_HISTORY
static s7_pointer history_cons(s7_scheme * sc, s7_pointer code,
s7_pointer args)
{
s7_pointer p = car(sc->history_pairs);
sc->history_pairs = cdr(sc->history_pairs);
set_car(p, code);
set_cdr(p, args);
return (p);
}
#else
#define history_cons(Sc, Code, Args) Code
#endif
/* -------- error handlers -------- */
static const char *make_type_name(s7_scheme * sc, const char *name,
article_t article)
{
s7_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);
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(int32_t typ, article_t article)
{
switch (typ) {
case T_FREE:
return ((article == NO_ARTICLE) ? "free-cell" : "a free cell");
case T_NIL:
return ("nil");
case T_UNUSED:
return ((article ==
NO_ARTICLE) ? "#<unused>" : "the unused object");
case T_EOF:
return ((article ==
NO_ARTICLE) ? "#<eof>" : "the end-of-file object");
case T_UNSPECIFIED:
return ((article ==
NO_ARTICLE) ? "#<unspecified>" :
"the unspecified object");
case T_UNDEFINED:
return ((article ==
NO_ARTICLE) ? "undefined" : "an undefined object");
case T_BOOLEAN:
return ("boolean");
case T_STRING:
return ((article == NO_ARTICLE) ? "string" : "a string");
case T_BYTE_VECTOR:
return ((article == NO_ARTICLE) ? "byte-vector" : "a byte-vector");
case T_SYMBOL:
return ((article == NO_ARTICLE) ? "symbol" : "a symbol");
case T_SYNTAX:
return ((article == NO_ARTICLE) ? "syntax" : "syntactic");
case T_PAIR:
return ((article == NO_ARTICLE) ? "pair" : "a pair");
case T_GOTO:
return ((article ==
NO_ARTICLE) ? "goto" : "a goto (from call-with-exit)");
case T_CONTINUATION:
return ((article ==
NO_ARTICLE) ? "continuation" : "a continuation");
case T_C_OPT_ARGS_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
case T_C_FUNCTION:
return ((article == NO_ARTICLE) ? "c-function" : "a c-function");
case T_C_FUNCTION_STAR:
return ((article == NO_ARTICLE) ? "c-function*" : "a c-function*");
case T_CLOSURE:
return ((article == NO_ARTICLE) ? "function" : "a function");
case T_CLOSURE_STAR:
return ((article == NO_ARTICLE) ? "function*" : "a function*");
case T_C_MACRO:
return ((article == NO_ARTICLE) ? "c-macro" : "a c-macro");
case T_C_POINTER:
return ((article == NO_ARTICLE) ? "c-pointer" : "a c-pointer");
case T_CHARACTER:
return ((article == NO_ARTICLE) ? "character" : "a character");
case T_VECTOR:
return ((article == NO_ARTICLE) ? "vector" : "a vector");
case T_INT_VECTOR:
return ((article == NO_ARTICLE) ? "int-vector" : "an int-vector");
case T_FLOAT_VECTOR:
return ((article ==
NO_ARTICLE) ? "float-vector" : "a float-vector");
case T_MACRO_STAR:
return ((article == NO_ARTICLE) ? "macro*" : "a macro*");
case T_MACRO:
return ((article == NO_ARTICLE) ? "macro" : "a macro");
case T_BACRO_STAR:
return ((article == NO_ARTICLE) ? "bacro*" : "a bacro*");
case T_BACRO:
return ((article == NO_ARTICLE) ? "bacro" : "a bacro");
case T_CATCH:
return ((article == NO_ARTICLE) ? "catch" : "a catch");
case T_STACK:
return ((article == NO_ARTICLE) ? "stack" : "a stack");
case T_DYNAMIC_WIND:
return ((article ==
NO_ARTICLE) ? "dynamic-wind" : "a dynamic-wind");
case T_HASH_TABLE:
return ((article == NO_ARTICLE) ? "hash-table" : "a hash-table");
case T_ITERATOR:
return ((article == NO_ARTICLE) ? "iterator" : "an iterator");
case T_LET:
return ((article == NO_ARTICLE) ? "let" : "a let");
case T_COUNTER:
return ((article ==
NO_ARTICLE) ? "internal-counter" : "an internal counter");
case T_RANDOM_STATE:
return ((article ==
NO_ARTICLE) ? "random-state" : "a random-state");
case T_SLOT:
return ((article ==
NO_ARTICLE) ? "slot" : "a slot (variable binding)");
case T_INTEGER:
return ((article == NO_ARTICLE) ? "integer" : "an integer");
case T_RATIO:
return ((article == NO_ARTICLE) ? "ratio" : "a ratio");
case T_REAL:
return ((article == NO_ARTICLE) ? "real" : "a real");
case T_COMPLEX:
return ((article ==
NO_ARTICLE) ? "complex-number" : "a complex number");
case T_BIG_INTEGER:
return ((article == NO_ARTICLE) ? "big-integer" : "a big integer");
case T_BIG_RATIO:
return ((article == NO_ARTICLE) ? "big-ratio" : "a big ratio");
case T_BIG_REAL:
return ((article == NO_ARTICLE) ? "big-real" : "a big real");
case T_BIG_COMPLEX:
return ((article ==
NO_ARTICLE) ? "big-complex-number" :
"a big complex number");
case T_INPUT_PORT:
return ((article == NO_ARTICLE) ? "input-port" : "an input port");
case T_OUTPUT_PORT:
return ((article ==
NO_ARTICLE) ? "output-port" : "an output port");
case T_C_OBJECT:
return ((article == NO_ARTICLE) ? "c-object" : "a c_object");
}
return (NULL);
}
static const char *type_name(s7_scheme * sc, s7_pointer arg,
article_t article)
{
switch (unchecked_type(arg)) {
case T_C_OBJECT:
return (make_type_name
(sc, string_value(c_object_scheme_name(sc, arg)),
article));
case T_INPUT_PORT:
return (make_type_name
(sc,
(is_file_port(arg)) ? "input file port"
: ((is_string_port(arg)) ? "input string port" :
"input port"), article));
case T_OUTPUT_PORT:
return (make_type_name
(sc,
(is_file_port(arg)) ? "output file port"
: ((is_string_port(arg)) ? "output string port" :
"output port"), article));
case T_LET:
if (has_active_methods(sc, arg)) {
s7_pointer class_name;
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(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;
uint8_t typ;
if (has_active_methods(sc, x)) {
p = find_method_with_let(sc, x, sc->class_name_symbol);
if (is_symbol(p))
return (symbol_name_cell(p));
}
typ = type(x);
switch (typ) {
case T_C_OBJECT:
return (c_object_scheme_name(sc, 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));
default:
p = sc->prepackaged_type_names[type(x)];
if (is_string(p))
return (p);
}
return (wrap_string(sc, "unknown type!", 13));
}
static s7_pointer type_name_string(s7_scheme * sc, s7_pointer arg)
{
if (type(arg) < NUM_TYPES) {
s7_pointer p;
p = sc->prepackaged_type_names[type(arg)]; /* these use INDEFINITE_ARTICLE */
if (is_string(p))
return (p);
}
return (s7_make_string_wrapper
(sc, type_name(sc, arg, INDEFINITE_ARTICLE)));
}
static 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 = 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->unused) ? 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(cdr(sc->simple_wrong_type_arg_info), caller, arg,
(typnam == sc->unused) ? 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,
s7_int arg_n, s7_pointer arg,
const char *descr)
{
if (arg_n > 0)
return (wrong_type_arg_error_prepackaged
(sc, wrap_string(sc, caller, safe_strlen(caller)),
wrap_integer1(sc, arg_n), arg, type_name_string(sc, arg),
wrap_string(sc, descr, safe_strlen(descr))));
return (simple_wrong_type_arg_error_prepackaged
(sc, wrap_string(sc, caller, safe_strlen(caller)), arg,
type_name_string(sc, arg), wrap_string(sc, descr,
safe_strlen(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)
{
set_wlist_4(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(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,
s7_int arg_n, s7_pointer arg,
const char *descr)
{
if (arg_n > 0)
return (out_of_range_error_prepackaged
(sc, wrap_string(sc, caller, safe_strlen(caller)),
wrap_integer1(sc, arg_n), arg, wrap_string(sc, descr,
safe_strlen
(descr))));
return (simple_out_of_range_error_prepackaged
(sc, wrap_string(sc, caller, safe_strlen(caller)), arg,
wrap_string(sc, descr, safe_strlen(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, s7_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,
wrap_string(sc, "~A: division by zero, ~S", 24),
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, wrap_string(sc, "~A: ~A ~S", 9),
s7_make_string_wrapper(sc, caller),
s7_make_string_wrapper(sc, descr),
s7_make_string_wrapper(sc, name))));
}
/* -------------------------------- profile -------------------------------- */
static void swap_stack(s7_scheme * sc, opcode_t new_op,
s7_pointer new_code, s7_pointer new_args)
{
s7_pointer code, args, e;
opcode_t op;
sc->stack_end -= 4;
code = sc->stack_end[0];
e = sc->stack_end[1];
args = sc->stack_end[2];
op = (opcode_t) (sc->stack_end[3]); /* this should be begin1 */
if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK)
&& (op != OP_BEGIN_HOOK))
fprintf(stderr, "swap %s\n", op_names[op]);
push_stack(sc, new_op, new_args, new_code);
sc->stack_end[0] = code;
sc->stack_end[1] = e;
sc->stack_end[2] = args;
sc->stack_end[3] = (s7_pointer) op;
sc->stack_end += 4;
}
static s7_pointer find_funclet(s7_scheme * sc, s7_pointer e)
{
if ((e == sc->rootlet) || (!is_let(e)))
return (sc->F);
if (!((is_funclet(e)) || (is_maclet(e))))
e = let_outlet(e);
if ((e == sc->rootlet) || (!is_let(e)))
return (sc->F);
return (((is_funclet(e)) || (is_maclet(e))) ? e : sc->F);
}
#define PD_INITIAL_SIZE 16
enum { PD_CALLS =
0, PD_RECUR, PD_START, PD_ITOTAL, PD_ETOTAL, PD_BLOCK_SIZE
};
static s7_pointer g_profile_out(s7_scheme * sc, s7_pointer args)
{
s7_int pos;
s7_int *v;
profile_data_t *pd = sc->profile_data;
pos = symbol_position(car(args));
v = (s7_int *) (pd->data + pos);
v[PD_RECUR]--;
if (v[PD_RECUR] == 0) {
s7_int cur_time;
cur_time = (my_clock() - v[PD_START]);
v[PD_ITOTAL] += cur_time;
v[PD_ETOTAL] += (cur_time - pd->excl[pd->excl_top]);
pd->excl_top--;
pd->excl[pd->excl_top] += cur_time;
}
return (sc->F);
}
static s7_pointer g_profile_in(s7_scheme * sc, s7_pointer args)
{ /* only external func -- added to each profiled func by add_profile above */
#define H_profile_in "(profile-in e) is the profiler's hook into closures"
#define Q_profile_in s7_make_signature(sc, 2, sc->T, sc->is_let_symbol)
s7_pointer e;
if (sc->profile == 0)
return (sc->F);
e = find_funclet(sc, car(args));
if ((is_let(e)) && (is_symbol(funclet_function(e)))) {
s7_pointer func_name;
s7_int pos;
s7_int *v;
profile_data_t *pd = sc->profile_data;
func_name = funclet_function(e);
pos = symbol_position(func_name);
if (pos == PD_POSITION_UNSET) {
if (pd->top == pd->size) {
s7_int i;
pd->size *= 2;
pd->funcs =
(s7_pointer *) Realloc(pd->funcs,
pd->size * sizeof(s7_pointer));
pd->data =
(s7_int *) Realloc(pd->data,
pd->size * PD_BLOCK_SIZE *
sizeof(s7_int));
for (i = pd->top * PD_BLOCK_SIZE;
i < pd->size * PD_BLOCK_SIZE; i++)
pd->data[i] = 0;
}
pos = pd->top * PD_BLOCK_SIZE;
symbol_set_position(func_name, pos);
pd->funcs[pd->top] = func_name;
pd->top++;
if (is_gensym(func_name))
sc->profiling_gensyms = true;
}
v = (s7_int *) (sc->profile_data->data + pos);
v[PD_CALLS]++;
if (v[PD_RECUR] == 0) {
v[PD_START] = my_clock();
pd->excl_top++;
if (pd->excl_top == pd->excl_size) {
pd->excl_size *= 2;
pd->excl =
(s7_int *) Realloc(pd->excl,
pd->excl_size * sizeof(s7_int));
}
pd->excl[pd->excl_top] = 0;
}
v[PD_RECUR]++;
/* this doesn't work in "continuation passing" code (e.g. cpstak.scm in the so-called standard benchmarks).
* swap_stack pushes dynamic_unwind, but we don't pop back to it, so the stack grows to the recursion depth.
*/
if (sc->stack_end >= sc->stack_resize_trigger) {
#define PROFILE_MAX_STACK_SIZE 10000000 /* around 5G counting lets/arglists/slots, maybe an *s7* field for this? */
if (sc->stack_size > PROFILE_MAX_STACK_SIZE)
s7_error(sc, make_symbol(sc, "stack-too-big"),
set_elist_2(sc,
wrap_string(sc,
"profiling stack size has grown past ~D",
38), make_integer(sc,
PROFILE_MAX_STACK_SIZE)));
/* rather than raise an error, we could unwind the stack here, popping off all unwind entries, but this is
* a very rare problem, and the results will be confusing anyway.
*/
resize_stack(sc);
}
swap_stack(sc, OP_DYNAMIC_UNWIND_PROFILE, sc->profile_out,
func_name);
}
return (sc->F);
}
static s7_pointer profile_info_out(s7_scheme * sc)
{
s7_pointer p, vs, vi;
profile_data_t *pd = sc->profile_data;
if ((!pd) || (pd->top == 0))
return (sc->F);
p = list_3(sc, sc->F, sc->F, make_integer(sc, ticks_per_second()));
sc->w = p;
set_car(p, vs = make_simple_vector(sc, pd->top));
memcpy((void *) (vector_elements(vs)), (void *) (pd->funcs),
pd->top * sizeof(s7_pointer));
set_car(cdr(p), vi =
make_simple_int_vector(sc, pd->top * PD_BLOCK_SIZE));
memcpy((void *) int_vector_ints(vi), (void *) pd->data,
pd->top * PD_BLOCK_SIZE * sizeof(s7_int));
sc->w = sc->nil;
return (p);
}
static s7_pointer clear_profile_info(s7_scheme * sc)
{
if (sc->profile_data) {
profile_data_t *pd = sc->profile_data;
int32_t i;
for (i = 0; i < pd->top; i++)
symbol_set_position(pd->funcs[i], PD_POSITION_UNSET);
memclr64(pd->data, pd->top * PD_BLOCK_SIZE * sizeof(s7_int)); /* memclr64 ok because init_size is 16 and we double when resizing */
pd->top = 0;
for (i = 0; i < pd->excl_top; i++)
pd->excl[i] = 0;
pd->excl_top = 0;
sc->profiling_gensyms = false;
}
return (sc->F);
}
static s7_pointer make_profile_info(s7_scheme * sc)
{
if (!sc->profile_data) {
profile_data_t *pd;
pd = (profile_data_t *) Malloc(sizeof(profile_data_t));
pd->size = PD_INITIAL_SIZE;
pd->excl_size = PD_INITIAL_SIZE;
pd->top = 0;
pd->excl_top = 0;
pd->funcs = (s7_pointer *) Calloc(pd->size, sizeof(s7_pointer));
pd->excl = (s7_int *) Calloc(pd->excl_size, sizeof(s7_int));
pd->data =
(s7_int *) Calloc(pd->size * PD_BLOCK_SIZE, sizeof(s7_int));
sc->profile_data = pd;
}
return (sc->F);
}
/* -------------------------------- dynamic-unwind -------------------------------- */
static s7_pointer dynamic_unwind(s7_scheme * sc, s7_pointer func,
s7_pointer e)
{
if ((S7_DEBUGGING) && (is_multiple_value(sc->value)))
fprintf(stderr, "%s[%d]: unexpected multiple-value! %s %s %s\n",
__func__, __LINE__, display(func), display(e),
display(sc->value));
return (s7_apply_function(sc, func, set_plist_2(sc, e, sc->value))); /* s7_apply_function returns sc->value */
}
static s7_pointer g_dynamic_unwind(s7_scheme * sc, s7_pointer args)
{
#define H_dynamic_unwind "(dynamic-unwind func arg) pushes func and arg on the stack, then (func arg) is called when the stack unwinds."
#define Q_dynamic_unwind s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->T)
swap_stack(sc, OP_DYNAMIC_UNWIND, car(args), cadr(args));
return (cadr(args));
}
/* -------------------------------- catch -------------------------------- */
static s7_pointer g_catch(s7_scheme * sc, s7_pointer args)
{
#define H_catch "(catch tag thunk handler) evaluates thunk; if an error occurs that matches the tag (#t matches all), the handler is called"
#define Q_catch s7_make_signature(sc, 4, sc->values_symbol, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_boolean_symbol), sc->is_procedure_symbol, sc->is_procedure_symbol)
s7_pointer p, proc = cadr(args), err = caddr(args);
/* Guile sets up the catch before looking for arg errors:
* (catch #t log (lambda args "hiho")) -> "hiho"
* which is consistent in that (catch #t (lambda () (log))...) should probably be the same as (catch #t log ...)
* but what if the error handler arg is messed up? Seems weird to handle args in reverse order with an intervening let etc.
*/
/* 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) = current_stack_top(sc);
catch_op_loc(p) = (int32_t) (sc->op_stack_now - sc->op_stack);
catch_set_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)?
* (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 */
/* is_thunk above checks is_aritable(proc, 0), but if it's (lambda args ...) we have to set up the let with args=()
* the case that caught this: (catch #t make-hook ...)
*/
sc->code = closure_body(proc);
if (is_symbol(closure_args(proc)))
sc->curlet =
make_let_with_slot(sc, closure_let(proc),
closure_args(proc), sc->nil);
else
sc->curlet = make_let(sc, closure_let(proc));
push_stack_no_args_direct(sc, sc->begin_op);
} else
push_stack(sc, OP_APPLY, sc->nil, proc);
return (sc->F);
}
s7_pointer s7_call_with_catch(s7_scheme * sc, s7_pointer tag,
s7_pointer body, s7_pointer error_handler)
{
s7_pointer p, result;
new_cell(sc, p, T_CATCH);
catch_tag(p) = tag;
catch_goto_loc(p) = current_stack_top(sc);
catch_op_loc(p) = (int32_t) (sc->op_stack_now - sc->op_stack);
catch_set_handler(p, error_handler);
if (!sc->longjmp_ok) {
declare_jump_info();
TRACK(sc);
store_jump_info(sc);
set_jump_info(sc, S7_CALL_SET_JUMP);
if (jump_loc != NO_JUMP) {
if (jump_loc != ERROR_JUMP)
eval(sc, sc->cur_op);
if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */
(sc->stack_end == sc->stack_start))
push_stack_op(sc, OP_ERROR_QUIT);
result = sc->value;
} else {
push_stack(sc, OP_CATCH, error_handler, p);
result = s7_call(sc, body, sc->nil);
}
restore_jump_info(sc);
} else {
push_stack(sc, OP_CATCH, error_handler, p);
result = s7_call(sc, body, sc->nil);
}
return (result);
}
static void op_c_catch(s7_scheme * sc)
{
/* (catch #t (lambda () (set! ("hi") #\a)) (lambda args args))
* code is (catch #t (lambda () ....) (lambda args ....))
*/
s7_pointer p, f = cadr(sc->code), args = cddr(sc->code), tag;
/* defer making the error lambda */
if (!is_pair(f)) /* (catch #t ...) or (catch sym ...) */
tag = (is_symbol(f)) ? lookup_checked(sc, f) : 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) = current_stack_top(sc);
catch_op_loc(p) = sc->op_stack_now - sc->op_stack;
catch_set_handler(p, cdadr(args)); /* not yet a closure... */
push_stack(sc, OP_CATCH_1, sc->code, p); /* code ignored here, except by GC */
sc->curlet = make_let(sc, sc->curlet);
sc->code = T_Pair(cddar(args));
}
static void op_c_catch_all(s7_scheme * sc)
{
sc->curlet = make_let(sc, sc->curlet);
catch_all_set_goto_loc(sc->curlet, current_stack_top(sc));
catch_all_set_op_loc(sc->curlet, sc->op_stack_now - sc->op_stack);
push_stack_no_args_direct(sc, OP_CATCH_ALL); /* used to GC protect sc->args here and below, 14-Jul-21 */
sc->code = T_Pair(opt1_pair(cdr(sc->code))); /* the body of the first lambda (or car of it if catch_all_o) */
}
static Inline void op_c_catch_all_a(s7_scheme * sc)
{
sc->curlet = make_let(sc, sc->curlet);
catch_all_set_goto_loc(sc->curlet, current_stack_top(sc));
catch_all_set_op_loc(sc->curlet, sc->op_stack_now - sc->op_stack);
push_stack_no_args_direct(sc, OP_CATCH_ALL);
sc->value = fx_call(sc, opt1_pair(cdr(sc->code)));
}
/* -------------------------------- owlet -------------------------------- */
/* error reporting info -- save filename and line number */
static s7_pointer init_owlet(s7_scheme * sc)
{
s7_pointer e, p;
e = make_let_slowly(sc, sc->nil);
sc->temp3 = e;
sc->error_type = add_slot_checked_with_id(sc, e, make_symbol(sc, "error-type"), sc->F); /* the error type or tag ('division-by-zero) */
sc->error_data = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-data"), sc->F); /* the message or information passed by the error function */
sc->error_code = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-code"), sc->F); /* the code that s7 thinks triggered the error */
sc->error_line = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-line"), p = make_permanent_integer_unchecked(0)); /* the line number of that code */
add_saved_pointer(sc, p);
sc->error_file = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-file"), sc->F); /* the file name of that code */
sc->error_position = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-position"), p = make_permanent_integer_unchecked(0)); /* the file-byte position of that code */
add_saved_pointer(sc, p);
#if WITH_HISTORY
sc->error_history = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-history"), sc->F); /* buffer of previous evaluations */
#endif
sc->temp3 = sc->nil;
return (e);
}
#if WITH_HISTORY
static s7_pointer cull_history(s7_scheme * sc, s7_pointer code)
{
s7_pointer p;
clear_symbol_list(sc); /* make a list of words banned from the history */
add_symbol_to_list(sc, sc->s7_let_symbol);
add_symbol_to_list(sc, sc->eval_symbol);
add_symbol_to_list(sc, make_symbol(sc, "debug"));
add_symbol_to_list(sc, make_symbol(sc, "trace-in"));
add_symbol_to_list(sc, make_symbol(sc, "trace-out"));
add_symbol_to_list(sc, sc->dynamic_unwind_symbol);
add_symbol_to_list(sc, make_symbol(sc, "history-enabled"));
for (p = code; is_pair(p); p = cdr(p)) {
if (tree_set_memq(sc, car(p)))
set_car(p, sc->nil);
if (cdr(p) == code)
break;
}
return (code);
}
#endif
static s7_pointer g_owlet(s7_scheme * sc, s7_pointer args)
{
#if WITH_HISTORY
#define H_owlet "(owlet) returns the environment at the point of the last error. \
It has the additional local variables: error-type, error-data, error-code, error-line, error-file, and error-history."
#else
#define H_owlet "(owlet) returns the environment at the point of the last error. \
It has the additional local variables: error-type, error-data, error-code, error-line, and error-file."
#endif
#define Q_owlet s7_make_signature(sc, 1, sc->is_let_symbol)
/* if owlet is not copied, (define e (owlet)), e changes as owlet does! */
s7_pointer e, x;
s7_int gc_loc;
#if WITH_HISTORY
slot_set_value(sc->error_history,
cull_history(sc, slot_value(sc->error_history)));
#endif
e = let_copy(sc, sc->owlet);
gc_loc = gc_protect_1(sc, e);
/* make sure the pairs/reals/strings/integers are copied: should be error-data, error-code, and error-history */
sc->gc_off = true;
for (x = let_slots(e); tis_slot(x); x = next_slot(x))
if (is_pair(slot_value(x))) {
s7_pointer new_list, p, sp;
new_list = copy_any_list(sc, slot_value(x));
slot_set_value(x, new_list);
for (p = new_list, sp = p; is_pair(p);
p = cdr(p), sp = cdr(sp)) {
s7_pointer val = car(p);
if (is_t_real(val))
set_car(p, make_real(sc, real(val)));
else if (is_string(val))
set_car(p,
make_string_with_length(sc, string_value(val),
string_length(val)));
else if (is_t_integer(val))
set_car(p, make_integer(sc, integer(val)));
p = cdr(p);
if ((!is_pair(p)) || (p == sp))
break;
val = car(p);
if (is_t_real(val))
set_car(p, make_real(sc, real(val)));
else if (is_string(val))
set_car(p,
make_string_with_length(sc, string_value(val),
string_length(val)));
}
}
sc->gc_off = false;
s7_gc_unprotect_at(sc, gc_loc);
return (e);
}
/* -------- catch handlers -------- (don't free the catcher) */
static bool catch_all_function(s7_scheme * sc, s7_int i, s7_pointer type,
s7_pointer info, bool *reset_hook)
{
s7_pointer catcher = stack_let(sc->stack, i);
sc->value = opt2_con(stack_code(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);
if (is_pair(sc->value))
sc->value =
(car(sc->value) == sc->quote_symbol) ? cadr(sc->value) : type;
else if (is_symbol(sc->value))
sc->value = type;
return (true);
}
static bool catch_2_function(s7_scheme * sc, s7_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 = stack_code(sc->stack, i);
if ((catch_tag(x) == sc->T) ||
(catch_tag(x) == type) || (type == sc->T)) {
int64_t 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);
if (needs_copied_args(sc->code))
sc->args = list_2(sc, type, info);
else { /* very unlikely: need c_macro as error catcher: (catch #t (lambda () (error 'oops)) require) */
set_car(sc->t2_1, type);
set_car(sc->t2_2, info);
sc->args = sc->t2_1;
}
sc->cur_op = OP_APPLY;
return (true);
}
return (false);
}
static bool catch_1_function(s7_scheme * sc, s7_int i, s7_pointer type,
s7_pointer info, bool *reset_hook)
{
s7_pointer x = stack_code(sc->stack, i);
if ((catch_tag(x) == sc->T) ||
(catch_tag(x) == type) || (type == sc->T)) {
uint64_t loc;
opcode_t op = stack_op(sc->stack, i);
s7_pointer catcher = x, error_func, error_body, error_args;
sc->temp4 = stack_let(sc->stack, i); /* GC protect this, since we're moving the stack top below */
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) {
error_body = cdr(error_func);
error_args = car(error_func);
} else if (is_closure(error_func)) {
error_body = closure_body(error_func);
error_args = closure_args(error_func);
} else {
error_body = NULL;
error_args = NULL;
}
if ((error_body) && (is_null(cdr(error_body)))) {
s7_pointer y = NULL;
error_body = car(error_body);
if (is_pair(error_body)) {
if (car(error_body) == sc->quote_symbol)
y = cadr(error_body);
else if ((car(error_body) == sc->car_symbol) &&
(cadr(error_body) == error_args))
y = type;
} else if (!is_symbol(error_body))
y = error_body; /* not pair or symbol */
else if (error_body == error_args)
y = list_2(sc, type, info);
else if (is_keyword(error_body))
y = error_body;
else if ((is_pair(error_args)) &&
(error_body == car(error_args)))
y = type;
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;
if (loc == 4)
sc->code = cons(sc, sc->value, sc->nil); /* if we end up at op_begin, give it something it can handle */
return (true);
}
}
if (op == OP_CATCH_1) {
s7_pointer p;
new_cell(sc, p, T_CLOSURE);
closure_set_args(p, car(error_func));
closure_set_body(p, cdr(error_func));
closure_set_setter(p, sc->F);
closure_set_arity(p, CLOSURE_ARITY_NOT_SET);
closure_set_let(p, sc->temp4);
sc->code = p;
} 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 arguments: ~S",
sc->code);
sc->args = list_2(sc, type, info); /* almost never able to skip this -- costs more to check! */
sc->cur_op = OP_APPLY;
/* explicit eval needed if s7_call called into scheme where a caught error occurred (ex6 in exs7.c)
* but putting it here (via eval(sc, OP_APPLY)) means the C stack is not cleared correctly in non-s7-call cases,
* so defer it until s7_call
*/
return (true);
}
return (false);
}
static bool catch_dynamic_wind_function(s7_scheme * sc, s7_int i,
s7_pointer type, s7_pointer info,
bool *reset_hook)
{
s7_pointer 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_direct(sc, OP_EVAL_DONE);
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, s7_int i, s7_pointer type,
s7_pointer info, bool *reset_hook)
{
s7_pointer 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 #<unused> */
if (x != sc->unused)
set_current_output_port(sc, x);
return (false);
}
static bool catch_in_function(s7_scheme * sc, s7_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 */
if (stack_args(sc->stack, i) != sc->unused)
set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */
return (false);
}
static bool catch_read_function(s7_scheme * sc, s7_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, s7_int i, s7_pointer type,
s7_pointer info, bool *reset_hook)
{
s7_close_input_port(sc, current_input_port(sc));
pop_input_port(sc);
return (false);
}
static bool catch_barrier_function(s7_scheme * sc, s7_int i,
s7_pointer type, s7_pointer info,
bool *reset_hook)
{
if (is_input_port(stack_args(sc->stack, i))) { /* (eval-string "'(1 .)") */
if (current_input_port(sc) == 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, s7_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, s7_int i, s7_pointer type,
s7_pointer info, bool *reset_hook)
{
call_exit_active(stack_args(sc->stack, i)) = false;
return (false);
}
static bool catch_let_temporarily_function(s7_scheme * sc, s7_int i,
s7_pointer type,
s7_pointer info,
bool *reset_hook)
{
let_temp_done(sc, stack_args(sc->stack, i), stack_code(sc->stack, i),
stack_let(sc->stack, i));
return (false);
}
static bool catch_let_temp_unwind_function(s7_scheme * sc, s7_int i,
s7_pointer type,
s7_pointer info,
bool *reset_hook)
{
slot_set_value(stack_code(sc->stack, i), stack_args(sc->stack, i));
return (false);
}
static bool catch_let_temp_s7_unwind_function(s7_scheme * sc, s7_int i,
s7_pointer type,
s7_pointer info,
bool *reset_hook)
{
g_s7_let_set_fallback(sc,
set_plist_3(sc, sc->s7_let,
stack_code(sc->stack, i),
stack_args(sc->stack, i)));
return (false);
}
static bool catch_dynamic_unwind_function(s7_scheme * sc, s7_int i,
s7_pointer type, s7_pointer info,
bool *reset_hook)
{
/* if func has an error, s7_error will call it as it unwinds the stack -- an infinite loop. So, cancel the unwind first. */
stack_element(sc->stack, i) = (s7_pointer) OP_GC_PROTECT;
/* we're in an error or throw, so there is no return value to report, but we need to decrement *debug-spaces* (if in debug)
* stack_let is the trace-in let at the point of the dynamic_unwind call
*/
if (sc->debug > 0) {
s7_pointer spaces;
spaces =
lookup_slot_from(make_symbol(sc, "*debug-spaces*"),
stack_let(sc->stack, i));
if (is_slot(spaces))
slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */
}
return (false);
}
typedef bool (*catch_function_t)(s7_scheme * sc, s7_int i, s7_pointer type,
s7_pointer info, bool *reset_hook);
static catch_function_t catchers[NUM_OPS];
static void init_catchers(void)
{
int32_t i;
for (i = 0; i < NUM_OPS; 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_dynamic_wind_function;
catchers[OP_DYNAMIC_UNWIND] = catch_dynamic_unwind_function;
catchers[OP_GET_OUTPUT_STRING] = 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] = catch_eval_function;
catchers[OP_BARRIER] = catch_barrier_function;
catchers[OP_DEACTIVATE_GOTO] = catch_goto_function;
catchers[OP_LET_TEMP_DONE] = catch_let_temporarily_function;
catchers[OP_LET_TEMP_UNWIND] = catch_let_temp_unwind_function;
catchers[OP_LET_TEMP_S7_UNWIND] = catch_let_temp_s7_unwind_function;
catchers[OP_ERROR_HOOK_QUIT] = catch_hook_function;
}
/* -------------------------------- throw -------------------------------- */
static s7_pointer g_throw(s7_scheme * sc, s7_pointer args)
{
#define H_throw "(throw tag . info) is like (error ...) but it does not affect 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 s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)
bool ignored_flag = false;
int64_t i;
s7_pointer type = car(args), info = cdr(args);
/* look for a catcher */
for (i = current_stack_top(sc) - 1; i >= 3; i -= 4) {
catch_function_t 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,
wrap_string(sc,
"no catch found for (throw ~W~{~^ ~S~})",
38), type, info)));
}
static void s7_warn(s7_scheme * sc, s7_int len, const char *ctrl, ...)
{ /* len = max size of output string (for vsnprintf) */
if ((sc->error_port != sc->F) && (!sc->muffle_warnings)) {
int bytes;
va_list ap;
block_t *b;
char *str;
b = mallocate(sc, len);
str = (char *) block_data(b);
str[0] = '\0';
va_start(ap, ctrl);
bytes = vsnprintf(str, len, ctrl, ap);
va_end(ap);
if (port_is_closed(sc->error_port))
sc->error_port = sc->standard_error;
if ((bytes > 0) && (sc->error_port != sc->F))
port_write_string(sc->error_port) (sc, str, bytes,
sc->error_port);
liberate(sc, b);
}
}
static void fill_error_location(s7_scheme * sc)
{
if (((is_input_port(current_input_port(sc)))
&& (is_loader_port(current_input_port(sc))))
||
(((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE)))) {
integer(slot_value(sc->error_line)) =
port_line_number(current_input_port(sc));
integer(slot_value(sc->error_position)) =
port_position(current_input_port(sc));
slot_set_value(sc->error_file,
wrap_string(sc,
port_filename(current_input_port(sc)),
port_filename_length(current_input_port
(sc))));
} else {
integer(slot_value(sc->error_line)) = 0;
integer(slot_value(sc->error_position)) = 0;
slot_set_value(sc->error_file, sc->F);
}
}
s7_pointer s7_error(s7_scheme * sc, s7_pointer type, s7_pointer info)
{
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->format_depth = -1;
sc->gc_off = false; /* this is in case we were triggered from the sort function -- clumsy! */
sc->object_out_locked = false; /* possible error in obj->str method after object_out has set this flag */
sc->has_openlets = true; /* same problem -- we need a cleaner way to handle this */
if (sc->current_safe_list > 0)
clear_list_in_use(sc->safe_lists[sc->current_safe_list]);
slot_set_value(sc->error_type, type);
slot_set_value(sc->error_data, info);
if (unchecked_type(sc->curlet) != T_LET)
sc->curlet = sc->nil; /* in the reader, the sc->curlet stack entry is mostly ignored, so it can be (and usually is) garbage */
let_set_outlet(sc->owlet, sc->curlet);
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->cur_code != sc->history_sink) {
sc->cur_code =
(sc->using_history1) ? sc->eval_history2 : sc->eval_history1;
sc->using_history1 = (!sc->using_history1);
pair_fill(sc, set_plist_2(sc, sc->cur_code, sc->nil));
}
#endif
if (is_pair(cur_code)) {
int32_t line = -1, file, position;
if (has_location(cur_code)) {
line = (int32_t) pair_line_number(cur_code); /* cast to int32_t (from uint32_t) for sc->last_error_line */
file = (int32_t) pair_file_number(cur_code);
position = (int32_t) pair_position(cur_code);
} else { /* try to find a plausible line number! */
s7_pointer p, sp;
for (p = cur_code, sp = cur_code; is_pair(p);
p = cdr(p), sp = cdr(sp)) {
if ((is_pair(car(p))) && /* what about p itself? */
(has_location(car(p)))) {
line = (int32_t) pair_line_number(car(p));
file = (int32_t) pair_file_number(car(p));
position = (int32_t) pair_position(car(p));
break;
}
p = cdr(p);
if ((!is_pair(p)) || (p == sp))
break;
if ((is_pair(car(p))) && (has_location(car(p)))) {
line = (int32_t) pair_line_number(car(p));
file = (int32_t) pair_file_number(car(p));
position = (int32_t) pair_position(car(p));
break;
}
}
}
if ((line > 0) && (line != sc->last_error_line)) {
sc->last_error_line = line;
if (file < 0)
fill_error_location(sc);
else {
integer(slot_value(sc->error_line)) = line;
integer(slot_value(sc->error_position)) = position;
slot_set_value(sc->error_file, sc->file_names[file]);
}
} else
fill_error_location(sc);
} else
fill_error_location(sc);
{ /* look for a catcher, call catch*function in the error context (before unwinding the stack), outlet(owlet) is curlet */
int64_t 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 = current_stack_top(sc) - 1; i >= 3; i -= 4) {
catch_function_t catcher;
catcher = catchers[stack_op(sc->stack, i)];
if ((catcher) &&
(catcher(sc, i, type, info, &reset_error_hook))) {
if ((S7_DEBUGGING) && (!sc->longjmp_ok))
fprintf(stderr, "s7_error jump not available?\n");
LongJmp(sc->goto_start, CATCH_JUMP);
}
}
}
/* 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->nil;
/* 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->code = error_hook_func;
sc->args = list_2(sc, type, info);
/* if we drop into the longjmp below, the hook functions are not called!
* OP_ERROR_HOOK_QUIT performs the longjmp, so it should be safe to go to eval.
*/
eval(sc, OP_APPLY);
} else {
s7_int op = sc->print_length;
if (op < 32)
sc->print_length = 32;
if ((!is_output_port(sc->error_port)) || /* error-port can be #f */
(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 ((!is_pair(info)) || (!is_string(car(info))))
format_to_port(sc, sc->error_port, "\n;~S ~S",
set_plist_2(sc, type, info), false, 7);
else {
/* it's possible that the error string is just a string -- not intended for format */
if ((type != sc->format_error_symbol) && /* avoid an infinite loop of format errors */
(strchr(string_value(car(info)), '~'))) {
char *errstr;
block_t *b;
s7_int len, str_len;
len = string_length(car(info)) + 8;
b = mallocate(sc, len);
errstr = (char *) block_data(b);
str_len =
catstrs_direct(errstr, "\n;", string_value(car(info)),
(const char *) NULL);
format_to_port(sc, sc->error_port, errstr, cdr(info),
false, str_len);
liberate(sc, b);
} else
format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), false, 7); /* 7 = ctrl str len */
}
if (op < 32)
sc->print_length = op;
/* now display location at end */
if (is_string(slot_value(sc->error_file))) {
s7_newline(sc, sc->error_port);
format_to_port(sc, sc->error_port, "; ~A\n",
set_plist_1(sc,
object_to_truncated_string(sc,
cur_code,
40)),
false, 8);
format_to_port(sc, sc->error_port,
"; ~A, line ~D, position: ~D\n",
set_plist_3(sc, slot_value(sc->error_file),
slot_value(sc->error_line),
slot_value(sc->error_position)),
false, 31);
} else {
if ((is_input_port(current_input_port(sc))) &&
(port_file(current_input_port(sc)) != stdin) &&
(!port_is_closed(current_input_port(sc)))) {
const char *filename =
port_filename(current_input_port(sc));
int32_t line = port_line_number(current_input_port(sc));
if (filename)
format_to_port(sc, sc->error_port, "\n; ~A[~D]",
set_plist_2(sc,
wrap_string(sc, filename,
port_filename_length
(current_input_port
(sc))),
wrap_integer3(sc, line)),
false, 10);
else if ((line > 0)
&& (integer(slot_value(sc->error_line)) > 0))
format_to_port(sc, sc->error_port, "\n; line ~D",
set_plist_1(sc,
wrap_integer3(sc, line)),
false, 11);
else if (sc->input_port_stack_loc > 0) {
s7_pointer p;
p = sc->input_port_stack[sc->input_port_stack_loc - 1];
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,
wrap_string
(sc,
filename,
port_filename_length
(current_input_port
(sc))),
wrap_integer3
(sc,
line)),
false, 10);
}
}
} else {
const char *call_name = sc->s7_call_name;
if (call_name) {
sc->s7_call_name = NULL;
if ((sc->s7_call_file) && (sc->s7_call_line >= 0))
format_to_port(sc, sc->error_port,
"\n; ~A ~A[~D]", set_plist_3(sc,
s7_make_string_wrapper
(sc,
call_name),
s7_make_string_wrapper
(sc,
sc->s7_call_file),
wrap_integer1
(sc,
sc->s7_call_line)),
false, 13);
}
}
s7_newline(sc, sc->error_port);
}
/* look for __func__ in the error environment etc */
if (sc->error_port != sc->F) {
s7_pointer errp;
errp = stacktrace_1(sc,
s7_integer_checked(sc,
car
(sc->stacktrace_defaults)),
s7_integer_checked(sc,
cadr
(sc->stacktrace_defaults)),
s7_integer_checked(sc,
caddr
(sc->stacktrace_defaults)),
s7_integer_checked(sc,
cadddr
(sc->stacktrace_defaults)),
s7_boolean(sc,
s7_list_ref(sc,
sc->stacktrace_defaults,
4)));
if (string_length(errp) > 0) {
port_write_string(sc->error_port) (sc, string_value(errp),
string_length(errp),
sc->error_port);
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)),
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;
sc->cur_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)?
*/
if (is_null(obj))
return (s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"attempt to apply nil to ~S in ~S?",
33), args,
current_code(sc))));
return (s7_error
(sc, sc->syntax_error_symbol,
set_elist_5(sc,
wrap_string(sc,
"attempt to apply ~A ~S to ~S in ~S?",
35), type_name_string(sc, obj), obj,
args, current_code(sc))));
}
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;
s7_int len;
s7_pointer pt = current_input_port(sc);
if (!string_error) {
/* make an heroic effort to find where we slid off the tracks */
if (is_string_port(current_input_port(sc))) {
#define QUOTE_SIZE 40
s7_int i, j, start = 0, end, slen, size, nlen;
char *recent_input = NULL;
s7_pointer p;
/* 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 */
size = port_data_size(pt);
for (i = port_position(pt), j = 0;
(i < size) && (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, 1);
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];
}
nlen = 0;
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;
p = make_empty_string(sc, len, '\0');
msg = string_value(p);
nlen =
snprintf(msg, len,
"%s: %s %s[%u], last top-level form at: %s[%"
ld64 "]", 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;
p = make_empty_string(sc, len, '\0');
msg = string_value(p);
if ((sc->current_file) && (sc->current_line >= 0))
nlen =
snprintf(msg, len,
"%s: %s, last top-level form at %s[%" ld64
"]", errmsg,
(recent_input) ? recent_input : "",
sc->current_file, sc->current_line);
else
nlen =
snprintf(msg, len, "%s: %s", errmsg,
(recent_input) ? recent_input : "");
}
string_length(p) = nlen;
if (recent_input)
free(recent_input);
return (s7_error
(sc, sc->read_error_symbol, set_elist_1(sc, p)));
}
}
if ((port_line_number(pt) > 0) && (port_filename(pt))) {
s7_pointer p;
s7_int nlen = 0;
len =
safe_strlen(errmsg) + port_filename_length(pt) +
safe_strlen(sc->current_file) + 128;
p = make_empty_string(sc, len, '\0');
msg = string_value(p);
if (string_error)
nlen =
snprintf(msg, len,
"%s %s[%u],\n; possible culprit: \"%s...\"\n; last top-level form at %s[%"
ld64 "]", errmsg, port_filename(pt),
port_line_number(pt), sc->strbuf,
sc->current_file, sc->current_line);
else
nlen =
snprintf(msg, len,
"%s %s[%u], last top-level form at %s[%" ld64 "]",
errmsg, port_filename(pt), port_line_number(pt),
sc->current_file, sc->current_line);
string_length(p) = nlen;
return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p)));
}
return (s7_error
(sc,
(string_error) ? sc->
string_read_error_symbol : sc->read_error_symbol,
set_elist_1(sc, s7_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 s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)
if (is_null(args))
return (s7_error(sc, sc->nil, sc->nil));
if (!is_string(car(args))) /* else a CL-style error? -- use tag = 'no-catch */
return (s7_error(sc, car(args), cdr(args)));
s7_error(sc, sc->no_catch_symbol, args); /* this can have trailing args (implicit format) */
return (sc->unspecified);
}
static char *truncate_string(char *form, s7_int len, use_write_t use_write)
{
uint8_t *f = (uint8_t *) form;
if (use_write != P_DISPLAY) {
/* I guess we need to protect the outer double quotes in this case */
s7_int i;
for (i = len - 5; i >= (len / 2); i--)
if (is_white_space((int32_t) f[i])) {
form[i] = '.';
form[i + 1] = '.';
form[i + 2] = '.';
form[i + 3] = '"';
form[i + 4] = '\0';
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 {
s7_int i;
for (i = len - 4; i >= (len / 2); i--)
if (is_white_space((int32_t) f[i])) {
form[i] = '.';
form[i + 1] = '.';
form[i + 2] = '.';
form[i + 3] = '\0';
return (form);
}
i = len - 4;
if (i >= 0) {
form[i] = '.';
form[i + 1] = '.';
form[i + 2] = '.';
form[i + 3] = '\0';
} else
form[len] = '\0';
}
return (form);
}
static s7_pointer object_to_truncated_string(s7_scheme * sc, s7_pointer p,
s7_int len)
{
char *s;
s7_int s_len;
s7_pointer strp;
sc->objstr_max_len = len + 2;
strp = s7_object_to_string(sc, p, false);
s = string_value(strp);
sc->objstr_max_len = S7_INT64_MAX;
s_len = string_length(strp);
if (s_len > len)
truncate_string(s, len, P_DISPLAY);
return (strp);
}
static s7_pointer tree_descend(s7_scheme * sc, s7_pointer p, uint32_t line)
{
s7_pointer tp;
if (!is_pair(p))
return (NULL);
if (has_location(p)) {
uint32_t x = (uint32_t) pair_line_number(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);
return ((tp) ? tp : tree_descend(sc, cdr(p), line));
}
static s7_pointer missing_close_paren_error(s7_scheme * sc)
{
s7_int len;
char *msg, *syntax_msg = NULL;
s7_pointer pt;
if ((unchecked_type(sc->curlet) != T_LET) && (sc->curlet != sc->nil))
sc->curlet = sc->nil;
pt = current_input_port(sc);
/* 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))) {
integer(slot_value(sc->error_line)) = port_line_number(pt);
integer(slot_value(sc->error_position)) = port_position(pt);
slot_set_value(sc->error_file,
wrap_string(sc, port_filename(pt),
port_filename_length(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_location(p))) {
s7_int msg_len, form_len;
s7_pointer strp;
char *form;
strp = object_to_truncated_string(sc, p, 40);
form = string_value(strp);
form_len = string_length(strp);
msg_len = form_len + 128;
syntax_msg = (char *) Malloc(msg_len);
snprintf(syntax_msg, msg_len,
"; current form awaiting a close paren starts around line %u: %s",
(uint32_t) pair_line_number(p), form);
}
}
if ((port_line_number(pt) > 0) && (port_filename(pt))) {
s7_pointer p;
s7_int nlen;
len =
port_filename_length(pt) + safe_strlen(sc->current_file) +
safe_strlen(syntax_msg) + 128;
p = make_empty_string(sc, len, '\0');
msg = string_value(p);
if (syntax_msg) {
nlen =
snprintf(msg, len,
"missing close paren, %s[%u], last top-level form at %s[%"
ld64 "]\n%s", port_filename(pt),
port_line_number(pt), sc->current_file,
sc->current_line, syntax_msg);
free(syntax_msg);
} else
nlen =
snprintf(msg, len,
"missing close paren, %s[%u], last top-level form at %s[%"
ld64 "]", port_filename(pt), port_line_number(pt),
sc->current_file, sc->current_line);
string_length(p) = nlen;
return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p)));
}
if (syntax_msg) {
s7_pointer p;
len = safe_strlen(syntax_msg) + 128;
p = make_empty_string(sc, len, '\0');
msg = string_value(p);
len =
catstrs(msg, len, "missing close paren\n", syntax_msg, "\n",
(char *) NULL);
free(syntax_msg);
string_length(p) = len;
return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p)));
}
if ((is_input_port(pt)) &&
(!port_is_closed(pt)) &&
(port_data(pt)) && (port_position(pt) > 0)) {
s7_pointer p;
s7_int start, pos;
p = make_empty_string(sc, 128, '\0');
msg = string_value(p);
memcpy((void *) msg, (void *) "missing close paren: ", 21);
pos = port_position(pt);
start = pos - 40;
if (start < 0)
start = 0;
memcpy((void *) (msg + 21), (void *) (port_data(pt) + start),
pos - start);
string_length(p) = 21 + pos - start;
return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p)));
}
return (s7_error
(sc, sc->read_error_symbol,
set_elist_1(sc, wrap_string(sc, "missing close paren", 19))));
}
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 `(func ,@(reverse args) . ,code) essentially where func is sc->value or pop_op_stack(sc)
*/
s7_pointer func;
func = pop_op_stack(sc);
if (sc->args == sc->nil) /* (abs . 1) */
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"attempt to evaluate (~S . ~S)?",
30), func, sc->code));
else
s7_error(sc, sc->syntax_error_symbol,
set_elist_4(sc,
wrap_string(sc,
"attempt to evaluate (~S ~S . ~S)?",
33), func, sc->args =
proper_list_reverse_in_place(sc, sc->args),
sc->code));
}
static void op_error_hook_quit(s7_scheme * sc)
{
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); /* is this necessary? is it a good idea?? */
push_stack_op(sc, OP_ERROR_QUIT); /* added 3-Dec-16: try to make sure we actually exit! */
sc->cur_op = OP_ERROR_QUIT;
if (sc->longjmp_ok)
LongJmp(sc->goto_start, ERROR_QUIT_JUMP);
}
/* -------------------------------- 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;
sc->begin_op = (hook) ? OP_BEGIN_HOOK : OP_BEGIN_NO_HOOK;
}
static bool call_begin_hook(s7_scheme * sc)
{
bool result = false;
/* originally begin_hook was bool (*hook)(s7_scheme *sc): the value was returned directly,
* rather than going through a *bool arg (&result below). That works in gcc (Linux/OSX),
* but does not work in MS Visual C++. In the latter, the compiler apparently completely
* eliminates any local, returning (for example) a thread-relative stack-allocated value
* directly, but then by the time we get here, that variable has vanished, and we get
* garbage. We had to thwart the optimization by adding if ((flag) && (!flag)) fprintf(...);
* So, in the new form (26-Jun-13), the value is passed directly into an s7 variable
* that I hope can't be optimized out of existence.
*
* cm/src/Scheme.cpp, used in Snd (listener looking for C-g I think)
* originally this facility was aimed at interrupting infinite loops, and the expected usage was:
* set begin_hook, eval-string(...), unset begin_hook
*/
opcode_t op = sc->cur_op;
s7_pointer cur_code;
push_stack_direct(sc, OP_BARRIER);
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 */
cur_code = current_code(sc);
slot_set_value(sc->error_code, cur_code);
if (has_location(cur_code)) {
integer(slot_value(sc->error_line)) =
(s7_int) pair_line_number(cur_code);
slot_set_value(sc->error_file,
sc->file_names[pair_file_number(cur_code)]);
integer(slot_value(sc->error_position)) =
(s7_int) pair_position(cur_code);
} else {
integer(slot_value(sc->error_line)) = 0;
integer(slot_value(sc->error_position)) = 0;
slot_set_value(sc->error_file, sc->F);
}
#if WITH_HISTORY
slot_set_value(sc->error_history, sc->F);
#endif
let_set_outlet(sc->owlet, sc->curlet);
sc->value = make_symbol(sc, "begin-hook-interrupt");
/* otherwise the evaluator returns whatever random thing is in sc->value (normally #<closure>)
* which makes debugging unnecessarily difficult. ?? why not return something useful? make return s7_pointer*, not bool*
*/
s7_quit(sc); /* don't call gc here -- eval_c_string is the context -- allows interrupt of infinite loop */
return (true);
}
pop_stack_no_op(sc);
sc->cur_op = op; /* for better error handling. otherwise we get "barrier" as the offending function name in eval_error */
return (false);
}
/* -------------------------------- apply -------------------------------- */
static s7_pointer apply_list_star(s7_scheme * sc, s7_pointer d)
{
s7_pointer p;
/* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */
p = cons(sc, car(d), cdr(d));
sc->w = p;
while (is_not_null(cddr(p))) {
d = cdr(d);
set_cdr(p, cons(sc, car(d), cdr(d)));
if (is_not_null(cdr(d)))
p = cdr(p);
}
set_cdr(p, cadr(p));
return (sc->w);
}
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,
wrap_string(sc,
"apply's last argument should be a proper list: ~S",
49), lst)));
}
static s7_pointer g_apply(s7_scheme * sc, s7_pointer args)
{
#define H_apply "(apply func ...) applies func to the rest of the arguments"
#define Q_apply s7_make_circular_signature(sc, 2, 3, sc->values_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_sequence_symbol), sc->T)
/* can apply always be replaced with apply values?
* (apply + '(1 2 3)) is the same as (+ (apply values '(1 2 3)))
* not if apply* in disguise, I think:
* (apply + 1 2 ()) -> 3
* (apply + 1 2 (apply values ())) -> error
*/
sc->code = car(args);
if (!is_applicable(sc->code))
apply_error(sc, sc->code, sc->args);
if (is_null(cdr(args))) {
sc->args = sc->nil;
push_stack_direct(sc, OP_APPLY);
return (sc->nil);
}
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 (!s7_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, but if we copy the APPLY table here (returning sc->value)
* the overhead from the now non-inline function calls is greater than the fewer-eval-jumps savings.
*/
push_stack(sc, OP_APPLY, cdr(args), sc->code);
return (sc->nil);
}
/* here we may have to copy the arg list */
sc->args =
(is_null(cddr(args))) ? cadr(args) : apply_list_star(sc,
cdr(args));
if (!s7_is_proper_list(sc, sc->args))
return (apply_list_error(sc, args));
sc->args =
(needs_copied_args(sc->code)) ? copy_proper_list(sc,
sc->
args) : sc->args;
push_stack_direct(sc, OP_APPLY);
return (sc->nil);
}
s7_pointer s7_apply_function(s7_scheme * sc, s7_pointer fnc,
s7_pointer args)
{
TRACK(sc);
if (is_c_function(fnc))
return (c_function_call(fnc) (sc, args));
/* if [if (!is_applicable(fnc)) apply_error(sc, fnc, sc->args);] here, needs_copied_args can be T_App */
push_stack_direct(sc, OP_EVAL_DONE);
sc->code = fnc;
sc->args =
(needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args;
eval(sc, OP_APPLY);
/* we're limited in choices here -- the caller might be (say) car(sc->t1_1) = fn_proc(...) where the fn_proc
* happens to fallback on a method -- we can't just push OP_APPLY and drop back into the evaluator normally.
*/
return (sc->value);
}
static s7_pointer implicit_index(s7_scheme * sc, s7_pointer obj,
s7_pointer indices)
{
s7_pointer res;
/* (let ((lst '("12" "34"))) (lst 0 1)) -> #\2
* (let ((lst (list #(1 2) #(3 4)))) (lst 0 1)) -> 2
* this can get tricky:
* ((list (lambda (a) (+ a 1)) (lambda (b) (* b 2))) 1 2) -> 4
* but what if func takes rest/optional args, etc?
* ((list (lambda args (car args))) 0 "hi" 0)
* should this return #\h or "hi"?? currently it is "hi" which is consistent with ((lambda args (car args)) "hi" 0)
* but ((lambda (arg) arg) "hi" 0) is currently an error (too many arguments)
* maybe it should be (((lambda (arg) arg) "hi") 0) -> #\h
*/
switch (type(obj)) {
case T_VECTOR: /* (#(#(1 2) #(3 4)) 1 1) -> 4 */
return (vector_ref_1(sc, obj, indices));
case T_FLOAT_VECTOR:
res =
univect_ref(sc, set_ulist_1(sc, obj, indices),
sc->float_vector_ref_symbol, T_FLOAT_VECTOR);
set_car(sc->u1_1, sc->F);
return (res);
case T_INT_VECTOR:
res =
univect_ref(sc, set_ulist_1(sc, obj, indices),
sc->int_vector_ref_symbol, T_INT_VECTOR);
set_car(sc->u1_1, sc->F);
return (res);
case T_BYTE_VECTOR:
res =
univect_ref(sc, set_ulist_1(sc, obj, indices),
sc->byte_vector_ref_symbol, T_BYTE_VECTOR);
set_car(sc->u1_1, sc->F);
return (res);
case T_STRING: /* (#("12" "34") 0 1) -> #\2 */
if (!is_null(cdr(indices)))
return (s7_error
(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, obj,
indices)));
if (!is_t_integer(car(indices)))
return (wrong_type_argument
(sc, sc->string_ref_symbol, 2, car(indices),
T_INTEGER));
return (string_ref_p_pi_unchecked(sc, obj, integer(car(indices))));
case T_PAIR: /* (#((1 2) (3 4)) 1 0) -> 3, (#((1 (2 3))) 0 1 0) -> 2 */
obj = list_ref_1(sc, obj, car(indices));
return ((is_pair(cdr(indices))) ?
implicit_index(sc, obj, cdr(indices)) : obj);
case T_HASH_TABLE: /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */
obj = s7_hash_table_ref(sc, obj, car(indices));
return ((is_pair(cdr(indices))) ?
implicit_index(sc, obj, cdr(indices)) : obj);
case T_C_OBJECT:
res =
(*(c_object_ref(sc, obj))) (sc, set_ulist_1(sc, obj, indices));
set_car(sc->u1_1, sc->F);
return (res);
case T_LET:
obj = s7_let_ref(sc, obj, car(indices));
return ((is_pair(cdr(indices))) ?
implicit_index(sc, obj, cdr(indices)) : obj);
case T_ITERATOR: /* indices is not nil, so this is an error */
return (s7_error
(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, obj,
indices)));
default: /* (#(a b c) 0 1) -> error, but ((list (lambda (x) x)) 0 "hi") -> "hi" */
if (!is_applicable(obj)) /* (apply (list cons cons) (list 1 2)) needs the argnum check mentioned below */
return (apply_error(sc, obj, indices));
if ((is_c_function(obj)) && (is_safe_procedure(obj))) {
s7_int len;
len = proper_list_length(indices);
if ((c_function_required_args(obj) <= len) &&
(c_function_all_args(obj) >= len))
return (c_function_call(obj) (sc, indices));
}
push_stack_direct(sc, OP_EVAL_DONE);
sc->code = obj;
sc->args =
(needs_copied_args(obj)) ? copy_proper_list(sc,
indices) : indices;
eval(sc, OP_APPLY);
/* here sc->values can be multiple-values: (list (list-ref (list (lambda (a) (values a (+ a 1)))) 0 1)) -> '((values 1 2)), but should be '(1 2) */
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
return (sc->value);
/* return(s7_apply_function(sc, obj, indices)); -- needs argnum check *//* was g_apply 23-Jan-19 which assumes we're not in map */
}
}
static inline void fill_star_defaults(s7_scheme * sc, s7_pointer func,
int32_t start_arg, int32_t n_args,
s7_pointer par)
{
int32_t i;
s7_pointer *df;
df = c_function_arg_defaults(func);
if (c_func_has_simple_defaults(func)) {
for (i = start_arg; i < n_args; i++, par = cdr(par))
set_car(par, df[i]);
} else
for (i = start_arg; i < n_args; i++, par = cdr(par)) {
s7_pointer defval = df[i];
if (is_symbol(defval))
set_car(par, lookup_checked(sc, defval));
else if (is_pair(defval))
set_car(par, s7_eval(sc, defval, sc->nil));
else
set_car(par, defval);
}
}
static s7_pointer set_c_function_star_args(s7_scheme * sc)
{
int32_t i, j, n_args;
s7_pointer arg, par, call_args, func = sc->code;
s7_pointer *df;
n_args = c_function_all_args(func); /* not counting keywords, I think */
call_args =
(is_safe_procedure(func)) ? c_function_call_args(func) :
protected_make_list(sc, c_function_optional_args(func), sc->F);
/* assume at the start that there are no keywords */
for (i = 0, arg = sc->args, par = call_args;
(i < n_args) && (is_pair(arg));
i++, arg = cdr(arg), par = cdr(par)) {
if (!is_keyword(car(arg)))
set_car(par, car(arg));
else {
s7_pointer kpar, karg;
int32_t ki;
/* oops -- there are keywords, change scanners (much duplicated code...)
* setting checked on the call_args here rather than parsing the parameters to use add_symbol_to_list
*/
for (kpar = call_args; kpar != par; kpar = cdr(kpar))
set_checked(kpar);
for (; is_pair(kpar); kpar = cdr(kpar))
clear_checked(kpar);
df = c_function_arg_names(func);
for (ki = i, karg = arg, kpar = par;
(ki < n_args) && (is_pair(karg)); ki++, karg = cdr(karg))
if (!is_keyword(car(karg))) {
if (is_checked(kpar))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
parameter_set_twice_string,
car(kpar), sc->args)));
set_checked(kpar);
set_car(kpar, car(karg));
kpar = cdr(kpar);
} else {
s7_pointer p;
for (j = 0, p = call_args; j < n_args; j++, p = cdr(p))
if (df[j] == car(karg))
break;
if (j == n_args) {
if (c_function_allows_other_keys(func)) {
karg = cdr(karg);
if (is_null(karg)) /* (f* :x) where f* arglist includes :allow-other-keys */
return (s7_error
(sc, sc->syntax_error_symbol,
set_elist_3(sc,
value_is_missing_string,
func, car(arg))));
ki--;
} else
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc,
"~A: not a parameter name?",
25),
car(karg))));
} else {
if (is_checked(p))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
parameter_set_twice_string,
car(p), sc->args)));
if (!is_pair(cdr(karg)))
return (s7_error
(sc, sc->syntax_error_symbol,
set_elist_3(sc,
value_is_missing_string,
func, car(karg))));
set_checked(p);
karg = cdr(karg);
set_car(p, car(karg));
kpar = cdr(kpar);
}
}
if ((!is_null(karg)) && (!c_function_allows_other_keys(func)))
return (s7_error
(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, func,
sc->args)));
if (ki < n_args) {
df = c_function_arg_defaults(func);
if (c_func_has_simple_defaults(func)) {
for (ki = i, kpar = par; ki < n_args;
ki++, kpar = cdr(kpar))
if (!is_checked(kpar))
set_car(kpar, df[ki]);
} else
for (ki = i, kpar = par; ki < n_args;
ki++, kpar = cdr(kpar))
if (!is_checked(kpar)) {
s7_pointer defval = df[ki];
if (is_symbol(defval))
set_car(kpar, lookup_checked(sc, defval));
else if (is_pair(defval))
set_car(kpar,
s7_eval(sc, defval, sc->nil));
else
set_car(kpar, defval);
}
}
return (call_args);
}
}
if (!is_null(arg))
return (s7_error
(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, func,
sc->args)));
if (i < n_args)
fill_star_defaults(sc, func, i, n_args, par);
return (call_args);
}
static s7_pointer set_c_function_star_defaults(s7_scheme * sc, int32_t num)
{
s7_pointer call_args, func = sc->code, par;
int32_t n_args = c_function_all_args(func);
call_args =
(is_safe_procedure(func)) ? c_function_call_args(func) :
protected_make_list(sc, n_args, sc->F);
par = call_args;
if (num == 1) {
set_car(par, car(sc->args));
par = cdr(par);
}
fill_star_defaults(sc, func, num, n_args, par);
return (call_args);
}
#define apply_c_function_star(Sc) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_args(Sc))
#define apply_c_function_star_fill_defaults(Sc, Num) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_defaults(Sc, Num))
s7_pointer s7_apply_function_star(s7_scheme * sc, s7_pointer fnc,
s7_pointer args)
{
TRACK(sc);
if (is_c_function_star(fnc)) {
sc->w = sc->args;
sc->z = sc->code;
sc->args = T_Pos(args);
sc->code = fnc;
apply_c_function_star(sc);
sc->args = sc->w;
sc->code = sc->z;
return (sc->value);
}
push_stack_direct(sc, OP_EVAL_DONE);
sc->code = fnc;
sc->args =
(needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args;
eval(sc, OP_APPLY);
return (sc->value);
}
/* -------------------------------- eval -------------------------------- */
s7_pointer s7_eval(s7_scheme * sc, s7_pointer code, s7_pointer e)
{
declare_jump_info();
TRACK(sc);
if (sc->safety > NO_SAFETY) {
if (!s7_is_valid(sc, code))
s7_warn(sc, 256, "bad code argument to %s: %p\n", __func__,
code);
if (!s7_is_valid(sc, e))
s7_warn(sc, 256, "bad environment argument to %s: %p\n",
__func__, e);
}
store_jump_info(sc);
set_jump_info(sc, EVAL_SET_JUMP);
if (jump_loc != NO_JUMP) {
if (jump_loc != ERROR_JUMP)
eval(sc, sc->cur_op);
} else {
push_stack_direct(sc, OP_EVAL_DONE);
sc->code = code;
if ((e != sc->rootlet) && (is_let(e)))
set_curlet(sc, e);
else
sc->curlet = 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 (let (curlet))) evaluates code in the environment let. 'let' \
defaults to the curlet; to evaluate something in the top-level environment instead, \
pass (rootlet):\n\
\n\
(define x 32) \n\
(let ((x 3))\n\
(eval 'x (rootlet)))\n\
\n\
returns 32"
#define Q_eval s7_make_signature(sc, 3, sc->values_symbol, sc->T, sc->is_let_symbol)
if (is_not_null(cdr(args))) {
s7_pointer e = cadr(args);
if (!is_let(e))
return (wrong_type_argument_with_type
(sc, sc->eval_symbol, 2, e, a_let_string));
set_curlet(sc, (e == sc->rootlet) ? sc->nil : e);
}
sc->code = car(args);
if ((sc->safety > NO_SAFETY) && (is_pair(sc->code))) {
check_free_heap_size(sc, 8192);
sc->code = copy_body(sc, sc->code);
} else if (is_optimized(sc->code))
clear_all_optimizations(sc, sc->code);
set_current_code(sc, sc->code);
if (current_stack_top(sc) < 12)
push_stack_op(sc, OP_BARRIER);
push_stack_direct(sc, OP_EVAL);
return (sc->nil);
}
s7_pointer s7_call(s7_scheme * sc, s7_pointer func, s7_pointer args)
{
declare_jump_info();
TRACK(sc);
set_current_code(sc, history_cons(sc, func, args));
if (SHOW_EVAL_OPS)
safe_print(fprintf
(stderr, "%s: %s %s\n", __func__, display(func),
display_80(args)));
if (is_c_function(func))
return (c_function_call(func) (sc, args)); /* no check for wrong-number-of-args -- is that reasonable? */
sc->temp4 = T_App(func); /* this is feeble GC protection */
sc->temp2 = T_Lst(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->cur_op);
if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */
(sc->stack_end == sc->stack_start))
push_stack_op(sc, OP_ERROR_QUIT);
} else {
if (sc->safety > NO_SAFETY)
check_list_validity(sc, "s7_call", args);
push_stack_direct(sc, OP_EVAL_DONE); /* this saves the current evaluation and will eventually finish this (possibly) nested call */
sc->code = func;
sc->args =
(needs_copied_args(func)) ? copy_proper_list(sc, args) : args;
/* 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);
/* don't clear temp4 or temp2 here -- lots of (Snd) code calls s7_call repeatedly and assumes the "func" arg is protected between calls. */
return (sc->value);
}
s7_pointer s7_call_with_location(s7_scheme * sc, s7_pointer func,
s7_pointer args, const char *caller,
const char *file, s7_int line)
{
s7_pointer result;
if (caller) {
sc->s7_call_name = caller;
sc->s7_call_file = file;
sc->s7_call_line = line;
}
result = s7_call(sc, func, args);
if (caller) {
sc->s7_call_name = NULL;
sc->s7_call_file = NULL;
sc->s7_call_line = -1;
}
return (result);
}
/* -------------------------------- type-of -------------------------------- */
#if (!WITH_GCC)
static inline bool gen_type_match(s7_scheme * sc, s7_pointer val,
uint8_t typ)
{ /* opt3_byte = uint8_t */
return ((type(val) == typ) ||
((has_active_methods(sc, val)) &&
(apply_boolean_method(sc, val, sc->type_to_typers[typ]) !=
sc->F)));
}
#else
#define gen_type_match(Sc, Val, Typ) ({s7_pointer _val_ = Val; ((type(_val_) == Typ) || ((has_active_methods(Sc, _val_)) && (apply_boolean_method(Sc, _val_, Sc->type_to_typers[Typ]) != Sc->F)));})
#endif
static void init_typers(s7_scheme * sc)
{
sc->type_to_typers[T_FREE] = sc->F;
sc->type_to_typers[T_PAIR] = sc->is_pair_symbol;
sc->type_to_typers[T_NIL] = sc->is_null_symbol;
sc->type_to_typers[T_EOF] = sc->is_eof_object_symbol;
sc->type_to_typers[T_UNDEFINED] = sc->is_undefined_symbol;
sc->type_to_typers[T_UNSPECIFIED] = sc->is_unspecified_symbol;
sc->type_to_typers[T_BOOLEAN] = sc->is_boolean_symbol;
sc->type_to_typers[T_CHARACTER] = sc->is_char_symbol;
sc->type_to_typers[T_SYMBOL] = sc->is_symbol_symbol; /* and keyword? */
sc->type_to_typers[T_SYNTAX] = sc->is_syntax_symbol;
sc->type_to_typers[T_INTEGER] = sc->is_integer_symbol;
sc->type_to_typers[T_RATIO] = sc->is_rational_symbol;
sc->type_to_typers[T_REAL] = sc->is_float_symbol;
sc->type_to_typers[T_COMPLEX] = sc->is_complex_symbol;
sc->type_to_typers[T_BIG_INTEGER] = sc->is_integer_symbol;
sc->type_to_typers[T_BIG_RATIO] = sc->is_rational_symbol;
sc->type_to_typers[T_BIG_REAL] = sc->is_float_symbol;
sc->type_to_typers[T_BIG_COMPLEX] = sc->is_complex_symbol;
sc->type_to_typers[T_STRING] = sc->is_string_symbol;
sc->type_to_typers[T_BYTE_VECTOR] = sc->is_byte_vector_symbol;
sc->type_to_typers[T_C_OBJECT] = sc->is_c_object_symbol;
sc->type_to_typers[T_VECTOR] = sc->is_vector_symbol;
sc->type_to_typers[T_INT_VECTOR] = sc->is_int_vector_symbol;
sc->type_to_typers[T_FLOAT_VECTOR] = sc->is_float_vector_symbol;
sc->type_to_typers[T_CATCH] = sc->F;
sc->type_to_typers[T_DYNAMIC_WIND] = sc->F;
sc->type_to_typers[T_HASH_TABLE] = sc->is_hash_table_symbol;
sc->type_to_typers[T_LET] = sc->is_let_symbol;
sc->type_to_typers[T_ITERATOR] = sc->is_iterator_symbol;
sc->type_to_typers[T_STACK] = sc->F;
sc->type_to_typers[T_COUNTER] = sc->F;
sc->type_to_typers[T_SLOT] = sc->F;
sc->type_to_typers[T_C_POINTER] = sc->is_c_pointer_symbol;
sc->type_to_typers[T_OUTPUT_PORT] = sc->is_output_port_symbol;
sc->type_to_typers[T_INPUT_PORT] = sc->is_input_port_symbol;
sc->type_to_typers[T_RANDOM_STATE] = sc->is_random_state_symbol;
sc->type_to_typers[T_GOTO] = sc->is_goto_symbol;
sc->type_to_typers[T_CONTINUATION] = sc->is_continuation_symbol;
sc->type_to_typers[T_CLOSURE] = sc->is_procedure_symbol;
sc->type_to_typers[T_CLOSURE_STAR] = sc->is_procedure_symbol;
sc->type_to_typers[T_C_MACRO] = sc->is_macro_symbol;
sc->type_to_typers[T_MACRO] = sc->is_macro_symbol;
sc->type_to_typers[T_MACRO_STAR] = sc->is_macro_symbol;
sc->type_to_typers[T_BACRO] = sc->is_macro_symbol;
sc->type_to_typers[T_BACRO_STAR] = sc->is_macro_symbol;
sc->type_to_typers[T_C_FUNCTION] = sc->is_procedure_symbol;
sc->type_to_typers[T_C_FUNCTION_STAR] = sc->is_procedure_symbol;
sc->type_to_typers[T_C_ANY_ARGS_FUNCTION] = sc->is_procedure_symbol;
sc->type_to_typers[T_C_OPT_ARGS_FUNCTION] = sc->is_procedure_symbol;
sc->type_to_typers[T_C_RST_ARGS_FUNCTION] = sc->is_procedure_symbol;
}
s7_pointer s7_type_of(s7_scheme * sc, s7_pointer arg)
{
return (sc->type_to_typers[type(arg)]);
}
static s7_pointer g_type_of(s7_scheme * sc, s7_pointer args)
{
#define H_type_of "(type-of obj) returns a symbol describing obj's type"
#define Q_type_of s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->not_symbol), sc->T)
return (sc->type_to_typers[type(car(args))]);
}
/* -------------------------------- exit emergency-exit -------------------------------- */
void s7_quit(s7_scheme * sc)
{
sc->longjmp_ok = false;
pop_input_port(sc);
stack_reset(sc);
push_stack_op_let(sc, OP_EVAL_DONE);
}
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 s7_make_signature(sc, 2, sc->T, sc->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_checked(sc, 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 s7_make_signature(sc, 2, sc->T, sc->T)
/* calling s7_eval_c_string in an atexit function seems to be problematic -- it works, but args can be changed? longjmp perhaps? */
s7_quit(sc);
if (show_gc_stats(sc))
s7_warn(sc, 256, "gc calls %" ld64 " total time: %f\n",
sc->gc_calls,
(double) (sc->gc_total_time) / ticks_per_second());
return (g_emergency_exit(sc, args));
}
#if WITH_GCC
static s7_pointer g_abort(s7_scheme * sc, s7_pointer args)
{
abort();
}
#endif
/* -------------------------------- optimizer stuff -------------------------------- */
/* There is a problem with cache misses: a bigger cache reduces one test from 24 seconds to 17 (cachegrind agrees).
* But how to optimize s7 for cache hits? The culprits are eval and gc. Looking at the numbers,
* I think the least affected tests are able to use opt_info optimization which makes everything local?
*/
#if S7_DEBUGGING
static void check_t_1(s7_scheme * sc, s7_pointer e, const char *func,
s7_pointer expr, s7_pointer var)
{
if (let_slots(e) != lookup_slot_from(var, sc->curlet)) {
fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func,
display(expr), display(var), display(sc->curlet),
(tis_slot(let_slots(e))) ? display(let_slots(e)) :
"no slots");
if (sc->stop_at_error)
abort();
}
}
static s7_pointer t_lookup_1(s7_scheme * sc, s7_pointer symbol,
const char *func, s7_pointer expr)
{
check_t_1(sc, sc->curlet, func, expr, symbol);
return (slot_value(let_slots(sc->curlet)));
}
static s7_pointer T_lookup_1(s7_scheme * sc, s7_pointer symbol,
const char *func, s7_pointer expr)
{
check_t_1(sc, let_outlet(sc->curlet), func, expr, symbol);
return (slot_value(let_slots(let_outlet(sc->curlet))));
}
static void check_u_1(s7_scheme * sc, s7_pointer e, const char *func,
s7_pointer expr, s7_pointer var)
{
if (next_slot(let_slots(e)) != lookup_slot_from(var, sc->curlet)) {
fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func,
display(expr), display(var), display(e),
(tis_slot(next_slot(let_slots(e)))) ?
display(next_slot(let_slots(e))) : "no next slot");
if (sc->stop_at_error)
abort();
}
}
static s7_pointer u_lookup_1(s7_scheme * sc, s7_pointer symbol,
const char *func, s7_pointer expr)
{
check_u_1(sc, sc->curlet, func, expr, symbol);
return (slot_value(next_slot(let_slots(sc->curlet))));
}
static s7_pointer U_lookup_1(s7_scheme * sc, s7_pointer symbol,
const char *func, s7_pointer expr)
{
check_u_1(sc, let_outlet(sc->curlet), func, expr, symbol);
return (slot_value(next_slot(let_slots(let_outlet(sc->curlet)))));
}
static void check_v_1(s7_scheme * sc, s7_pointer e, const char *func,
s7_pointer expr, s7_pointer var)
{
if (next_slot(next_slot(let_slots(e))) !=
lookup_slot_from(var, sc->curlet)) {
fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func,
display(expr), display(var), display(e),
(tis_slot(next_slot(next_slot(let_slots(e))))) ?
display(next_slot(next_slot(let_slots(e)))) :
"no next slot");
if (sc->stop_at_error)
abort();
}
}
static s7_pointer v_lookup_1(s7_scheme * sc, s7_pointer symbol,
const char *func, s7_pointer expr)
{
check_v_1(sc, sc->curlet, func, expr, symbol);
return (slot_value(next_slot(next_slot(let_slots(sc->curlet)))));
}
static s7_pointer V_lookup_1(s7_scheme * sc, s7_pointer symbol,
const char *func, s7_pointer expr)
{
check_v_1(sc, let_outlet(sc->curlet), func, expr, symbol);
return (slot_value
(next_slot(next_slot(let_slots(let_outlet(sc->curlet))))));
}
static void check_o_1(s7_scheme * sc, s7_pointer e, const char *func,
s7_pointer expr, s7_pointer var)
{
s7_pointer slot;
slot = lookup_slot_from(var, sc->curlet);
if (lookup_slot_from(var, e) != slot) {
fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func,
display(expr), display(var), display(e),
(tis_slot(slot)) ? display(slot) : "undefined");
if (sc->stop_at_error)
abort();
}
}
static s7_pointer o_lookup_1(s7_scheme * sc, s7_pointer symbol,
const char *func, s7_pointer expr)
{
check_o_1(sc, let_outlet(sc->curlet), func, expr, symbol);
return (lookup_from(sc, symbol, let_outlet(sc->curlet)));
}
static s7_pointer O_lookup_1(s7_scheme * sc, s7_pointer symbol,
const char *func, s7_pointer expr)
{
check_o_1(sc, let_outlet(let_outlet(sc->curlet)), func, expr, symbol);
return (lookup_from(sc, symbol, let_outlet(sc->curlet)));
}
#define t_lookup(Sc, Symbol, Expr) t_lookup_1(Sc, Symbol, __func__, Expr)
#define u_lookup(Sc, Symbol, Expr) u_lookup_1(Sc, Symbol, __func__, Expr)
#define v_lookup(Sc, Symbol, Expr) v_lookup_1(Sc, Symbol, __func__, Expr)
#define T_lookup(Sc, Symbol, Expr) T_lookup_1(Sc, Symbol, __func__, Expr)
#define U_lookup(Sc, Symbol, Expr) U_lookup_1(Sc, Symbol, __func__, Expr)
#define V_lookup(Sc, Symbol, Expr) V_lookup_1(Sc, Symbol, __func__, Expr)
#define o_lookup(Sc, Symbol, Expr) o_lookup_1(Sc, Symbol, __func__, Expr)
#define O_lookup(Sc, Symbol, Expr) O_lookup_1(Sc, Symbol, __func__, Expr)
#else
#define t_lookup(Sc, Symbol, Expr) slot_value(let_slots(sc->curlet))
#define u_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(sc->curlet)))
#define v_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(sc->curlet))))
#define T_lookup(Sc, Symbol, Expr) slot_value(let_slots(let_outlet(sc->curlet)))
#define U_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(let_outlet(sc->curlet))))
#define V_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet)))))
#define o_lookup(Sc, Symbol, Expr) lookup_from(Sc, Symbol, let_outlet(Sc->curlet))
#define O_lookup(Sc, Symbol, Expr) lookup_from(Sc, Symbol, let_outlet(let_outlet(Sc->curlet)))
#endif
#define s_lookup(Sc, Sym, Expr) lookup(Sc, Sym)
#define g_lookup(Sc, Sym, Expr) lookup_global(Sc, Sym)
/* arg here is the full expression */
static s7_pointer fx_c(s7_scheme * sc, s7_pointer arg)
{
return (arg);
}
static s7_pointer fx_q(s7_scheme * sc, s7_pointer arg)
{
return (cadr(arg));
}
static s7_pointer fx_unsafe_s(s7_scheme * sc, s7_pointer arg)
{
return (lookup_checked(sc, T_Sym(arg)));
}
static s7_pointer fx_s(s7_scheme * sc, s7_pointer arg)
{
return (lookup(sc, T_Sym(arg)));
}
static s7_pointer fx_g(s7_scheme * sc, s7_pointer arg)
{
return ((is_global(arg)) ? global_value(arg) : lookup(sc, arg));
}
static s7_pointer fx_o(s7_scheme * sc, s7_pointer arg)
{
return (o_lookup(sc, T_Sym(arg), arg));
}
static s7_pointer fx_t(s7_scheme * sc, s7_pointer arg)
{
return (t_lookup(sc, T_Sym(arg), arg));
}
static s7_pointer fx_u(s7_scheme * sc, s7_pointer arg)
{
return (u_lookup(sc, T_Sym(arg), arg));
}
static s7_pointer fx_v(s7_scheme * sc, s7_pointer arg)
{
return (v_lookup(sc, T_Sym(arg), arg));
}
static s7_pointer fx_T(s7_scheme * sc, s7_pointer arg)
{
return (T_lookup(sc, T_Sym(arg), arg));
}
static s7_pointer fx_U(s7_scheme * sc, s7_pointer arg)
{
return (U_lookup(sc, T_Sym(arg), arg));
}
static s7_pointer fx_c_nc(s7_scheme * sc, s7_pointer arg)
{
return (fc_call(sc, arg));
}
#define fx_c_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t1_1, Lookup(sc, cadr(arg), arg)); \
return(fn_proc(arg)(sc, sc->t1_1)); \
}
fx_c_any(fx_c_s, s_lookup)
fx_c_any(fx_c_g, g_lookup)
fx_c_any(fx_c_t, t_lookup)
fx_c_any(fx_c_u, u_lookup)
fx_c_any(fx_c_v, v_lookup)
fx_c_any(fx_c_o, o_lookup)
fx_c_any(fx_c_T, T_lookup)
static s7_pointer fx_c_g_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc,
lookup_global(sc,
cadr(arg))));
}
static s7_pointer fx_c_s_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc,
lookup(sc, cadr(arg))));
}
static s7_pointer fx_c_o_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc,
o_lookup(sc, cadr(arg),
arg)));
}
static s7_pointer fx_c_t_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc,
t_lookup(sc, cadr(arg),
arg)));
}
static s7_pointer fx_c_u_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc,
u_lookup(sc, cadr(arg),
arg)));
}
static s7_pointer fx_c_v_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc,
v_lookup(sc, cadr(arg),
arg)));
}
#define fx_car_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer val; \
val = Lookup(sc, cadr(arg), arg); \
return((is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \
}
fx_car_any(fx_car_s, s_lookup)
fx_car_any(fx_car_t, t_lookup)
fx_car_any(fx_car_u, u_lookup)
fx_car_any(fx_car_o, o_lookup)
#define fx_cdr_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer val; \
val = Lookup(sc, cadr(arg), arg); \
return((is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \
}
fx_cdr_any(fx_cdr_s, s_lookup)
fx_cdr_any(fx_cdr_t, t_lookup)
fx_cdr_any(fx_cdr_u, u_lookup)
fx_cdr_any(fx_cdr_v, v_lookup)
fx_cdr_any(fx_cdr_o, o_lookup)
#define fx_cadr_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\
{ \
s7_pointer val; \
val = Lookup(sc, cadr(arg), arg); \
return(((is_pair(val)) && (is_pair(cdr(val)))) ? cadr(val) : g_cadr(sc, set_plist_1(sc, val))); \
}
fx_cadr_any(fx_cadr_s, s_lookup)
fx_cadr_any(fx_cadr_t, t_lookup)
fx_cadr_any(fx_cadr_u, u_lookup)
fx_cadr_any(fx_cadr_o, o_lookup)
#define fx_cddr_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\
{ \
s7_pointer val; \
val = Lookup(sc, cadr(arg), arg); \
return(((is_pair(val)) && (is_pair(cdr(val)))) ? cddr(val) : g_cddr(sc, set_plist_1(sc, val))); \
}
fx_cddr_any(fx_cddr_s, s_lookup)
fx_cddr_any(fx_cddr_t, t_lookup)
fx_cddr_any(fx_cddr_u, u_lookup)
fx_cddr_any(fx_cddr_o, o_lookup)
#define fx_add_s1_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer x; \
x = Lookup(sc, cadr(arg), arg); \
if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) + 1)); \
return(g_add_x1_1(sc, x, 1)); /* arg=(+ x 1) */ \
}
fx_add_s1_any(fx_add_s1, s_lookup)
fx_add_s1_any(fx_add_t1, t_lookup)
fx_add_s1_any(fx_add_u1, u_lookup)
fx_add_s1_any(fx_add_T1, T_lookup)
fx_add_s1_any(fx_add_U1, U_lookup)
fx_add_s1_any(fx_add_V1, V_lookup)
static s7_pointer fx_num_eq_xi_1(s7_scheme * sc, s7_pointer args,
s7_pointer val, s7_int y)
{
if ((S7_DEBUGGING) && (is_t_integer(val)))
fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__,
display(val));
switch (type(val)) {
case T_REAL:
return (make_boolean(sc, real(val) == y));
case T_RATIO:
case T_COMPLEX:
return (sc->F);
#if WITH_GMP
case T_BIG_INTEGER:
return (make_boolean(sc, mpz_cmp_si(big_integer(val), y) == 0));
case T_BIG_REAL:
return (make_boolean(sc, mpfr_cmp_si(big_real(val), y) == 0));
case T_BIG_RATIO:
case T_BIG_COMPLEX:
return (sc->F);
#endif
default:
return (method_or_bust_with_type_pp
(sc, val, sc->num_eq_symbol, val, cadr(args),
a_number_string, 1));
}
return (sc->T);
}
static s7_pointer fx_num_eq_s0f(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = lookup(sc, cadr(arg));
if (is_t_real(val))
return (make_boolean(sc, real(val) == 0.0));
return (make_boolean(sc, num_eq_b_7pp(sc, val, real_zero)));
}
#define fx_num_eq_si_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_int y; \
s7_pointer val, args = cdr(arg); \
val = Lookup(sc, car(args), arg); \
y = integer(cadr(args)); \
return((is_t_integer(val)) ? make_boolean(sc, integer(val) == y) : \
((is_t_real(val)) ? make_boolean(sc, real(val) == y) : fx_num_eq_xi_1(sc, args, val, y))); \
}
fx_num_eq_si_any(fx_num_eq_si, s_lookup)
fx_num_eq_si_any(fx_num_eq_ti, t_lookup)
fx_num_eq_si_any(fx_num_eq_ui, u_lookup)
fx_num_eq_si_any(fx_num_eq_vi, v_lookup)
fx_num_eq_si_any(fx_num_eq_Ti, T_lookup)
#define fx_num_eq_s0_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer val; \
val = Lookup(sc, cadr(arg), arg); \
return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : fx_num_eq_xi_1(sc, cdr(arg), val, 0)); \
}
fx_num_eq_s0_any(fx_num_eq_s0, s_lookup)
fx_num_eq_s0_any(fx_num_eq_t0, t_lookup)
fx_num_eq_s0_any(fx_num_eq_u0, u_lookup)
fx_num_eq_s0_any(fx_num_eq_v0, v_lookup)
static s7_pointer fx_num_eq_0s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = lookup(sc, caddr(arg));
return ((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) :
g_num_eq(sc, set_plist_2(sc, val, int_zero)));
}
static s7_pointer fx_random_i(s7_scheme * sc, s7_pointer arg)
{
#if WITH_GMP
return (g_random_i(sc, cdr(arg)));
#else
return (make_integer
(sc,
(s7_int) (integer(cadr(arg)) *
next_random(sc->default_rng))));
#endif
}
static s7_pointer fx_add_i_random(s7_scheme * sc, s7_pointer arg)
{
#if WITH_GMP
return (add_p_pp(sc, cadr(arg), random_p_p(sc, opt3_int(cdr(arg)))));
#else
s7_int x = integer(cadr(arg)), y = integer(opt3_int(cdr(arg))); /* cadadr */
return (make_integer(sc, x + (s7_int) (y * next_random(sc->default_rng)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */
#endif
}
static s7_pointer fx_add_sf(s7_scheme * sc, s7_pointer arg)
{
return (g_add_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg)))));
}
static s7_pointer fx_add_fs(s7_scheme * sc, s7_pointer arg)
{
return (g_add_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg))));
}
static s7_pointer fx_add_tf(s7_scheme * sc, s7_pointer arg)
{
return (g_add_xf
(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg)))));
}
static s7_pointer fx_add_si(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = lookup(sc, cadr(arg));
#if (!WITH_GMP)
if (is_t_integer(x)) {
#if HAVE_OVERFLOW_CHECKS
s7_int val;
if (!add_overflow(integer(x), integer(opt2_con(cdr(arg))), &val))
return (make_integer(sc, val));
/* else fall into add_p_pp below */
#else
return (make_integer
(sc, integer(x) + integer(opt2_con(cdr(arg)))));
#endif
/* return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(opt2_con(cdr(arg))))); -- slightly slower than the add_overflow code above */
}
#endif
return (add_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */
}
static s7_pointer fx_add_ss(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc, s_lookup(sc, cadr(arg), arg),
s_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_add_ts(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
s_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_add_tu(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
u_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_add_ut(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc, u_lookup(sc, cadr(arg), arg),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_add_us(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc, u_lookup(sc, cadr(arg), arg),
s_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_add_vu(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc, v_lookup(sc, cadr(arg), arg),
u_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
#define fx_subtract_s1_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer x; \
x = Lookup(sc, cadr(arg), arg); \
if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) - 1)); \
return(minus_c1(sc, x)); \
}
fx_subtract_s1_any(fx_subtract_s1, s_lookup)
fx_subtract_s1_any(fx_subtract_t1, t_lookup)
fx_subtract_s1_any(fx_subtract_u1, u_lookup)
fx_subtract_s1_any(fx_subtract_T1, T_lookup)
fx_subtract_s1_any(fx_subtract_U1, U_lookup)
#define fx_subtract_si_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer x; \
x = Lookup(sc, cadr(arg), arg); \
if ((!WITH_GMP) && (is_t_integer(x))) \
{ \
if (HAVE_OVERFLOW_CHECKS) \
{ \
s7_int val; \
if (!subtract_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \
return(make_integer(sc, val)); \
} \
else return(make_integer(sc, integer(x) - integer(opt2_con(cdr(arg))))); \
} \
return(subtract_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \
}
fx_subtract_si_any(fx_subtract_si, s_lookup)
fx_subtract_si_any(fx_subtract_ti, t_lookup)
#define fx_subtract_sf_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer x; \
x = Lookup(sc, cadr(arg), arg); \
if (is_t_real(x)) \
return(make_real(sc, real(x) - real(opt2_con(cdr(arg))))); /* caddr(arg) */ \
return(g_subtract_2f(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \
}
fx_subtract_sf_any(fx_subtract_sf, s_lookup)
fx_subtract_sf_any(fx_subtract_tf, t_lookup)
#define fx_subtract_ss_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) {return(subtract_p_pp(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg)));}
fx_subtract_ss_any(fx_subtract_ss, s_lookup, s_lookup)
fx_subtract_ss_any(fx_subtract_ts, t_lookup, s_lookup)
fx_subtract_ss_any(fx_subtract_tu, t_lookup, u_lookup)
fx_subtract_ss_any(fx_subtract_ut, u_lookup, t_lookup)
fx_subtract_ss_any(fx_subtract_us, u_lookup, s_lookup)
static s7_pointer fx_subtract_fs(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
s7_double n = real(cadr(arg));
x = lookup(sc, opt2_sym(cdr(arg))); /* caddr(arg) */
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 (make_complex_not_0i(sc, n - real_part(x), -imag_part(x)));
#if WITH_GMP
case T_BIG_INTEGER:
case T_BIG_RATIO:
case T_BIG_REAL:
case T_BIG_COMPLEX:
return (subtract_p_pp(sc, cadr(arg), x));
#endif
default:
return (method_or_bust_with_type_pp
(sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string,
2));
}
return (x);
}
#define fx_is_eq_sc_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return(make_boolean(sc, Lookup(sc, cadr(arg), arg) == opt2_con(cdr(arg)))); /* fx_choose checks that the second arg is not unspecified */ \
}
fx_is_eq_sc_any(fx_is_eq_sc, s_lookup)
fx_is_eq_sc_any(fx_is_eq_tc, t_lookup)
#define fx_is_eq_car_sq_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer lst, a = cdr(arg); \
lst = Lookup(sc, opt3_sym(a), arg); \
return(make_boolean(sc, (is_pair(lst)) ? (car(lst) == opt2_con(a)) : s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt2_con(a)))); \
}
fx_is_eq_car_sq_any(fx_is_eq_car_sq, s_lookup)
fx_is_eq_car_sq_any(fx_is_eq_car_tq, t_lookup)
static s7_pointer fx_is_eq_caar_sq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer lst, a = cdr(arg);
lst = lookup(sc, opt3_sym(a));
if ((is_pair(lst)) && (is_pair(car(lst))))
return (make_boolean(sc, caar(lst) == opt2_con(a)));
return (make_boolean
(sc, s7_is_eq(g_caar(sc, set_plist_1(sc, lst)), opt2_con(a))));
}
static s7_pointer fx_not_is_eq_car_sq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer lst;
lst = lookup(sc, opt1_sym(cdr(arg)));
if (is_pair(lst))
return (make_boolean(sc, car(lst) != opt3_con(cdr(arg))));
return (make_boolean
(sc,
!s7_is_eq(g_car(sc, set_plist_1(sc, lst)),
opt3_con(cdr(arg)))));
}
#define fx_is_pair_car_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup(sc, opt2_sym(cdr(arg)), arg); \
return((is_pair(p)) ? make_boolean(sc, is_pair(car(p))) : g_is_pair(sc, set_plist_1(sc, g_car(sc, set_plist_1(sc, p))))); \
}
fx_is_pair_car_s_any(fx_is_pair_car_s, s_lookup)
fx_is_pair_car_s_any(fx_is_pair_car_t, t_lookup)
#define fx_is_pair_cdr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup(sc, opt2_sym(cdr(arg)), arg); \
return((is_pair(p)) ? make_boolean(sc, is_pair(cdr(p))) : g_is_pair(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \
}
fx_is_pair_cdr_s_any(fx_is_pair_cdr_s, s_lookup)
fx_is_pair_cdr_s_any(fx_is_pair_cdr_t, t_lookup)
fx_is_pair_cdr_s_any(fx_is_pair_cdr_u, u_lookup)
#define fx_is_pair_cadr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup(sc, opt2_sym(cdr(arg)), arg); \
return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cadr(p))) : g_is_pair(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \
}
fx_is_pair_cadr_s_any(fx_is_pair_cadr_s, s_lookup)
fx_is_pair_cadr_s_any(fx_is_pair_cadr_t, t_lookup)
#define fx_is_pair_cddr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup(sc, opt2_sym(cdr(arg)), arg); \
return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cddr(p))) : g_is_pair(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \
}
fx_is_pair_cddr_s_any(fx_is_pair_cddr_s, s_lookup)
fx_is_pair_cddr_s_any(fx_is_pair_cddr_t, t_lookup)
#define fx_is_null_cdr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup(sc, opt2_sym(cdr(arg)), arg); \
return((is_pair(p)) ? make_boolean(sc, is_null(cdr(p))) : g_is_null(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \
}
fx_is_null_cdr_s_any(fx_is_null_cdr_s, s_lookup)
fx_is_null_cdr_s_any(fx_is_null_cdr_t, t_lookup)
#define fx_is_null_cadr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup(sc, opt2_sym(cdr(arg)), arg); \
return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cadr(p))) : g_is_null(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \
}
fx_is_null_cadr_s_any(fx_is_null_cadr_s, s_lookup)
fx_is_null_cadr_s_any(fx_is_null_cadr_t, t_lookup)
#define fx_is_null_cddr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup(sc, opt2_sym(cdr(arg)), arg); \
return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cddr(p))) : g_is_null(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \
}
fx_is_null_cddr_s_any(fx_is_null_cddr_s, s_lookup)
fx_is_null_cddr_s_any(fx_is_null_cddr_t, t_lookup)
#define fx_is_symbol_cadr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup(sc, opt2_sym(cdr(arg)), arg); \
return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_symbol(cadr(p))) : g_is_symbol(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \
}
fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_s, s_lookup)
fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_t, t_lookup)
static s7_pointer fx_is_symbol_car_t(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = t_lookup(sc, opt2_sym(cdr(arg)), arg);
return (make_boolean
(sc,
(is_pair(val)) ? is_symbol(car(val)) :
is_symbol(g_car(sc, set_plist_1(sc, val)))));
}
static s7_pointer fx_floor_sqrt_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p;
p = lookup(sc, opt2_sym(cdr(arg)));
#if WITH_GMP
if ((is_t_big_integer(p)) && (mpz_cmp_ui(big_integer(p), 0) >= 0)) { /* p >= 0 */
mpz_sqrt(sc->mpz_1, big_integer(p));
return (mpz_to_integer(sc, sc->mpz_1));
}
#else
if (!is_negative_b_7p(sc, p))
return (make_integer(sc, (s7_int)
floor(sqrt
(s7_number_to_real_with_caller
(sc, p, "sqrt")))));
#endif
return (floor_p_p(sc, sqrt_p_p(sc, p)));
}
static s7_pointer fx_is_positive_u(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p1;
p1 = u_lookup(sc, cadr(arg), arg);
if (is_t_integer(p1))
return (make_boolean(sc, integer(p1) > 0));
return (make_boolean(sc, is_positive_b_7p(sc, p1)));
}
static s7_pointer fx_is_zero_u(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean
(sc, is_zero_b_7p(sc, u_lookup(sc, cadr(arg), arg))));
}
#define fx_real_part_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer z; \
z = Lookup(sc, cadr(arg), arg); \
return((is_t_complex(z)) ? make_real(sc, real_part(z)) : real_part_p_p(sc, z)); \
}
fx_real_part_s_any(fx_real_part_s, s_lookup)
fx_real_part_s_any(fx_real_part_t, t_lookup)
#define fx_imag_part_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer z; \
z = Lookup(sc, cadr(arg), arg); \
return((is_t_complex(z)) ? make_real(sc, imag_part(z)) : imag_part_p_p(sc, z)); \
}
fx_imag_part_s_any(fx_imag_part_s, s_lookup)
fx_imag_part_s_any(fx_imag_part_t, t_lookup) /* not used in current timing tests */
#define fx_iterate_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer iter; \
iter = Lookup(sc, cadr(arg), arg); \
if (is_iterator(iter)) \
return((iterator_next(iter))(sc, iter)); \
return(method_or_bust_one_arg_p(sc, iter, sc->iterate_symbol, T_ITERATOR)); \
}
fx_iterate_s_any(fx_iterate_s, s_lookup)
fx_iterate_s_any(fx_iterate_o, o_lookup)
static s7_pointer fx_length_s(s7_scheme * sc, s7_pointer arg)
{
return (s7_length(sc, lookup(sc, cadr(arg))));
}
static s7_pointer fx_length_t(s7_scheme * sc, s7_pointer arg)
{
return (s7_length(sc, t_lookup(sc, cadr(arg), arg)));
}
static s7_pointer fx_num_eq_length_i(s7_scheme * sc, s7_pointer arg)
{
/* avoid make_integer (and telescope opts), we get here with car=length expr, cadr=int */
s7_int ilen = integer(opt2_con(cdr(arg))); /* is_t_integer checked in fx_choose */
s7_pointer val;
val = lookup(sc, opt3_sym(cdr(arg)));
switch (type(val)) {
case T_PAIR:
return (make_boolean(sc, s7_list_length(sc, val) == ilen));
case T_NIL:
return (make_boolean(sc, ilen == 0));
case T_STRING:
return (make_boolean(sc, string_length(val) == ilen));
case T_HASH_TABLE:
return (make_boolean(sc, (hash_table_mask(val) + 1) == ilen));
case T_C_OBJECT:
return (make_boolean(sc, c_object_length_to_int(sc, val) == ilen));
case T_LET:
return (make_boolean(sc, let_length(sc, val) == ilen));
case T_BYTE_VECTOR:
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
return (make_boolean(sc, vector_length(val) == ilen));
case T_ITERATOR:
{
s7_pointer len;
len = s7_length(sc, iterator_sequence(val));
return (make_boolean
(sc, (is_t_integer(len)) && (integer(len) == ilen)));
}
case T_CLOSURE:
case T_CLOSURE_STAR:
if (has_active_methods(sc, val))
return (make_boolean(sc, closure_length(sc, val) == ilen));
/* fall through */
default:
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);
}
static s7_pointer fx_less_length_i(s7_scheme * sc, s7_pointer arg)
{
s7_int ilen = integer(opt2_con(cdr(arg))); /* caddr(arg) */
s7_pointer val;
val = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg) */
switch (type(val)) {
case T_PAIR:
return (make_boolean(sc, s7_list_length(sc, val) < ilen));
case T_NIL:
return (make_boolean(sc, ilen > 0));
case T_STRING:
return (make_boolean(sc, string_length(val) < ilen));
case T_HASH_TABLE:
return (make_boolean(sc, (hash_table_mask(val) + 1) < ilen)); /* was <=? -- changed 15-Dec-15, then again 6-Jan-17: mask is len-1 */
case T_C_OBJECT:
return (make_boolean(sc, c_object_length_to_int(sc, val) < ilen));
case T_LET:
return (make_boolean(sc, let_length(sc, val) < ilen)); /* this works because let_length handles the length method itself! */
case T_BYTE_VECTOR:
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
return (make_boolean(sc, vector_length(val) < ilen));
case T_ITERATOR:
{
s7_pointer len;
len = s7_length(sc, iterator_sequence(val));
return (make_boolean
(sc, (is_t_integer(len)) && (integer(len) < ilen)));
}
case T_CLOSURE:
case T_CLOSURE_STAR:
if (has_active_methods(sc, val))
return (make_boolean(sc, closure_length(sc, val) < ilen));
/* fall through */
default:
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 fx_is_null_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_null_o(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(o_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
} /* very few hits */
static s7_pointer fx_is_null_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_null_u(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_null_v(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_null_T(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(T_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_symbol_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_symbol(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_symbol_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_symbol(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_symbol_u(s7_scheme * sc, s7_pointer arg)
{
return ((is_symbol(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_eof_s(s7_scheme * sc, s7_pointer arg)
{
return ((lookup(sc, cadr(arg)) == eof_object) ? sc->T : sc->F);
}
static s7_pointer fx_is_eof_t(s7_scheme * sc, s7_pointer arg)
{
return ((t_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F);
}
static s7_pointer fx_is_eof_u(s7_scheme * sc, s7_pointer arg)
{
return ((u_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F);
}
static s7_pointer fx_is_type_s(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean
(sc,
(uint8_t) (opt3_byte(cdr(arg))) ==
type(lookup(sc, cadr(arg)))));
}
static s7_pointer fx_is_type_t(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean
(sc,
(uint8_t) (opt3_byte(cdr(arg))) ==
type(t_lookup(sc, cadr(arg), arg))));
}
static s7_pointer fx_is_type_u(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean
(sc,
(uint8_t) (opt3_byte(cdr(arg))) ==
type(u_lookup(sc, cadr(arg), arg))));
}
#if WITH_GMP
static s7_pointer fx_is_integer_s(s7_scheme * sc, s7_pointer arg)
{
return ((s7_is_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_integer_t(s7_scheme * sc, s7_pointer arg)
{
return ((s7_is_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
#else
static s7_pointer fx_is_integer_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_t_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_integer_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_t_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
#endif
static s7_pointer fx_is_string_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_string(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_string_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_string(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_procedure_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_procedure(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_procedure_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_procedure(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_pair_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_pair_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_pair_u(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_pair_v(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_keyword_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_keyword(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_vector_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_any_vector(lookup(sc, cadr(arg)))) ? sc->T : sc->F);
}
static s7_pointer fx_is_vector_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_any_vector(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);
}
static s7_pointer fx_is_proper_list_s(s7_scheme * sc, s7_pointer arg)
{
return ((s7_is_proper_list(sc, lookup(sc, cadr(arg)))) ? sc->
T : sc->F);
}
static s7_pointer fx_not_s(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean(sc, is_false(sc, lookup(sc, cadr(arg)))));
}
static s7_pointer fx_not_t(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean(sc, is_false(sc, t_lookup(sc, cadr(arg), arg))));
}
static s7_pointer fx_not_o(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean(sc, is_false(sc, o_lookup(sc, cadr(arg), arg))));
}
static s7_pointer fx_not_is_pair_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);
}
static s7_pointer fx_not_is_pair_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);
}
static s7_pointer fx_not_is_pair_u(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);
}
static s7_pointer fx_not_is_pair_v(s7_scheme * sc, s7_pointer arg)
{
return ((is_pair(v_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);
}
static s7_pointer fx_not_is_null_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);
}
static s7_pointer fx_not_is_null_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);
}
static s7_pointer fx_not_is_null_u(s7_scheme * sc, s7_pointer arg)
{
return ((is_null(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);
}
static s7_pointer fx_not_is_symbol_s(s7_scheme * sc, s7_pointer arg)
{
return ((is_symbol(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);
}
static s7_pointer fx_not_is_symbol_t(s7_scheme * sc, s7_pointer arg)
{
return ((is_symbol(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);
}
#define fx_c_sc_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t2_1, Lookup(sc, cadr(arg), arg)); \
set_car(sc->t2_2, opt2_con(cdr(arg))); \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_sc_any(fx_c_sc, s_lookup)
fx_c_sc_any(fx_c_tc, t_lookup)
fx_c_sc_any(fx_c_uc, u_lookup) /* few hits */
fx_c_sc_any(fx_c_vc, v_lookup)
static s7_pointer fx_c_sc_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, lookup(sc, cadr(arg)),
opt2_con(cdr(arg))));
}
static s7_pointer fx_c_si_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pi_t) opt3_direct(cdr(arg))) (sc, lookup(sc, cadr(arg)),
integer(opt2_con
(cdr(arg)))));
}
static s7_pointer fx_c_ti_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pi_t) opt3_direct(cdr(arg))) (sc,
t_lookup(sc, cadr(arg),
arg),
integer(opt2_con
(cdr(arg)))));
}
static s7_pointer fx_c_tc_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc,
t_lookup(sc, cadr(arg),
arg),
opt2_con(cdr(arg))));
}
static s7_pointer fx_vector_ref_tc(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pi
(sc, t_lookup(sc, cadr(arg), arg),
integer(opt2_con(cdr(arg)))));
}
static s7_pointer fx_memq_sc(s7_scheme * sc, s7_pointer arg)
{
return (memq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));
}
static s7_pointer fx_memq_sc_3(s7_scheme * sc, s7_pointer arg)
{
return (memq_3_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));
}
static s7_pointer fx_memq_tc(s7_scheme * sc, s7_pointer arg)
{
return (memq_p_pp
(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg))));
}
static s7_pointer fx_leq_sc(s7_scheme * sc, s7_pointer arg)
{
return (leq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));
}
static s7_pointer fx_lt_sc(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));
}
static s7_pointer fx_gt_sc(s7_scheme * sc, s7_pointer arg)
{
return (gt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));
}
static s7_pointer fx_geq_sc(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));
}
#define fx_char_eq_sc_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer c; \
c = Lookup(sc, cadr(arg), arg); \
if (c == opt2_con(cdr(arg))) return(sc->T); \
if (is_character(c)) return(sc->F); \
return(method_or_bust(sc, cadr(arg), sc->char_eq_symbol, cdr(arg), T_CHARACTER, 1)); \
}
fx_char_eq_sc_any(fx_char_eq_sc, s_lookup)
fx_char_eq_sc_any(fx_char_eq_tc, t_lookup)
#define fx_c_cs_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t2_1, opt1_con(cdr(arg))); /* cadr(arg) or cadadr */ \
set_car(sc->t2_2, Lookup(sc, opt2_sym(cdr(arg)), arg)); /* caddr(arg) */ \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_cs_any(fx_c_cs, s_lookup)
fx_c_cs_any(fx_c_ct, t_lookup)
fx_c_cs_any(fx_c_cu, u_lookup)
static s7_pointer fx_c_ct_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, opt1_con(cdr(arg)),
t_lookup(sc,
opt2_sym(cdr
(arg)),
arg)));
}
static s7_pointer fx_cons_cs(s7_scheme * sc, s7_pointer arg)
{
return (cons(sc, opt1_con(cdr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_cons_ct(s7_scheme * sc, s7_pointer arg)
{
return (cons
(sc, opt1_con(cdr(arg)),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
#define fx_c_ss_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \
set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(arg)), arg)); \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_ss_any(fx_c_ss, s_lookup, s_lookup)
fx_c_ss_any(fx_c_st, s_lookup, t_lookup)
fx_c_ss_any(fx_c_ts, t_lookup, s_lookup)
fx_c_ss_any(fx_c_tu, t_lookup, u_lookup)
fx_c_ss_any(fx_c_uv, u_lookup, v_lookup)
fx_c_ss_any(fx_c_tU, t_lookup, U_lookup)
static s7_pointer fx_memq_ss(s7_scheme * sc, s7_pointer arg)
{
return (memq_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_memq_tu(s7_scheme * sc, s7_pointer arg)
{
return (memq_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
u_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_assq_ss(s7_scheme * sc, s7_pointer arg)
{
return (assq_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_vref_ss(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_vref_st(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, lookup(sc, cadr(arg)),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_vref_ts(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
s_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_vref_tu(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
u_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_vref_ot(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, o_lookup(sc, cadr(arg), arg),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_vref_gt(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, lookup_global(sc, cadr(arg)),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_string_ref_ss(s7_scheme * sc, s7_pointer arg)
{
return (string_ref_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_cons_ss(s7_scheme * sc, s7_pointer arg)
{
return (cons
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_cons_st(s7_scheme * sc, s7_pointer arg)
{
return (cons
(sc, s_lookup(sc, cadr(arg), arg),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_cons_ts(s7_scheme * sc, s7_pointer arg)
{
return (cons
(sc, t_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_cons_tU(s7_scheme * sc, s7_pointer arg)
{
return (cons
(sc, t_lookup(sc, cadr(arg), arg),
U_lookup(sc, caddr(arg), arg)));
}
#define fx_c_ss_direct_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \
}
fx_c_ss_direct_any(fx_c_ss_direct, s_lookup, s_lookup)
fx_c_ss_direct_any(fx_c_ts_direct, t_lookup, s_lookup)
fx_c_ss_direct_any(fx_c_st_direct, s_lookup, t_lookup)
fx_c_ss_direct_any(fx_c_gt_direct, g_lookup, t_lookup)
fx_c_ss_direct_any(fx_c_tU_direct, t_lookup, U_lookup)
static s7_pointer fx_multiply_ss(s7_scheme * sc, s7_pointer arg)
{
return (multiply_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_multiply_ts(s7_scheme * sc, s7_pointer arg)
{
return (multiply_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_multiply_Ts(s7_scheme * sc, s7_pointer arg)
{
return (multiply_p_pp
(sc, T_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_multiply_fs(s7_scheme * sc, s7_pointer arg)
{
return (g_mul_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg))));
}
static s7_pointer fx_multiply_sf(s7_scheme * sc, s7_pointer arg)
{
return (g_mul_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg)))));
}
static s7_pointer fx_multiply_tf(s7_scheme * sc, s7_pointer arg)
{
return (g_mul_xf
(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg)))));
}
static s7_pointer fx_multiply_si(s7_scheme * sc, s7_pointer arg)
{
return (g_mul_xi
(sc, lookup(sc, cadr(arg)), integer(opt2_con(cdr(arg)))));
}
static s7_pointer fx_multiply_is(s7_scheme * sc, s7_pointer arg)
{
return (g_mul_xi
(sc, lookup(sc, opt2_sym(cdr(arg))), integer(cadr(arg))));
}
static s7_pointer fx_multiply_tu(s7_scheme * sc, s7_pointer arg)
{
return (multiply_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
u_lookup(sc, caddr(arg), arg)));
}
static inline s7_pointer fx_sqr_1(s7_scheme * sc, s7_pointer x)
{
if (is_t_real(x))
return (make_real(sc, real(x) * real(x)));
#if WITH_GMP
return (multiply_p_pp(sc, x, x));
#else
switch (type(x)) {
#if HAVE_OVERFLOW_CHECKS
case T_INTEGER:
{
s7_int val;
if (multiply_overflow(integer(x), integer(x), &val)) {
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer sqr overflow: (* %" ld64 " %" ld64
")\n", integer(x), integer(x));
return (make_real
(sc,
(long_double) integer(x) *
(long_double) integer(x)));
}
return (make_integer(sc, val));
}
case T_RATIO:
{
s7_int num, den;
if ((multiply_overflow(numerator(x), numerator(x), &num)) ||
(multiply_overflow(denominator(x), denominator(x), &den)))
return (make_real(sc, fraction(x) * fraction(x)));
return (s7_make_ratio(sc, num, den));
}
#else
case T_INTEGER:
return (make_integer(sc, integer(x) * integer(x)));
case T_RATIO:
return (make_ratio
(sc, numerator(x) * numerator(x),
denominator(x) * denominator(x)));
#endif
case T_REAL:
return (make_real(sc, real(x) * real(x)));
case T_COMPLEX:
return (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:
return (method_or_bust_with_type_pp
(sc, x, sc->multiply_symbol, x, x, a_number_string, 1));
}
return (x);
#endif
}
static s7_pointer fx_sqr_s(s7_scheme * sc, s7_pointer arg)
{
return (fx_sqr_1(sc, lookup(sc, cadr(arg))));
}
static s7_pointer fx_sqr_t(s7_scheme * sc, s7_pointer arg)
{
return (fx_sqr_1(sc, t_lookup(sc, cadr(arg), arg)));
}
static s7_pointer fx_add_sqr_sqr(s7_scheme * sc, s7_pointer arg)
{ /* tbig -- need t case here */
sc->u = fx_sqr_1(sc, lookup(sc, car(opt1_pair(cdr(arg))))); /* cadadr(arg) */
return (add_p_pp(sc, sc->u, fx_sqr_1(sc, lookup(sc, car(opt3_pair(arg)))))); /* cadaddr(arg) */
}
static s7_pointer fx_c_s_sqr(s7_scheme * sc, s7_pointer arg)
{ /* call */
set_car(sc->t2_1, lookup(sc, cadr(arg)));
set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt2_sym(cdr(arg))))); /* cadaddr(arg) */
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_c_sqr(s7_scheme * sc, s7_pointer arg)
{ /* fb */
set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt1_sym(cdr(arg))))); /* cadaddr(arg) */
set_car(sc->t2_1, cadr(arg));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_geq_ss(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_geq_ts(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_geq_st(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, lookup(sc, cadr(arg)),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_geq_us(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, u_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_geq_vs(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, v_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_geq_tT(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
T_lookup(sc, caddr(arg), arg)));
}
static s7_pointer fx_geq_tu(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
u_lookup(sc, caddr(arg), arg)));
}
static s7_pointer fx_geq_to(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
o_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_geq_ot(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, o_lookup(sc, cadr(arg), arg),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_gt_ss(s7_scheme * sc, s7_pointer arg)
{
return (gt_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_gt_ts(s7_scheme * sc, s7_pointer arg)
{
return (gt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_gt_to(s7_scheme * sc, s7_pointer arg)
{
return (gt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
o_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_gt_tu(s7_scheme * sc, s7_pointer arg)
{
return (gt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
u_lookup(sc, caddr(arg), arg)));
}
static s7_pointer fx_gt_ut(s7_scheme * sc, s7_pointer arg)
{
return (gt_p_pp
(sc, u_lookup(sc, cadr(arg), arg),
t_lookup(sc, caddr(arg), arg)));
}
static s7_pointer fx_gt_tg(s7_scheme * sc, s7_pointer arg)
{
return (gt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
global_value(opt2_sym(cdr(arg)))));
}
static s7_pointer fx_gt_tT(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p1, p2;
p1 = t_lookup(sc, cadr(arg), arg);
p2 = T_lookup(sc, caddr(arg), arg);
return (((is_t_integer(p1))
&& (is_t_integer(p2))) ? make_boolean(sc,
integer(p1) >
integer(p2)) :
gt_p_pp(sc, p1, p2));
}
static s7_pointer fx_gt_si(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = lookup(sc, cadr(arg));
if (is_t_integer(x))
return (make_boolean
(sc, integer(x) > integer(opt2_con(cdr(arg)))));
if (is_t_real(x))
return (make_boolean(sc, real(x) > integer(opt2_con(cdr(arg)))));
return (g_greater_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */
}
static s7_pointer fx_gt_ti(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, cadr(arg), arg);
if (is_t_integer(x))
return (make_boolean
(sc, integer(x) > integer(opt2_con(cdr(arg)))));
return (g_greater_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */
}
static s7_pointer fx_leq_ss(s7_scheme * sc, s7_pointer arg)
{
return (leq_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_leq_ts(s7_scheme * sc, s7_pointer arg)
{
return (leq_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_leq_tu(s7_scheme * sc, s7_pointer arg)
{
return (leq_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
u_lookup(sc, caddr(arg), arg)));
}
static s7_pointer fx_leq_si(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = lookup(sc, cadr(arg));
if (is_t_integer(x))
return (make_boolean
(sc, integer(x) <= integer(opt2_con(cdr(arg)))));
return (g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */
}
static s7_pointer fx_leq_ti(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, cadr(arg), arg);
if (is_t_integer(x))
return (make_boolean
(sc, integer(x) <= integer(opt2_con(cdr(arg)))));
return (g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */
}
static s7_pointer fx_lt_ss(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_lt_sg(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp
(sc, lookup(sc, cadr(arg)),
lookup_global(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_lt_tg(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
lookup_global(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_lt_gsg(s7_scheme * sc, s7_pointer arg)
{
s7_pointer v1, v2, v3;
v1 = lookup_global(sc, cadr(arg));
v2 = lookup(sc, opt1_sym(cdr(arg))); /* caddr(arg) */
v3 = lookup_global(sc, opt2_sym(cdr(arg))); /* cadddr(arg) */
if ((is_t_integer(v1)) && (is_t_integer(v2)) && (is_t_integer(v3)))
return (make_boolean(sc, ((v1 < v2) && (v2 < v3))));
if (!is_real(v3))
wrong_type_argument(sc, sc->lt_symbol, 3, v3, T_REAL); /* else (< 2 1 1+i) returns #f */
return (make_boolean
(sc, (lt_b_7pp(sc, v1, v2)) && (lt_b_7pp(sc, v2, v3))));
}
static s7_pointer fx_lt_ts(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_lt_tT(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
T_lookup(sc, opt2_sym(cdr(arg)), cadr(arg))));
}
static s7_pointer fx_lt_tu(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
u_lookup(sc, caddr(arg), arg)));
}
static s7_pointer fx_lt_tU(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp
(sc, t_lookup(sc, cadr(arg), arg),
U_lookup(sc, caddr(arg), arg)));
}
static s7_pointer fx_lt_ut(s7_scheme * sc, s7_pointer arg)
{
return (lt_p_pp
(sc, u_lookup(sc, cadr(arg), arg),
t_lookup(sc, caddr(arg), arg)));
}
static s7_pointer fx_lt_tf(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, cadr(arg), arg);
if (is_t_real(x))
return (make_boolean(sc, real(x) < real(opt2_con(cdr(arg)))));
return (g_less_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */
}
#define fx_lt_si_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer x; \
x = Lookup(sc, cadr(arg), arg); \
if (is_t_integer(x)) return(make_boolean(sc, integer(x) < integer(opt2_con(cdr(arg))))); \
return(g_less_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \
}
fx_lt_si_any(fx_lt_si, s_lookup)
fx_lt_si_any(fx_lt_ti, t_lookup)
static s7_pointer fx_lt_t0(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, cadr(arg), arg);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) < 0));
return (g_less_xi(sc, set_plist_2(sc, x, int_zero)));
}
static s7_pointer fx_lt_t1(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, cadr(arg), arg);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) < 1));
return (g_less_xi(sc, set_plist_2(sc, x, int_one)));
}
static s7_pointer fx_lt_t2(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, cadr(arg), arg);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) < 2));
return (g_less_xi(sc, set_plist_2(sc, x, int_two)));
}
static s7_pointer fx_geq_tf(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, cadr(arg), arg);
if (is_t_real(x))
return (make_boolean(sc, real(x) >= real(opt2_con(cdr(arg)))));
return (g_geq_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */
}
#define fx_geq_si_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer x; \
x = Lookup(sc, cadr(arg), arg); \
if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= integer(opt2_con(cdr(arg))))); \
return(g_geq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \
}
fx_geq_si_any(fx_geq_si, s_lookup)
fx_geq_si_any(fx_geq_ti, t_lookup)
static s7_pointer fx_geq_t0(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, cadr(arg), arg);
if (is_t_integer(x))
return (make_boolean(sc, integer(x) >= 0));
return (g_geq_xi(sc, set_plist_2(sc, x, int_zero)));
}
#define fx_num_eq_ss_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer x, y; \
x = Lookup1(sc, cadr(arg), arg); \
y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \
return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y))); \
}
fx_num_eq_ss_any(fx_num_eq_ss, s_lookup, s_lookup)
fx_num_eq_ss_any(fx_num_eq_ts, t_lookup, s_lookup)
fx_num_eq_ss_any(fx_num_eq_to, t_lookup, o_lookup)
fx_num_eq_ss_any(fx_num_eq_tO, t_lookup, O_lookup)
fx_num_eq_ss_any(fx_num_eq_tg, t_lookup, g_lookup)
fx_num_eq_ss_any(fx_num_eq_tT, t_lookup, T_lookup)
fx_num_eq_ss_any(fx_num_eq_tu, t_lookup, u_lookup)
fx_num_eq_ss_any(fx_num_eq_ut, u_lookup, t_lookup)
fx_num_eq_ss_any(fx_num_eq_us, u_lookup, s_lookup)
fx_num_eq_ss_any(fx_num_eq_vs, v_lookup, s_lookup)
#define fx_is_eq_ss_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer x, y; \
x = Lookup1(sc, cadr(arg), arg); \
y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \
return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); \
}
fx_is_eq_ss_any(fx_is_eq_ss, s_lookup, s_lookup)
fx_is_eq_ss_any(fx_is_eq_ts, t_lookup, s_lookup)
fx_is_eq_ss_any(fx_is_eq_tu, t_lookup, u_lookup)
fx_is_eq_ss_any(fx_is_eq_to, t_lookup, o_lookup)
static s7_pointer fx_not_is_eq_ss(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x, y;
x = lookup(sc, opt3_sym(arg));
y = lookup(sc, opt1_sym(cdr(arg)));
return (make_boolean(sc, (x != y)
&& ((!is_unspecified(x))
|| (!is_unspecified(y)))));
}
static s7_pointer fx_not_is_eq_sq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x, y = opt3_con(cdr(arg));
x = lookup(sc, opt2_sym(cdr(arg)));
return (make_boolean(sc, (x != y)
&& ((!is_unspecified(x))
|| (!is_unspecified(y)))));
}
static s7_pointer x_hash_table_ref_ss(s7_scheme * sc, s7_pointer table,
s7_pointer key)
{
return ((is_hash_table(table)) ?
hash_entry_value((*hash_table_checker(table)) (sc, table, key))
: g_hash_table_ref(sc, set_plist_2(sc, table, key)));
}
static s7_pointer fx_hash_table_ref_ss(s7_scheme * sc, s7_pointer arg)
{
return (x_hash_table_ref_ss
(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
}
static s7_pointer fx_hash_table_ref_st(s7_scheme * sc, s7_pointer arg)
{
return (x_hash_table_ref_ss
(sc, lookup(sc, cadr(arg)),
t_lookup(sc, opt2_sym(cdr(arg)), arg)));
}
static s7_pointer fx_hash_table_ref_car(s7_scheme * sc, s7_pointer arg)
{
s7_pointer table, lst;
table = lookup(sc, cadr(arg));
lst = lookup(sc, opt2_sym(cdr(arg)));
if (!is_pair(lst))
return (simple_wrong_type_argument
(sc, sc->car_symbol, lst, T_PAIR));
return ((is_hash_table(table)) ?
hash_entry_value((*hash_table_checker(table))
(sc, table, car(lst))) : g_hash_table_ref(sc,
set_plist_2
(sc,
table,
car
(lst))));
}
static inline s7_pointer fx_hash_table_increment_1(s7_scheme * sc,
s7_pointer table,
s7_pointer key,
s7_pointer arg)
{
hash_entry_t *val;
if (!is_hash_table(table))
return (mutable_method_or_bust_ppp
(sc, table, sc->hash_table_set_symbol, table, key,
fx_call(sc, cdddr(arg)), T_HASH_TABLE, 1));
val = (*hash_table_checker(table)) (sc, table, key);
if (val != sc->unentry) {
if (!is_t_integer(hash_entry_value(val)))
simple_wrong_type_argument(sc, sc->add_symbol, cadddr(arg),
T_INTEGER);
hash_entry_set_value(val,
make_integer(sc,
integer(hash_entry_value(val)) +
1));
return (hash_entry_value(val));
}
s7_hash_table_set(sc, table, key, int_one);
return (int_one);
}
static s7_pointer fx_hash_table_increment(s7_scheme * sc, s7_pointer arg)
{
return (fx_hash_table_increment_1
(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)), arg));
}
static s7_pointer fx_lint_let_ref_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer lt, sym, y;
lt = cdr(s_lookup(sc, opt2_sym(arg), arg)); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */
if (!is_let(lt))
return (wrong_type_argument_with_type
(sc, sc->let_ref_symbol, 1, lt, a_let_string));
sym = opt2_sym(cdr(arg)); /* (let-ref (cdr v) 'ref) -> ref == opt3_sym(cdar(closure_body(opt1_lambda(arg)))); */
for (y = let_slots(lt); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == sym)
return (slot_value(y));
return (lint_let_ref_p_pp(sc, let_outlet(lt), sym));
}
static s7_pointer fx_memq_sq_2(s7_scheme * sc, s7_pointer arg)
{
s7_pointer obj, p = opt2_con(cdr(arg));
obj = lookup(sc, cadr(arg));
if (obj == car(p))
return (p);
return ((obj == cadr(p)) ? cdr(p) : sc->F);
}
static s7_pointer fx_c_cq(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t2_1, cadr(arg));
set_car(sc->t2_2, opt2_con(cdr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
#define fx_c_sss_any(Name, Lookup1, Lookup2, Lookup3) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \
set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \
set_car(sc->t3_3, Lookup3(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \
return(fn_proc(arg)(sc, sc->t3_1)); \
}
fx_c_sss_any(fx_c_sss, s_lookup, s_lookup, s_lookup)
fx_c_sss_any(fx_c_sts, s_lookup, t_lookup, s_lookup)
fx_c_sss_any(fx_c_tus, t_lookup, u_lookup, s_lookup)
fx_c_sss_any(fx_c_tuv, t_lookup, u_lookup, v_lookup)
static s7_pointer fx_c_sss_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_ppp_t) opt3_direct(cdr(arg))) (sc,
lookup(sc, cadr(arg)),
lookup(sc,
opt1_sym(cdr
(arg))),
lookup(sc,
opt2_sym(cdr
(arg)))));
}
static s7_pointer fx_vset_sts(s7_scheme * sc, s7_pointer arg)
{
return (vector_set_p_ppp
(sc, lookup(sc, cadr(arg)),
t_lookup(sc, opt1_sym(cdr(arg)), arg), lookup(sc,
opt2_sym(cdr
(arg)))));
}
static s7_pointer fx_vset_oto(s7_scheme * sc, s7_pointer arg)
{
return (vector_set_p_ppp
(sc, o_lookup(sc, cadr(arg), arg),
t_lookup(sc, opt1_sym(cdr(arg)), arg), o_lookup(sc,
opt2_sym(cdr
(arg)),
arg)));
}
#define fx_c_scs_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \
set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \
set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */ \
return(fn_proc(arg)(sc, sc->t3_1)); \
}
fx_c_scs_any(fx_c_scs, s_lookup, s_lookup)
fx_c_scs_any(fx_c_tcs, t_lookup, s_lookup)
#define fx_c_scs_direct_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), opt1_con(cdr(arg)), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \
}
fx_c_scs_direct_any(fx_c_scs_direct, s_lookup, s_lookup)
fx_c_scs_direct_any(fx_c_tcu_direct, t_lookup, u_lookup)
fx_c_scs_direct_any(fx_c_tcs_direct, t_lookup, s_lookup)
fx_c_scs_direct_any(fx_c_TcU_direct, T_lookup, U_lookup)
static s7_pointer fx_c_scc(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_1, lookup(sc, cadr(arg)));
set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */
set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */
return (fn_proc(arg) (sc, sc->t3_1));
}
#define fx_c_css_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t3_2, Lookup1(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \
set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \
set_car(sc->t3_1, cadr(arg)); \
return(fn_proc(arg)(sc, sc->t3_1)); \
}
fx_c_css_any(fx_c_css, s_lookup, s_lookup)
fx_c_css_any(fx_c_ctv, t_lookup, v_lookup)
static s7_pointer fx_c_csc(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_2, lookup(sc, opt1_sym(cdr(arg)))); /* caddr(arg) */
set_car(sc->t3_1, opt3_con(cdr(arg))); /* cadr(arg) or maybe cadadr if quoted? */
set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_ccs(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_3, lookup(sc, opt1_sym(cdr(arg)))); /* cadddr(arg) */
set_car(sc->t3_1, cadr(arg)); /* maybe opt3_con? */
set_car(sc->t3_2, opt2_con(cdr(arg))); /* caddr(arg) */
return (fn_proc(arg) (sc, sc->t3_1));
}
#define fx_c_ssc_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \
set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \
set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ \
return(fn_proc(arg)(sc, sc->t3_1)); \
}
fx_c_ssc_any(fx_c_ssc, s_lookup, s_lookup)
fx_c_ssc_any(fx_c_tuc, t_lookup, u_lookup)
static s7_pointer fx_c_opncq(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t1_1, fc_call(sc, cadr(arg)));
return (fn_proc(arg) (sc, sc->t1_1));
}
#define fx_c_opsq_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer largs = cadr(arg); \
set_car(sc->t1_1, Lookup(sc, cadr(largs), largs)); \
set_car(sc->t1_1, fn_proc(largs)(sc, sc->t1_1)); \
return(fn_proc(arg)(sc, sc->t1_1)); \
}
fx_c_opsq_any(fx_c_opsq, s_lookup)
fx_c_opsq_any(fx_c_optq, t_lookup)
static s7_pointer fx_c_optq_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc, ((s7_p_p_t)
opt3_direct(cdr(arg)))
(sc,
t_lookup(sc,
opt1_sym(cdr
(arg)),
arg))));
}
#define fx_c_car_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer val; \
val = Lookup(sc, opt2_sym(cdr(arg)), arg); \
set_car(sc->t1_1, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \
return(fn_proc(arg)(sc, sc->t1_1)); \
}
fx_c_car_s_any(fx_c_car_s, s_lookup)
fx_c_car_s_any(fx_c_car_t, t_lookup)
fx_c_car_s_any(fx_c_car_u, u_lookup)
#define fx_c_cdr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer val; \
val = Lookup(sc, opt2_sym(cdr(arg)), arg); \
set_car(sc->t1_1, (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \
return(fn_proc(arg)(sc, sc->t1_1)); \
}
fx_c_cdr_s_any(fx_c_cdr_s, s_lookup)
fx_c_cdr_s_any(fx_c_cdr_t, t_lookup)
#define fx_is_type_opsq_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t1_1, Lookup(sc, opt2_sym(cdr(arg)), arg)); \
return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(fn_proc(cadr(arg))(sc, sc->t1_1)))); \
}
fx_is_type_opsq_any(fx_is_type_opsq, s_lookup)
fx_is_type_opsq_any(fx_is_type_optq, t_lookup)
static s7_pointer fx_is_type_car_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = lookup(sc, opt2_sym(cdr(arg)));
return (make_boolean(sc, (is_pair(val)) ?
((uint8_t) (opt3_byte(cdr(arg))) ==
type(car(val)))
: ((uint8_t) (opt3_byte(cdr(arg))) ==
type(g_car(sc, set_plist_1(sc, val))))));
}
static s7_pointer fx_is_type_car_t(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = t_lookup(sc, opt2_sym(cdr(arg)), arg);
if (is_pair(val))
return (make_boolean
(sc, (uint8_t) (opt3_byte(cdr(arg))) == type(car(val))));
if (has_active_methods(sc, val)) { /* this verbosity saves 1/3 total compute time (overhead!) */
s7_pointer func;
func = find_method_with_let(sc, val, sc->car_symbol);
if (func != sc->undefined)
return (make_boolean
(sc,
type(call_method(sc, val, func, set_plist_1(sc, val)))
== (uint8_t) opt3_byte(cdr(arg))));
}
return (wrong_type_argument(sc, sc->car_symbol, 1, val, T_PAIR));
}
static s7_pointer fx_eq_weak1_type_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = lookup(sc, opt2_sym(cdr(arg)));
if (is_c_pointer(val)) /* (let? (c-pointer-weak1 val)) etc */
return (make_boolean
(sc,
(uint8_t) (opt3_byte(cdr(arg))) ==
type(c_pointer_weak1(val))));
if (has_active_methods(sc, val)) { /* calling g_c_pointer_weak1 here instead is much slower, error by itself is much faster! splitting out does not help */
s7_pointer func;
func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol);
if (func != sc->undefined)
return (make_boolean
(sc,
type(call_method(sc, val, func, set_plist_1(sc, val)))
== (uint8_t) opt3_byte(cdr(arg))));
}
return (wrong_type_argument
(sc, sc->c_pointer_weak1_symbol, 1, val, T_C_POINTER));
}
static s7_pointer fx_not_opsq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cadr(arg);
set_car(sc->t1_1, lookup(sc, cadr(largs)));
return ((fn_proc(largs) (sc, sc->t1_1) == sc->F) ? sc->T : sc->F);
}
#define fx_c_opssq_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t2_1, Lookup1(sc, opt3_sym(arg), arg)); \
set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* or opt2_sym */ \
set_car(sc->t1_1, fn_proc(cadr(arg))(sc, sc->t2_1)); \
return(fn_proc(arg)(sc, sc->t1_1)); \
}
fx_c_opssq_any(fx_c_opssq, s_lookup, s_lookup)
fx_c_opssq_any(fx_c_optuq, t_lookup, u_lookup)
fx_c_opssq_any(fx_c_opstq, s_lookup, t_lookup)
#define fx_c_opssq_direct_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt3_sym(arg), arg), Lookup2(sc, opt1_sym(cdr(arg)), arg)))); \
}
fx_c_opssq_direct_any(fx_c_opssq_direct, s_lookup, s_lookup)
fx_c_opssq_direct_any(fx_c_opstq_direct, s_lookup, t_lookup)
fx_c_opssq_direct_any(fx_c_optuq_direct, t_lookup, u_lookup)
#define fx_not_opssq_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer larg = cadr(arg); \
set_car(sc->t2_1, Lookup1(sc, cadr(larg), larg)); \
set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(larg)), larg)); \
return((fn_proc(larg)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); \
}
fx_not_opssq_any(fx_not_opssq, s_lookup, s_lookup)
fx_not_opssq_any(fx_not_oputq, u_lookup, t_lookup)
static s7_pointer fx_not_lt_ut(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x, y;
y = u_lookup(sc, opt3_sym(arg), arg);
x = t_lookup(sc, opt1_sym(cdr(arg)), arg);
return (make_boolean(sc, ((is_t_integer(x))
&& (is_t_integer(y))) ? (integer(y) >=
integer(x)) :
geq_b_7pp(sc, y, x)));
}
static s7_pointer fx_is_zero_remainder_car(s7_scheme * sc, s7_pointer arg)
{
s7_pointer u, t;
u = u_lookup(sc, opt3_sym(arg), arg);
u = (is_pair(u)) ? car(u) : g_car(sc, set_plist_1(sc, u)); /* g_car much less overhead than car_p_p or simple_error(?) */
t = t_lookup(sc, opt1_sym(cdr(arg)), arg);
if ((is_t_integer(u)) && (is_t_integer(t)))
return (make_boolean
(sc, remainder_i_7ii(sc, integer(u), integer(t)) == 0));
return (make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, u, t))));
}
static s7_pointer fx_is_zero_remainder_o(s7_scheme * sc, s7_pointer arg)
{
s7_pointer s, t;
s = o_lookup(sc, opt3_sym(arg), arg);
t = t_lookup(sc, opt1_sym(cdr(arg)), arg);
if ((is_t_integer(s)) && (is_t_integer(t)))
return (make_boolean
(sc, remainder_i_7ii(sc, integer(s), integer(t)) == 0));
return (make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, s, t))));
}
#define fx_c_opscq_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer largs = cadr(arg); \
set_car(sc->t2_1, Lookup(sc, cadr(largs), largs)); \
set_car(sc->t2_2, opt2_con(cdr(largs))); \
set_car(sc->t1_1, fn_proc(largs)(sc, sc->t2_1)); \
return(fn_proc(arg)(sc, sc->t1_1)); \
}
fx_c_opscq_any(fx_c_opscq, s_lookup)
fx_c_opscq_any(fx_c_optcq, t_lookup)
static s7_pointer fx_not_opscq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cadr(arg);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, opt2_con(cdr(largs)));
return ((fn_proc(largs) (sc, sc->t2_1) == sc->F) ? sc->T : sc->F);
}
static s7_pointer fx_c_opcsq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cadr(arg);
set_car(sc->t2_2, lookup(sc, caddr(largs)));
set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */
set_car(sc->t1_1, fn_proc(largs) (sc, sc->t2_1));
return (fn_proc(arg) (sc, sc->t1_1));
}
static s7_pointer fx_c_opcsq_c(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cadr(arg);
set_car(sc->t2_2, lookup(sc, caddr(largs)));
set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */
set_car(sc->t2_1, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_2, caddr(arg));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_opcsq_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cadr(arg);
set_car(sc->t2_2, lookup(sc, caddr(largs)));
set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */
set_car(sc->t2_1, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_2, lookup(sc, caddr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_opssq_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cadr(arg);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs))));
set_car(sc->t2_1, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_2, lookup(sc, caddr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_opssq_s_direct(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */
return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, ((s7_p_pp_t)
opt3_direct(cdr
(arg)))
(sc,
lookup(sc, car(largs)),
lookup(sc,
opt2_sym(largs))),
lookup(sc, caddr(arg))));
}
static s7_pointer fx_add_mul_opssq_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = opt3_pair(arg), a, b, c; /* cdadr(arg) */
a = lookup(sc, car(largs));
b = lookup(sc, opt2_sym(largs));
c = lookup(sc, caddr(arg));
if ((is_t_integer(a)) && (is_t_integer(b)) && (is_t_integer(c)))
#if HAVE_OVERFLOW_CHECKS
{
s7_int val;
if ((multiply_overflow(integer(a), integer(b), &val)) ||
(add_overflow(val, integer(c), &val))) {
if (WITH_WARNINGS)
s7_warn(sc, 128,
"integer multiply/add overflow: (+ (* %" ld64 " %"
ld64 ") %" ld64 ")\n", integer(a), integer(b),
integer(c));
return (make_real
(sc,
((long_double) integer(a) *
(long_double) integer(b)) +
(long_double) integer(c)));
}
return (make_integer(sc, val));
}
#else
return (make_integer(sc, (integer(a) * integer(b)) + integer(c)));
#endif
return (add_p_pp(sc, multiply_p_pp(sc, a, b), c));
}
static s7_pointer fx_add_vref_s(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc,
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg)))),
lookup(sc, caddr(arg))));
}
static s7_pointer fx_add_s_vref(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc, lookup(sc, cadr(arg)),
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg))))));
}
static s7_pointer fx_subtract_vref_s(s7_scheme * sc, s7_pointer arg)
{
return (subtract_p_pp
(sc,
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg)))),
lookup(sc, caddr(arg))));
}
static s7_pointer fx_subtract_s_vref(s7_scheme * sc, s7_pointer arg)
{
return (subtract_p_pp
(sc, lookup(sc, cadr(arg)),
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg))))));
}
static s7_pointer fx_multiply_s_vref(s7_scheme * sc, s7_pointer arg)
{
return (multiply_p_pp
(sc, lookup(sc, cadr(arg)),
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg))))));
}
static s7_pointer fx_cons_cons_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */
return (cons_unchecked
(sc,
cons(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))),
lookup(sc, caddr(arg))));
}
#define fx_add_sqr_s_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p1, p3; \
p1 = Lookup(sc, car(opt3_pair(arg)), arg); \
p3 = lookup(sc, caddr(arg)); \
if ((is_t_complex(p1)) && (is_t_complex(p3))) \
{ \
s7_double r = real_part(p1), i = imag_part(p1); \
return(make_complex(sc, real_part(p3) + r * r - i * i, imag_part(p3) + 2.0 * r * i)); \
} \
return(add_p_pp(sc, fx_sqr_1(sc, p1), p3)); \
}
fx_add_sqr_s_any(fx_add_sqr_s, s_lookup)
fx_add_sqr_s_any(fx_add_sqr_T, T_lookup)
static s7_pointer fx_add_sub_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p1, p2, p3, largs = opt3_pair(arg); /* cdadr(arg) */
p1 = lookup(sc, car(largs));
p2 = lookup(sc, opt2_sym(largs));
p3 = lookup(sc, caddr(arg));
if ((is_t_real(p1)) && (is_t_real(p2)) && (is_t_real(p3)))
return (make_real(sc, real(p3) + real(p1) - real(p2)));
return (add_p_pp(sc, subtract_p_pp(sc, p1, p2), p3));
}
static s7_pointer fx_gt_add_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x1, x2, x3, largs = opt3_pair(arg); /* cdadr(arg) */
x1 = lookup(sc, car(largs));
x2 = lookup(sc, opt2_sym(largs));
x3 = lookup(sc, caddr(arg));
if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3)))
return (make_boolean(sc, (real(x1) + real(x2)) > real(x3)));
return (gt_p_pp(sc, add_p_pp(sc, x1, x2), x3));
}
static s7_pointer fx_gt_vref_s(s7_scheme * sc, s7_pointer arg)
{
return (gt_p_pp
(sc,
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg)))),
lookup(sc, caddr(arg))));
}
static s7_pointer fx_geq_s_vref(s7_scheme * sc, s7_pointer arg)
{
return (geq_p_pp
(sc, lookup(sc, cadr(arg)),
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg))))));
}
static s7_pointer fx_is_eq_s_vref(s7_scheme * sc, s7_pointer arg)
{
return (make_boolean
(sc,
lookup(sc, cadr(arg)) == vector_ref_p_pp(sc,
lookup(sc,
car(opt3_pair
(arg))),
lookup(sc,
opt2_sym
(opt3_pair
(arg))))));
}
static s7_pointer fx_href_s_vref(s7_scheme * sc, s7_pointer arg)
{
return (hash_table_ref_p_pp
(sc, lookup(sc, cadr(arg)),
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg))))));
}
static s7_pointer fx_lref_s_vref(s7_scheme * sc, s7_pointer arg)
{
return (s7_let_ref
(sc, lookup(sc, cadr(arg)),
vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg))))));
}
static s7_pointer fx_vref_s_add(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, lookup(sc, cadr(arg)),
add_p_pp(sc, lookup(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg))))));
}
static inline s7_pointer fx_vref_vref_3(s7_scheme * sc, s7_pointer v1,
s7_pointer p1, s7_pointer p2)
{
if ((is_t_integer(p1)) && (is_t_integer(p2))
&& ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) {
s7_int i1 = integer(p1), i2 = integer(p2);
if ((i1 >= 0) && (i2 >= 0) && (i1 < vector_length(v1))) {
s7_pointer v2 = vector_element(v1, i1);
if ((is_normal_vector(v2)) && (vector_rank(v2) == 1)
&& (i2 < vector_length(v2)))
return (vector_element(v2, i2));
}
}
return (vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p1), p2));
}
#define fx_vref_vref_ss_s_any(Name, Lookup1, Lookup2, Lookup3) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return(fx_vref_vref_3(sc, Lookup1(sc, car(opt3_pair(arg)), arg), Lookup2(sc, opt2_sym(opt3_pair(arg)), arg), Lookup3(sc, caddr(arg), arg))); \
}
fx_vref_vref_ss_s_any(fx_vref_vref_ss_s, s_lookup, s_lookup, s_lookup)
fx_vref_vref_ss_s_any(fx_vref_vref_gs_t, g_lookup, s_lookup, t_lookup)
fx_vref_vref_ss_s_any(fx_vref_vref_go_t, g_lookup, o_lookup, t_lookup)
fx_vref_vref_ss_s_any(fx_vref_vref_tu_v, t_lookup, u_lookup, v_lookup)
static s7_pointer fx_vref_vref_3_no_let(s7_scheme * sc, s7_pointer code)
{ /* out one level from vref_vref_tu_v */
return (fx_vref_vref_3
(sc, lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)),
lookup(sc, opt3_sym(code))));
}
static s7_pointer fx_c_opscq_c(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cadr(arg);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, opt2_con(cdr(largs)));
set_car(sc->t2_1, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_2, caddr(arg));
return (fn_proc(arg) (sc, sc->t2_1));
}
#define fx_c_opssq_c_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer largs = cadr(arg); \
set_car(sc->t2_1, Lookup1(sc, cadr(largs), largs)); \
set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(largs)), largs)); \
set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); \
set_car(sc->t2_2, opt3_con(cdr(arg))); /* caddr */ \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_opssq_c_any(fx_c_opssq_c, s_lookup, s_lookup)
fx_c_opssq_c_any(fx_c_opstq_c, s_lookup, t_lookup)
static s7_pointer fx_c_opstq_c_direct(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cadr(arg);
return (((s7_p_pp_t) opt3_direct(arg)) (sc,
fn_proc(largs) (sc,
set_plist_2(sc,
lookup
(sc,
cadr
(largs)),
t_lookup
(sc,
caddr
(largs),
arg))),
opt3_con(cdr(arg))));
}
static s7_pointer fx_is_eq_vref_opotq_c(s7_scheme * sc, s7_pointer arg)
{ /* experiment, (eqv? <> char) is <>==char without error checks? */
s7_pointer largs = cdadr(arg);
return (make_boolean
(sc,
vector_ref_p_pp(sc, o_lookup(sc, car(largs), largs),
t_lookup(sc, cadr(largs),
arg)) == opt3_con(cdr(arg))));
}
#define fx_c_opsq_s_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer largs = cadr(arg); \
set_car(sc->t1_1, Lookup1(sc, cadr(largs), arg)); /* also opt1_sym(cdr(arg)) */ \
set_car(sc->t2_1, fn_proc(largs)(sc, sc->t1_1)); \
set_car(sc->t2_2, Lookup2(sc, opt3_sym(arg), arg)); /* caddr(arg) */ \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_opsq_s_any(fx_c_opsq_s, s_lookup, s_lookup)
fx_c_opsq_s_any(fx_c_optq_s, t_lookup, s_lookup)
fx_c_opsq_s_any(fx_c_opuq_t, u_lookup, t_lookup)
#define fx_c_opsq_s_direct_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, \
((s7_p_p_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt1_sym(cdr(arg)), arg)), \
Lookup2(sc, opt3_sym(arg), arg))); \
}
fx_c_opsq_s_direct_any(fx_c_opsq_s_direct, s_lookup, s_lookup)
fx_c_opsq_s_direct_any(fx_c_optq_s_direct, t_lookup, s_lookup)
fx_c_opsq_s_direct_any(fx_c_opuq_t_direct, u_lookup, t_lookup)
#define fx_cons_car_s_s_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p; \
p = Lookup1(sc, opt1_sym(cdr(arg)), arg); \
if (is_pair(p)) return(cons(sc, car(p), Lookup2(sc, opt3_sym(arg), arg))); \
return(cons(sc, car_p_p(sc, p), Lookup2(sc, opt3_sym(arg), arg))); \
}
fx_cons_car_s_s_any(fx_cons_car_s_s, s_lookup, s_lookup)
fx_cons_car_s_s_any(fx_cons_car_t_s, t_lookup, s_lookup)
fx_cons_car_s_s_any(fx_cons_car_t_v, t_lookup, v_lookup)
fx_cons_car_s_s_any(fx_cons_car_u_t, u_lookup, t_lookup)
static s7_pointer fx_cons_opuq_t(s7_scheme * sc, s7_pointer arg)
{
return (cons
(sc,
((s7_p_p_t) opt3_direct(cdr(arg))) (sc,
u_lookup(sc,
opt1_sym(cdr
(arg)),
arg)),
t_lookup(sc, opt3_sym(arg), arg)));
}
#define fx_c_opsq_cs_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t1_1, Lookup1(sc, opt3_sym(cdr(arg)), arg)); /* cadadr(arg); */ \
set_car(sc->t3_1, fn_proc(cadr(arg))(sc, sc->t1_1)); \
set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadaddr(arg) */ \
set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg); */ \
return(fn_proc(arg)(sc, sc->t3_1)); \
}
fx_c_opsq_cs_any(fx_c_opsq_cs, s_lookup, s_lookup)
fx_c_opsq_cs_any(fx_c_optq_cu, t_lookup, u_lookup)
#define fx_c_opsq_c_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t1_1, Lookup(sc, opt1_sym(cdr(arg)), arg)); /* cadadr */ \
set_car(sc->t2_1, fn_proc(cadr(arg))(sc, sc->t1_1)); \
set_car(sc->t2_2, opt2_con(cdr(arg))); \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_opsq_c_any(fx_c_opsq_c, s_lookup)
fx_c_opsq_c_any(fx_c_optq_c, t_lookup)
static s7_pointer fx_c_optq_c_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt3_direct(arg)) (sc, ((s7_p_p_t)
opt3_direct(cdr(arg)))
(sc,
t_lookup(sc,
opt1_sym(cdr(arg)),
arg)),
opt2_con(cdr(arg))));
}
static s7_pointer fx_c_optq_i_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_ii_t) opt3_direct(arg)) (sc, ((s7_i_7p_t)
opt3_direct(cdr(arg)))
(sc,
t_lookup(sc,
opt1_sym(cdr(arg)),
arg)),
integer(opt2_con(cdr(arg)))));
}
static s7_pointer fx_memq_car_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x, obj;
obj = lookup(sc, opt1_sym(cdr(arg)));
obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj));
x = opt2_con(cdr(arg));
while (true) {
LOOP_4(if (obj == car(x)) return (x); x = cdr(x);
if (!is_pair(x)) return (sc->F));
}
return (sc->F);
}
static s7_pointer fx_memq_car_s_2(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x, obj;
obj = lookup(sc, opt1_sym(cdr(arg)));
obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj));
x = opt2_con(cdr(arg));
if (obj == car(x))
return (x);
return ((obj == cadr(x)) ? cdr(x) : sc->F);
}
static s7_pointer fx_c_s_opssq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = caddr(arg);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs))));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_1, lookup(sc, cadr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
#define fx_c_s_opssq_direct_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer largs = opt3_pair(arg); /* cdaddr(arg) */ \
arg = cdr(arg); \
return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), Lookup2(sc, opt2_sym(largs), largs)))); \
}
fx_c_s_opssq_direct_any(fx_c_s_opssq_direct, s_lookup, s_lookup)
fx_c_s_opssq_direct_any(fx_c_s_opstq_direct, s_lookup, t_lookup)
fx_c_s_opssq_direct_any(fx_c_t_opsuq_direct, t_lookup, u_lookup)
static s7_pointer fx_vref_g_vref_gs(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, lookup_global(sc, cadr(arg)),
vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))),
lookup(sc, opt2_sym(opt3_pair(arg))))));
}
static s7_pointer fx_vref_g_vref_gt(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, lookup_global(sc, cadr(arg)),
vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))),
t_lookup(sc, opt2_sym(opt3_pair(arg)),
arg))));
}
static s7_pointer fx_c_c_opssq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = caddr(arg);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs))));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_1, cadr(arg)); /* currently (<safe-f> 'a <opssq>) goes to safe_c_ca so this works by inadvertence */
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_c_opssq_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, cadr(arg), /* see above */
((s7_p_pp_t)
opt3_direct(cdr(arg)))
(sc,
lookup(sc,
opt3_sym(arg)),
lookup(sc,
opt1_sym(cdr
(arg))))));
}
static s7_pointer fx_c_nc_opssq_direct(s7_scheme * sc, s7_pointer arg)
{ /* clm2xen (* 1.0 (oscil g2 x2)) */
s7_double x2;
x2 = ((s7_d_pd_t) opt3_direct(cdr(arg))) (lookup(sc, opt3_sym(arg)),
real_to_double(sc,
lookup(sc,
opt1_sym
(cdr
(arg))),
"number_to_double"));
return (((s7_p_dd_t) opt2_direct(cdr(arg))) (sc,
real_to_double(sc,
cadr(arg),
"*"), x2));
}
static s7_pointer fx_multiply_c_opssq(s7_scheme * sc, s7_pointer arg)
{ /* (* c=float (* x1 x2))! */
s7_pointer x1, x2;
x1 = lookup(sc, opt3_sym(arg));
x2 = lookup(sc, opt1_sym(cdr(arg)));
if ((is_t_real(x1)) && (is_t_real(x2)))
return (make_real(sc, real(cadr(arg)) * real(x1) * real(x2)));
return (multiply_p_pp(sc, cadr(arg), multiply_p_pp(sc, x1, x2)));
}
static s7_pointer fx_c_s_opscq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = caddr(arg);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, opt2_con(cdr(largs)));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_1, lookup(sc, cadr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_s_opscq_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, lookup(sc, cadr(arg)),
((s7_p_pp_t)
opt3_direct(cdr(arg)))
(sc,
lookup(sc,
opt3_sym(arg)),
opt1_con(cdr(arg)))));
}
static s7_pointer fx_c_s_opsiq_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, lookup(sc, cadr(arg)),
((s7_p_pi_t)
opt3_direct(cdr(arg)))
(sc,
lookup(sc,
opt3_sym(arg)),
integer(opt1_con
(cdr(arg))))));
}
static s7_pointer fx_c_t_opoiq_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc,
t_lookup(sc, cadr(arg),
arg),
((s7_p_pi_t)
opt3_direct(cdr(arg)))
(sc,
o_lookup(sc,
opt3_sym(arg),
arg),
integer(opt1_con
(cdr(arg))))));
}
static s7_pointer fx_vref_p1(s7_scheme * sc, s7_pointer arg)
{
s7_pointer v, i;
i = lookup(sc, opt3_sym(arg));
v = lookup(sc, cadr(arg));
if ((is_t_integer(i)) && (is_normal_vector(v))
&& (vector_rank(v) == 1)) {
s7_int index = integer(i) + 1;
if ((index >= 0) && (vector_length(v) > index))
return (vector_element(v, index));
}
return (vector_ref_p_pp(sc, v, g_add_xi(sc, i, 1)));
}
static s7_pointer fx_num_eq_add_s_si(s7_scheme * sc, s7_pointer arg)
{
s7_pointer i1, i2;
i1 = lookup(sc, cadr(arg));
i2 = lookup(sc, opt3_sym(arg));
if ((is_t_integer(i1)) && (is_t_integer(i2)))
return (make_boolean
(sc,
integer(i1) ==
(integer(i2) + integer(opt1_con(cdr(arg))))));
return (make_boolean
(sc,
num_eq_b_7pp(sc, i1,
g_add_xi(sc, i2, integer(opt1_con(cdr(arg)))))));
}
static s7_pointer fx_num_eq_subtract_s_si(s7_scheme * sc, s7_pointer arg)
{
s7_pointer i1, i2;
i1 = lookup(sc, cadr(arg));
i2 = lookup(sc, opt3_sym(arg));
if ((is_t_integer(i1)) && (is_t_integer(i2)))
return (make_boolean
(sc,
integer(i1) ==
(integer(i2) - integer(opt1_con(cdr(arg))))));
return (make_boolean
(sc,
num_eq_b_7pp(sc, i1,
g_sub_xi(sc, i2, integer(opt1_con(cdr(arg)))))));
}
#define fx_c_t_opscq_direct_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), \
((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), opt1_con(cdr(arg))))); \
}
fx_c_t_opscq_direct_any(fx_c_t_opscq_direct, s_lookup)
fx_c_t_opscq_direct_any(fx_c_t_opucq_direct, u_lookup)
static s7_pointer fx_c_s_opsq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = caddr(arg);
set_car(sc->t1_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t1_1));
set_car(sc->t2_1, lookup(sc, cadr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
#define fx_c_s_opsq_direct_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
arg = cdr(arg); \
return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), ((s7_p_p_t)opt3_direct(arg))(sc, Lookup2(sc, opt1_sym(arg), arg)))); /* cadadr */ \
}
fx_c_s_opsq_direct_any(fx_c_s_opsq_direct, s_lookup, s_lookup)
fx_c_s_opsq_direct_any(fx_c_t_opuq_direct, t_lookup, u_lookup)
fx_c_s_opsq_direct_any(fx_c_u_opvq_direct, u_lookup, v_lookup)
#define fx_c_s_car_s_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer val; \
val = Lookup2(sc, opt2_sym(cdr(arg)), arg); \
set_car(sc->t2_2, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \
set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_s_car_s_any(fx_c_s_car_s, s_lookup, s_lookup)
fx_c_s_car_s_any(fx_c_s_car_t, s_lookup, t_lookup)
fx_c_s_car_s_any(fx_c_t_car_u, t_lookup, u_lookup)
fx_c_s_car_s_any(fx_c_t_car_v, t_lookup, v_lookup)
#define fx_add_s_car_s_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer val1, val2; \
val2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); \
val2 = (is_pair(val2)) ? car(val2) : g_car(sc, set_plist_1(sc, val2)); \
val1 = Lookup1(sc, cadr(arg), arg); \
return(((is_t_integer(val1)) && (is_t_integer(val2))) ? make_integer(sc, integer(val1) + integer(val2)) : add_p_pp(sc, val1, val2)); \
}
fx_add_s_car_s_any(fx_add_s_car_s, s_lookup, s_lookup)
fx_add_s_car_s_any(fx_add_u_car_t, u_lookup, t_lookup)
fx_add_s_car_s_any(fx_add_t_car_v, t_lookup, v_lookup)
static s7_pointer fx_cons_s_cdr_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = lookup(sc, opt2_sym(cdr(arg)));
val = (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val));
return (cons(sc, lookup(sc, cadr(arg)), val));
}
static s7_pointer fx_c_op_s_opsqq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer outer = cadr(arg), args;
args = caddr(outer);
set_car(sc->t1_1, lookup(sc, cadr(args)));
set_car(sc->t2_2, fn_proc(args) (sc, sc->t1_1));
set_car(sc->t2_1, lookup(sc, cadr(outer)));
set_car(sc->t1_1, fn_proc(outer) (sc, sc->t2_1));
return (fn_proc(arg) (sc, sc->t1_1));
}
static s7_pointer fx_not_op_s_opsqq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer outer = cadr(arg), args;
args = caddr(outer);
set_car(sc->t1_1, lookup(sc, cadr(args)));
set_car(sc->t2_2, fn_proc(args) (sc, sc->t1_1));
set_car(sc->t2_1, lookup(sc, cadr(outer)));
return (((fn_proc(outer) (sc, sc->t2_1)) == sc->F) ? sc->T : sc->F);
}
static s7_pointer fx_c_op_opsq_sq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer outer = cadr(arg), args;
args = cadr(outer);
set_car(sc->t1_1, lookup(sc, cadr(args)));
set_car(sc->t2_1, fn_proc(args) (sc, sc->t1_1));
set_car(sc->t2_2, lookup(sc, caddr(outer)));
set_car(sc->t1_1, fn_proc(outer) (sc, sc->t2_1));
return (fn_proc(arg) (sc, sc->t1_1));
}
static s7_pointer fx_not_op_optq_sq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer outer = cadr(arg), args;
args = cadr(outer);
set_car(sc->t1_1, t_lookup(sc, cadr(args), arg));
set_car(sc->t2_1, fn_proc(args) (sc, sc->t1_1));
set_car(sc->t2_2, lookup(sc, caddr(outer)));
return ((fn_proc(outer) (sc, sc->t2_1) == sc->F) ? sc->T : sc->F);
}
static s7_pointer fx_c_c_opsq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = opt3_pair(arg); /* caddr(arg); */
set_car(sc->t1_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t1_1));
set_car(sc->t2_1, cadr(arg));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_c_opsq_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, cadr(arg), ((s7_p_p_t)
opt3_direct
(cdr
(arg)))
(sc,
lookup(sc,
opt1_sym(cdr
(arg))))));
}
static s7_pointer fx_c_opsq_opsq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cdr(arg);
set_car(sc->t1_1, lookup(sc, cadar(largs)));
gc_protect_via_stack(sc, fn_proc(car(largs)) (sc, sc->t1_1));
largs = cadr(largs);
set_car(sc->t1_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t1_1));
set_car(sc->t2_1, stack_protected1(sc));
unstack(sc);
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_opsq_opsq_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt3_direct(arg)) (sc, ((s7_p_p_t) opt2_direct(cdr(arg))) (sc, lookup(sc, cadadr(arg))), /* no free field in arg or cdr(arg) */
((s7_p_p_t) opt3_direct(cdr(arg))) (sc, lookup(sc, opt1_sym(cdr(arg)))))); /* cadaddr(arg) */
}
static s7_pointer fx_c_optq_optq_direct(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* cadadr and cadaddr */
return (((s7_p_pp_t) opt3_direct(arg)) (sc, ((s7_p_p_t)
opt2_direct(cdr(arg)))
(sc, x), ((s7_p_p_t)
opt3_direct(cdr
(arg)))
(sc, x)));
}
#define fx_car_s_car_s_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
s7_pointer p1, p2; \
p1 = Lookup1(sc, opt1_sym(cdr(arg)), arg); \
p2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); /* cadaddr(arg) */ \
return(((s7_p_pp_t)opt3_direct(arg))(sc, (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)), (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2)))); \
}
fx_car_s_car_s_any(fx_car_s_car_s, s_lookup, s_lookup)
fx_car_s_car_s_any(fx_car_t_car_u, t_lookup, u_lookup)
static s7_pointer fx_cdr_s_cdr_s(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p1, p2;
p1 = lookup(sc, opt1_sym(cdr(arg)));
p2 = lookup(sc, opt2_sym(cdr(arg))); /* cadaddr(arg) */
return (((s7_p_pp_t) opt3_direct(arg)) (sc,
(is_pair(p1)) ? cdr(p1) :
g_cdr(sc, set_plist_1(sc, p1)),
(is_pair(p2)) ? cdr(p2) :
g_cdr(sc,
set_plist_1(sc, p2))));
}
static s7_pointer fx_is_eq_car_car_tu(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p1, p2;
p1 = t_lookup(sc, opt1_sym(cdr(arg)), arg);
p1 = (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1));
p2 = u_lookup(sc, opt2_sym(cdr(arg)), arg);
p2 = (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2));
return (make_boolean(sc, (p1 == p2)
|| ((is_unspecified(p1))
&& (is_unspecified(p2)))));
}
static s7_pointer fx_c_opsq_opssq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cdr(arg);
set_car(sc->t1_1, lookup(sc, cadar(largs)));
gc_protect_via_stack(sc, fn_proc(car(largs)) (sc, sc->t1_1));
largs = cadr(largs);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); /* caddr(largs) */
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_1, stack_protected1(sc));
unstack(sc);
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_opsq_optuq_direct(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cdr(arg);
return (((s7_p_pp_t) opt3_direct(arg)) (sc, ((s7_p_p_t)
opt2_direct(largs)) (sc,
lookup
(sc,
cadar
(largs))),
((s7_p_pp_t)
opt3_direct(largs)) (sc,
t_lookup
(sc,
opt2_sym
(cdr
(largs)),
arg),
u_lookup
(sc,
opt1_sym
(largs),
arg))));
}
static s7_pointer fx_num_eq_car_v_add_tu(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p1, p2, p3;
p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg));
p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg);
p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg);
if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3)))
return (make_boolean
(sc, integer(p1) == (integer(p2) + integer(p3))));
return (make_boolean(sc, num_eq_b_7pp(sc, p1, add_p_pp(sc, p2, p3))));
}
static s7_pointer fx_num_eq_car_v_subtract_tu(s7_scheme * sc,
s7_pointer arg)
{
s7_pointer p1, p2, p3;
p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg));
p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg);
p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg);
if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3)))
return (make_boolean
(sc, integer(p1) == (integer(p2) - integer(p3))));
return (make_boolean
(sc, num_eq_b_7pp(sc, p1, subtract_p_pp(sc, p2, p3))));
}
static s7_pointer fx_c_opssq_opsq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cdr(arg);
set_car(sc->t2_1, lookup(sc, cadar(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs))));
gc_protect_via_stack(sc, fn_proc(car(largs)) (sc, sc->t2_1));
largs = cadr(largs);
set_car(sc->t1_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t1_1));
set_car(sc->t2_1, stack_protected1(sc));
unstack(sc);
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_opssq_opssq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = cdr(arg);
set_car(sc->t2_1, lookup(sc, cadar(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs))));
gc_protect_via_stack(sc, fn_proc(car(largs)) (sc, sc->t2_1));
largs = cadr(largs);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs))));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_1, stack_protected1(sc));
unstack(sc);
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_sub_mul_mul(s7_scheme * sc, s7_pointer arg)
{ /* (- (* s1 s2) (* s3 s4)) */
s7_pointer a2, s1, s2, s3, s4, a1 = opt3_pair(arg); /* cdaddr(arg); */
s1 = lookup(sc, car(a1));
s2 = lookup(sc, cadr(a1));
a2 = opt1_pair(cdr(arg)); /* cdadr(arg) *//* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */
s3 = lookup(sc, car(a2));
s4 = lookup(sc, cadr(a2));
if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3))
&& (is_t_real(s4)))
return (make_real
(sc, (real(s3) * real(s4)) - (real(s1) * real(s2))));
sc->u = multiply_p_pp(sc, s1, s2);
return (subtract_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->u));
}
static s7_pointer fx_add_mul_mul(s7_scheme * sc, s7_pointer arg)
{ /* (+ (* s1 s2) (* s3 s4)) */
s7_pointer a2, s1, s2, s3, s4, a1 = opt3_pair(arg); /* cdaddr(arg); */
s1 = lookup(sc, car(a1));
s2 = lookup(sc, cadr(a1));
a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */
s3 = lookup(sc, car(a2));
s4 = lookup(sc, cadr(a2));
if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3))
&& (is_t_real(s4)))
return (make_real
(sc, (real(s3) * real(s4)) + (real(s1) * real(s2))));
sc->u = multiply_p_pp(sc, s1, s2);
return (add_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->u));
}
static s7_pointer fx_mul_sub_sub(s7_scheme * sc, s7_pointer arg)
{ /* (* (- s1 s2) (- s3 s4)) */
s7_pointer a2, s1, s2, s3, s4, a1 = opt3_pair(arg); /* cdaddr(arg); */
s1 = lookup(sc, car(a1));
s2 = lookup(sc, cadr(a1));
a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */
s3 = lookup(sc, car(a2));
s4 = lookup(sc, cadr(a2));
if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3))
&& (is_t_real(s4)))
return (make_real
(sc, (real(s3) - real(s4)) * (real(s1) - real(s2))));
sc->u = subtract_p_pp(sc, s1, s2);
return (multiply_p_pp(sc, subtract_p_pp(sc, s3, s4), sc->u));
}
static s7_pointer fx_lt_sub2(s7_scheme * sc, s7_pointer arg)
{
s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
sc->u = subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1)));
a1 = opt1_pair(cdr(arg)); /* cdadr(arg) */
return (lt_p_pp
(sc,
subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))),
sc->u));
}
static s7_pointer fx_sub_vref2(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p1, p2, v1, a1 = cdadr(arg);
v1 = lookup(sc, car(a1));
p1 = lookup(sc, cadr(a1));
p2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg)); */
if ((is_t_integer(p1)) && (is_t_integer(p2))
&& ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) {
s7_int i1 = integer(p1), i2 = integer(p2);
if ((i1 >= 0) && (i1 <= vector_length(v1)) && (i2 >= 0)
&& (i2 < vector_length(v1)))
return (subtract_p_pp
(sc, vector_ref_p_pi(sc, v1, i1),
vector_ref_p_pi(sc, v1, i2)));
}
return (subtract_p_pp
(sc, vector_ref_p_pp(sc, v1, p1),
vector_ref_p_pp(sc, v1, p2)));
}
static s7_pointer fx_c_op_opsqq(s7_scheme * sc, s7_pointer code)
{
set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(code))));
set_car(sc->t1_1, fn_proc(opt3_pair(code)) (sc, sc->t1_1));
set_car(sc->t1_1, fn_proc(cadr(code)) (sc, sc->t1_1));
return (fn_proc(code) (sc, sc->t1_1));
}
static s7_pointer fx_not_op_opsqq(s7_scheme * sc, s7_pointer code)
{
set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(code))));
set_car(sc->t1_1, fn_proc(opt3_pair(code)) (sc, sc->t1_1));
return ((fn_proc(cadr(code)) (sc, sc->t1_1) == sc->F) ? sc->T : sc->F);
}
static s7_pointer fx_not_is_pair_opsq(s7_scheme * sc, s7_pointer code)
{
return (make_boolean(sc, !is_pair(fn_proc(opt3_pair(code))
(sc,
set_plist_1(sc,
lookup(sc,
opt3_sym(cdr
(code))))))));
}
static s7_pointer fx_string_ref_t_last(s7_scheme * sc, s7_pointer arg)
{
return (string_ref_p_plast
(sc, t_lookup(sc, cadr(arg), arg), int_zero));
}
static s7_pointer fx_c_a(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t1_1, fx_call(sc, cdr(arg)));
return (fn_proc(arg) (sc, sc->t1_1));
}
static s7_pointer fx_c_a_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_p_t) opt3_direct(arg)) (sc, fx_call(sc, cdr(arg))));
}
static s7_pointer fx_not_a(s7_scheme * sc, s7_pointer arg)
{
return ((fx_call(sc, cdr(arg)) == sc->F) ? sc->T : sc->F);
}
static s7_pointer fx_c_saa(s7_scheme * sc, s7_pointer arg)
{
gc_protect_via_stack(sc, fx_call(sc, opt3_pair(arg))); /* opt3_pair=cddr */
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_1, lookup(sc, cadr(arg)));
set_car(sc->t3_2, stack_protected1(sc));
unstack(sc);
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_ssa(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_1, lookup(sc, cadr(arg)));
set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg))));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_ssa_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_ppp_t) opt2_direct(cdr(arg))) (sc,
lookup(sc, cadr(arg)),
lookup(sc,
car(opt3_pair
(arg))),
fx_call(sc,
cdr(opt3_pair
(arg)))));
}
static Inline s7_pointer op_ssa_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_ppp_t) opt2_direct(cdr(arg))) (sc,
lookup(sc, cadr(arg)),
lookup(sc,
car(opt3_pair
(arg))),
fx_call(sc,
cdr(opt3_pair
(arg)))));
}
static s7_pointer fx_c_ass(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_1, fx_call(sc, cdr(arg)));
set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg))));
set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg))));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_agg(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_1, fx_call(sc, cdr(arg)));
set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_sas(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
set_car(sc->t3_1, lookup(sc, cadr(arg)));
set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg))));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_sca(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_1, lookup(sc, cadr(arg)));
set_car(sc->t3_2, car(opt3_pair(arg)));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_Tca(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_1, T_lookup(sc, cadr(arg), arg));
set_car(sc->t3_2, car(opt3_pair(arg)));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_csa(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_1, cadr(arg));
set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg))));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_cac(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
set_car(sc->t3_1, cadr(arg));
set_car(sc->t3_3, cadr(opt3_pair(arg)));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_aa(s7_scheme * sc, s7_pointer arg)
{
/* check_stack_size(sc); */
gc_protect_via_stack(sc, fx_call(sc, cdr(arg)));
set_car(sc->t2_2, fx_call(sc, opt3_pair(arg))); /* cddr(arg) */
set_car(sc->t2_1, T_Pos(stack_protected1(sc)));
unstack(sc);
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_ca(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t2_2, fx_call(sc, cddr(arg)));
set_car(sc->t2_1, opt3_con(arg));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_ac(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t2_1, fx_call(sc, cdr(arg)));
set_car(sc->t2_2, opt3_con(arg));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_ac_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, fx_call(sc, cdr(arg)),
opt3_con(arg)));
}
static s7_pointer fx_is_eq_ac(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x, y = opt3_con(arg);
x = fx_call(sc, cdr(arg));
return (make_boolean(sc, (x == y)
|| ((is_unspecified(x)) && (is_unspecified(y)))));
}
#define fx_c_sa_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t2_2, fx_call(sc, cddr(arg))); \
set_car(sc->t2_1, Lookup(sc, opt3_sym(arg), arg)); \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_sa_any(fx_c_sa, s_lookup)
fx_c_sa_any(fx_c_ta, t_lookup)
fx_c_sa_any(fx_c_ua, u_lookup)
static s7_pointer fx_c_za(s7_scheme * sc, s7_pointer arg)
{ /* "z"=unsafe_s */
s7_pointer val;
val = lookup_checked(sc, cadr(arg)); /* this can call an autoload function that steps on sc->t2_1 */
set_car(sc->t2_2, fx_call(sc, opt3_pair(arg)));
set_car(sc->t2_1, val);
return (fn_proc(arg) (sc, sc->t2_1));
}
#define fx_c_sa_direct_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), fx_call(sc, cddr(arg)))); \
}
fx_c_sa_direct_any(fx_c_sa_direct, s_lookup)
fx_c_sa_direct_any(fx_c_ua_direct, u_lookup)
static s7_pointer fx_cons_ca(s7_scheme * sc, s7_pointer arg)
{
return (cons(sc, opt3_con(arg), fx_call(sc, cddr(arg))));
}
static s7_pointer fx_cons_ac(s7_scheme * sc, s7_pointer arg)
{
return (cons(sc, fx_call(sc, cdr(arg)), opt3_con(arg)));
}
static s7_pointer fx_cons_sa(s7_scheme * sc, s7_pointer arg)
{
return (cons(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));
}
static s7_pointer fx_cons_as(s7_scheme * sc, s7_pointer arg)
{
return (cons(sc, fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg))));
}
static s7_pointer fx_cons_aa(s7_scheme * sc, s7_pointer arg)
{
return (cons(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))));
}
#define fx_c_as_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
set_car(sc->t2_1, fx_call(sc, cdr(arg))); \
set_car(sc->t2_2, Lookup(sc, opt3_sym(arg), arg)); \
return(fn_proc(arg)(sc, sc->t2_1)); \
}
fx_c_as_any(fx_c_as, s_lookup)
fx_c_as_any(fx_c_at, t_lookup)
static s7_pointer fx_c_as_direct(s7_scheme * sc, s7_pointer arg)
{
return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, fx_call(sc, cdr(arg)),
lookup(sc,
opt3_sym(arg))));
}
static s7_pointer fx_add_as(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x1, x2;
x1 = fx_call(sc, cdr(arg));
x2 = lookup(sc, opt3_sym(arg));
if ((is_t_real(x1)) && (is_t_real(x2)))
return (make_real(sc, real(x1) + real(x2)));
return (add_p_pp(sc, x1, x2));
}
static s7_pointer fx_multiply_sa(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x1, x2;
x1 = lookup(sc, cadr(arg));
x2 = fx_call(sc, cddr(arg));
if ((is_t_real(x1)) && (is_t_real(x2)))
return (make_real(sc, real(x1) * real(x2)));
return (multiply_p_pp(sc, x1, x2));
}
static s7_pointer fx_subtract_aa(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x1, x2;
x1 = fx_call(sc, cdr(arg));
x2 = fx_call(sc, opt3_pair(arg));
if ((is_t_real(x1)) && (is_t_real(x2)))
return (make_real(sc, real(x1) - real(x2)));
return (subtract_p_pp(sc, x1, x2));
}
static s7_pointer fx_add_aa(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x1, x2;
x1 = fx_call(sc, cdr(arg));
x2 = fx_call(sc, opt3_pair(arg));
if ((is_t_real(x1)) && (is_t_real(x2)))
return (make_real(sc, real(x1) + real(x2)));
return (add_p_pp(sc, x1, x2));
}
static s7_pointer fx_multiply_aa(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x1, x2;
x1 = fx_call(sc, cdr(arg));
x2 = fx_call(sc, opt3_pair(arg));
if ((is_t_real(x1)) && (is_t_real(x2)))
return (make_real(sc, real(x1) * real(x2)));
return (multiply_p_pp(sc, x1, x2));
}
static s7_pointer fx_add_sa(s7_scheme * sc, s7_pointer arg)
{
return (add_p_pp
(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));
}
static s7_pointer fx_number_to_string_aa(s7_scheme * sc, s7_pointer arg)
{
return (number_to_string_p_pp
(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))));
}
static s7_pointer fx_c_3g(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_1, fx_call(sc, cdr(arg)));
set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_aaa(s7_scheme * sc, s7_pointer arg)
{
/* check_stack_size(sc); */
gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)),
fx_call(sc, opt3_pair(arg)));
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_2, stack_protected2(sc));
set_car(sc->t3_1, stack_protected1(sc));
unstack(sc);
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_gac(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
set_car(sc->t3_3, cadr(opt3_pair(arg)));
set_car(sc->t3_1, lookup_global(sc, cadr(arg)));
return (fn_proc(arg) (sc, sc->t3_1));
}
static s7_pointer fx_c_opaq_s(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t1_1, fx_call(sc, cdadr(arg)));
set_car(sc->t2_1, fn_proc(cadr(arg)) (sc, sc->t1_1));
set_car(sc->t2_2, lookup_checked(sc, caddr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_s_opaq(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t1_1, fx_call(sc, opt3_pair(arg))); /* cdaddr(arg); */
set_car(sc->t2_2, fn_proc(caddr(arg)) (sc, sc->t1_1));
set_car(sc->t2_1, lookup_checked(sc, cadr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_opaq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p = cadr(arg);
set_car(sc->t1_1, fx_call(sc, cdr(p)));
set_car(sc->t1_1, fn_proc(p) (sc, sc->t1_1));
return (fn_proc(arg) (sc, sc->t1_1));
}
static s7_pointer fx_c_opaaq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p = cadr(arg);
/* check_stack_size(sc); */
gc_protect_via_stack(sc, fx_call(sc, cdr(p)));
set_car(sc->t2_2, fx_call(sc, cddr(p)));
set_car(sc->t2_1, stack_protected1(sc));
unstack(sc);
set_car(sc->t1_1, fn_proc(p) (sc, sc->t2_1));
return (fn_proc(arg) (sc, sc->t1_1));
}
static s7_pointer fx_c_opsaq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p = cadr(arg);
set_car(sc->t2_2, fx_call(sc, cddr(p)));
set_car(sc->t2_1, lookup(sc, cadr(p)));
set_car(sc->t1_1, fn_proc(p) (sc, sc->t2_1));
return (fn_proc(arg) (sc, sc->t1_1));
}
static s7_pointer fx_c_opaaaq(s7_scheme * sc, s7_pointer code)
{
s7_pointer arg = cadr(code);
gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_1, stack_protected1(sc));
set_car(sc->t3_2, stack_protected2(sc));
unstack(sc);
set_car(sc->t1_1, fn_proc(arg) (sc, sc->t3_1));
return (fn_proc(code) (sc, sc->t1_1));
}
static s7_pointer fx_c_s_opaaq(s7_scheme * sc, s7_pointer code)
{
s7_pointer arg = caddr(code);
gc_protect_via_stack(sc, fx_call(sc, cdr(arg)));
set_car(sc->t2_2, fx_call(sc, cddr(arg)));
set_car(sc->t2_1, stack_protected1(sc));
set_car(sc->t2_2, fn_proc(arg) (sc, sc->t2_1));
set_car(sc->t2_1, lookup(sc, cadr(code)));
unstack(sc);
return (fn_proc(code) (sc, sc->t2_1));
}
static s7_pointer fx_c_s_opaaaq(s7_scheme * sc, s7_pointer code)
{
s7_pointer arg = caddr(code);
gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_1, stack_protected1(sc));
set_car(sc->t3_2, stack_protected2(sc));
unstack(sc);
set_car(sc->t2_2, fn_proc(arg) (sc, sc->t3_1));
set_car(sc->t2_1, lookup(sc, cadr(code)));
return (fn_proc(code) (sc, sc->t2_1));
}
static s7_pointer fx_c_4a(s7_scheme * sc, s7_pointer code)
{
s7_pointer res = cdr(code);
check_stack_size(sc); /* t718 pp cycles #f */
gc_protect_2_via_stack(sc, fx_call(sc, res), fx_call(sc, cdr(res)));
res = cddr(res);
stack_protected3(sc) = fx_call(sc, res);
set_car(sc->t3_3, fx_call(sc, cdr(res)));
set_car(sc->t3_2, stack_protected3(sc));
set_car(sc->t3_1, stack_protected2(sc));
set_car(sc->t4_1, stack_protected1(sc));
unstack(sc);
res = fn_proc(code) (sc, sc->t4_1);
set_car(sc->t4_1, sc->F);
return (res);
}
static s7_pointer fx_c_4g(s7_scheme * sc, s7_pointer code)
{ /* all opts in use for code, opt1 free cdr(code), code opt3 is line_number, cdr(code) opt3 is arglen?? */
s7_pointer res = cdr(code);
set_car(sc->t4_1, fx_call(sc, res));
set_car(sc->t3_1, fx_call(sc, cdr(res)));
set_car(sc->t3_2, fx_call(sc, opt3_pair(code))); /* cddr(res) */
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(code)))); /* cdddr(res) */
res = fn_proc(code) (sc, sc->t4_1);
set_car(sc->t4_1, sc->F);
return (res);
}
static s7_pointer fx_c_c_opscq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = caddr(arg);
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, opt2_con(cdr(largs)));
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_1, cadr(arg));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_s_opcsq(s7_scheme * sc, s7_pointer arg)
{
s7_pointer largs = caddr(arg);
set_car(sc->t2_2, lookup(sc, caddr(largs)));
set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */
set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1));
set_car(sc->t2_1, lookup(sc, cadr(arg)));
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_c_op_opssqq_s(s7_scheme * sc, s7_pointer code)
{
s7_pointer arg = opt1_pair(cdr(code));
set_car(sc->t2_1, lookup(sc, cadr(arg)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg))));
set_car(sc->t1_1, fn_proc(arg) (sc, sc->t2_1));
set_car(sc->t2_1, fn_proc(cadr(code)) (sc, sc->t1_1));
set_car(sc->t2_2, lookup(sc, caddr(code)));
return (fn_proc(code) (sc, sc->t2_1));
}
static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme * sc, s7_pointer code)
{
s7_pointer arg = opt1_pair(cdr(code));
return (((s7_p_pp_t) opt3_direct(code)) (sc, ((s7_p_p_t)
opt2_direct(cdr(code)))
(sc,
((s7_p_pp_t)
opt3_direct(cdr(code))) (sc,
lookup
(sc,
cadr
(arg)),
lookup
(sc,
caddr
(arg)))),
lookup(sc, caddr(code))));
}
static s7_pointer fx_c_ns(s7_scheme * sc, s7_pointer arg)
{
s7_pointer args, p, lst;
lst = safe_list_if_possible(sc, integer(opt3_arglen(cdr(arg))));
if (in_heap(lst))
gc_protect_via_stack(sc, lst);
for (args = cdr(arg), p = lst; is_pair(args);
args = cdr(args), p = cdr(p))
set_car(p, lookup(sc, car(args)));
p = fn_proc(arg) (sc, lst);
if (in_heap(lst))
unstack(sc);
else
clear_list_in_use(lst);
return (p);
}
static s7_pointer fx_list_ns(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p, args, lst;
lst = make_list(sc, integer(opt3_arglen(cdr(arg))), sc->nil);
for (args = cdr(arg), p = lst; is_pair(args);
args = cdr(args), p = cdr(p))
set_car(p, lookup(sc, car(args)));
return (lst);
}
static s7_pointer fx_vector_ns(s7_scheme * sc, s7_pointer arg)
{
s7_pointer args, vec;
s7_int i;
s7_pointer *els;
vec = make_simple_vector(sc, integer(opt3_arglen(cdr(arg))));
els = (s7_pointer *) vector_elements(vec);
for (args = cdr(arg), i = 0; is_pair(args); args = cdr(args), i++)
els[i] = lookup(sc, car(args));
return (vec);
}
static s7_pointer fx_c_all_ca(s7_scheme * sc, s7_pointer code)
{
s7_pointer args, p, lst;
lst = safe_list_if_possible(sc, integer(opt3_arglen(cdr(code))));
if (in_heap(lst))
gc_protect_via_stack(sc, lst);
for (args = cdr(code), p = lst; is_pair(args);
args = cdr(args), p = cddr(p)) {
set_car(p, opt2_con(args));
args = cdr(args);
set_car(cdr(p), fx_call(sc, args));
}
p = fn_proc(code) (sc, lst);
if (in_heap(lst))
unstack(sc);
else
clear_list_in_use(lst);
return (p);
}
static s7_pointer fx_inlet_ca(s7_scheme * sc, s7_pointer code)
{
s7_pointer new_e, x;
int64_t id;
new_cell(sc, new_e, T_LET | T_SAFE_PROCEDURE);
let_set_slots(new_e, slot_end(sc));
let_set_outlet(new_e, sc->nil);
gc_protect_via_stack(sc, new_e);
/* as in let, we need to call the var inits before making the new let, but a simpler equivalent is to make the new let
* but don't set its id yet.
*/
for (x = cdr(code); is_pair(x); x = cddr(x)) {
s7_pointer symbol = car(x), value;
symbol = (is_keyword(symbol)) ? keyword_symbol(symbol) : cadr(symbol); /* (inlet ':allow-other-keys 3) */
if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */
return (wrong_type_argument_with_type
(sc, sc->inlet_symbol, 1, symbol,
a_non_constant_symbol_string));
value = fx_call(sc, cdr(x)); /* it's necessary to do this first, before add_slot_unchecked */
add_slot_unchecked(sc, new_e, symbol, value, symbol_id(symbol));
}
id = ++sc->let_number;
let_set_id(new_e, id);
for (x = let_slots(new_e); tis_slot(x); x = next_slot(x))
symbol_set_id(slot_symbol(x), id);
unstack(sc);
return (new_e);
}
static s7_pointer fx_c_na(s7_scheme * sc, s7_pointer arg)
{
s7_pointer args, p, val;
val = safe_list_if_possible(sc, integer(opt3_arglen(cdr(arg))));
if (in_heap(val))
gc_protect_via_stack(sc, val);
for (args = cdr(arg), p = val; is_pair(args);
args = cdr(args), p = cdr(p))
set_car(p, fx_call(sc, args));
p = fn_proc(arg) (sc, val);
if (in_heap(val))
unstack(sc);
else
clear_list_in_use(val);
return (p);
}
static s7_pointer fx_vector_all_a(s7_scheme * sc, s7_pointer arg)
{
s7_pointer v, args;
s7_pointer *els;
s7_int i, len = integer(opt3_arglen(cdr(arg)));
/* check_free_heap_size(sc, len + 1); *//* I think since v is a filled vector protected on the stack that this is unnecessary */
v = s7_make_vector(sc, len);
gc_protect_via_stack(sc, v);
els = vector_elements(v);
for (i = 0, args = cdr(arg); i < len; args = cdr(args), i++)
els[i] = fx_call(sc, args);
sc->value = v;
unstack(sc);
return (v);
}
static s7_pointer fx_if_a_a(s7_scheme * sc, s7_pointer arg)
{
return ((is_true(sc, fx_call(sc, cdr(arg)))) ?
fx_call(sc, opt1_pair(arg)) : sc->unspecified);
}
static s7_pointer fx_if_not_a_a(s7_scheme * sc, s7_pointer arg)
{
return ((is_false(sc, fx_call(sc, opt1_pair(arg)))) ?
fx_call(sc, opt2_pair(arg)) : sc->unspecified);
}
static s7_pointer fx_if_a_a_a(s7_scheme * sc, s7_pointer arg)
{
return ((is_true(sc, fx_call(sc, cdr(arg)))) ?
fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg)));
}
#define fx_if_s_a_a_any(Name, Lookup) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
return((Lookup(sc, cadr(arg), arg) != sc->F) ? fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg))); \
}
fx_if_s_a_a_any(fx_if_s_a_a, s_lookup)
fx_if_s_a_a_any(fx_if_o_a_a, o_lookup) /* diff s->o of ca 3 */
static s7_pointer fx_if_and2_s_a(s7_scheme * sc, s7_pointer arg)
{
return (((fx_call(sc, opt1_pair(arg)) == sc->F)
|| (fx_call(sc, opt2_pair(arg)) == sc->F)) ? fx_call(sc,
cdddr
(arg)) :
lookup(sc, opt3_sym(arg)));
}
static s7_pointer fx_if_not_a_a_a(s7_scheme * sc, s7_pointer arg)
{
return ((is_false(sc, fx_call(sc, opt1_pair(arg)))) ?
fx_call(sc, opt2_pair(arg)) : fx_call(sc, opt3_pair(arg)));
}
static s7_pointer fx_if_a_c_c(s7_scheme * sc, s7_pointer arg)
{
return ((is_true(sc, fx_call(sc, cdr(arg)))) ? opt1_con(arg) :
opt2_con(arg));
}
static s7_pointer fx_if_is_type_s_a_a(s7_scheme * sc, s7_pointer arg)
{
if (gen_type_match
(sc, lookup(sc, opt2_sym(cdr(arg))), opt3_byte(cdr(arg))))
return (fx_call(sc, cddr(arg)));
return (fx_call(sc, opt2_pair(arg))); /* cdddr(arg) */
}
static inline s7_pointer fx_and_2a(s7_scheme * sc, s7_pointer arg)
{ /* arg is the full expr: (and ...) */
return ((fx_call(sc, cdr(arg)) == sc->F) ? sc->F : fx_call(sc,
cddr(arg)));
}
static inline s7_pointer fx_and_s_2(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg) */
return ((fn_proc(cadr(arg)) (sc, sc->t1_1) ==
sc->F) ? sc->F : fn_proc(caddr(arg)) (sc, sc->t1_1));
}
static s7_pointer fx_and_or_2a_vref(s7_scheme * sc, s7_pointer arg)
{
s7_pointer or1 = cadr(arg), arg11, v;
arg11 = cdadr(or1);
v = lookup(sc, cadar(arg11));
if ((is_normal_vector(v)) && (vector_rank(v) == 1)) {
s7_pointer ip, jp;
ip = lookup(sc, opt3_sym(or1));
jp = lookup(sc, opt1_sym(or1));
if ((is_t_integer(ip)) && (is_t_integer(jp))) {
s7_int i = integer(ip), j = integer(jp);
if ((i >= 0) && (j >= 0) &&
(i < vector_length(v)) && (j < vector_length(v)) &&
(is_t_real(vector_element(v, i)))
&& (is_t_real(vector_element(v, j)))) {
s7_pointer xp;
xp = lookup(sc, cadr(arg11));
if (is_t_real(xp)) {
s7_double vi = real(vector_element(v, i)), vj =
real(vector_element(v, j)), xf = real(xp);
return (make_boolean(sc, ((vi > xf) || (xf >= vj))
&& ((vj > xf) || (xf >= vi))));
}
}
}
}
return (fx_and_2a(sc, arg));
}
static s7_pointer fx_len2_t(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* isn't this unprotected from mock pair? *//* opt1_sym == cadadr(arg) */
return (make_boolean(sc, is_pair(val) && (is_pair(cdr(val)))
&& (is_null(cddr(val)))));
}
static s7_pointer fx_len3_t(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = t_lookup(sc, opt1_sym(cdr(arg)), arg);
return (make_boolean(sc, is_pair(val) && (is_pair(cdr(val)))
&& (is_pair(cddr(val)))));
}
static s7_pointer fx_and_3a(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p = cdr(arg), val;
val = fx_call(sc, p);
if (val == sc->F)
return (val);
p = cdr(p);
val = fx_call(sc, p);
return ((val == sc->F) ? val : fx_call(sc, cdr(p)));
}
static s7_pointer fx_and_n(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p, x = sc->T;
for (p = cdr(arg); is_pair(p); p = cdr(p)) { /* in lg, 5/6 args appears to predominate */
x = fx_call(sc, p);
if (is_false(sc, x))
return (x);
}
return (x);
}
static s7_pointer fx_or_2a(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p = cdr(arg), val;
val = fx_call(sc, p);
return ((val != sc->F) ? val : fx_call(sc, cdr(p)));
}
static s7_pointer fx_or_s_2(s7_scheme * sc, s7_pointer arg)
{
/* the "s" is looked up once here -- not obvious how to use fx_call anyway */
s7_pointer x;
set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg); */
x = fn_proc(cadr(arg)) (sc, sc->t1_1);
return ((x != sc->F) ? x : fn_proc(caddr(arg)) (sc, sc->t1_1));
}
static s7_pointer fx_or_s_type_2(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x;
x = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg)); */
return (make_boolean(sc, (type(x) == integer(opt3_int(arg)))
|| (type(x) == integer(opt2_int(cdr(arg))))));
}
static s7_pointer fx_not_symbol_or_keyword(s7_scheme * sc, s7_pointer arg)
{
s7_pointer val;
val = lookup(sc, opt3_sym(arg));
return (make_boolean(sc, (!is_symbol(val)) || (is_keyword(val))));
}
static s7_pointer fx_or_and_2a(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p = cdr(arg), val;
val = fx_call(sc, p);
if (val != sc->F)
return (val);
p = opt3_pair(arg); /* cdadr(p); */
val = fx_call(sc, p);
return ((val == sc->F) ? val : fx_call(sc, cdr(p)));
}
static s7_pointer fx_or_and_3a(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p = cdr(arg), val;
val = fx_call(sc, p);
if (val != sc->F)
return (val);
p = opt3_pair(arg); /* cdadr(p); */
val = fx_call(sc, p);
if (val == sc->F)
return (val);
p = cdr(p);
val = fx_call(sc, p);
return ((val == sc->F) ? val : fx_call(sc, cdr(p)));
}
static s7_pointer fx_or_3a(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p = cdr(arg), val;
val = fx_call(sc, p);
if (val != sc->F)
return (val);
p = cdr(p);
val = fx_call(sc, p);
return ((val != sc->F) ? val : fx_call(sc, cdr(p)));
}
static s7_pointer fx_or_n(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p;
for (p = cdr(arg); is_pair(p); p = cdr(p)) {
s7_pointer x;
x = fx_call(sc, p);
if (is_true(sc, x))
return (x);
}
return (sc->F);
}
static s7_pointer fx_begin_aa(s7_scheme * sc, s7_pointer arg)
{
arg = cdr(arg);
fx_call(sc, arg);
return (fx_call(sc, cdr(arg)));
}
static s7_pointer fx_begin_na(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p;
for (p = cdr(arg); is_pair(cdr(p)); p = cdr(p))
fx_call(sc, p);
return (fx_call(sc, p));
}
static s7_pointer fx_safe_thunk_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer f, result;
gc_protect_via_stack(sc, sc->curlet);
f = opt1_lambda(code);
set_curlet(sc, closure_let(f));
result = fx_call(sc, closure_body(f));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer op_safe_thunk_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer f = opt1_lambda(code);
set_curlet(sc, closure_let(f));
return (fx_call(sc, closure_body(f)));
}
static s7_pointer fx_safe_closure_s_a(s7_scheme * sc, s7_pointer code)
{ /* also called from h_safe_closure_s_a in eval */
s7_pointer result;
gc_protect_via_stack(sc, sc->curlet);
sc->curlet =
update_let_with_slot(sc, closure_let(opt1_lambda(code)),
lookup(sc, opt2_sym(code)));
result = fx_call(sc, closure_body(opt1_lambda(code)));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer op_safe_closure_s_a(s7_scheme * sc, s7_pointer code)
{ /* also called from h_safe_closure_s_a in eval */
sc->curlet =
update_let_with_slot(sc, closure_let(opt1_lambda(code)),
lookup(sc, opt2_sym(code)));
return (fx_call(sc, closure_body(opt1_lambda(code))));
}
static s7_pointer fx_safe_closure_t_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer result;
gc_protect_via_stack(sc, sc->curlet);
sc->curlet =
update_let_with_slot(sc, closure_let(opt1_lambda(code)),
t_lookup(sc, opt2_sym(code), code));
result = fx_call(sc, closure_body(opt1_lambda(code)));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer fx_safe_closure_s_to_s(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t1_1, lookup(sc, opt2_sym(arg)));
return (fn_proc(car(closure_body(opt1_lambda(arg)))) (sc, sc->t1_1));
}
static s7_pointer fx_safe_closure_s_to_sc(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t2_2, opt3_con(cdr(arg)));
set_car(sc->t2_1, lookup(sc, opt2_sym(arg)));
return (fn_proc(car(closure_body(opt1_lambda(arg)))) (sc, sc->t2_1));
}
static s7_pointer fx_safe_closure_s_to_vref(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, lookup(sc, opt2_sym(arg)), opt3_con(cdr(arg))));
}
static s7_pointer fx_safe_closure_s_to_sub1(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p;
p = lookup(sc, opt2_sym(arg));
if ((!WITH_GMP) && (is_t_integer(p)))
return (make_integer(sc, integer(p) - 1));
return (minus_c1(sc, p));
}
static s7_pointer fx_safe_closure_s_to_add1(s7_scheme * sc, s7_pointer arg)
{
s7_pointer p;
p = lookup(sc, opt2_sym(arg));
if ((!WITH_GMP) && (is_t_integer(p)))
return (make_integer(sc, integer(p) + 1));
return (g_add_x1_1(sc, p, 1));
}
static s7_pointer fx_c_ff(s7_scheme * sc, s7_pointer arg)
{
s7_pointer x, p = cdr(arg);
x = fx_proc(cdar(p)) (sc, car(p));
set_car(sc->t2_2, fx_proc(cdadr(p)) (sc, cadr(p)));
set_car(sc->t2_1, x);
return (fn_proc(arg) (sc, sc->t2_1));
}
static s7_pointer fx_safe_closure_a_to_sc(s7_scheme * sc, s7_pointer arg)
{
set_car(sc->t2_1, fx_call(sc, cdr(arg)));
set_car(sc->t2_2, opt3_con(cdr(arg)));
return (fn_proc(car(closure_body(opt1_lambda(arg)))) (sc, sc->t2_1));
}
static s7_pointer fx_safe_closure_a_to_vref(s7_scheme * sc, s7_pointer arg)
{
return (vector_ref_p_pp
(sc, fx_call(sc, cdr(arg)), opt3_con(cdr(arg))));
}
static s7_pointer fx_safe_closure_s_and_2a(s7_scheme * sc, s7_pointer code)
{ /* safe_closure_s_a where "a" is fx_and_2a */
s7_pointer result;
gc_protect_via_stack(sc, sc->curlet);
sc->curlet =
update_let_with_slot(sc, closure_let(opt1_lambda(code)),
lookup(sc, opt2_sym(code)));
code = cdar(closure_body(opt1_lambda(code)));
result = fx_call(sc, code); /* have to unwind the stack so this can't return */
if (result != sc->F)
result = fx_call(sc, cdr(code));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer fx_safe_closure_s_and_pair(s7_scheme * sc,
s7_pointer code)
{ /* safe_closure_s_a where "a" is fx_and_2a with is_pair as first clause */
s7_pointer result;
gc_protect_via_stack(sc, sc->curlet);
sc->curlet =
update_let_with_slot(sc, closure_let(opt1_lambda(code)),
lookup(sc, opt2_sym(code)));
code = cdar(closure_body(opt1_lambda(code)));
if (is_pair(t_lookup(sc, cadar(code), code))) /* pair? arg = func par, pair? is global, symbol_id=0 */
result = fx_call(sc, cdr(code));
else
result = sc->F;
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer fx_safe_closure_a_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer result;
gc_protect_via_stack(sc, sc->curlet);
sc->curlet =
update_let_with_slot(sc, closure_let(opt1_lambda(code)),
fx_call(sc, cdr(code)));
result = fx_call(sc, closure_body(opt1_lambda(code)));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer op_safe_closure_a_a(s7_scheme * sc, s7_pointer code)
{
sc->curlet =
update_let_with_slot(sc, closure_let(opt1_lambda(code)),
fx_call(sc, cdr(code)));
return (fx_call(sc, closure_body(opt1_lambda(code))));
}
static s7_pointer fx_safe_closure_a_sqr(s7_scheme * sc, s7_pointer code)
{
return (fx_sqr_1(sc, fx_call(sc, cdr(code))));
}
static s7_pointer fx_safe_closure_s_sqr(s7_scheme * sc, s7_pointer code)
{
return (fx_sqr_1(sc, lookup(sc, opt2_sym(code))));
}
static s7_pointer fx_safe_closure_a_and_2a(s7_scheme * sc, s7_pointer code)
{
s7_pointer and_arg, result;
gc_protect_via_stack(sc, sc->curlet);
sc->curlet =
update_let_with_slot(sc, closure_let(opt1_lambda(code)),
fx_call(sc, cdr(code)));
and_arg = cdar(closure_body(opt1_lambda(code)));
result = fx_call(sc, and_arg);
if (result != sc->F)
result = fx_call(sc, cdr(and_arg));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer fx_safe_closure_ss_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer result;
gc_protect_via_stack(sc, sc->curlet);
sc->curlet =
update_let_with_two_slots(sc, closure_let(opt1_lambda(code)),
lookup(sc, cadr(code)), lookup(sc,
opt2_sym
(code)));
result = fx_call(sc, closure_body(opt1_lambda(code)));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer op_safe_closure_ss_a(s7_scheme * sc, s7_pointer code)
{
sc->curlet =
update_let_with_two_slots(sc, closure_let(opt1_lambda(code)),
lookup(sc, cadr(code)), lookup(sc,
opt2_sym
(code)));
return (fx_call(sc, closure_body(opt1_lambda(code))));
}
static s7_pointer fx_safe_closure_3s_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer result;
gc_protect_via_stack(sc, sc->curlet);
sc->curlet =
update_let_with_three_slots(sc, closure_let(opt1_lambda(code)),
lookup(sc, cadr(code)), lookup(sc,
opt2_sym
(code)),
lookup(sc, opt3_sym(code)));
result = fx_call(sc, closure_body(opt1_lambda(code)));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (result);
}
static s7_pointer op_safe_closure_3s_a(s7_scheme * sc, s7_pointer code)
{
sc->curlet =
update_let_with_three_slots(sc, closure_let(opt1_lambda(code)),
lookup(sc, cadr(code)), lookup(sc,
opt2_sym
(code)),
lookup(sc, opt3_sym(code)));
return (fx_call(sc, closure_body(opt1_lambda(code))));
}
static s7_pointer fx_safe_closure_aa_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer f, p = cdr(code);
gc_protect_2_via_stack(sc, sc->curlet, fx_call(sc, cdr(p))); /* this is needed even if one of the args is a symbol, so nothing is saved by splitting out that case */
f = opt1_lambda(code);
sc->curlet =
update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p),
stack_protected2(sc));
p = fx_call(sc, closure_body(f));
set_curlet(sc, stack_protected1(sc));
unstack(sc);
return (p);
}
static inline s7_pointer fx_cond_fx_fx(s7_scheme * sc, s7_pointer code)
{ /* all tests are fxable, results are all fx, no =>, no missing results */
s7_pointer p;
for (p = cdr(code); is_pair(p); p = cdr(p))
if (is_true(sc, fx_call(sc, car(p)))) {
for (p = cdar(p); is_pair(cdr(p)); p = cdr(p))
fx_call(sc, p);
return (fx_call(sc, p));
}
return (sc->unspecified);
}
static s7_pointer s7_let_field(s7_scheme * sc, s7_pointer sym);
static s7_pointer fx_implicit_s7_let_ref_s(s7_scheme * sc, s7_pointer arg)
{
return (s7_let_field(sc, opt3_sym(arg)));
}
static s7_pointer fx_implicit_s7_let_set_sa(s7_scheme * sc, s7_pointer arg)
{
return (s7_let_field_set
(sc, opt3_sym(cdr(arg)), fx_call(sc, cddr(arg))));
}
static s7_function *fx_function = NULL;
static bool is_fxable(s7_scheme * sc, s7_pointer p)
{
if (!is_pair(p))
return (true);
if ((is_optimized(p)) && /* this is needed. In check_tc, for example, is_fxable can be confused by early optimize_op */
(fx_function[optimize_op(p)]))
return (true);
return (is_proper_quote(sc, p));
}
static bool is_gxable(s7_pointer p)
{
opcode_t op;
if (!is_optimized(p))
return (false);
op = optimize_op(p);
return ((is_symbol(car(p))) && (symbol_ctr(car(p)) == 1) &&
(op < FIRST_UNHOPPABLE_OP) &&
(op > OP_GC_PROTECT) && (fx_function[op | 1]));
}
static int32_t fx_count(s7_scheme * sc, s7_pointer x)
{
int32_t count = 0;
s7_pointer p;
for (p = cdr(x); is_pair(p); p = cdr(p))
if (is_fxable(sc, car(p)))
count++;
return (count);
}
static bool is_code_constant(s7_scheme * sc, s7_pointer p)
{
return ((is_pair(p)) ? (car(p) == sc->quote_symbol) :
is_constant(sc, p));
}
static inline s7_pointer check_quote(s7_scheme * sc, s7_pointer code);
static s7_p_p_t s7_p_p_function(s7_pointer f);
static s7_p_pp_t s7_p_pp_function(s7_pointer f);
static s7_p_ppp_t s7_p_ppp_function(s7_pointer f);
static s7_p_dd_t s7_p_dd_function(s7_pointer f);
static s7_p_pi_t s7_p_pi_function(s7_pointer f);
static s7_p_ii_t s7_p_ii_function(s7_pointer f);
#define is_unchanged_global(P) \
((is_symbol(P)) && (is_global(P)) && (symbol_id(P) == 0) && \
(is_slot(initial_slot(P))) && \
(initial_value(P) == global_value(P)))
#define is_global_and_has_func(P, Func) ((is_unchanged_global(P)) && (Func(global_value(P)))) /* Func = s7_p_pp_function and friends */
static bool fx_matches(s7_pointer symbol, s7_pointer target_symbol)
{
return ((symbol == target_symbol) && (is_unchanged_global(symbol)));
}
static s7_pointer fx_in_place(s7_scheme * sc, s7_pointer arg)
{
return (opt3_con(arg));
}
/* #define fx_choose(Sc, Holder, E, Checker) fx_choose_1(Sc, Holder, E, Checker, __func__, __LINE__) */
static s7_function fx_choose(s7_scheme * sc, s7_pointer holder,
s7_pointer e, safe_sym_t * checker)
{ /* , const char *func, int line) */
s7_pointer arg = car(holder);
if (!is_pair(arg)) {
if (is_symbol(arg)) {
if ((is_keyword(arg))
|| ((arg == sc->else_symbol) && (is_global(arg))))
return (fx_c);
return ((is_global(arg)) ? fx_g
: ((checker(sc, arg, e)) ? fx_s : fx_unsafe_s));
}
return (fx_c);
}
if (is_optimized(arg)) {
switch (optimize_op(arg)) {
case HOP_SAFE_C_NC:
if (fn_proc(arg) == g_add_i_random)
return (fx_add_i_random);
/* an experiment -- does this ever happen in real code? -- no */
/* integer->char string->number (string) (list) complex sqrt log expt * + - /
*/
if (((fn_proc(arg) == g_abs) && (is_t_integer(cadr(arg)))) ||
#if WITH_PURE_S7
((fn_proc(arg) == g_length) && (is_string(cadr(arg)))))
#else
(((fn_proc(arg) == g_string_length)
|| (fn_proc(arg) == g_length))
&& (is_string(cadr(arg)))))
#endif
{
set_opt3_con(arg,
make_permanent_integer((fn_proc(arg) ==
g_abs) ?
s7_int_abs(integer
(cadr(arg)))
:
string_length(cadr
(arg))));
return (fx_in_place);
}
return ((fn_proc(arg) == g_random_i) ? fx_random_i : fx_c_nc);
case OP_OR_2A:
if (fx_proc(cddr(arg)) == fx_and_2a) {
set_opt3_pair(arg, cdaddr(arg));
return (fx_or_and_2a);
}
if (fx_proc(cddr(arg)) == fx_and_3a) {
set_opt3_pair(arg, cdaddr(arg));
return (fx_or_and_3a);
}
if ((fx_proc(cdr(arg)) == fx_not_is_symbol_s)
&& (fx_proc(cddr(arg)) == fx_is_keyword_s)
&& (cadr(cadadr(arg)) == cadaddr(arg))) {
/* (or (not (symbol? body)) (keyword? body)) */
set_opt3_sym(arg, cadaddr(arg));
return (fx_not_symbol_or_keyword);
}
return (fx_or_2a);
case OP_AND_2A:
if ((fx_proc(cdr(arg)) == fx_or_2a)
&& (fx_proc(cddr(arg)) == fx_or_2a)) {
s7_pointer o1 = cadr(arg), o2 = caddr(arg);
if ((fx_proc(cdr(o1)) == fx_gt_vref_s)
&& (fx_proc(cddr(o1)) == fx_geq_s_vref)
&& (fx_proc(cdr(o2)) == fx_gt_vref_s)
&& (fx_proc(cddr(o2)) == fx_geq_s_vref)) {
s7_pointer v = cadr(cadadr(o1));
if ((v == cadr(cadadr(o2)))
&& (v == (cadr(caddaddr(o1))))
&& (v == (cadr(caddaddr(o2))))) {
s7_pointer x = caddadr(o1);
if ((x == caddadr(o2)) && (x == cadaddr(o1))
&& (x == cadaddr(o2))) {
s7_pointer i = caddr(cadadr(o1)), j =
caddaddr(caddr(o1));
if ((j == caddr(cadadr(o2)))
&& (i == caddaddr(caddr(o2)))) {
set_opt1_sym(o1, j);
set_opt3_sym(o1, i);
return (fx_and_or_2a_vref);
}
}
}
}
}
return (fx_and_2a);
case HOP_SAFE_C_S:
if (is_unchanged_global(car(arg))) {
uint8_t typ;
if (car(arg) == sc->cdr_symbol)
return (fx_cdr_s);
if (car(arg) == sc->car_symbol)
return (fx_car_s);
if (car(arg) == sc->cadr_symbol)
return (fx_cadr_s);
if (car(arg) == sc->cddr_symbol)
return (fx_cddr_s);
if (car(arg) == sc->is_null_symbol)
return (fx_is_null_s);
if (car(arg) == sc->is_pair_symbol)
return (fx_is_pair_s);
if (car(arg) == sc->is_symbol_symbol)
return (fx_is_symbol_s);
if (car(arg) == sc->is_eof_object_symbol)
return (fx_is_eof_s);
if (car(arg) == sc->is_integer_symbol)
return (fx_is_integer_s);
if (car(arg) == sc->is_string_symbol)
return (fx_is_string_s);
if (car(arg) == sc->not_symbol)
return (fx_not_s);
if (car(arg) == sc->is_proper_list_symbol)
return (fx_is_proper_list_s);
if (car(arg) == sc->is_vector_symbol)
return (fx_is_vector_s);
if (car(arg) == sc->is_keyword_symbol)
return (fx_is_keyword_s);
if (car(arg) == sc->is_procedure_symbol)
return (fx_is_procedure_s);
if (car(arg) == sc->length_symbol)
return (fx_length_s);
/* not read_char here... */
typ = symbol_type(car(arg));
if (typ > 0) {
set_opt3_byte(cdr(arg), typ);
return (fx_is_type_s);
}
/* car_p_p (et al) does not look for a method so in:
* (define kar car) (load "mockery.scm") (let ((p (mock-pair '(1 2 3)))) (call-with-exit (lambda (x) (x (kar p)))))
* "kar" fails but not "car" because symbol_id(kar) == 0! symbol_id(car) > 0 because mockery provides a method for it.
*/
if (symbol_id(make_symbol(sc, c_function_name(global_value(car(arg))))) == 0) { /* yow! */
s7_p_p_t f = s7_p_p_function(global_value(car(arg)));
if (f) {
set_opt2_direct(cdr(arg), (s7_pointer) f);
if (f == real_part_p_p)
return (fx_real_part_s);
if (f == imag_part_p_p)
return (fx_imag_part_s);
if (f == iterate_p_p)
return (fx_iterate_s);
if (f == car_p_p)
return (fx_car_s); /* can happen if (define var-name car) etc */
return ((is_global(cadr(arg))) ? fx_c_g_direct :
fx_c_s_direct);
}
}
}
return ((is_global(cadr(arg))) ? fx_c_g : fx_c_s);
case HOP_SAFE_C_SS:
if (fn_proc(arg) == g_cons)
return (fx_cons_ss);
if (fx_matches(car(arg), sc->num_eq_symbol))
return (fx_num_eq_ss);
if (fn_proc(arg) == g_geq_2)
return (fx_geq_ss);
if (fn_proc(arg) == g_greater_2)
return (fx_gt_ss);
if (fn_proc(arg) == g_leq_2)
return (fx_leq_ss);
if (fn_proc(arg) == g_less_2)
return ((is_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss);
if ((fx_matches(car(arg), sc->multiply_symbol))
&& (cadr(arg) == caddr(arg)))
return (fx_sqr_s);
if (fn_proc(arg) == g_multiply_2)
return (fx_multiply_ss);
if (fn_proc(arg) == g_is_eq)
return (fx_is_eq_ss);
if (fn_proc(arg) == g_add_2)
return (fx_add_ss);
if (fn_proc(arg) == g_subtract_2)
return (fx_subtract_ss);
if (fn_proc(arg) == g_hash_table_ref_2)
return (fx_hash_table_ref_ss);
if (is_global_and_has_func(car(arg), s7_p_pp_function)) {
if (car(arg) == sc->assq_symbol)
return (fx_assq_ss);
if (car(arg) == sc->memq_symbol)
return (fx_memq_ss);
if (car(arg) == sc->vector_ref_symbol)
return (fx_vref_ss);
if (car(arg) == sc->string_ref_symbol)
return (fx_string_ref_ss);
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
return (fx_c_ss_direct);
}
/* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */
return (fx_c_ss);
case HOP_SAFE_C_NS:
if (fn_proc(arg) == g_list)
return (fx_list_ns);
return ((fn_proc(arg) == g_vector) ? fx_vector_ns : fx_c_ns);
case HOP_SAFE_C_opSq_S:
if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
(is_global_and_has_func(caadr(arg), s7_p_p_function))) {
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_p_function
(global_value(caadr(arg)))));
return (((car(arg) == sc->cons_symbol)
&& (caadr(arg) ==
sc->car_symbol)) ? fx_cons_car_s_s :
fx_c_opsq_s_direct);
}
return (fx_c_opsq_s);
case HOP_SAFE_C_SSS:
if ((fn_proc(arg) == g_less) && (is_global(cadr(arg)))
&& (is_global(cadddr(arg))))
return (fx_lt_gsg);
if (is_global_and_has_func(car(arg), s7_p_ppp_function)) {
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_ppp_function
(global_value(car(arg)))));
return (fx_c_sss_direct);
}
return (fx_c_sss);
case HOP_SAFE_C_SSA:
if (is_global_and_has_func(car(arg), s7_p_ppp_function)) {
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_ppp_function
(global_value(car(arg)))));
return (fx_c_ssa_direct);
}
return (fx_c_ssa);
case HOP_SAFE_C_SCS:
if (is_global_and_has_func(car(arg), s7_p_ppp_function)) {
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_ppp_function
(global_value(car(arg)))));
return (fx_c_scs_direct);
}
return (fx_c_scs);
case HOP_SAFE_C_AAA:
if ((fx_proc(cdr(arg)) == fx_g)
&& (fx_proc(cdddr(arg)) == fx_c))
return (fx_c_gac);
if ((is_unquoted_pair(cadr(arg)))
|| (is_unquoted_pair(caddr(arg)))
|| (is_unquoted_pair(cadddr(arg))))
return (fx_c_aaa);
return (fx_c_3g);
case HOP_SAFE_C_4A:
{
s7_pointer p;
for (p = cdr(arg); is_pair(p); p = cdr(p))
if (is_unquoted_pair(car(p)))
break;
set_opt3_pair(arg, cdddr(arg));
return ((is_null(p)) ? fx_c_4g : fx_c_4a); /* fx_c_ssaa doesn't save much */
}
case HOP_SAFE_C_S_opSSq:
{
s7_pointer s2 = caddr(arg);
if ((fx_matches(car(s2), sc->multiply_symbol))
&& (cadr(s2) == caddr(s2)))
return (fx_c_s_sqr);
if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
(is_global_and_has_func(car(s2), s7_p_pp_function))) {
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(car(s2)))));
set_opt3_pair(arg, cdr(s2));
if (car(s2) == sc->vector_ref_symbol) {
if (car(arg) == sc->add_symbol)
return (fx_add_s_vref);
if (car(arg) == sc->subtract_symbol)
return (fx_subtract_s_vref);
if (car(arg) == sc->multiply_symbol)
return (fx_multiply_s_vref);
if (car(arg) == sc->geq_symbol)
return (fx_geq_s_vref);
if (car(arg) == sc->is_eq_symbol)
return (fx_is_eq_s_vref);
if (car(arg) == sc->hash_table_ref_symbol)
return (fx_href_s_vref);
if (car(arg) == sc->let_ref_symbol)
return (fx_lref_s_vref);
if ((is_global(cadr(arg))) && (is_global(cadr(s2)))
&& (car(arg) == sc->vector_ref_symbol))
return (fx_vref_g_vref_gs);
}
if ((car(arg) == sc->vector_ref_symbol)
&& (car(s2) == sc->add_symbol))
return (fx_vref_s_add);
return (fx_c_s_opssq_direct);
}
return (fx_c_s_opssq);
}
case HOP_SAFE_C_opSSq_S:
if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
(is_global_and_has_func(caadr(arg), s7_p_pp_function))) {
/* op_c_opgsq_t */
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(caadr(arg)))));
set_opt3_pair(arg, cdadr(arg));
if (caadr(arg) == sc->vector_ref_symbol) {
if (car(arg) == sc->subtract_symbol)
return (fx_subtract_vref_s);
if (car(arg) == sc->gt_symbol)
return (fx_gt_vref_s);
if (car(arg) == sc->vector_ref_symbol)
return (fx_vref_vref_ss_s);
if (car(arg) == sc->add_symbol)
return (fx_add_vref_s);
}
if (car(arg) == sc->add_symbol) {
if ((caadr(arg) == sc->multiply_symbol)
&& (cadadr(arg) == caddadr(arg)))
return (fx_add_sqr_s);
if (caadr(arg) == sc->subtract_symbol)
return (fx_add_sub_s);
}
if ((car(arg) == sc->cons_symbol)
&& (caadr(arg) == sc->cons_symbol))
return (fx_cons_cons_s);
/* also div(sub)[2] mul(div) */
return (((car(arg) == sc->gt_symbol)
&& (caadr(arg) ==
sc->add_symbol)) ? fx_gt_add_s : (((car(arg)
==
sc->add_symbol)
&&
(caadr(arg)
==
sc->multiply_symbol))
?
fx_add_mul_opssq_s
:
fx_c_opssq_s_direct));
}
return (fx_c_opssq_s);
case HOP_SAFE_C_opSSq_opSSq:
{
s7_pointer s1 = cadr(arg), s2 = caddr(arg);
set_opt3_pair(arg, cdr(s2));
if ((fx_matches(car(s1), sc->multiply_symbol))
&& (car(s2) == sc->multiply_symbol)) {
set_opt1_pair(cdr(arg), cdr(s1));
if (car(arg) == sc->subtract_symbol)
return (fx_sub_mul_mul);
if (car(arg) == sc->add_symbol)
return (((cadr(s1) == caddr(s1))
&& (cadr(s2) ==
caddr(s2))) ? fx_add_sqr_sqr :
fx_add_mul_mul);
}
if ((fx_matches(car(s1), sc->subtract_symbol))
&& (car(s2) == sc->subtract_symbol)) {
set_opt1_pair(cdr(arg), cdr(s1));
if (car(arg) == sc->multiply_symbol)
return (fx_mul_sub_sub);
if (car(arg) == sc->lt_symbol)
return (fx_lt_sub2);
}
if ((fx_matches(car(arg), sc->subtract_symbol))
&& (fx_matches(car(s1), sc->vector_ref_symbol))
&& (car(s2) == sc->vector_ref_symbol)
&& (cadr(s1) == cadr(s2))) {
set_opt3_sym(arg, cadr(cdaddr(arg)));
return (fx_sub_vref2);
}
return (fx_c_opssq_opssq);
}
case HOP_SAFE_C_opSq:
if (is_unchanged_global(caadr(arg))) {
if (fx_matches(car(arg), sc->is_pair_symbol)) {
if (caadr(arg) == sc->car_symbol) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_is_pair_car_s);
}
if (caadr(arg) == sc->cdr_symbol) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_is_pair_cdr_s);
}
if (caadr(arg) == sc->cadr_symbol) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_is_pair_cadr_s);
}
if (caadr(arg) == sc->cddr_symbol) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_is_pair_cddr_s);
}
}
if (fx_matches(car(arg), sc->is_null_symbol)) {
if (caadr(arg) == sc->cdr_symbol) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_is_null_cdr_s);
}
if (caadr(arg) == sc->cadr_symbol) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_is_null_cadr_s);
}
if (caadr(arg) == sc->cddr_symbol) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_is_null_cddr_s);
}
}
if ((fx_matches(car(arg), sc->is_symbol_symbol)) &&
(caadr(arg) == sc->cadr_symbol)) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_is_symbol_cadr_s);
}
if (fx_matches(car(arg), sc->not_symbol)) {
if (caadr(arg) == sc->is_pair_symbol) {
set_opt3_sym(arg, cadadr(arg));
return (fx_not_is_pair_s);
}
if (caadr(arg) == sc->is_null_symbol) {
set_opt3_sym(arg, cadadr(arg));
return (fx_not_is_null_s);
}
if (caadr(arg) == sc->is_symbol_symbol) {
set_opt3_sym(arg, cadadr(arg));
return (fx_not_is_symbol_s);
}
return (fx_not_opsq);
}
if ((fx_matches(car(arg), sc->floor_symbol))
&& (caadr(arg) == sc->sqrt_symbol)) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_floor_sqrt_s);
}
}
if (is_unchanged_global(car(arg))) { /* (? (op arg)) where (op arg) might return a let with a ? method etc */
/* other possibility: fx_c_a */
uint8_t typ = symbol_type(car(arg));
if (typ > 0) { /* h_safe_c here so the type checker isn't shadowed */
set_opt2_sym(cdr(arg), cadadr(arg));
set_opt3_byte(cdr(arg), typ);
if (fn_proc(cadr(arg)) ==
(s7_function) g_c_pointer_weak1)
return (fx_eq_weak1_type_s);
return (fx_matches(caadr(arg), sc->car_symbol) ?
fx_is_type_car_s : fx_is_type_opsq);
}
}
/* this should follow the is_type* check above */
if (fx_matches(caadr(arg), sc->car_symbol)) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_c_car_s);
}
if (fx_matches(caadr(arg), sc->cdr_symbol)) {
set_opt2_sym(cdr(arg), cadadr(arg));
return (fx_c_cdr_s);
}
return (fx_c_opsq);
case HOP_SAFE_C_SC:
if (is_unchanged_global(car(arg))) {
if (car(arg) == sc->add_symbol) {
if (is_t_real(caddr(arg)))
return (fx_add_sf);
if (is_t_integer(caddr(arg)))
return ((integer(caddr(arg)) ==
1) ? fx_add_s1 : fx_add_si);
}
if (car(arg) == sc->subtract_symbol) {
if (is_t_real(caddr(arg)))
return (fx_subtract_sf);
if (is_t_integer(caddr(arg)))
return ((integer(caddr(arg)) ==
1) ? fx_subtract_s1 : fx_subtract_si);
}
if (car(arg) == sc->multiply_symbol) {
if (is_t_real(caddr(arg)))
return (fx_multiply_sf);
if (is_t_integer(caddr(arg)))
return (fx_multiply_si);
}
if ((fn_proc(arg) == g_memq_2) && (is_pair(caddr(arg))))
return (fx_memq_sq_2);
if ((fn_proc(arg) == g_is_eq)
&& (!is_unspecified(caddr(arg))))
return (fx_is_eq_sc);
if ((is_t_integer(caddr(arg)))
&& (s7_p_pi_function(global_value(car(arg))))) {
if (car(arg) == sc->num_eq_symbol)
return ((integer(caddr(arg)) ==
0) ? fx_num_eq_s0 : fx_num_eq_si);
if (car(arg) == sc->lt_symbol)
return (fx_lt_si);
if (car(arg) == sc->leq_symbol)
return (fx_leq_si);
if (car(arg) == sc->gt_symbol)
return (fx_gt_si);
if (car(arg) == sc->geq_symbol)
return (fx_geq_si);
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pi_function
(global_value
(car(arg)))));
return (fx_c_si_direct);
}
if ((is_t_real(caddr(arg))) && (real(caddr(arg)) == 0.0)
&& (car(arg) == sc->num_eq_symbol))
return (fx_num_eq_s0f);
if ((s7_p_pp_function(global_value(car(arg))))
&& (fn_proc(arg) != g_divide_by_2)) {
if (car(arg) == sc->memq_symbol) {
if ((is_pair(caddr(arg)))
&& (is_proper_list_3(sc, cadaddr(arg))))
return (fx_memq_sc_3);
return (fx_memq_sc);
}
if ((car(arg) == sc->char_eq_symbol)
&& (is_character(caddr(arg))))
return (fx_char_eq_sc); /* maybe fx_char_eq_newline */
if (car(arg) == sc->lt_symbol)
return (fx_lt_sc); /* integer case handled above */
if (car(arg) == sc->leq_symbol)
return (fx_leq_sc);
if (car(arg) == sc->gt_symbol)
return (fx_gt_sc);
if (car(arg) == sc->geq_symbol)
return (fx_geq_sc);
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(car(arg)))));
return (fx_c_sc_direct);
}
}
return (fx_c_sc);
case HOP_SAFE_C_CS:
if (is_unchanged_global(car(arg))) {
if (car(arg) == sc->cons_symbol)
return (fx_cons_cs);
if ((car(arg) == sc->add_symbol) && (is_t_real(cadr(arg))))
return (fx_add_fs);
if ((car(arg) == sc->subtract_symbol)
&& (is_t_real(cadr(arg))))
return (fx_subtract_fs);
if ((car(arg) == sc->num_eq_symbol)
&& (cadr(arg) == int_zero))
return (fx_num_eq_0s);
if (car(arg) == sc->multiply_symbol) {
if (is_t_real(cadr(arg)))
return (fx_multiply_fs);
if (is_t_integer(cadr(arg)))
return (fx_multiply_is);
}
}
return (fx_c_cs);
case HOP_SAFE_C_S_opSq:
if (fx_matches(car(caddr(arg)), sc->car_symbol)) {
set_opt2_sym(cdr(arg), cadaddr(arg));
if (fx_matches(car(arg), sc->hash_table_ref_symbol))
return (fx_hash_table_ref_car);
return (fx_matches(car(arg), sc->add_symbol) ?
fx_add_s_car_s : fx_c_s_car_s);
}
if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
(is_global_and_has_func(caaddr(arg), s7_p_p_function))) {
if ((car(arg) == sc->cons_symbol)
&& (caaddr(arg) == sc->cdr_symbol)) {
set_opt2_sym(cdr(arg), cadaddr(arg));
return (fx_cons_s_cdr_s);
}
set_opt1_sym(cdr(arg), cadaddr(arg));
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_p_function
(global_value
(caaddr(arg)))));
return (fx_c_s_opsq_direct);
}
return (fx_c_s_opsq);
case HOP_SAFE_C_C_opSq:
if (is_global_and_has_func(car(arg), s7_p_pp_function)) {
s7_pointer arg2 = caddr(arg);
if (is_global_and_has_func(car(arg2), s7_p_p_function)) {
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_p_function
(global_value
(car(arg2)))));
set_opt1_sym(cdr(arg), cadr(arg2));
return (fx_c_c_opsq_direct);
}
}
return (fx_c_c_opsq);
case HOP_SAFE_C_opSq_C:
if (is_unchanged_global(car(arg))) {
if ((car(arg) == sc->memq_symbol) &&
(fx_matches(caadr(arg), sc->car_symbol)) &&
(is_proper_quote(sc, caddr(arg))) &&
(is_pair(cadaddr(arg))))
return ((s7_list_length(sc, opt2_con(cdr(arg))) ==
2) ? fx_memq_car_s_2 : fx_memq_car_s);
if (car(arg) == sc->is_eq_symbol) {
if (((fx_matches(caadr(arg), sc->car_symbol))
|| (fx_matches(caadr(arg), sc->caar_symbol)))
&& (is_proper_quote(sc, caddr(arg)))) {
set_opt3_sym(cdr(arg), cadadr(arg));
set_opt2_con(cdr(arg), cadaddr(arg));
return ((caadr(arg) ==
sc->car_symbol) ? fx_is_eq_car_sq :
fx_is_eq_caar_sq);
}
}
if (((car(arg) == sc->lt_symbol)
|| (car(arg) == sc->num_eq_symbol))
&& (is_t_integer(caddr(arg)))
&& (fx_matches(caadr(arg), sc->length_symbol))) {
set_opt3_sym(cdr(arg), cadadr(arg));
set_opt2_con(cdr(arg), caddr(arg));
return ((car(arg) ==
sc->lt_symbol) ? fx_less_length_i :
fx_num_eq_length_i);
}
}
set_opt1_sym(cdr(arg), cadadr(arg));
return (fx_c_opsq_c);
case HOP_SAFE_C_op_opSqq:
return ((fx_matches(car(arg), sc->not_symbol))
? ((fn_proc(cadr(arg)) ==
g_is_pair) ? fx_not_is_pair_opsq : fx_not_op_opsqq)
: fx_c_op_opsqq);
case HOP_SAFE_C_opSCq:
if (fx_matches(car(arg), sc->not_symbol)) {
if (fn_proc(cadr(arg)) == g_is_eq) {
set_opt2_sym(cdr(arg), cadadr(arg));
set_opt3_con(cdr(arg),
(is_pair(caddadr(arg))) ?
cadaddr(cadr(arg)) : caddadr(arg));
return (fx_not_is_eq_sq);
}
return (fx_not_opscq);
}
return (fx_c_opscq);
case HOP_SAFE_C_S_opSCq:
if (is_global_and_has_func(car(arg), s7_p_pp_function)) {
s7_pointer arg2 = caddr(arg);
if ((is_global_and_has_func(car(arg2), s7_p_pi_function))
&& (is_t_integer(caddr(arg2)))) {
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pi_function
(global_value
(car(arg2)))));
set_opt3_sym(arg, cadr(arg2));
set_opt1_con(cdr(arg), caddr(arg2));
if (car(arg) == sc->num_eq_symbol) {
if (car(arg2) == sc->add_symbol)
return (fx_num_eq_add_s_si);
if (car(arg2) == sc->subtract_symbol)
return (fx_num_eq_subtract_s_si);
}
if ((car(arg) == sc->vector_ref_symbol)
&& (car(arg2) == sc->add_symbol)
&& (integer(caddr(arg2)) == 1))
return (fx_vref_p1);
return (fx_c_s_opsiq_direct);
}
if (is_global_and_has_func(car(arg2), s7_p_pp_function)) {
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(car(arg2)))));
set_opt3_sym(arg, cadr(arg2));
set_opt1_con(cdr(arg),
(is_pair(caddr(arg2))) ? cadaddr(arg2) :
caddr(arg2));
return (fx_c_s_opscq_direct);
}
}
return (fx_c_s_opscq);
case HOP_SAFE_C_opSSq:
if (fx_matches(car(arg), sc->not_symbol)) {
if (fn_proc(cadr(arg)) == g_is_eq)
return (fx_not_is_eq_ss);
return (fx_not_opssq);
}
if ((is_global_and_has_func(car(arg), s7_p_p_function)) &&
(is_global_and_has_func(caadr(arg), s7_p_pp_function))) {
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_p_function
(global_value(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(caadr(arg)))));
return (fx_c_opssq_direct);
}
return (fx_c_opssq);
case HOP_SAFE_C_C_opSSq:
{
s7_pointer s2 = caddr(arg);
if ((fx_matches(car(s2), sc->multiply_symbol))
&& (cadr(s2) == caddr(s2)))
return (fx_c_c_sqr);
}
if ((is_small_real(cadr(arg))) && (is_global_and_has_func(car(arg), s7_p_dd_function)) && (is_global_and_has_func(caaddr(arg), s7_d_pd_function))) { /* not * currently (this is for clm) */
set_opt3_direct(cdr(arg),
s7_d_pd_function(global_value
(caaddr(arg))));
set_opt2_direct(cdr(arg),
s7_p_dd_function(global_value(car(arg))));
set_opt3_sym(arg, cadaddr(arg));
set_opt1_sym(cdr(arg), caddaddr(arg));
return (fx_c_nc_opssq_direct);
}
if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
(is_global_and_has_func(caaddr(arg), s7_p_pp_function))) {
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(caaddr(arg)))));
set_opt3_sym(arg, cadaddr(arg));
set_opt1_sym(cdr(arg), caddaddr(arg));
if ((is_t_real(cadr(arg))) && (car(arg) == caaddr(arg))
&& (car(arg) == sc->multiply_symbol))
return (fx_multiply_c_opssq);
return (fx_c_c_opssq_direct);
}
return (fx_c_c_opssq);
case HOP_SAFE_C_opSq_opSq:
if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
(is_global_and_has_func(caadr(arg), s7_p_p_function)) &&
(is_global_and_has_func(caaddr(arg), s7_p_p_function))) {
set_opt3_direct(arg,
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_p_function
(global_value(caadr(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_p_function
(global_value
(caaddr(arg)))));
if ((caadr(arg) == caaddr(arg))
&& (caadr(arg) == sc->cdr_symbol)) {
set_opt1_sym(cdr(arg), cadadr(arg));
set_opt2_sym(cdr(arg), cadaddr(arg));
return (fx_cdr_s_cdr_s);
}
set_opt1_sym(cdr(arg), cadaddr(arg)); /* opt2 is taken by second func */
return (fx_c_opsq_opsq_direct);
}
return (fx_c_opsq_opsq);
case HOP_SAFE_C_op_S_opSqq:
return ((fx_matches(car(arg), sc->not_symbol)) ?
fx_not_op_s_opsqq : fx_c_op_s_opsqq);
case HOP_SAFE_C_op_opSSqq_S:
if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
(is_global_and_has_func(caadr(arg), s7_p_p_function)) &&
(is_global_and_has_func
(car(cadadr(arg)), s7_p_pp_function))) {
set_opt3_direct(arg,
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
set_opt2_direct(cdr(arg),
(s7_pointer) (s7_p_p_function
(global_value(caadr(arg)))));
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value
(caadr(cadr(arg))))));
return (fx_c_op_opssqq_s_direct);
}
return (fx_c_op_opssqq_s);
case HOP_SAFE_C_A:
if (fx_matches(car(arg), sc->not_symbol)) {
if (fx_proc(cdr(arg)) == fx_is_eq_car_sq) {
set_opt1_sym(cdr(arg), cadadr(cadr(arg)));
set_opt3_con(cdr(arg), cadaddr(cadr(arg)));
return (fx_not_is_eq_car_sq);
}
return (fx_not_a);
}
if (is_global_and_has_func(car(arg), s7_p_p_function)) {
set_opt3_direct(arg,
(s7_pointer) (s7_p_p_function
(global_value(car(arg)))));
return (fx_c_a_direct);
}
return (fx_c_a);
case HOP_SAFE_C_AC:
if (fn_proc(arg) == g_cons)
return (fx_cons_ac);
if (fx_matches(car(arg), sc->is_eq_symbol))
return (fx_is_eq_ac);
if (is_global_and_has_func(car(arg), s7_p_pp_function)) {
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
if ((opt3_direct(cdr(arg)) == (s7_pointer) string_ref_p_pp)
&& (is_t_integer(caddr(arg)))
&& (integer(caddr(arg)) == 0))
set_opt3_direct(cdr(arg), string_ref_p_p0);
if (opt3_direct(cdr(arg)) == (s7_pointer) memq_p_pp) {
if (fn_proc(arg) == g_memq_2)
set_opt3_direct(cdr(arg),
(s7_pointer) memq_2_p_pp);
else if ((is_pair(caddr(arg)))
&& (is_proper_list_3(sc, cadaddr(arg))))
set_opt3_direct(cdr(arg), memq_3_p_pp);
else if (fn_proc(arg) == g_memq_4)
set_opt3_direct(cdr(arg), memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */
}
return (fx_c_ac_direct);
}
return (fx_c_ac);
case HOP_SAFE_C_CA:
return ((fn_proc(arg) == g_cons) ? fx_cons_ca : fx_c_ca);
case HOP_SAFE_C_SA:
if (fn_proc(arg) == g_multiply_2)
return (fx_multiply_sa);
if (fn_proc(arg) == g_add_2)
return (fx_add_sa);
if (is_global_and_has_func(car(arg), s7_p_pp_function)) {
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
return ((fn_proc(arg) ==
g_cons) ? fx_cons_sa : fx_c_sa_direct);
}
return (fx_c_sa);
case HOP_SAFE_C_AS:
if (fn_proc(arg) == g_add_2)
return (fx_add_as);
if (is_global_and_has_func(car(arg), s7_p_pp_function)) {
set_opt3_direct(cdr(arg),
(s7_pointer) (s7_p_pp_function
(global_value(car(arg)))));
return ((fn_proc(arg) ==
g_cons) ? fx_cons_as : fx_c_as_direct);
}
return (fx_c_as);
case HOP_SAFE_C_AA:
/* (* wr (float-vector-ref rl 0 j)) (* wr (block-ref (vector-ref rl j) 0)) (- (float-vector-ref rl 0 i) tempr) */
if (fn_proc(arg) == g_add_2)
return (fx_add_aa);
if (fn_proc(arg) == g_subtract_2)
return (fx_subtract_aa);
if (fn_proc(arg) == g_multiply_2)
return (fx_multiply_aa);
if (fn_proc(arg) == g_number_to_string)
return (fx_number_to_string_aa);
if (fn_proc(arg) == g_cons)
return (fx_cons_aa);
/* we can get here from gx_annotate which does not call fx_tree, where A=fx_unsafe_s */
if (fx_proc(cdr(arg)) == fx_unsafe_s)
return (fx_c_za);
return (fx_c_aa);
case HOP_SAFE_C_opAAq:
return ((fx_proc(cdadr(arg)) ==
fx_s) ? fx_c_opsaq : fx_c_opaaq);
case HOP_SAFE_C_NA:
return ((fn_proc(arg) ==
g_vector) ? fx_vector_all_a : fx_c_na);
case HOP_SAFE_C_ALL_CA:
return ((fn_proc(arg) ==
g_simple_inlet) ? fx_inlet_ca : fx_c_all_ca);
case HOP_SAFE_CLOSURE_S_A:
{
s7_pointer body = car(closure_body(opt1_lambda(arg)));
if (is_pair(body)) {
if (optimize_op(body) == OP_AND_2A) {
if ((fx_matches(caadr(body), sc->is_pair_symbol))
&& (cadadr(body) ==
car(closure_args(opt1_lambda(arg)))))
return (fx_safe_closure_s_and_pair); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */
return (fx_safe_closure_s_and_2a);
}
if (optimize_op(body) == HOP_SAFE_C_opSq_C) {
if ((fn_proc(body) == g_lint_let_ref) &&
(cadadr(body) ==
car(closure_args(opt1_lambda(arg))))) {
set_opt2_sym(cdr(arg), cadaddr(body));
return (fx_lint_let_ref_s); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */
}
}
}
return ((fx_proc(closure_body(opt1_lambda(arg))) ==
fx_sqr_t) ? fx_safe_closure_s_sqr :
fx_safe_closure_s_a);
}
case HOP_SAFE_CLOSURE_S_TO_SC:
{
s7_pointer body = car(closure_body(opt1_lambda(arg)));
if (fn_proc(body) == g_vector_ref_2)
return (fx_safe_closure_s_to_vref);
if ((is_t_integer(caddr(body)))
&& (integer(caddr(body)) == 1)) {
if (car(body) == sc->subtract_symbol)
return (fx_safe_closure_s_to_sub1);
if (car(body) == sc->add_symbol)
return (fx_safe_closure_s_to_add1);
}
return (fx_safe_closure_s_to_sc);
}
case HOP_SAFE_CLOSURE_A_TO_SC:
return ((fn_proc(car(closure_body(opt1_lambda(arg)))) ==
g_vector_ref_2) ? fx_safe_closure_a_to_vref :
fx_safe_closure_a_to_sc);
case HOP_SAFE_CLOSURE_A_A:
if (fx_proc(closure_body(opt1_lambda(arg))) == fx_and_2a)
return (fx_safe_closure_a_and_2a);
return ((fx_proc(closure_body(opt1_lambda(arg))) ==
fx_sqr_t) ? fx_safe_closure_a_sqr :
fx_safe_closure_a_a);
case HOP_SAFE_CLOSURE_3S_A:
if (fx_proc(closure_body(opt1_lambda(arg))) ==
fx_vref_vref_tu_v)
return (fx_vref_vref_3_no_let);
default:
/* if ((!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], display(arg)); */
return (fx_function[optimize_op(arg)]);
}
} /* is_optimized */
if ((car(arg) == sc->quote_symbol) && (is_global(sc->quote_symbol))) {
check_quote(sc, arg);
return (fx_q);
}
return (NULL);
}
#if S7_DEBUGGING
#define with_fx(P, F) with_fx_1(sc, P, F)
static bool with_fx_1(s7_scheme * sc, s7_pointer p, s7_function f) /* sc needed for set_opt2 under debugger = set_opt2_1(sc,...) */
#else
static bool with_fx(s7_pointer p, s7_function f)
#endif
{
set_fx_direct(p, f);
return (true);
}
static bool o_var_ok(s7_pointer p, s7_pointer var1, s7_pointer var2,
s7_pointer var3)
{
return ((p != var1) && (p != var2) && (p != var3));
}
static bool fx_tree_out(s7_scheme * sc, s7_pointer tree, s7_pointer var1,
s7_pointer var2, s7_pointer var3, bool more_vars)
{
s7_pointer p = car(tree);
/* if (fx_proc(tree) == fx_iterate_o) fprintf(stderr, "[%d] %s %s %s %s\n", __LINE__, display(p), display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : ""); */
/* fprintf(stderr, "%s[%d] %s %s %d: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", has_fx(tree), display(tree)); */
if (is_symbol(p)) {
if ((fx_proc(tree) == fx_s) || (fx_proc(tree) == fx_o)) {
if (p == var1)
return (with_fx(tree, fx_T));
if (p == var2)
return (with_fx(tree, fx_U));
/* if O possible, make sure fx_tree_in checked all vars and its own more_vars -- ideally "o" coming in */
}
return (false);
}
if ((is_pair(p)) && (is_pair(cdr(p)))) {
if (cadr(p) == var1) {
if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o))
return (with_fx(tree, fx_c_T)); /* fx_c_T_direct got no hits */
if (fx_proc(tree) == fx_is_null_s)
return (with_fx(tree, fx_is_null_T));
if (fx_proc(tree) == fx_subtract_s1)
return (with_fx(tree, fx_subtract_T1));
if (fx_proc(tree) == fx_add_s1)
return (with_fx(tree, fx_add_T1));
if (fx_proc(tree) == fx_c_sca)
return (with_fx(tree, fx_c_Tca));
if ((fx_proc(tree) == fx_num_eq_si)
|| (fx_proc(tree) == fx_num_eq_s0))
return (with_fx(tree, fx_num_eq_Ti));
if (fx_proc(tree) == fx_multiply_ss)
return (with_fx(tree, fx_multiply_Ts));
if ((fx_proc(tree) == fx_c_scs_direct) && (cadddr(p) == var2))
return (with_fx(tree, fx_c_TcU_direct));
} else if (cadr(p) == var2) {
if (fx_proc(tree) == fx_subtract_s1)
return (with_fx(tree, fx_subtract_U1));
if (fx_proc(tree) == fx_add_s1)
return (with_fx(tree, fx_add_U1));
} else if (cadr(p) == var3) {
if (fx_proc(tree) == fx_add_s1)
return (with_fx(tree, fx_add_V1));
} else if (is_pair(cddr(p))) {
if (caddr(p) == var1) {
if ((fx_proc(tree) == fx_num_eq_ts)
|| (fx_proc(tree) == fx_num_eq_to))
return (with_fx(tree, fx_num_eq_tT));
if ((fx_proc(tree) == fx_gt_ts)
|| (fx_proc(tree) == fx_gt_to))
return (with_fx(tree, fx_gt_tT));
if (fx_proc(tree) == fx_lt_ts)
return (with_fx(tree, fx_lt_tT));
if ((fx_proc(tree) == fx_geq_ts)
|| (fx_proc(tree) == fx_geq_to))
return (with_fx(tree, fx_geq_tT));
} else if (caddr(p) == var2) {
if (fx_proc(tree) == fx_c_ts)
return (with_fx(tree, fx_c_tU));
if (fx_proc(tree) == fx_cons_ts)
return (with_fx(tree, fx_cons_tU));
if (fx_proc(tree) == fx_c_ts_direct)
return (with_fx(tree, fx_c_tU_direct));
if (fx_proc(tree) == fx_lt_ts)
return (with_fx(tree, fx_lt_tU));
} else {
if ((!more_vars) && (caddr(p) != var3)
&& ((fx_proc(tree) == fx_num_eq_ts)
|| (fx_proc(tree) == fx_num_eq_to)))
return (with_fx(tree, fx_num_eq_tO));
if ((fx_proc(tree) == fx_add_sqr_s) && (cadadr(p) == var1))
return (with_fx(tree, fx_add_sqr_T));
}
}
}
return (false);
}
static s7_b_7p_t s7_b_7p_function(s7_pointer f);
static bool fx_tree_in(s7_scheme * sc, s7_pointer tree, s7_pointer var1,
s7_pointer var2, s7_pointer var3, bool more_vars)
{
s7_pointer p = car(tree);
#if 0
/* if ((s7_tree_memq(sc, var1, car(tree))) || ((var2) && (s7_tree_memq(sc, var2, car(tree)))) || ((var3) && (s7_tree_memq(sc, var3, car(tree))))) */
if (fx_proc(tree) == fx_c_s_opssq_direct)
fprintf(stderr, "fx_tree_in %s %s %s %s: %s\n",
op_names[optimize_op(car(tree))], display(var1),
(var2) ? display(var2) : "", (var3) ? display(var3) : "",
display_80(car(tree)));
#endif
if (is_symbol(p)) {
if (fx_proc(tree) == fx_s) {
if (p == var1)
return (with_fx(tree, fx_t));
if (p == var2)
return (with_fx(tree, fx_u));
if (p == var3)
return (with_fx(tree, fx_v));
if (is_global(p))
return (with_fx(tree, fx_g));
if (!more_vars)
return (with_fx(tree, fx_o));
}
return (false);
}
if ((S7_DEBUGGING) && (!has_fx(tree)))
fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__,
display_80(p));
if ((!is_pair(p)) || (is_fx_treed(tree)))
return (false);
set_fx_treed(tree);
switch (optimize_op(p)) {
case HOP_SAFE_C_S:
if (cadr(p) == var1) {
if (fx_proc(tree) == fx_c_s)
return (with_fx(tree, fx_c_t));
if (fx_proc(tree) == fx_c_s_direct)
return (with_fx
(tree,
(opt2_direct(cdr(p)) ==
(s7_pointer) cddr_p_p) ? fx_cddr_t :
fx_c_t_direct));
if (fx_proc(tree) == fx_car_s)
return (with_fx(tree, fx_car_t));
if (fx_proc(tree) == fx_cdr_s)
return (with_fx(tree, fx_cdr_t));
if (fx_proc(tree) == fx_cddr_s)
return (with_fx(tree, fx_cddr_t));
if (fx_proc(tree) == fx_cadr_s)
return (with_fx(tree, fx_cadr_t));
if (fx_proc(tree) == fx_not_s)
return (with_fx(tree, fx_not_t));
if (fx_proc(tree) == fx_is_null_s)
return (with_fx(tree, fx_is_null_t));
if (fx_proc(tree) == fx_is_pair_s)
return (with_fx(tree, fx_is_pair_t));
if (fx_proc(tree) == fx_is_symbol_s)
return (with_fx(tree, fx_is_symbol_t));
if (fx_proc(tree) == fx_is_eof_s)
return (with_fx(tree, fx_is_eof_t));
if (fx_proc(tree) == fx_is_string_s)
return (with_fx(tree, fx_is_string_t));
if (fx_proc(tree) == fx_is_vector_s)
return (with_fx(tree, fx_is_vector_t));
if (fx_proc(tree) == fx_is_integer_s)
return (with_fx(tree, fx_is_integer_t));
if (fx_proc(tree) == fx_is_procedure_s)
return (with_fx(tree, fx_is_procedure_t));
if (fx_proc(tree) == fx_is_type_s)
return (with_fx(tree, fx_is_type_t));
if (fx_proc(tree) == fx_length_s)
return (with_fx(tree, fx_length_t));
if (fx_proc(tree) == fx_real_part_s)
return (with_fx(tree, fx_real_part_t));
if (fx_proc(tree) == fx_imag_part_s)
return (with_fx(tree, fx_imag_part_t));
return (false);
}
if (cadr(p) == var2) {
if (fx_proc(tree) == fx_c_s) {
if (is_global_and_has_func(car(p), s7_p_p_function)) {
set_opt2_direct(cdr(p),
(s7_pointer) (s7_p_p_function
(global_value(car(p)))));
return (with_fx
(tree,
(car(p) ==
sc->cddr_symbol) ? fx_cddr_u : ((car(p) ==
sc->is_positive_symbol)
?
fx_is_positive_u
: ((car(p) ==
sc->is_zero_symbol)
?
fx_is_zero_u
:
fx_c_u_direct))));
}
return (with_fx(tree, fx_c_u));
}
if (fx_proc(tree) == fx_c_s_direct)
return (with_fx
(tree,
(car(p) ==
sc->cddr_symbol) ? fx_cddr_u : ((car(p) ==
sc->is_positive_symbol)
?
fx_is_positive_u
: ((car(p) ==
sc->is_zero_symbol)
? fx_is_zero_u
:
fx_c_u_direct))));
if (fx_proc(tree) == fx_cdr_s)
return (with_fx(tree, fx_cdr_u));
if (fx_proc(tree) == fx_cadr_s)
return (with_fx(tree, fx_cadr_u));
if (fx_proc(tree) == fx_cddr_s)
return (with_fx(tree, fx_cddr_u));
if (fx_proc(tree) == fx_car_s)
return (with_fx(tree, fx_car_u));
if (fx_proc(tree) == fx_is_null_s)
return (with_fx(tree, fx_is_null_u));
if (fx_proc(tree) == fx_is_type_s)
return (with_fx(tree, fx_is_type_u));
if (fx_proc(tree) == fx_is_pair_s)
return (with_fx(tree, fx_is_pair_u));
if (fx_proc(tree) == fx_is_symbol_s)
return (with_fx(tree, fx_is_symbol_u));
if (fx_proc(tree) == fx_is_eof_s)
return (with_fx(tree, fx_is_eof_u));
return (false);
}
if (cadr(p) == var3) {
if (fx_proc(tree) == fx_cdr_s)
return (with_fx(tree, fx_cdr_v));
if (fx_proc(tree) == fx_is_null_s)
return (with_fx(tree, fx_is_null_v));
if (fx_proc(tree) == fx_is_pair_s)
return (with_fx(tree, fx_is_pair_v));
if (fx_proc(tree) == fx_c_s)
return (with_fx(tree, fx_c_v));
if (fx_proc(tree) == fx_c_s_direct)
return (with_fx(tree, fx_c_v_direct));
return (false);
}
if (!more_vars) {
if (fx_proc(tree) == fx_is_null_s)
return (with_fx(tree, fx_is_null_o));
if (fx_proc(tree) == fx_car_s)
return (with_fx(tree, fx_car_o));
if (fx_proc(tree) == fx_cdr_s)
return (with_fx(tree, fx_cdr_o));
if (fx_proc(tree) == fx_cadr_s)
return (with_fx(tree, fx_cadr_o));
if (fx_proc(tree) == fx_cddr_s)
return (with_fx(tree, fx_cddr_o));
if (fx_proc(tree) == fx_iterate_s)
return (with_fx(tree, fx_iterate_o));
if (fx_proc(tree) == fx_not_s)
return (with_fx(tree, fx_not_o));
if (fx_proc(tree) == fx_c_s_direct)
return (with_fx(tree, fx_c_o_direct));
if (fx_proc(tree) == fx_c_s)
return (with_fx(tree, fx_c_o));
}
break;
case HOP_SAFE_C_SC:
/* fprintf(stderr, "%s %d %s %s %s\n", display(p), cadr(p) == var3, display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : ""); */
if (cadr(p) == var1) {
if ((fx_proc(tree) == fx_char_eq_sc)
|| (fn_proc(p) == g_char_equal_2))
return (with_fx(tree, fx_char_eq_tc));
if (fx_proc(tree) == fx_c_sc)
return (with_fx(tree, fx_c_tc));
if (fx_proc(tree) == fx_add_sf)
return (with_fx(tree, fx_add_tf));
if (fn_proc(p) == g_less_xf)
return (with_fx(tree, fx_lt_tf));
if (fn_proc(p) == g_less_x0)
return (with_fx(tree, fx_lt_t0));
if (fn_proc(p) == g_less_xi)
return (with_fx
(tree,
(integer(caddr(p)) ==
2) ? fx_lt_t2 : ((integer(caddr(p)) ==
1) ? fx_lt_t1 : fx_lt_ti)));
if (fn_proc(p) == g_geq_xf)
return (with_fx(tree, fx_geq_tf));
if (fn_proc(p) == g_geq_xi)
return (with_fx
(tree,
(integer(caddr(p)) ==
0) ? fx_geq_t0 : fx_geq_ti));
if (fn_proc(p) == g_leq_xi)
return (with_fx(tree, fx_leq_ti));
if (fn_proc(p) == g_greater_xi)
return (with_fx(tree, fx_gt_ti));
if (fx_proc(tree) == fx_c_sc_direct) { /* p_pp cases */
if ((opt3_direct(cdr(p)) == (s7_pointer) vector_ref_p_pp)
&& (is_t_integer(caddr(p))))
return (with_fx(tree, fx_vector_ref_tc));
if ((opt3_direct(cdr(p)) == (s7_pointer) string_ref_p_pp)
&& (is_t_integer(caddr(p)))
&& (integer(caddr(p)) == 0))
set_opt3_direct(cdr(p), string_ref_p_p0);
return (with_fx(tree, fx_c_tc_direct));
}
if (fx_proc(tree) == fx_c_si_direct) { /* p_pi cases */
if (opt3_direct(cdr(p)) == (s7_pointer) vector_ref_p_pi)
return (with_fx(tree, fx_vector_ref_tc));
if ((opt3_direct(cdr(p)) == (s7_pointer) string_ref_p_pi)
&& (integer(caddr(p)) == 0))
set_opt3_direct(cdr(p), string_ref_p_p0);
return (with_fx(tree, fx_c_ti_direct));
}
if (fx_proc(tree) == fx_is_eq_sc)
return (with_fx(tree, fx_is_eq_tc));
if (fx_proc(tree) == fx_add_s1)
return (with_fx(tree, fx_add_t1));
if (fx_proc(tree) == fx_subtract_s1)
return (with_fx(tree, fx_subtract_t1));
if (fx_proc(tree) == fx_subtract_si)
return (with_fx(tree, fx_subtract_ti));
if (fx_proc(tree) == fx_subtract_sf)
return (with_fx(tree, fx_subtract_tf));
if (fx_proc(tree) == fx_multiply_sf)
return (with_fx(tree, fx_multiply_tf));
if (fx_proc(tree) == fx_lt_si) /* is this ever hit? */
return (with_fx
(tree,
(integer(caddr(p)) ==
2) ? fx_lt_t2 : ((integer(caddr(p)) ==
1) ? fx_lt_t1 : fx_lt_ti)));
if (fx_proc(tree) == fx_leq_si)
return (with_fx(tree, fx_leq_ti));
if (fx_proc(tree) == fx_gt_si)
return (with_fx(tree, fx_gt_ti));
if (fx_proc(tree) == fx_num_eq_si)
return (with_fx(tree, fx_num_eq_ti));
if (fx_proc(tree) == fx_num_eq_s0)
return (with_fx(tree, fx_num_eq_t0));
if (fx_proc(tree) == fx_memq_sc)
return (with_fx(tree, fx_memq_tc));
return (false);
}
if (cadr(p) == var2) {
if (fx_proc(tree) == fx_c_sc)
return (with_fx(tree, fx_c_uc));
if (fx_proc(tree) == fx_num_eq_s0)
return (with_fx(tree, fx_num_eq_u0));
if (fx_proc(tree) == fx_num_eq_si)
return (with_fx(tree, fx_num_eq_ui));
if (fx_proc(tree) == fx_add_s1)
return (with_fx(tree, fx_add_u1));
if (fx_proc(tree) == fx_subtract_s1)
return (with_fx(tree, fx_subtract_u1));
return (false);
}
if (cadr(p) == var3) {
if (fx_proc(tree) == fx_num_eq_s0)
return (with_fx(tree, fx_num_eq_v0));
if (fx_proc(tree) == fx_num_eq_si)
return (with_fx(tree, fx_num_eq_vi));
if (fx_proc(tree) == fx_c_sc)
return (with_fx(tree, fx_c_vc));
return (false);
}
break;
case HOP_SAFE_C_CS:
if (caddr(p) == var1) {
if ((car(p) == sc->cons_symbol)
&& (is_unchanged_global(sc->cons_symbol)))
return (with_fx(tree, fx_cons_ct));
if (fx_proc(tree) == fx_c_cs) {
if (is_global_and_has_func(car(p), s7_p_pp_function)) {
if (fn_proc(p) == g_tree_set_memq_1)
set_opt3_direct(cdr(p),
(s7_pointer) tree_set_memq_direct);
else
set_opt3_direct(cdr(p),
(s7_pointer) (s7_p_pp_function
(global_value
(car(p)))));
set_fx_direct(tree, fx_c_ct_direct);
} else
set_fx_direct(tree, fx_c_ct);
return (true);
}
}
if ((caddr(p) == var2) && (fx_proc(tree) == fx_c_cs))
return (with_fx(tree, fx_c_cu));
break;
case HOP_SAFE_C_SS:
if (cadr(p) == var1) {
if (fx_proc(tree) == fx_c_ss)
return (with_fx
(tree, (caddr(p) == var2) ? fx_c_tu : fx_c_ts));
if (fx_proc(tree) == fx_c_ss_direct)
return (with_fx(tree, fx_c_ts_direct));
if (fx_proc(tree) == fx_add_ss)
return (with_fx
(tree,
(caddr(p) == var2) ? fx_add_tu : fx_add_ts));
if (fx_proc(tree) == fx_subtract_ss)
return (with_fx
(tree,
(caddr(p) ==
var2) ? fx_subtract_tu : fx_subtract_ts));
if (fx_proc(tree) == fx_cons_ss)
return (with_fx(tree, fx_cons_ts));
if (caddr(p) == var2) {
if (fx_proc(tree) == fx_gt_ss)
return (with_fx(tree, fx_gt_tu));
if (fx_proc(tree) == fx_lt_ss)
return (with_fx(tree, fx_lt_tu));
if (fx_proc(tree) == fx_leq_ss)
return (with_fx(tree, fx_leq_tu));
if (fx_proc(tree) == fx_geq_ss)
return (with_fx(tree, fx_geq_tu));
if (fx_proc(tree) == fx_multiply_ss)
return (with_fx(tree, fx_multiply_tu));
if (fx_proc(tree) == fx_num_eq_ss)
return (with_fx(tree, fx_num_eq_tu));
if (fx_proc(tree) == fx_memq_ss)
return (with_fx(tree, fx_memq_tu));
}
if (fx_proc(tree) == fx_multiply_ss)
return (with_fx(tree, fx_multiply_ts));
if (fx_proc(tree) == fx_num_eq_ss) {
if (is_global(caddr(p)))
return (with_fx(tree, fx_num_eq_tg));
if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3)))
return (with_fx(tree, fx_num_eq_to));
return (with_fx(tree, fx_num_eq_ts));
}
if (fx_proc(tree) == fx_geq_ss) {
if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3)))
return (with_fx(tree, fx_geq_to));
return (with_fx(tree, fx_geq_ts));
}
if (fx_proc(tree) == fx_leq_ss)
return (with_fx(tree, fx_leq_ts));
if (fx_proc(tree) == fx_lt_ss)
return (with_fx(tree, fx_lt_ts));
if (fx_proc(tree) == fx_lt_sg)
return (with_fx(tree, fx_lt_tg));
if (fx_proc(tree) == fx_gt_ss) {
if (is_global(caddr(p)))
return (with_fx(tree, fx_gt_tg));
if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3)))
return (with_fx(tree, fx_gt_to));
return (with_fx(tree, fx_gt_ts));
}
if (fx_proc(tree) == fx_sqr_s)
return (with_fx(tree, fx_sqr_t));
if (fx_proc(tree) == fx_is_eq_ss) {
if (caddr(p) == var2)
return (with_fx(tree, fx_is_eq_tu));
if ((!more_vars) && (caddr(p) != var3)
&& (caddr(p) != var1))
return (with_fx(tree, fx_is_eq_to));
return (with_fx(tree, fx_is_eq_ts));
}
if (fx_proc(tree) == fx_vref_ss) {
if (caddr(p) == var2)
return (with_fx(tree, fx_vref_tu));
return (with_fx(tree, fx_vref_ts));
}
}
if (caddr(p) == var1) {
if (fx_proc(tree) == fx_c_ss)
return (with_fx(tree, fx_c_st));
if (fx_proc(tree) == fx_c_ss_direct) {
return (with_fx
(tree,
(is_global(cadr(p))) ? fx_c_gt_direct :
fx_c_st_direct));
}
if (fx_proc(tree) == fx_hash_table_ref_ss)
return (with_fx(tree, fx_hash_table_ref_st));
if (fx_proc(tree) == fx_cons_ss)
return (with_fx(tree, fx_cons_st));
if (fx_proc(tree) == fx_vref_ss) {
if (is_global(cadr(p)))
return (with_fx(tree, fx_vref_gt));
if ((!more_vars) && (cadr(p) != var2) && (cadr(p) != var3))
return (with_fx(tree, fx_vref_ot));
return (with_fx(tree, fx_vref_st));
}
if ((fx_proc(tree) == fx_gt_ss) && (cadr(p) == var2))
return (with_fx(tree, fx_gt_ut));
if ((fx_proc(tree) == fx_lt_ss) && (cadr(p) == var2))
return (with_fx(tree, fx_lt_ut));
if ((fx_proc(tree) == fx_geq_ss)) {
if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3)))
return (with_fx(tree, fx_geq_ot));
return (with_fx(tree, fx_geq_st));
}
}
if (cadr(p) == var2) {
if (fx_proc(tree) == fx_num_eq_ss)
return (with_fx
(tree,
(caddr(p) ==
var1) ? fx_num_eq_ut : fx_num_eq_us));
if (fx_proc(tree) == fx_geq_ss)
return (with_fx(tree, fx_geq_us));
if (fx_proc(tree) == fx_add_ss)
return (with_fx
(tree,
(caddr(p) == var1) ? fx_add_ut : fx_add_us));
if (fx_proc(tree) == fx_subtract_ss)
return (with_fx
(tree,
(caddr(p) ==
var1) ? fx_subtract_ut : fx_subtract_us));
if (caddr(p) == var3)
return (with_fx(tree, fx_c_uv));
}
if (cadr(p) == var3) {
if (fx_proc(tree) == fx_num_eq_ss)
return (with_fx(tree, fx_num_eq_vs));
if ((fx_proc(tree) == fx_add_ss) && (caddr(p) == var2))
return (with_fx(tree, fx_add_vu));
if (fx_proc(tree) == fx_geq_ss)
return (with_fx(tree, fx_geq_vs));
}
break;
case HOP_SAFE_C_AS:
if (caddr(p) == var1)
return (with_fx(tree, fx_c_at));
break;
case HOP_SAFE_C_SA:
if (cadr(p) == var1) {
if ((fx_proc(cddr(p)) == fx_c_opsq_c) &&
(cadadr(caddr(p)) == var1) &&
(is_t_integer(caddaddr(p))) &&
(integer(caddaddr(p)) == 1) &&
(car(p) == sc->string_ref_symbol) &&
(caaddr(p) == sc->subtract_symbol) &&
#if (!WITH_PURE_S7)
((caadr(caddr(p)) == sc->string_length_symbol)
|| (caadr(caddr(p)) == sc->length_symbol)))
#else
(caadr(caddr(p)) == sc->length_symbol))
#endif
return (with_fx(tree, fx_string_ref_t_last));
return (with_fx(tree, fx_c_ta));
}
if (cadr(p) == var2)
return (with_fx
(tree,
(fx_proc(tree) ==
fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua));
break;
case HOP_SAFE_C_SCS:
if (cadr(p) == var1) {
if (fx_proc(tree) == fx_c_scs)
return (with_fx(tree, fx_c_tcs));
if (fx_proc(tree) == fx_c_scs_direct)
return (with_fx
(tree,
(cadddr(p) ==
var2) ? fx_c_tcu_direct : fx_c_tcs_direct));
}
break;
case HOP_SAFE_C_SSC:
if ((cadr(p) == var1) && (caddr(p) == var2))
return (with_fx(tree, fx_c_tuc));
break;
case HOP_SAFE_C_CSS:
if ((caddr(p) == var1) && (cadddr(p) == var3))
return (with_fx(tree, fx_c_ctv));
break;
case HOP_SAFE_C_SSS:
if ((cadr(p) == var1)
&& ((caddr(p) == var2)
&& ((fx_proc(tree) == fx_c_sss)
|| (fx_proc(tree) == fx_c_sss_direct))))
return (with_fx
(tree, (cadddr(p) == var3) ? fx_c_tuv : fx_c_tus));
if (caddr(p) == var1) {
if (car(p) == sc->vector_set_symbol) {
if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))
&& (o_var_ok(cadddr(p), var1, var2, var3)))
return (with_fx(tree, fx_vset_oto));
return (with_fx(tree, fx_vset_sts));
}
return (with_fx(tree, fx_c_sts));
}
break;
case HOP_SAFE_C_opSq:
if (cadadr(p) == var1) {
if (fx_proc(tree) == fx_is_pair_car_s)
return (with_fx(tree, fx_is_pair_car_t));
if (fx_proc(tree) == fx_is_pair_cdr_s)
return (with_fx(tree, fx_is_pair_cdr_t));
if (fx_proc(tree) == fx_is_pair_cadr_s)
return (with_fx(tree, fx_is_pair_cadr_t));
if (fx_proc(tree) == fx_is_symbol_cadr_s)
return (with_fx(tree, fx_is_symbol_cadr_t));
if (fx_proc(tree) == fx_is_pair_cddr_s)
return (with_fx(tree, fx_is_pair_cddr_t));
if (fx_proc(tree) == fx_is_null_cdr_s)
return (with_fx(tree, fx_is_null_cdr_t));
if (fx_proc(tree) == fx_is_null_cadr_s)
return (with_fx(tree, fx_is_null_cadr_t));
if (fx_proc(tree) == fx_is_null_cddr_s)
return (with_fx(tree, fx_is_null_cddr_t));
if (fx_proc(tree) == fx_not_is_pair_s)
return (with_fx(tree, fx_not_is_pair_t));
if (fx_proc(tree) == fx_not_is_null_s)
return (with_fx(tree, fx_not_is_null_t));
if (fx_proc(tree) == fx_not_is_symbol_s)
return (with_fx(tree, fx_not_is_symbol_t));
if (fx_proc(tree) == fx_is_type_car_s)
return (with_fx
(tree,
(car(p) ==
sc->is_symbol_symbol) ? fx_is_symbol_car_t :
fx_is_type_car_t));
if (fx_proc(tree) == fx_c_opsq) {
set_opt1_sym(cdr(p), cadadr(p));
if ((is_global_and_has_func(car(p), s7_p_p_function)) &&
(is_global_and_has_func(caadr(p), s7_p_p_function))) {
set_opt2_direct(cdr(p),
(s7_pointer) (s7_p_p_function
(global_value(car(p)))));
set_opt3_direct(cdr(p),
(s7_pointer) (s7_p_p_function
(global_value
(caadr(p)))));
return (with_fx(tree, fx_c_optq_direct));
}
return (with_fx(tree, fx_c_optq));
}
if (fx_proc(tree) == fx_c_car_s)
return (with_fx(tree, fx_c_car_t));
if (fx_proc(tree) == fx_c_cdr_s)
return (with_fx(tree, fx_c_cdr_t));
if (fx_proc(tree) == fx_is_type_opsq)
return (with_fx(tree, fx_is_type_optq));
}
if (cadadr(p) == var2) {
if (fx_proc(tree) == fx_c_car_s)
return (with_fx(tree, fx_c_car_u));
if (fx_proc(tree) == fx_not_is_null_s)
return (with_fx(tree, fx_not_is_null_u));
if (fx_proc(tree) == fx_not_is_pair_s)
return (with_fx(tree, fx_not_is_pair_u));
if (fx_proc(tree) == fx_is_pair_cdr_s)
return (with_fx(tree, fx_is_pair_cdr_u));
}
if (cadadr(p) == var3) {
if (fx_proc(tree) == fx_not_is_pair_s)
return (with_fx(tree, fx_not_is_pair_v));
}
break;
case HOP_SAFE_C_opSq_S:
if (cadadr(p) == var1) {
if (fx_proc(tree) == fx_c_opsq_s) {
if ((is_global_and_has_func(car(p), s7_p_pp_function)) &&
(is_global_and_has_func(caadr(p), s7_p_p_function))) {
set_opt2_direct(cdr(p),
(s7_pointer) (s7_p_pp_function
(global_value(car(p)))));
set_opt3_direct(cdr(p),
(s7_pointer) (s7_p_p_function
(global_value
(caadr(p)))));
return (with_fx(tree, fx_c_optq_s_direct));
}
return (with_fx(tree, fx_c_optq_s));
}
if (fx_proc(tree) == fx_c_opsq_s_direct)
return (with_fx(tree, fx_c_optq_s_direct));
if (fx_proc(tree) == fx_cons_car_s_s) {
set_opt1_sym(cdr(p), var1);
return (with_fx
(tree,
(caddr(p) ==
var3) ? fx_cons_car_t_v : fx_cons_car_t_s));
}
}
if (cadadr(p) == var2) {
if ((fx_proc(tree) == fx_c_opsq_s) && (caddr(p) == var1)) {
if ((is_global_and_has_func(car(p), s7_p_pp_function)) && (is_global_and_has_func(caadr(p), s7_p_p_function))) { /* (memq (car sequence) items) lint */
set_opt2_direct(cdr(p),
(s7_pointer) (s7_p_pp_function
(global_value(car(p)))));
set_opt3_direct(cdr(p),
(s7_pointer) (s7_p_p_function
(global_value
(caadr(p)))));
return (with_fx
(tree,
(car(p) ==
sc->cons_symbol) ? ((caadr(p) ==
sc->car_symbol) ?
fx_cons_car_u_t :
fx_cons_opuq_t) :
fx_c_opuq_t_direct));
}
return (with_fx(tree, fx_c_opuq_t));
}
if (((fx_proc(tree) == fx_c_opsq_s_direct)
|| (fx_proc(tree) == fx_cons_car_s_s))
&& (caddr(p) == var1))
return (with_fx
(tree,
(car(p) ==
sc->cons_symbol) ? ((caadr(p) ==
sc->car_symbol) ?
fx_cons_car_u_t :
fx_cons_opuq_t) :
fx_c_opuq_t_direct));
}
break;
case HOP_SAFE_C_S_opSq:
if (cadr(p) == var1) {
if (cadaddr(p) == var2) {
if (fx_proc(tree) == fx_c_s_car_s)
return (with_fx(tree, fx_c_t_car_u));
if (fx_proc(tree) == fx_c_s_opsq_direct)
return (with_fx(tree, fx_c_t_opuq_direct));
}
if (cadaddr(p) == var3) {
if (fx_proc(tree) == fx_add_s_car_s)
return (with_fx(tree, fx_add_t_car_v));
if (fx_proc(tree) == fx_c_s_car_s)
return (with_fx(tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */
}
}
if (cadr(p) == var2) {
if ((fx_proc(tree) == fx_add_s_car_s) && (cadaddr(p) == var1))
return (with_fx(tree, fx_add_u_car_t));
if ((fx_proc(tree) == fx_c_s_opsq_direct)
&& (cadaddr(p) == var3))
return (with_fx(tree, fx_c_u_opvq_direct));
}
if ((cadaddr(p) == var1) && (fx_proc(tree) == fx_c_s_car_s))
return (with_fx(tree, fx_c_s_car_t));
break;
case HOP_SAFE_C_opSq_opSq:
if (fx_proc(tree) == fx_c_opsq_opsq_direct) {
if ((cadadr(p) == var1) && (cadadr(p) == cadaddr(p))) {
set_opt1_sym(cdr(p), cadadr(p));
return (with_fx(tree, fx_c_optq_optq_direct)); /* opuq got few hits */
}
if ((caadr(p) == caaddr(p)) && (caadr(p) == sc->car_symbol)) {
set_opt1_sym(cdr(p), cadadr(p));
set_opt2_sym(cdr(p), cadaddr(p));
return (with_fx(tree, ((cadadr(p) == var1)
&& (cadaddr(p) ==
var2)) ? ((opt3_direct(p) ==
(s7_pointer)
is_eq_p_pp) ?
fx_is_eq_car_car_tu :
fx_car_t_car_u) :
fx_car_s_car_s));
}
}
break;
case HOP_SAFE_C_opSq_C:
if (cadadr(p) == var1) {
if (fx_proc(tree) == fx_is_eq_car_sq)
return (with_fx(tree, fx_is_eq_car_tq));
if ((fx_proc(tree) == fx_c_opsq_c)
|| (fx_proc(tree) == fx_c_optq_c)) {
if (fn_proc(p) != g_lint_let_ref) { /* don't step on opt3_sym */
if ((is_global_and_has_func(car(p), s7_p_pp_function))
&&
(is_global_and_has_func
(caadr(p), s7_p_p_function))) {
if (fn_proc(p) == g_memq_2)
set_opt3_direct(p, (s7_pointer) memq_2_p_pp);
else
set_opt3_direct(p,
(s7_pointer) (s7_p_pp_function
(global_value
(car(p)))));
set_opt3_direct(cdr(p),
(s7_pointer) (s7_p_p_function
(global_value
(caadr(p)))));
set_fx_direct(tree, fx_c_optq_c_direct);
return (true);
}
if ((is_t_integer(caddr(p))) &&
(is_global_and_has_func
(caadr(p), s7_i_7p_function))
&&
(is_global_and_has_func(car(p), s7_p_ii_function)))
{
set_opt3_direct(p,
(s7_pointer) (s7_p_ii_function
(global_value
(car(p)))));
set_opt3_direct(cdr(p),
(s7_pointer) (s7_i_7p_function
(global_value
(caadr(p)))));
set_fx_direct(tree, fx_c_optq_i_direct);
} else
set_fx_direct(tree, fx_c_optq_c);
}
return (true);
}
}
break;
case HOP_SAFE_C_opSSq:
if (fx_proc(tree) == fx_c_opssq) {
if (caddadr(p) == var1)
return (with_fx(tree, fx_c_opstq));
if ((cadadr(p) == var1) && (caddadr(p) == var2))
return (with_fx(tree, fx_c_optuq));
}
if (fx_proc(tree) == fx_c_opssq_direct) {
if ((cadadr(p) == var1) && (caddadr(p) == var2))
return (with_fx(tree, fx_c_optuq_direct));
if (caddadr(p) == var1) {
if ((opt2_direct(cdr(p)) == (s7_pointer) is_zero_p_p)
&& (opt3_direct(cdr(p)) == (s7_pointer) remainder_p_pp)
&& (!more_vars)
&& (o_var_ok(cadadr(p), var1, var2, var3)))
return (with_fx(tree, fx_is_zero_remainder_o));
return (with_fx(tree, fx_c_opstq_direct));
}
}
if ((cadadr(p) == var2) && (fx_proc(tree) == fx_not_opssq)
&& (caddadr(p) == var1)) {
if (fn_proc(cadr(p)) == g_less_2)
set_fx_direct(tree, fx_not_lt_ut);
else
set_fx_direct(tree, fx_not_oputq);
return (true);
}
break;
case HOP_SAFE_C_opSCq:
if (cadr(p) == var1)
return (with_fx(tree, fx_c_optcq)); /* there currently isn't any fx_c_opscq_direct */
break;
case HOP_SAFE_C_opSSq_C:
if ((fx_proc(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) {
if (is_global_and_has_func(car(p), s7_p_pp_function)) {
if ((car(p) == sc->is_eq_symbol)
&& (!is_unspecified(caddr(p)))
&& (caadr(p) == sc->vector_ref_symbol) && (!more_vars)
&& (o_var_ok(cadadr(p), var1, var2, var3)))
return (with_fx(tree, fx_is_eq_vref_opotq_c));
set_opt3_direct(p,
(s7_pointer) (s7_p_pp_function
(global_value(car(p)))));
return (with_fx(tree, fx_c_opstq_c_direct));
}
return (with_fx(tree, fx_c_opstq_c));
}
break;
case HOP_SAFE_C_S_opSCq:
if (cadr(p) == var1) {
if (fx_proc(tree) == fx_c_s_opscq_direct)
return (with_fx
(tree,
(cadaddr(p) ==
var2) ? fx_c_t_opucq_direct :
fx_c_t_opscq_direct));
if ((fx_proc(tree) == fx_c_s_opsiq_direct) && (!more_vars)
&& (o_var_ok(cadaddr(p), var1, var2, var3)))
return (with_fx(tree, fx_c_t_opoiq_direct));
}
break;
case HOP_SAFE_C_opSq_CS:
if ((cadadr(p) == var1) && (fx_proc(tree) == fx_c_opsq_cs)
&& (cadddr(p) == var2))
return (with_fx(tree, fx_c_optq_cu));
break;
case HOP_SAFE_C_opSq_opSSq:
if ((fx_proc(tree) == fx_c_opsq_opssq) && (cadaddr(p) == var1)
&& (caddaddr(p) == var2)
&& (is_global_and_has_func(car(p), s7_p_pp_function))
&& (is_global_and_has_func(caadr(p), s7_p_p_function))
&& (is_global_and_has_func(caaddr(p), s7_p_pp_function))) {
set_opt3_direct(p,
(s7_pointer) (s7_p_pp_function
(global_value(car(p)))));
set_opt2_direct(cdr(p),
(s7_pointer) (s7_p_p_function
(global_value(caadr(p)))));
set_opt3_direct(cdr(p),
(s7_pointer) (s7_p_pp_function
(global_value(caaddr(p)))));
set_opt1_sym(cdr(p), var2); /* caddaddr(p) */
if ((car(p) == sc->num_eq_symbol)
&& (caadr(p) == sc->car_symbol) && (cadadr(p) == var3)) {
if (caaddr(p) == sc->add_symbol) {
set_opt2_sym(cddr(p), var1);
return (with_fx(tree, fx_num_eq_car_v_add_tu));
}
if (caaddr(p) == sc->subtract_symbol) {
set_opt2_sym(cddr(p), var1);
return (with_fx(tree, fx_num_eq_car_v_subtract_tu));
}
}
return (with_fx(tree, fx_c_opsq_optuq_direct));
}
break;
case HOP_SAFE_C_opSSq_S:
if (fx_proc(tree) == fx_vref_vref_ss_s) {
if ((caddr(p) == var1) && (is_global(cadadr(p)))) {
if ((!more_vars)
&& (o_var_ok(caddadr(p), var1, var2, var3)))
return (with_fx(tree, fx_vref_vref_go_t));
return (with_fx(tree, fx_vref_vref_gs_t));
}
if ((cadadr(p) == var1) && (caddadr(p) == var2)
&& (caddr(p) == var3))
return (with_fx(tree, fx_vref_vref_tu_v));
}
break;
case HOP_SAFE_C_S_opSSq:
if (caddaddr(p) == var1) {
if ((fn_proc(p) == g_vector_ref_2)
&& (is_global(cadr(p)) && (is_global(cadaddr(p))))) {
set_opt3_pair(p, cdaddr(p));
return (with_fx(tree, fx_vref_g_vref_gt));
}
if (fx_proc(tree) == fx_c_s_opssq_direct)
return (with_fx(tree, fx_c_s_opstq_direct));
}
if ((fx_proc(tree) == fx_c_s_opssq_direct) && (cadr(p) == var1)
&& (caddaddr(p) == var2))
return (with_fx(tree, fx_c_t_opsuq_direct));
break;
case HOP_SAFE_C_op_opSq_Sq:
if ((car(p) == sc->not_symbol) && (is_global(sc->not_symbol))
&& (var1 == cadr(cadadr(p))))
return (with_fx(tree, fx_not_op_optq_sq));
break;
case HOP_SAFE_C_AC:
if (((fx_proc(tree) == fx_c_ac)
|| (fx_proc(tree) == fx_c_ac_direct))
&& (fn_proc(p) == g_num_eq_xi) && (caddr(p) == int_zero)
&& (fx_proc(cdr(p)) == fx_c_opuq_t_direct)
&& (caadr(p) == sc->remainder_symbol)
&& (fn_proc(cadadr(p)) == g_car)) {
set_opt3_sym(p, cadr(cadadr(p)));
set_opt1_sym(cdr(p), caddadr(p));
return (with_fx(tree, fx_is_zero_remainder_car));
}
break;
case HOP_SAFE_CLOSURE_S_A:
if ((cadr(p) == var1) && (fx_proc(tree) == fx_safe_closure_s_a))
return (with_fx(tree, fx_safe_closure_t_a));
break;
case OP_IF_S_A_A:
if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3)))
return (with_fx(tree, fx_if_o_a_a));
break;
case OP_AND_3A:
if ((fx_proc(tree) == fx_and_3a) && (is_pair(cadr(p))) && (is_pair(cdadr(p))) && (cadadr(p) == var1) && /* so "s" below is "t" */
(((fx_proc(cdr(p)) == fx_is_pair_t)
&& (fx_proc(cddr(p)) == fx_is_pair_cdr_t))
|| ((fx_proc(cdr(p)) == fx_is_pair_s)
&& (fx_proc(cddr(p)) == fx_is_pair_cdr_s)))) {
set_opt1_sym(cdr(p), cadadr(p));
if ((fx_proc(cdddr(p)) == fx_is_null_cddr_t)
|| (fx_proc(cdddr(p)) == fx_is_null_cddr_s))
return (with_fx(tree, fx_len2_t));
if ((fx_proc(cdddr(p)) == fx_is_pair_cddr_t)
|| (fx_proc(cdddr(p)) == fx_is_pair_cddr_s))
return (with_fx(tree, fx_len3_t));
}
break;
}
#if 0
if ((var3)
&& ((s7_tree_memq(sc, var1, car(tree)))
|| ((var2) && (s7_tree_memq(sc, var2, car(tree)))) || ((var3)
&&
(s7_tree_memq
(sc,
var3,
car
(tree))))))
fprintf(stderr, "fx_tree_in %s %s %s: %s %s\n", display(var1),
(var2) ? display(var2) : "", (var3) ? display(var3) : "",
display_80(car(tree)), op_names[optimize_op(car(tree))]);
#endif
return (false);
}
static void fx_tree(s7_scheme * sc, s7_pointer tree, s7_pointer var1,
s7_pointer var2, s7_pointer var3, bool more_vars)
{
if (!is_pair(tree))
return;
if ((is_symbol(car(tree))) && (is_definer_or_binder(car(tree)))) {
if ((car(tree) == sc->let_symbol) && (is_pair(cdr(tree)))
&& (is_pair(cadr(tree))) && (is_null(cdadr(tree))))
fx_tree(sc, cddr(tree), caaadr(tree), NULL, NULL, more_vars);
return;
}
if (is_syntax(car(tree)))
return; /* someday let #_when/#_if etc through -- the symbol 'if, for example, is not syntax */
if ((!has_fx(tree)) ||
(!fx_tree_in(sc, tree, var1, var2, var3, more_vars)))
fx_tree(sc, car(tree), var1, var2, var3, more_vars);
fx_tree(sc, cdr(tree), var1, var2, var3, more_vars);
}
static void fx_tree_outer(s7_scheme * sc, s7_pointer tree, s7_pointer var1,
s7_pointer var2, s7_pointer var3, bool more_vars)
{
/* if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display_80(tree), has_fx(tree), display(var1), (var2) ? display(var2) : ""); */
if ((!is_pair(tree)) ||
((is_symbol(car(tree))) && (is_definer_or_binder(car(tree)))) ||
(is_syntax(car(tree))))
return;
if ((!has_fx(tree)) ||
(!fx_tree_out(sc, tree, var1, var2, var3, more_vars)))
fx_tree_outer(sc, car(tree), var1, var2, var3, more_vars);
fx_tree_outer(sc, cdr(tree), var1, var2, var3, more_vars);
}
/* -------------------------------------------------------------------------------- */
static opt_funcs_t *alloc_permanent_opt_func(s7_scheme * sc)
{
if (sc->alloc_opt_func_k == ALLOC_FUNCTION_SIZE) {
sc->alloc_opt_func_cells =
(opt_funcs_t *) malloc(ALLOC_FUNCTION_SIZE *
sizeof(opt_funcs_t));
add_saved_pointer(sc, sc->alloc_opt_func_cells);
sc->alloc_opt_func_k = 0;
}
return (&(sc->alloc_opt_func_cells[sc->alloc_opt_func_k++]));
}
static void add_opt_func(s7_scheme * sc, s7_pointer f, opt_func_t typ,
void *func)
{
opt_funcs_t *op;
#if S7_DEBUGGING
static const char *o_names[] =
{ "o_d_v", "o_d_vd", "o_d_vdd", "o_d_vid", "o_d_id", "o_d_7pi",
"o_d_7pii", "o_d_7piid", "o_d_7piii", "o_d_7piiid",
"o_d_ip", "o_d_pd", "o_d_7pid", "o_d", "o_d_d", "o_d_dd",
"o_d_7dd", "o_d_ddd", "o_d_dddd",
"o_i_i", "o_i_7i", "o_i_ii", "o_i_7ii", "o_i_iii", "o_i_7pi",
"o_i_7pii", "o_i_7_piii", "o_d_p",
"o_b_p", "o_b_7p", "o_b_pp", "o_b_7pp", "o_b_pp_unchecked",
"o_b_pi", "o_b_ii", "o_b_7ii", "o_b_dd",
"o_p", "o_p_p", "o_p_ii", "o_p_d", "o_p_dd", "o_i_7d", "o_i_7p",
"o_d_7d", "o_p_pp", "o_p_ppp", "o_p_pi", "o_p_pi_unchecked",
"o_p_ppi", "o_p_i", "o_p_pii", "o_p_pip", "o_p_pip_unchecked",
"o_p_piip", "o_b_i", "o_b_d"
};
if (!is_c_function(f)) {
fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__,
__LINE__, s7_object_to_c_string(sc, f));
if (sc->stop_at_error)
abort();
} else if (c_function_opt_data(f)) {
opt_funcs_t *p;
for (p = c_function_opt_data(f); p; p = p->next) {
if (p->typ == typ)
fprintf(stderr,
"%s[%d]: %s has a function of type %d (%s)\n",
__func__, __LINE__, s7_object_to_c_string(sc, f),
typ, o_names[typ]);
if (p->func == func)
fprintf(stderr,
"%s[%d]: %s already has this function as type %d %s (current: %d %s)\n",
__func__, __LINE__, s7_object_to_c_string(sc, f),
p->typ, o_names[p->typ], typ, o_names[typ]);
}
}
#endif
op = alloc_permanent_opt_func(sc);
op->typ = typ;
op->func = func;
op->next = c_function_opt_data(f);
c_function_opt_data(f) = op;
}
static void *opt_func(s7_pointer f, opt_func_t typ)
{
if (is_c_function(f)) {
opt_funcs_t *p;
for (p = c_function_opt_data(f); p; p = p->next)
if (p->typ == typ)
return (p->func);
}
return (NULL);
}
/* clm2xen.c */
void s7_set_d_function(s7_scheme * sc, s7_pointer f, s7_d_t df)
{
add_opt_func(sc, f, o_d, (void *) df);
}
s7_d_t s7_d_function(s7_pointer f)
{
return ((s7_d_t) opt_func(f, o_d));
}
void s7_set_d_d_function(s7_scheme * sc, s7_pointer f, s7_d_d_t df)
{
add_opt_func(sc, f, o_d_d, (void *) df);
}
s7_d_d_t s7_d_d_function(s7_pointer f)
{
return ((s7_d_d_t) opt_func(f, o_d_d));
}
void s7_set_d_dd_function(s7_scheme * sc, s7_pointer f, s7_d_dd_t df)
{
add_opt_func(sc, f, o_d_dd, (void *) df);
}
s7_d_dd_t s7_d_dd_function(s7_pointer f)
{
return ((s7_d_dd_t) opt_func(f, o_d_dd));
}
void s7_set_d_v_function(s7_scheme * sc, s7_pointer f, s7_d_v_t df)
{
add_opt_func(sc, f, o_d_v, (void *) df);
}
s7_d_v_t s7_d_v_function(s7_pointer f)
{
return ((s7_d_v_t) opt_func(f, o_d_v));
}
void s7_set_d_vd_function(s7_scheme * sc, s7_pointer f, s7_d_vd_t df)
{
add_opt_func(sc, f, o_d_vd, (void *) df);
}
s7_d_vd_t s7_d_vd_function(s7_pointer f)
{
return ((s7_d_vd_t) opt_func(f, o_d_vd));
}
void s7_set_d_vdd_function(s7_scheme * sc, s7_pointer f, s7_d_vdd_t df)
{
add_opt_func(sc, f, o_d_vdd, (void *) df);
}
s7_d_vdd_t s7_d_vdd_function(s7_pointer f)
{
return ((s7_d_vdd_t) opt_func(f, o_d_vdd));
}
void s7_set_d_vid_function(s7_scheme * sc, s7_pointer f, s7_d_vid_t df)
{
add_opt_func(sc, f, o_d_vid, (void *) df);
}
s7_d_vid_t s7_d_vid_function(s7_pointer f)
{
return ((s7_d_vid_t) opt_func(f, o_d_vid));
}
void s7_set_d_id_function(s7_scheme * sc, s7_pointer f, s7_d_id_t df)
{
add_opt_func(sc, f, o_d_id, (void *) df);
}
s7_d_id_t s7_d_id_function(s7_pointer f)
{
return ((s7_d_id_t) opt_func(f, o_d_id));
}
void s7_set_d_7pid_function(s7_scheme * sc, s7_pointer f, s7_d_7pid_t df)
{
add_opt_func(sc, f, o_d_7pid, (void *) df);
}
s7_d_7pid_t s7_d_7pid_function(s7_pointer f)
{
return ((s7_d_7pid_t) opt_func(f, o_d_7pid));
}
void s7_set_d_ip_function(s7_scheme * sc, s7_pointer f, s7_d_ip_t df)
{
add_opt_func(sc, f, o_d_ip, (void *) df);
}
s7_d_ip_t s7_d_ip_function(s7_pointer f)
{
return ((s7_d_ip_t) opt_func(f, o_d_ip));
}
void s7_set_d_pd_function(s7_scheme * sc, s7_pointer f, s7_d_pd_t df)
{
add_opt_func(sc, f, o_d_pd, (void *) df);
}
s7_d_pd_t s7_d_pd_function(s7_pointer f)
{
return ((s7_d_pd_t) opt_func(f, o_d_pd));
}
void s7_set_d_p_function(s7_scheme * sc, s7_pointer f, s7_d_p_t df)
{
add_opt_func(sc, f, o_d_p, (void *) df);
}
s7_d_p_t s7_d_p_function(s7_pointer f)
{
return ((s7_d_p_t) opt_func(f, o_d_p));
}
void s7_set_b_p_function(s7_scheme * sc, s7_pointer f, s7_b_p_t df)
{
add_opt_func(sc, f, o_b_p, (void *) df);
}
s7_b_p_t s7_b_p_function(s7_pointer f)
{
return ((s7_b_p_t) opt_func(f, o_b_p));
}
void s7_set_d_7pi_function(s7_scheme * sc, s7_pointer f, s7_d_7pi_t df)
{
add_opt_func(sc, f, o_d_7pi, (void *) df);
}
s7_d_7pi_t s7_d_7pi_function(s7_pointer f)
{
return ((s7_d_7pi_t) opt_func(f, o_d_7pi));
}
static void s7_set_d_7pii_function(s7_scheme * sc, s7_pointer f,
s7_d_7pii_t df)
{
add_opt_func(sc, f, o_d_7pii, (void *) df);
}
static s7_d_7pii_t s7_d_7pii_function(s7_pointer f)
{
return ((s7_d_7pii_t) opt_func(f, o_d_7pii));
}
static void s7_set_d_7piii_function(s7_scheme * sc, s7_pointer f,
s7_d_7piii_t df)
{
add_opt_func(sc, f, o_d_7piii, (void *) df);
}
static s7_d_7piii_t s7_d_7piii_function(s7_pointer f)
{
return ((s7_d_7piii_t) opt_func(f, o_d_7piii));
}
void s7_set_i_7p_function(s7_scheme * sc, s7_pointer f, s7_i_7p_t df)
{
add_opt_func(sc, f, o_i_7p, (void *) df);
}
s7_i_7p_t s7_i_7p_function(s7_pointer f)
{
return ((s7_i_7p_t) opt_func(f, o_i_7p));
}
/* cload.scm */
void s7_set_d_ddd_function(s7_scheme * sc, s7_pointer f, s7_d_ddd_t df)
{
add_opt_func(sc, f, o_d_ddd, (void *) df);
}
s7_d_ddd_t s7_d_ddd_function(s7_pointer f)
{
return ((s7_d_ddd_t) opt_func(f, o_d_ddd));
}
void s7_set_d_dddd_function(s7_scheme * sc, s7_pointer f, s7_d_dddd_t df)
{
add_opt_func(sc, f, o_d_dddd, (void *) df);
}
s7_d_dddd_t s7_d_dddd_function(s7_pointer f)
{
return ((s7_d_dddd_t) opt_func(f, o_d_dddd));
}
void s7_set_i_i_function(s7_scheme * sc, s7_pointer f, s7_i_i_t df)
{
add_opt_func(sc, f, o_i_i, (void *) df);
}
s7_i_i_t s7_i_i_function(s7_pointer f)
{
return ((s7_i_i_t) opt_func(f, o_i_i));
}
void s7_set_i_ii_function(s7_scheme * sc, s7_pointer f, s7_i_ii_t df)
{
add_opt_func(sc, f, o_i_ii, (void *) df);
}
s7_i_ii_t s7_i_ii_function(s7_pointer f)
{
return ((s7_i_ii_t) opt_func(f, o_i_ii));
}
void s7_set_i_7d_function(s7_scheme * sc, s7_pointer f, s7_i_7d_t df)
{
add_opt_func(sc, f, o_i_7d, (void *) df);
}
s7_i_7d_t s7_i_7d_function(s7_pointer f)
{
return ((s7_i_7d_t) opt_func(f, o_i_7d));
}
/* s7test.scm */
void s7_set_p_d_function(s7_scheme * sc, s7_pointer f, s7_p_d_t df)
{
add_opt_func(sc, f, o_p_d, (void *) df);
}
s7_p_d_t s7_p_d_function(s7_pointer f)
{
return ((s7_p_d_t) opt_func(f, o_p_d));
}
static void s7_set_d_7dd_function(s7_scheme * sc, s7_pointer f,
s7_d_7dd_t df)
{
add_opt_func(sc, f, o_d_7dd, (void *) df);
}
static s7_d_7dd_t s7_d_7dd_function(s7_pointer f)
{
return ((s7_d_7dd_t) opt_func(f, o_d_7dd));
}
static void s7_set_i_7i_function(s7_scheme * sc, s7_pointer f,
s7_i_7i_t df)
{
add_opt_func(sc, f, o_i_7i, (void *) df);
}
static s7_i_7i_t s7_i_7i_function(s7_pointer f)
{
return ((s7_i_7i_t) opt_func(f, o_i_7i));
}
static void s7_set_i_7ii_function(s7_scheme * sc, s7_pointer f,
s7_i_7ii_t df)
{
add_opt_func(sc, f, o_i_7ii, (void *) df);
}
static s7_i_7ii_t s7_i_7ii_function(s7_pointer f)
{
return ((s7_i_7ii_t) opt_func(f, o_i_7ii));
}
static void s7_set_i_iii_function(s7_scheme * sc, s7_pointer f,
s7_i_iii_t df)
{
add_opt_func(sc, f, o_i_iii, (void *) df);
}
s7_i_iii_t s7_i_iii_function(s7_pointer f)
{
return ((s7_i_iii_t) opt_func(f, o_i_iii));
}
static void s7_set_p_pi_function(s7_scheme * sc, s7_pointer f,
s7_p_pi_t df)
{
add_opt_func(sc, f, o_p_pi, (void *) df);
}
static s7_p_pi_t s7_p_pi_function(s7_pointer f)
{
return ((s7_p_pi_t) opt_func(f, o_p_pi));
}
static void s7_set_p_ppi_function(s7_scheme * sc, s7_pointer f,
s7_p_ppi_t df)
{
add_opt_func(sc, f, o_p_ppi, (void *) df);
}
static s7_p_ppi_t s7_p_ppi_function(s7_pointer f)
{
return ((s7_p_ppi_t) opt_func(f, o_p_ppi));
}
static void s7_set_i_7pi_function(s7_scheme * sc, s7_pointer f,
s7_i_7pi_t df)
{
add_opt_func(sc, f, o_i_7pi, (void *) df);
}
static s7_i_7pi_t s7_i_7pi_function(s7_pointer f)
{
return ((s7_i_7pi_t) opt_func(f, o_i_7pi));
}
static void s7_set_i_7pii_function(s7_scheme * sc, s7_pointer f,
s7_i_7pii_t df)
{
add_opt_func(sc, f, o_i_7pii, (void *) df);
}
static s7_i_7pii_t s7_i_7pii_function(s7_pointer f)
{
return ((s7_i_7pii_t) opt_func(f, o_i_7pii));
}
static void s7_set_i_7piii_function(s7_scheme * sc, s7_pointer f,
s7_i_7piii_t df)
{
add_opt_func(sc, f, o_i_7piii, (void *) df);
}
static s7_i_7piii_t s7_i_7piii_function(s7_pointer f)
{
return ((s7_i_7piii_t) opt_func(f, o_i_7piii));
}
static void s7_set_b_d_function(s7_scheme * sc, s7_pointer f, s7_b_d_t df)
{
add_opt_func(sc, f, o_b_d, (void *) df);
}
static s7_b_d_t s7_b_d_function(s7_pointer f)
{
return ((s7_b_d_t) opt_func(f, o_b_d));
}
static void s7_set_b_i_function(s7_scheme * sc, s7_pointer f, s7_b_i_t df)
{
add_opt_func(sc, f, o_b_i, (void *) df);
}
static s7_b_i_t s7_b_i_function(s7_pointer f)
{
return ((s7_b_i_t) opt_func(f, o_b_i));
}
static void s7_set_b_7p_function(s7_scheme * sc, s7_pointer f,
s7_b_7p_t df)
{
add_opt_func(sc, f, o_b_7p, (void *) df);
}
static s7_b_7p_t s7_b_7p_function(s7_pointer f)
{
return ((s7_b_7p_t) opt_func(f, o_b_7p));
}
static void s7_set_b_pp_function(s7_scheme * sc, s7_pointer f,
s7_b_pp_t df)
{
add_opt_func(sc, f, o_b_pp, (void *) df);
}
static s7_b_pp_t s7_b_pp_function(s7_pointer f)
{
return ((s7_b_pp_t) opt_func(f, o_b_pp));
}
static void s7_set_b_7pp_function(s7_scheme * sc, s7_pointer f,
s7_b_7pp_t df)
{
add_opt_func(sc, f, o_b_7pp, (void *) df);
}
static s7_b_7pp_t s7_b_7pp_function(s7_pointer f)
{
return ((s7_b_7pp_t) opt_func(f, o_b_7pp));
}
static void s7_set_d_7d_function(s7_scheme * sc, s7_pointer f,
s7_d_7d_t df)
{
add_opt_func(sc, f, o_d_7d, (void *) df);
}
static s7_d_7d_t s7_d_7d_function(s7_pointer f)
{
return ((s7_d_7d_t) opt_func(f, o_d_7d));
}
static void s7_set_b_pi_function(s7_scheme * sc, s7_pointer f,
s7_b_pi_t df)
{
add_opt_func(sc, f, o_b_pi, (void *) df);
}
static s7_b_pi_t s7_b_pi_function(s7_pointer f)
{
return ((s7_b_pi_t) opt_func(f, o_b_pi));
}
static void s7_set_b_ii_function(s7_scheme * sc, s7_pointer f,
s7_b_ii_t df)
{
add_opt_func(sc, f, o_b_ii, (void *) df);
}
static s7_b_ii_t s7_b_ii_function(s7_pointer f)
{
return ((s7_b_ii_t) opt_func(f, o_b_ii));
}
static void s7_set_b_7ii_function(s7_scheme * sc, s7_pointer f,
s7_b_7ii_t df)
{
add_opt_func(sc, f, o_b_7ii, (void *) df);
}
static s7_b_7ii_t s7_b_7ii_function(s7_pointer f)
{
return ((s7_b_7ii_t) opt_func(f, o_b_7ii));
}
static void s7_set_b_dd_function(s7_scheme * sc, s7_pointer f,
s7_b_dd_t df)
{
add_opt_func(sc, f, o_b_dd, (void *) df);
}
static s7_b_dd_t s7_b_dd_function(s7_pointer f)
{
return ((s7_b_dd_t) opt_func(f, o_b_dd));
}
static void s7_set_p_p_function(s7_scheme * sc, s7_pointer f, s7_p_p_t df)
{
add_opt_func(sc, f, o_p_p, (void *) df);
}
static s7_p_p_t s7_p_p_function(s7_pointer f)
{
return ((s7_p_p_t) opt_func(f, o_p_p));
}
static void s7_set_p_function(s7_scheme * sc, s7_pointer f, s7_p_t df)
{
add_opt_func(sc, f, o_p, (void *) df);
}
static s7_p_t s7_p_function(s7_pointer f)
{
return ((s7_p_t) opt_func(f, o_p));
}
static void s7_set_p_pp_function(s7_scheme * sc, s7_pointer f,
s7_p_pp_t df)
{
add_opt_func(sc, f, o_p_pp, (void *) df);
}
static s7_p_pp_t s7_p_pp_function(s7_pointer f)
{
return ((s7_p_pp_t) opt_func(f, o_p_pp));
}
static void s7_set_p_ppp_function(s7_scheme * sc, s7_pointer f,
s7_p_ppp_t df)
{
add_opt_func(sc, f, o_p_ppp, (void *) df);
}
static s7_p_ppp_t s7_p_ppp_function(s7_pointer f)
{
return ((s7_p_ppp_t) opt_func(f, o_p_ppp));
}
static void s7_set_p_pip_function(s7_scheme * sc, s7_pointer f,
s7_p_pip_t df)
{
add_opt_func(sc, f, o_p_pip, (void *) df);
}
static s7_p_pip_t s7_p_pip_function(s7_pointer f)
{
return ((s7_p_pip_t) opt_func(f, o_p_pip));
}
static void s7_set_p_pii_function(s7_scheme * sc, s7_pointer f,
s7_p_pii_t df)
{
add_opt_func(sc, f, o_p_pii, (void *) df);
}
static s7_p_pii_t s7_p_pii_function(s7_pointer f)
{
return ((s7_p_pii_t) opt_func(f, o_p_pii));
}
static void s7_set_p_piip_function(s7_scheme * sc, s7_pointer f,
s7_p_piip_t df)
{
add_opt_func(sc, f, o_p_piip, (void *) df);
}
static s7_p_piip_t s7_p_piip_function(s7_pointer f)
{
return ((s7_p_piip_t) opt_func(f, o_p_piip));
}
static void s7_set_p_pi_unchecked_function(s7_scheme * sc, s7_pointer f,
s7_p_pi_t df)
{
add_opt_func(sc, f, o_p_pi_unchecked, (void *) df);
}
static s7_p_pi_t s7_p_pi_unchecked_function(s7_pointer f)
{
return ((s7_p_pi_t) opt_func(f, o_p_pi_unchecked));
}
static void s7_set_p_pip_unchecked_function(s7_scheme * sc, s7_pointer f,
s7_p_pip_t df)
{
add_opt_func(sc, f, o_p_pip_unchecked, (void *) df);
}
static s7_p_pip_t s7_p_pip_unchecked_function(s7_pointer f)
{
return ((s7_p_pip_t) opt_func(f, o_p_pip_unchecked));
}
static void s7_set_b_pp_unchecked_function(s7_scheme * sc, s7_pointer f,
s7_b_pp_t df)
{
add_opt_func(sc, f, o_b_pp_unchecked, (void *) df);
}
static s7_b_pp_t s7_b_pp_unchecked_function(s7_pointer f)
{
return ((s7_b_pp_t) opt_func(f, o_b_pp_unchecked));
}
static void s7_set_p_i_function(s7_scheme * sc, s7_pointer f, s7_p_i_t df)
{
add_opt_func(sc, f, o_p_i, (void *) df);
}
static s7_p_i_t s7_p_i_function(s7_pointer f)
{
return ((s7_p_i_t) opt_func(f, o_p_i));
}
static void s7_set_p_ii_function(s7_scheme * sc, s7_pointer f,
s7_p_ii_t df)
{
add_opt_func(sc, f, o_p_ii, (void *) df);
}
static s7_p_ii_t s7_p_ii_function(s7_pointer f)
{
return ((s7_p_ii_t) opt_func(f, o_p_ii));
}
static void s7_set_d_7piid_function(s7_scheme * sc, s7_pointer f,
s7_d_7piid_t df)
{
add_opt_func(sc, f, o_d_7piid, (void *) df);
}
static s7_d_7piid_t s7_d_7piid_function(s7_pointer f)
{
return ((s7_d_7piid_t) opt_func(f, o_d_7piid));
}
static void s7_set_d_7piiid_function(s7_scheme * sc, s7_pointer f,
s7_d_7piiid_t df)
{
add_opt_func(sc, f, o_d_7piiid, (void *) df);
}
static s7_d_7piiid_t s7_d_7piiid_function(s7_pointer f)
{
return ((s7_d_7piiid_t) opt_func(f, o_d_7piiid));
}
static void s7_set_p_dd_function(s7_scheme * sc, s7_pointer f,
s7_p_dd_t df)
{
add_opt_func(sc, f, o_p_dd, (void *) df);
}
static s7_p_dd_t s7_p_dd_function(s7_pointer f)
{
return ((s7_p_dd_t) opt_func(f, o_p_dd));
}
static opt_info *alloc_opo(s7_scheme * sc)
{
opt_info *o;
if (sc->pc >= OPTS_SIZE)
sc->pc = OPTS_SIZE - 1;
o = sc->opts[sc->pc++];
o->v[O_WRAP].fd = NULL; /* see bool_optimize -- this is a kludge */
return (o);
}
#define backup_pc(sc) sc->pc--
#define OPT_PRINT 0
#if OPT_PRINT
#define return_false(Sc, Expr) return(return_false_1(Sc, Expr, __func__, __LINE__))
static bool return_false_1(s7_scheme * sc, s7_pointer expr,
const char *func, int32_t line)
{
if (expr)
fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT, func, line,
UNBOLD_TEXT, display_80(expr));
else
fprintf(stderr, " %s%s[%d]%s: false\n", BOLD_TEXT, func, line,
UNBOLD_TEXT);
return (false);
}
#define return_true(Sc, P, Expr) return(return_true_1(Sc, P, Expr, __func__, __LINE__))
static s7_pfunc return_true_1(s7_scheme * sc, s7_pfunc p, s7_pointer expr,
const char *func, int line)
{
fprintf(stderr, " %s%s[%d]%s: %s %ssuccess%s\n", BOLD_TEXT, func,
line, UNBOLD_TEXT, display_80(expr), BOLD_TEXT "\033[32m",
UNBOLD_TEXT "\033[0m");
return (p);
}
#define return_null(Sc, Expr) return(return_null_1(Sc, Expr, __func__, __LINE__))
static s7_pfunc return_null_1(s7_scheme * sc, s7_pointer expr,
const char *func, int line)
{
fprintf(stderr, " %s%s[%d]%s: %s %sfailure%s\n", BOLD_TEXT, func,
line, UNBOLD_TEXT, display_80(expr), BOLD_TEXT "\033[31m",
UNBOLD_TEXT "\033[0m");
return (NULL);
}
#else
#define return_false(Sc, Expr) return(false)
#define return_true(Sc, P, Expr) return(P)
#define return_null(Sc, Expr) return(NULL)
#endif
static s7_pointer opt_integer_symbol(s7_scheme * sc, s7_pointer sym)
{
if (is_symbol(sym)) {
s7_pointer p;
p = lookup_slot_from(sym, sc->curlet);
if ((is_slot(p)) && (is_t_integer(slot_value(p))))
return (p);
}
return (NULL);
}
static s7_pointer opt_real_symbol(s7_scheme * sc, s7_pointer sym)
{
if (is_symbol(sym)) {
s7_pointer p;
p = lookup_slot_from(sym, sc->curlet);
if ((is_slot(p)) && (is_small_real(slot_value(p))))
return (p);
}
return (NULL);
}
static s7_pointer opt_float_symbol(s7_scheme * sc, s7_pointer sym)
{
if (is_symbol(sym)) {
s7_pointer p;
p = lookup_slot_from(sym, sc->curlet);
if ((is_slot(p)) && (is_t_real(slot_value(p))))
return (p);
}
return (NULL);
}
static s7_pointer opt_simple_symbol(s7_scheme * sc, s7_pointer sym)
{
s7_pointer p;
p = lookup_slot_from(sym, sc->curlet);
if ((is_slot(p)) && (!has_methods(slot_value(p))))
return (p);
return (NULL);
}
static s7_pointer opt_types_match(s7_scheme * sc, s7_pointer check,
s7_pointer sym)
{
s7_pointer slot, checker;
checker = s7_symbol_value(sc, check);
slot = lookup_slot_from(sym, sc->curlet);
if (is_slot(slot)) {
s7_pointer obj;
obj = slot_value(slot);
if (s7_apply_function(sc, checker, set_plist_1(sc, obj)) == sc->T)
return (slot);
}
return (NULL);
}
typedef s7_pointer(*opt_pfunc) (s7_scheme * sc);
static s7_pointer opt_bool_any(s7_scheme * sc)
{
return ((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);
}
static s7_pointer opt_float_any_nr(s7_scheme * sc)
{
sc->opts[0]->v[0].fd(sc->opts[0]);
return (NULL);
}
static s7_pointer opt_int_any_nr(s7_scheme * sc)
{
sc->opts[0]->v[0].fi(sc->opts[0]);
return (NULL);
}
static s7_pointer opt_bool_any_nr(s7_scheme * sc)
{
sc->opts[0]->v[0].fb(sc->opts[0]);
return (NULL);
}
static s7_pointer opt_cell_any_nr(s7_scheme * sc)
{
return (sc->opts[0]->v[0].fp(sc->opts[0]));
} /* this is faster than returning null */
static s7_pointer opt_wrap_float(s7_scheme * sc)
{
return (make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0])));
}
static s7_pointer opt_wrap_int(s7_scheme * sc)
{
return (make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0])));
}
static s7_pointer opt_wrap_cell(s7_scheme * sc)
{
return (sc->opts[0]->v[0].fp(sc->opts[0]));
}
static s7_pointer opt_wrap_bool(s7_scheme * sc)
{
return ((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);
}
static bool p_to_b(opt_info * o)
{
return (o->v[O_WRAP].fp(o) != opt_sc(o)->F);
}
static s7_pointer d_to_p(opt_info * o)
{
return (make_real(opt_sc(o), o->v[O_WRAP].fd(o)));
}
static s7_pointer d_to_p_nr(opt_info * o)
{
o->v[O_WRAP].fd(o);
return (NULL);
}
static s7_pointer i_to_p(opt_info * o)
{
return (make_integer(opt_sc(o), o->v[O_WRAP].fi(o)));
}
static s7_pointer i_to_p_nr(opt_info * o)
{
o->v[O_WRAP].fi(o);
return (NULL);
}
/* -------------------------------- int opts -------------------------------- */
static bool int_optimize(s7_scheme * sc, s7_pointer expr);
static bool float_optimize(s7_scheme * sc, s7_pointer expr);
static s7_int opt_i_c(opt_info * o)
{
return (o->v[1].i);
}
static s7_int opt_i_s(opt_info * o)
{
return (integer(slot_value(o->v[1].p)));
}
static bool opt_int_not_pair(s7_scheme * sc, s7_pointer car_x)
{
opt_info *opc;
s7_pointer p;
if (is_t_integer(car_x)) {
opc = alloc_opo(sc);
opc->v[1].i = integer(car_x);
opc->v[0].fi = opt_i_c;
return (true);
}
p = opt_integer_symbol(sc, car_x);
if (!p)
return_false(sc, car_x);
opc = alloc_opo(sc);
opc->v[1].p = p;
opc->v[0].fi = opt_i_s;
return (true);
}
/* -------- i_i|d|p -------- */
static s7_int opt_i_i_c(opt_info * o)
{
return (o->v[2].i_i_f(o->v[1].i));
}
static s7_int opt_i_i_s(opt_info * o)
{
return (o->v[2].i_i_f(integer(slot_value(o->v[1].p))));
}
static s7_int opt_i_7i_c(opt_info * o)
{
return (o->v[2].i_7i_f(opt_sc(o), o->v[1].i));
}
static s7_int opt_i_7i_s(opt_info * o)
{
return (o->v[2].i_7i_f(opt_sc(o), integer(slot_value(o->v[1].p))));
}
static s7_int opt_i_7i_s_rand(opt_info * o)
{
return (random_i_7i(opt_sc(o), integer(slot_value(o->v[1].p))));
}
static s7_int opt_i_d_c(opt_info * o)
{
return (o->v[2].i_7d_f(opt_sc(o), o->v[1].x));
}
static s7_int opt_i_d_s(opt_info * o)
{
return (o->v[2].i_7d_f(opt_sc(o), real(slot_value(o->v[1].p))));
}
static s7_int opt_i_i_f(opt_info * o)
{
return (o->v[2].i_i_f(o->v[4].fi(o->v[3].o1)));
}
static s7_int opt_i_7i_f(opt_info * o)
{
return (o->v[2].i_7i_f(opt_sc(o), o->v[4].fi(o->v[3].o1)));
}
static s7_int opt_i_7d_f(opt_info * o)
{
return (o->v[2].i_7d_f(opt_sc(o), o->v[4].fd(o->v[3].o1)));
}
static s7_int opt_i_7p_f(opt_info * o)
{
return (o->v[2].i_7p_f(opt_sc(o), o->v[4].fp(o->v[3].o1)));
}
static s7_int opt_i_7p_f_cint(opt_info * o)
{
return (char_to_integer_i_7p(opt_sc(o), o->v[4].fp(o->v[3].o1)));
}
static s7_int opt_i_i_s_abs(opt_info * o)
{
return (abs_i_i(integer(slot_value(o->v[1].p))));
}
static s7_int opt_i_i_f_abs(opt_info * o)
{
return (abs_i_i(o->v[4].fi(o->v[3].o1)));
}
static bool i_idp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_i_i_t func;
s7_i_7i_t func7 = NULL;
s7_i_7d_t idf;
s7_i_7p_t ipf;
s7_pointer p;
int32_t start = sc->pc;
opc->v[3].o1 = sc->opts[start];
func = s7_i_i_function(s_func);
if (!func)
func7 = s7_i_7i_function(s_func);
if ((func) || (func7)) {
if (func)
opc->v[2].i_i_f = func;
else
opc->v[2].i_7i_f = func7;
if (is_t_integer(cadr(car_x))) {
opc->v[1].i = integer(cadr(car_x));
opc->v[0].fi = (func) ? opt_i_i_c : opt_i_7i_c;
return (true);
}
p = opt_integer_symbol(sc, cadr(car_x));
if (p) {
opc->v[1].p = p;
opc->v[0].fi =
(func) ? ((func == abs_i_i) ? opt_i_i_s_abs : opt_i_i_s)
: ((func7 == random_i_7i) ? opt_i_7i_s_rand : opt_i_7i_s);
return (true);
}
if (int_optimize(sc, cdr(car_x))) {
opc->v[4].fi = sc->opts[start]->v[0].fi;
opc->v[0].fi =
(func) ? ((func == abs_i_i) ? opt_i_i_f_abs : opt_i_i_f) :
opt_i_7i_f;
return (true);
}
pc_fallback(sc, start);
}
if (!is_t_ratio(cadr(car_x))) {
idf = s7_i_7d_function(s_func);
if (idf) {
opc->v[2].i_7d_f = idf;
if (is_small_real(cadr(car_x))) {
opc->v[1].x = s7_number_to_real(sc, cadr(car_x));
opc->v[0].fi = opt_i_d_c;
return (true);
}
p = opt_float_symbol(sc, cadr(car_x));
if (p) {
opc->v[1].p = p;
opc->v[0].fi = opt_i_d_s;
return (true);
}
if (float_optimize(sc, cdr(car_x))) {
opc->v[0].fi = opt_i_7d_f;
opc->v[4].fd = sc->opts[start]->v[0].fd;
return (true);
}
pc_fallback(sc, start);
}
}
ipf = s7_i_7p_function(s_func);
if (ipf) {
opc->v[2].i_7p_f = ipf;
if (cell_optimize(sc, cdr(car_x))) {
opc->v[0].fi =
(ipf ==
char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f;
opc->v[4].fp = sc->opts[start]->v[0].fp;
return (true);
}
pc_fallback(sc, start);
}
return_false(sc, car_x);
}
/* -------- i_pi -------- */
static s7_int opt_i_7pi_ss(opt_info * o)
{
return (o->v[3].i_7pi_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))));
}
static s7_int opt_7pi_ss_ivref(opt_info * o)
{
return (int_vector
(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));
}
static s7_int opt_7pi_ss_bvref(opt_info * o)
{
return (byte_vector
(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));
}
static s7_int opt_i_7pi_sf(opt_info * o)
{
return (o->v[3].i_7pi_f(opt_sc(o), slot_value(o->v[1].p),
o->v[5].fi(o->v[4].o1)));
}
static bool i_7pi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_pointer sig;
s7_i_7pi_t pfunc;
pfunc = s7_i_7pi_function(s_func);
if (!pfunc)
return_false(sc, car_x);
sig = c_function_signature(s_func);
if (is_pair(sig)) {
s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x);
int32_t start = sc->pc;
if ((is_symbol(cadr(sig))) &&
(is_symbol(arg1)) &&
(slot = opt_types_match(sc, cadr(sig), arg1))) {
s7_pointer p;
opc->v[1].p = slot;
if ((s_func == slot_value(global_slot(sc->int_vector_ref_symbol))) && /* ivref etc */
((!is_int_vector(slot_value(slot))) ||
(vector_rank(slot_value(slot)) > 1)))
return_false(sc, car_x);
if ((s_func == slot_value(global_slot(sc->byte_vector_ref_symbol))) && /* bvref etc */
((!is_byte_vector(slot_value(slot))) ||
(vector_rank(slot_value(slot)) > 1)))
return_false(sc, car_x);
opc->v[3].i_7pi_f = pfunc;
p = opt_integer_symbol(sc, arg2);
if (p) {
opc->v[2].p = p;
opc->v[0].fi = opt_i_7pi_ss;
if ((s_func ==
slot_value(global_slot(sc->int_vector_ref_symbol)))
&&
(step_end_fits
(opc->v[2].p,
vector_length(slot_value(opc->v[1].p))))) {
opc->v[0].fi = opt_7pi_ss_ivref;
opc->v[3].i_7pi_f = int_vector_ref_unchecked;
} else
if ((s_func ==
slot_value(global_slot
(sc->byte_vector_ref_symbol)))
&&
(step_end_fits
(opc->v[2].p,
vector_length(slot_value(opc->v[1].p))))) {
opc->v[0].fi = opt_7pi_ss_bvref;
opc->v[3].i_7pi_f = byte_vector_ref_unchecked;
}
return (true);
}
opc->v[4].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[0].fi = opt_i_7pi_sf;
opc->v[5].fi = opc->v[4].o1->v[0].fi;
return (true);
}
pc_fallback(sc, start);
}
}
return_false(sc, car_x);
}
/* -------- i_ii -------- */
static s7_int opt_i_ii_cc(opt_info * o)
{
return (o->v[3].i_ii_f(o->v[1].i, o->v[2].i));
}
static s7_int opt_i_ii_cs(opt_info * o)
{
return (o->v[3].i_ii_f(o->v[1].i, integer(slot_value(o->v[2].p))));
}
static s7_int opt_i_ii_cs_mul(opt_info * o)
{
return (o->v[1].i * integer(slot_value(o->v[2].p)));
}
static s7_int opt_i_ii_sc(opt_info * o)
{
return (o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));
}
static s7_int opt_i_ii_sc_add(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) + o->v[2].i);
} /* +1 is not faster */
static s7_int opt_i_ii_sc_sub(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) - o->v[2].i);
} /* -1 is not faster */
static s7_int opt_i_ii_ss(opt_info * o)
{
return (o->v[3].i_ii_f(integer(slot_value(o->v[1].p)),
integer(slot_value(o->v[2].p))));
}
static s7_int opt_i_ii_ss_add(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) +
integer(slot_value(o->v[2].p)));
}
static s7_pointer opt_p_ii_ss_add(opt_info * o)
{
return (make_integer
(opt_sc(o),
integer(slot_value(o->v[1].p)) +
integer(slot_value(o->v[2].p))));
}
static s7_int opt_i_ii_cf(opt_info * o)
{
return (o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1)));
}
static s7_int opt_i_ii_cf_mul(opt_info * o)
{
return (o->v[1].i * o->v[5].fi(o->v[4].o1));
}
static s7_int opt_i_ii_sf(opt_info * o)
{
return (o->v[3].i_ii_f(integer(slot_value(o->v[1].p)),
o->v[5].fi(o->v[4].o1)));
}
static s7_int opt_i_ii_sf_add(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1));
}
static s7_int opt_i_ii_ff(opt_info * o)
{
s7_int i1, i2;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
return (o->v[3].i_ii_f(i1, i2));
}
static s7_int opt_i_ii_fc(opt_info * o)
{
return (o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));
}
static s7_int opt_i_ii_fc_add(opt_info * o)
{
return (o->v[11].fi(o->v[10].o1) + o->v[2].i);
}
static s7_int opt_i_ii_fc_mul(opt_info * o)
{
return (o->v[11].fi(o->v[10].o1) * o->v[2].i);
}
static s7_int opt_i_7ii_fc(opt_info * o)
{
return (o->
v[3].i_7ii_f(opt_sc(o), o->v[11].fi(o->v[10].o1), o->v[2].i));
}
static s7_int opt_i_ii_fco(opt_info * o)
{
return (o->
v[3].i_ii_f(o->
v[4].i_7pi_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))),
o->v[5].i));
}
static s7_int opt_i_ii_fco_ivref_add(opt_info * o)
{
return (int_vector_ref_unchecked
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))) + o->v[5].i);
} /* tref */
static s7_int opt_i_7ii_fco(opt_info * o)
{
return (o->v[3].i_7ii_f(opt_sc(o),
o->v[4].i_7pi_f(opt_sc(o),
slot_value(o->v[1].p),
integer(slot_value
(o->v[2].p))),
o->v[5].i));
}
static bool i_ii_fc_combinable(s7_scheme * sc, opt_info * opc,
s7_i_ii_t func)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if ((o1->v[0].fi == opt_i_7pi_ss)
|| (o1->v[0].fi == opt_7pi_ss_ivref)) {
opc->v[5].i = opc->v[2].i; /* move v2.i ("c" in fc = arg2) out of the symbols' way */
opc->v[4].i_7pi_f = o1->v[3].i_7pi_f;
opc->v[1].p = o1->v[1].p;
opc->v[2].p = o1->v[2].p;
if (func)
opc->v[0].fi = ((opc->v[3].i_ii_f == add_i_ii)
&& (opc->v[4].i_7pi_f ==
int_vector_ref_unchecked)) ?
opt_i_ii_fco_ivref_add : opt_i_ii_fco;
else
opc->v[0].fi = opt_i_7ii_fco;
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static s7_int opt_i_7ii_cc(opt_info * o)
{
return (o->v[3].i_7ii_f(opt_sc(o), o->v[1].i, o->v[2].i));
}
static s7_int opt_i_7ii_cs(opt_info * o)
{
return (o->
v[3].i_7ii_f(opt_sc(o), o->v[1].i,
integer(slot_value(o->v[2].p))));
}
static s7_int opt_i_7ii_sc(opt_info * o)
{
return (o->
v[3].i_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)),
o->v[2].i));
} /* currently unhittable I think */
static s7_int opt_i_7ii_ss(opt_info * o)
{
return (o->v[3].i_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)),
integer(slot_value(o->v[2].p))));
}
static s7_int opt_i_7ii_cf(opt_info * o)
{
return (o->v[3].i_7ii_f(opt_sc(o), o->v[1].i, o->v[5].fi(o->v[4].o1)));
}
static s7_int opt_i_7ii_sf(opt_info * o)
{
return (o->v[3].i_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)),
o->v[5].fi(o->v[4].o1)));
}
static s7_int opt_i_7ii_ff(opt_info * o)
{
s7_int i1, i2;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
return (o->v[3].i_7ii_f(opt_sc(o), i1, i2));
}
#if WITH_GMP
static s7_int opt_add_i_random_i(opt_info * o)
{
return (o->v[1].i + (s7_int) (o->v[2].i * next_random(opt_sc(o))));
}
static s7_int opt_subtract_random_i_i(opt_info * o)
{
return ((s7_int) (o->v[1].i * next_random(opt_sc(o))) - o->v[2].i);
}
#else
static s7_int opt_add_i_random_i(opt_info * o)
{
return (o->v[1].i +
(s7_int) (o->v[2].i * next_random(opt_sc(o)->default_rng)));
}
static s7_int opt_subtract_random_i_i(opt_info * o)
{
return ((s7_int) (o->v[1].i * next_random(opt_sc(o)->default_rng)) -
o->v[2].i);
}
#endif
static bool i_ii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_i_ii_t ifunc;
s7_i_7ii_t ifunc7 = NULL;
s7_pointer p, sig;
ifunc = s7_i_ii_function(s_func);
if (!ifunc) {
ifunc7 = s7_i_7ii_function(s_func);
if (!ifunc7)
return_false(sc, car_x);
}
sig = c_function_signature(s_func);
if (is_pair(sig)) {
s7_pointer arg1 = cadr(car_x), arg2 = caddr(car_x);
int32_t start = sc->pc;
if (ifunc)
opc->v[3].i_ii_f = ifunc;
else
opc->v[3].i_7ii_f = ifunc7;
if (is_t_integer(arg1)) {
opc->v[1].i = integer(arg1);
if (is_t_integer(arg2)) {
opc->v[2].i = integer(arg2);
opc->v[0].fi = (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc;
return (true);
}
p = opt_integer_symbol(sc, arg2);
if (p) {
opc->v[2].p = p;
if (ifunc)
opc->v[0].fi =
(opc->v[3].i_ii_f ==
multiply_i_ii) ? opt_i_ii_cs_mul : opt_i_ii_cs;
else
opc->v[0].fi = opt_i_7ii_cs;
return (true);
}
opc->v[4].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
if (ifunc) {
opc->v[0].fi = opt_i_ii_cf; /* sc->opts[start]->v[0].fi -> opt_i_7i_c -> same_opt->v[2].i_7i_f = random_i_7i tmap */
if ((ifunc == add_i_ii)
&& (opc == sc->opts[sc->pc - 2])
&& (sc->opts[start]->v[0].fi == opt_i_7i_c)
&& (sc->opts[start]->v[2].i_7i_f == random_i_7i)) {
opc->v[0].fi = opt_add_i_random_i;
opc->v[2].i = sc->opts[start]->v[1].i;
backup_pc(sc);
} else if (ifunc == multiply_i_ii)
opc->v[0].fi = opt_i_ii_cf_mul;
} else
opc->v[0].fi = opt_i_7ii_cf;
opc->v[5].fi = opc->v[4].o1->v[0].fi;
return (true);
}
pc_fallback(sc, start);
} else {
p = opt_integer_symbol(sc, arg1);
if (p) {
opc->v[1].p = p;
if (is_t_integer(arg2)) {
opc->v[2].i = integer(arg2);
if (ifunc) {
if (opc->v[3].i_ii_f == add_i_ii)
opc->v[0].fi = opt_i_ii_sc_add;
else
opc->v[0].fi = (opc->v[3].i_ii_f == subtract_i_ii) ? opt_i_ii_sc_sub : opt_i_ii_sc; /* add1/sub1 are not faster */
} else
opc->v[0].fi = opt_i_7ii_sc;
if ((car(car_x) == sc->modulo_symbol) &&
(integer(arg2) > 1))
opc->v[3].i_ii_f = modulo_i_ii_unchecked;
else {
if (car(car_x) == sc->ash_symbol) {
if (opc->v[2].i < 0) {
opc->v[3].i_ii_f =
(opc->v[2].i ==
-1) ? rsh_i_i2_direct :
rsh_i_ii_unchecked;
opc->v[0].fi = opt_i_ii_sc;
} else if (opc->v[2].i < S7_INT_BITS) {
opc->v[3].i_ii_f = lsh_i_ii_unchecked;
opc->v[0].fi = opt_i_ii_sc;
}
} else if (opc->v[2].i > 0) {
/* these assume vunion is a union, not a struct; i_7ii_f otherwise might be leftover from a previous use */
if (opc->v[3].i_7ii_f == quotient_i_7ii) {
opc->v[3].i_ii_f = quotient_i_ii_unchecked;
opc->v[0].fi = opt_i_ii_sc;
} else if ((opc->v[2].i > 1)
&& (opc->v[3].i_7ii_f ==
remainder_i_7ii)) {
opc->v[3].i_ii_f =
remainder_i_ii_unchecked;
opc->v[0].fi = opt_i_ii_sc;
}
}
}
return (true);
} /* opt_int arg2 */
p = opt_integer_symbol(sc, arg2);
if (p) {
opc->v[2].p = p;
if (ifunc)
opc->v[0].fi =
(opc->v[3].i_ii_f ==
add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss;
else
opc->v[0].fi = opt_i_7ii_ss;
return (true);
}
if (int_optimize(sc, cddr(car_x))) {
opc->v[4].o1 = sc->opts[start];
opc->v[5].fi = sc->opts[start]->v[0].fi;
if (ifunc)
opc->v[0].fi =
(opc->v[3].i_ii_f ==
add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf;
else
opc->v[0].fi = opt_i_7ii_sf;
return (true);
}
pc_fallback(sc, start);
} else {
if (is_t_integer(arg2)) {
opc->v[2].i = integer(arg2);
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[11].fi = opc->v[10].o1->v[0].fi;
if (!i_ii_fc_combinable(sc, opc, ifunc)) {
if (ifunc) {
if (opc->v[3].i_ii_f == add_i_ii) {
opc->v[0].fi = opt_i_ii_fc_add;
return (true);
}
if (opc->v[3].i_ii_f == multiply_i_ii) {
opc->v[0].fi = opt_i_ii_fc_mul;
return (true);
}
opc->v[0].fi = opt_i_ii_fc;
if ((opc->v[3].i_ii_f == subtract_i_ii)
&& (opc == sc->opts[sc->pc - 2])
&& (sc->opts[start]->v[0].fi ==
opt_i_7i_c)
&& (sc->opts[start]->v[2].i_7i_f ==
random_i_7i)) {
opc->v[0].fi = opt_subtract_random_i_i;
opc->v[1].i = sc->opts[start]->v[1].i;
backup_pc(sc);
}
} else
opc->v[0].fi = opt_i_7ii_fc;
if (opc->v[2].i > 0) {
if (opc->v[3].i_7ii_f == quotient_i_7ii) {
opc->v[3].i_ii_f =
quotient_i_ii_unchecked;
opc->v[0].fi = opt_i_ii_fc;
} else if ((opc->v[2].i > 1)
&& (opc->v[3].i_7ii_f ==
remainder_i_7ii)) {
opc->v[3].i_ii_f =
remainder_i_ii_unchecked;
opc->v[0].fi = opt_i_ii_fc;
}
}
}
return (true);
}
pc_fallback(sc, start);
} else {
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[9].fi = opc->v[8].o1->v[0].fi;
opc->v[0].fi =
(ifunc) ? opt_i_ii_ff : opt_i_7ii_ff;
return (true);
}
pc_fallback(sc, start);
}
}
}
}
}
return_false(sc, car_x);
}
/* -------- i_iii -------- */
static s7_int opt_i_iii_fff(opt_info * o)
{
s7_int i1, i2, i3;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
i3 = o->v[5].fi(o->v[4].o1);
return (o->v[3].i_iii_f(i1, i2, i3));
}
static bool i_iii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
int32_t start;
s7_i_iii_t ifunc;
ifunc = s7_i_iii_function(s_func);
if (!ifunc)
return_false(sc, car_x);
start = sc->pc;
opc->v[10].o1 = sc->opts[start];
if (int_optimize(sc, cdr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[4].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdddr(car_x))) {
opc->v[3].i_iii_f = ifunc;
opc->v[0].fi = opt_i_iii_fff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
opc->v[5].fi = opc->v[4].o1->v[0].fi;
return (true);
}
}
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- i_7pii -------- */
static s7_int opt_i_7pii_ssf(opt_info * o)
{
return (o->v[3].i_7pii_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[5].fi(o->v[4].o1)));
}
static s7_int opt_i_7pii_ssf_vset(opt_info * o)
{
return (int_vector_set_unchecked
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1)));
}
static s7_int opt_i_7pii_ssc(opt_info * o)
{
return (o->v[3].i_7pii_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)), o->v[4].i));
}
static s7_int opt_i_7pii_sss(opt_info * o)
{
return (o->v[4].i_7pii_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p))));
}
static s7_int opt_i_pii_sss_ivref_unchecked(opt_info * o)
{
s7_pointer v = slot_value(o->v[1].p);
return (int_vector
(v,
((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) +
integer(slot_value(o->v[3].p)))));
}
static s7_int opt_i_7pii_sff(opt_info * o)
{
s7_int i1, i2;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
return (o->v[3].i_7pii_f(opt_sc(o), slot_value(o->v[1].p), i1, i2));
}
/* -------- i_7piii -------- */
static s7_int opt_i_7piii_sssf(opt_info * o)
{
return (o->v[5].i_7piii_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)),
o->v[11].fi(o->v[10].o1)));
}
static s7_int opt_i_piii_sssf_ivset_unchecked(opt_info * o)
{
s7_pointer v = slot_value(o->v[1].p);
s7_int val;
val = o->v[11].fi(o->v[10].o1);
int_vector(v,
((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) +
integer(slot_value(o->v[3].p)))) = val;
return (val);
}
static s7_int opt_i_7piii_sssc(opt_info * o)
{
return (o->v[5].i_7piii_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)), o->v[4].i));
}
static s7_int opt_i_7piii_ssss(opt_info * o)
{
return (o->v[5].i_7piii_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)),
integer(slot_value(o->v[4].p))));
}
static s7_int opt_i_7piii_sfff(opt_info * o)
{
s7_int i1, i2, i3;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
i3 = o->v[6].fi(o->v[4].o1);
return (o->
v[5].i_7piii_f(opt_sc(o), slot_value(o->v[1].p), i1, i2, i3));
}
static bool opt_i_7piii_args(s7_scheme * sc, opt_info * opc,
s7_pointer indexp1, s7_pointer indexp2,
s7_pointer valp)
{
/* opc->v[5] is the called function (int-vector-set! etc) */
s7_pointer slot;
slot = opt_integer_symbol(sc, car(indexp2));
if (slot) {
opc->v[3].p = slot;
slot = opt_integer_symbol(sc, car(indexp1));
if (slot) {
opc->v[2].p = slot;
if (is_t_integer(car(valp))) {
opc->v[0].fi = opt_i_7piii_sssc;
opc->v[4].i = integer(car(valp));
return (true);
}
slot = opt_integer_symbol(sc, car(valp));
if (slot) {
opc->v[4].p = slot;
opc->v[0].fi = opt_i_7piii_ssss;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, valp)) {
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[0].fi = opt_i_7piii_sssf;
if ((opc->v[5].i_7piii_f == int_vector_set_i_7piii) &&
(step_end_fits
(opc->v[2].p,
vector_dimension(slot_value(opc->v[1].p), 0)))
&&
(step_end_fits
(opc->v[3].p,
vector_dimension(slot_value(opc->v[1].p), 1))))
opc->v[0].fi = opt_i_piii_sssf_ivset_unchecked;
return (true);
}
}
return_false(sc, NULL);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp1)) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp2)) {
opc->v[4].o1 = sc->opts[sc->pc];
if (int_optimize(sc, valp)) {
opc->v[0].fi = opt_i_7piii_sfff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
opc->v[6].fi = opc->v[4].o1->v[0].fi; /* v[5] is in use */
return (true);
}
}
}
return_false(sc, indexp1);
}
static bool opt_int_vector_set(s7_scheme * sc, int otype, opt_info * opc,
s7_pointer v, s7_pointer indexp1,
s7_pointer indexp2, s7_pointer valp)
{
s7_pointer settee;
settee = lookup_slot_from(v, sc->curlet);
if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) {
bool int_case;
s7_pointer slot, vect = slot_value(settee);
int_case = (is_int_vector(vect));
opc->v[1].p = settee;
if ((int_case) || (is_byte_vector(vect))) {
if ((otype >= 0) && (otype != ((int_case) ? 1 : 0)))
return_false(sc, indexp1);
if ((!indexp2) && (vector_rank(vect) == 1)) {
opc->v[3].i_7pii_f =
(int_case) ? int_vector_set_i_7pii :
byte_vector_set_i_7pii;
slot = opt_integer_symbol(sc, car(indexp1));
if (slot) {
int32_t start = sc->pc;
opc->v[2].p = slot;
if (step_end_fits(opc->v[2].p, vector_length(vect)))
opc->v[3].i_7pii_f =
(int_case) ? int_vector_set_unchecked :
byte_vector_set_unchecked;
if ((is_pair(valp)) && (is_null(cdr(valp)))
&& (is_t_integer(car(valp)))) {
opc->v[4].i = integer(car(valp));
opc->v[0].fi = opt_i_7pii_ssc;
return (true);
}
if (!int_optimize(sc, valp))
return_false(sc, NULL);
opc->v[0].fi =
(opc->v[3].i_7pii_f ==
int_vector_set_unchecked) ? opt_i_7pii_ssf_vset :
opt_i_7pii_ssf;
opc->v[4].o1 = sc->opts[start];
opc->v[5].fi = sc->opts[start]->v[0].fi;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp1)) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, valp)) {
opc->v[0].fi = opt_i_7pii_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
return (true);
}
}
return_false(sc, NULL);
}
if ((indexp2) && (vector_rank(vect) == 2)) {
opc->v[5].i_7piii_f =
(int_case) ? int_vector_set_i_7piii :
byte_vector_set_i_7piii;
return (opt_i_7piii_args(sc, opc, indexp1, indexp2, valp));
}
}
}
return_false(sc, v);
}
static bool is_target_or_its_alias(s7_pointer symbol, s7_pointer symfunc,
s7_pointer target)
{
return ((symbol == target) || (symfunc == initial_value(target)));
}
static bool i_7pii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_pointer sig;
s7_i_7pii_t pfunc;
pfunc = s7_i_7pii_function(s_func);
if (!pfunc)
return_false(sc, car_x);
sig = c_function_signature(s_func);
if ((is_pair(sig)) && (is_symbol(cadr(car_x)))) {
s7_pointer slot, fname = car(car_x);
if ((is_target_or_its_alias
(fname, s_func, sc->int_vector_set_symbol))
||
(is_target_or_its_alias
(fname, s_func, sc->byte_vector_set_symbol)))
return (opt_int_vector_set
(sc, (fname == sc->int_vector_set_symbol) ? 1 : 0, opc,
cadr(car_x), cddr(car_x), NULL, cdddr(car_x)));
slot = opt_types_match(sc, cadr(sig), cadr(car_x));
if (slot) {
s7_pointer arg2, p;
int32_t start = sc->pc;
opc->v[1].p = slot;
if (((is_target_or_its_alias
(fname, s_func, sc->int_vector_ref_symbol))
||
(is_target_or_its_alias
(fname, s_func, sc->byte_vector_ref_symbol)))
&& (vector_rank(slot_value(slot)) != 2))
return_false(sc, car_x);
arg2 = caddr(car_x);
p = opt_integer_symbol(sc, arg2);
if (p) {
opc->v[2].p = p;
p = opt_integer_symbol(sc, cadddr(car_x));
if (p) {
opc->v[3].p = p;
opc->v[4].i_7pii_f = pfunc;
opc->v[0].fi = opt_i_7pii_sss;
if ((pfunc == int_vector_ref_i_7pii) &&
(step_end_fits
(opc->v[2].p,
vector_dimension(slot_value(opc->v[1].p), 0)))
&&
(step_end_fits
(opc->v[3].p,
vector_dimension(slot_value(opc->v[1].p), 1))))
opc->v[0].fi = opt_i_pii_sss_ivref_unchecked;
return (true);
}
if (int_optimize(sc, cdddr(car_x))) {
opc->v[3].i_7pii_f = pfunc;
opc->v[0].fi = opt_i_7pii_ssf;
opc->v[4].o1 = sc->opts[start];
opc->v[5].fi = sc->opts[start]->v[0].fi;
return (true);
}
return_false(sc, car_x);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdddr(car_x))) {
opc->v[3].i_7pii_f = pfunc;
opc->v[0].fi = opt_i_7pii_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
return (true);
}
}
pc_fallback(sc, start);
}
}
return_false(sc, car_x);
}
static bool i_7piii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_i_7piii_t f;
f = s7_i_7piii_function(s_func);
if ((f) && (is_symbol(cadr(car_x)))) {
s7_pointer settee;
if ((is_target_or_its_alias
(car(car_x), s_func, sc->int_vector_set_symbol))
||
(is_target_or_its_alias
(car(car_x), s_func, sc->byte_vector_set_symbol)))
return (opt_int_vector_set
(sc, (car(car_x) == sc->int_vector_set_symbol) ? 1 : 0,
opc, cadr(car_x), cddr(car_x), cdddr(car_x),
cddddr(car_x)));
settee = lookup_slot_from(cadr(car_x), sc->curlet);
if (is_slot(settee)) {
s7_pointer vect = slot_value(settee);
if ((is_int_vector(vect)) && (vector_rank(vect) == 3)) {
opc->v[5].i_7piii_f = f;
opc->v[1].p = settee;
return (opt_i_7piii_args
(sc, opc, cddr(car_x), cdddr(car_x),
cddddr(car_x)));
}
}
}
return_false(sc, car_x);
}
/* -------- i_add|multiply_any -------- */
static s7_int opt_i_add_any_f(opt_info * o)
{
s7_int sum = 0;
int32_t i;
for (i = 0; i < o->v[1].i; i++) {
opt_info *o1;
o1 = o->v[i + 2].o1;
sum += o1->v[0].fi(o1);
}
return (sum);
}
static s7_int opt_i_add2(opt_info * o)
{
s7_int sum;
sum = o->v[6].fi(o->v[2].o1);
return (sum + o->v[7].fi(o->v[3].o1));
}
static s7_int opt_i_mul2(opt_info * o)
{
s7_int sum;
sum = o->v[6].fi(o->v[2].o1);
return (sum * o->v[7].fi(o->v[3].o1));
}
static s7_int opt_i_add3(opt_info * o)
{
s7_int sum;
sum = o->v[6].fi(o->v[2].o1);
sum += o->v[7].fi(o->v[3].o1);
return (sum + o->v[8].fi(o->v[4].o1));
}
static s7_int opt_i_mul3(opt_info * o)
{
s7_int sum;
sum = o->v[6].fi(o->v[2].o1);
sum *= o->v[7].fi(o->v[3].o1);
return (sum * o->v[8].fi(o->v[4].o1));
}
static s7_int opt_i_add4(opt_info * o)
{
s7_int sum;
sum = o->v[6].fi(o->v[2].o1);
sum += o->v[7].fi(o->v[3].o1);
sum += o->v[8].fi(o->v[4].o1);
return (sum + o->v[9].fi(o->v[5].o1));
}
static s7_int opt_i_mul4(opt_info * o)
{
s7_int sum;
sum = o->v[6].fi(o->v[2].o1);
sum *= o->v[7].fi(o->v[3].o1);
sum *= o->v[8].fi(o->v[4].o1);
return (sum * o->v[9].fi(o->v[5].o1));
}
static s7_int opt_i_multiply_any_f(opt_info * o)
{
s7_int sum = 1;
int32_t i;
for (i = 0; i < o->v[1].i; i++) {
opt_info *o1;
o1 = o->v[i + 2].o1;
sum *= o1->v[0].fi(o1);
}
return (sum);
}
static bool i_add_any_ok(s7_scheme * sc, opt_info * opc, s7_pointer car_x)
{
s7_pointer p, head = car(car_x);
int32_t cur_len, start = sc->pc;
for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12);
p = cdr(p), cur_len++) {
opc->v[cur_len + 2].o1 = sc->opts[sc->pc];
if (!int_optimize(sc, p))
break;
}
if (is_null(p)) {
opc->v[1].i = cur_len;
if (cur_len <= 4) {
int32_t i;
for (i = 0; i < cur_len; i++)
opc->v[i + 6].fi = opc->v[i + 2].o1->v[0].fi;
}
if (cur_len == 2)
opc->v[0].fi =
(head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2;
else if (cur_len == 3)
opc->v[0].fi =
(head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3;
else if (cur_len == 4)
opc->v[0].fi =
(head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4;
else
opc->v[0].fi =
(head ==
sc->add_symbol) ? opt_i_add_any_f : opt_i_multiply_any_f;
return (true);
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- set_i_i -------- */
static s7_int opt_set_i_i_f(opt_info * o)
{
s7_int x;
x = o->v[3].fi(o->v[2].o1);
slot_set_value(o->v[1].p, make_integer(opt_sc(o), x));
return (x);
}
static s7_int opt_set_i_i_fm(opt_info * o)
{ /* called in increment: (set! sum (+ sum (...))) where are all ints */
s7_int x;
x = o->v[3].fi(o->v[2].o1);
integer(slot_value(o->v[1].p)) = x;
return (x);
}
static s7_int opt_set_i_i_fo(opt_info * o)
{
s7_int x;
x = integer(slot_value(o->v[3].p)) + o->v[2].i;
slot_set_value(o->v[1].p, make_integer(opt_sc(o), x));
return (x);
}
static bool set_i_i_f_combinable(s7_scheme * sc, opt_info * opc)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if (o1->v[0].fi == opt_i_ii_sc_add) {
/* opc->v[4].i_ii_f = o1->v[3].i_ii_f; */
opc->v[3].p = o1->v[1].p;
opc->v[2].i = o1->v[2].i;
opc->v[0].fi = opt_set_i_i_fo;
backup_pc(sc);
return (true); /* ii_sc v[1].p is a slot */
}
}
return_false(sc, NULL);
}
static bool i_syntax_ok(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
if ((car(car_x) == sc->set_symbol) && (len == 3)) {
opt_info *opc;
opc = alloc_opo(sc);
if (is_symbol(cadr(car_x))) { /* (set! i 3) */
s7_pointer settee;
if (is_immutable(cadr(car_x)))
return_false(sc, car_x);
settee = lookup_slot_from(cadr(car_x), sc->curlet);
if ((is_slot(settee)) &&
(!is_immutable(settee)) && ((!slot_has_setter(settee))
|| (slot_setter(settee) !=
initial_value(sc->
is_integer_symbol))))
{
opt_info *o1 = sc->opts[sc->pc];
opc->v[1].p = settee;
if ((is_t_integer(slot_value(settee))) &&
(int_optimize(sc, cddr(car_x)))) {
if (set_i_i_f_combinable(sc, opc))
return (true);
opc->v[0].fi =
(is_mutable_integer(slot_value(opc->v[1].p))) ?
opt_set_i_i_fm : opt_set_i_i_f;
opc->v[2].o1 = o1;
opc->v[3].fi = o1->v[0].fi;
return (true); /* or OO_I? */
}
}
} else if ((is_pair(cadr(car_x))) && /* if is_pair(settee) get setter */
(is_symbol(caadr(car_x))) && (is_pair(cdadr(car_x)))) {
if (is_null(cddadr(car_x)))
return (opt_int_vector_set
(sc, -1, opc, caadr(car_x), cdadr(car_x), NULL,
cddr(car_x)));
if (is_null(cdddr(cadr(car_x))))
return (opt_int_vector_set
(sc, -1, opc, caadr(car_x), cdadr(car_x),
cddadr(car_x), cddr(car_x)));
}
}
return_false(sc, car_x);
}
static bool i_implicit_ok(s7_scheme * sc, s7_pointer s_slot,
s7_pointer car_x, int32_t len)
{
s7_pointer obj = slot_value(s_slot);
if ((is_int_vector(obj)) || (is_byte_vector(obj))) {
bool int_case = is_int_vector(obj);
s7_pointer slot;
if ((len == 2) && (vector_rank(obj) == 1)) {
opt_info *opc;
opc = alloc_opo(sc);
opc->v[1].p = s_slot;
slot = opt_integer_symbol(sc, cadr(car_x));
if (slot) {
opc->v[0].fi = opt_i_7pi_ss;
opc->v[3].i_7pi_f =
(int_case) ? int_vector_ref_i_7pi :
byte_vector_ref_i_7pi;
opc->v[2].p = slot;
if (step_end_fits(opc->v[2].p, vector_length(obj)))
opc->v[3].i_7pi_f =
(int_case) ? int_vector_ref_unchecked :
byte_vector_ref_unchecked;
/* not opc->v[0].fi = opt_7pi_ss_ivref -- this causes a huge slowdown in dup.scm?? */
return (true);
}
opc->v[4].o1 = sc->opts[sc->pc];
if (!int_optimize(sc, cdr(car_x)))
return_false(sc, car_x);
opc->v[0].fi = opt_i_7pi_sf;
opc->v[3].i_7pi_f =
(int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi;
opc->v[5].fi = opc->v[4].o1->v[0].fi;
return (true);
}
if ((len == 3) && (vector_rank(obj) == 2)) {
opt_info *opc;
opc = alloc_opo(sc);
opc->v[1].p = s_slot;
slot = opt_integer_symbol(sc, cadr(car_x));
if (slot) {
opc->v[2].p = slot;
slot = opt_integer_symbol(sc, caddr(car_x));
if (!slot)
return_false(sc, car_x);
opc->v[4].i_7pii_f =
(int_case) ? int_vector_ref_i_7pii :
byte_vector_ref_i_7pii;
opc->v[3].p = slot;
opc->v[0].fi = opt_i_7pii_sss;
if ((int_case) &&
(step_end_fits(opc->v[2].p, vector_dimension(obj, 0)))
&&
(step_end_fits(opc->v[3].p, vector_dimension(obj, 1))))
opc->v[0].fi = opt_i_pii_sss_ivref_unchecked;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[3].i_7pii_f =
(int_case) ? int_vector_ref_i_7pii :
byte_vector_ref_i_7pii;
opc->v[0].fi = opt_i_7pii_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
return (true);
}
}
}
}
return_false(sc, car_x);
}
/* ------------------------------------- float opts ------------------------------------------- */
static s7_double opt_d_c(opt_info * o)
{
return (o->v[1].x);
}
static s7_double opt_d_s(opt_info * o)
{
return (real(slot_value(o->v[1].p)));
}
static s7_double opt_D_s(opt_info * o)
{
s7_pointer x = slot_value(o->v[1].p);
return ((is_t_integer(x)) ? (s7_double) (integer(x)) :
s7_number_to_real(opt_sc(o), x));
}
static bool opt_float_not_pair(s7_scheme * sc, s7_pointer car_x)
{
opt_info *opc;
s7_pointer p;
if (is_small_real(car_x)) {
opc = alloc_opo(sc);
opc->v[1].x = s7_number_to_real(sc, car_x);
opc->v[0].fd = opt_d_c;
return (true);
}
p = opt_real_symbol(sc, car_x);
if (p) {
opc = alloc_opo(sc);
opc->v[1].p = p;
opc->v[0].fd = (is_t_real(slot_value(p))) ? opt_d_s : opt_D_s;
return (true);
}
return_false(sc, car_x);
}
/* -------- d -------- */
static s7_double opt_d_f(opt_info * o)
{
return (o->v[1].d_f());
}
static bool d_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func)
{
s7_d_t func; /* (f): (mus-srate) */
func = s7_d_function(s_func);
if (!func)
return_false(sc, NULL);
opc->v[0].fd = opt_d_f;
opc->v[1].d_f = func;
return (true);
}
/* -------- d_d -------- */
static s7_double opt_d_d_c(opt_info * o)
{
return (o->v[3].d_d_f(o->v[1].x));
}
static s7_double opt_d_d_s(opt_info * o)
{
return (o->v[3].d_d_f(real(slot_value(o->v[1].p))));
}
static s7_double opt_d_d_s_abs(opt_info * o)
{
return (abs_d_d(real(slot_value(o->v[1].p))));
}
static s7_double opt_d_7d_c(opt_info * o)
{
return (o->v[3].d_7d_f(opt_sc(o), o->v[1].x));
}
static s7_double opt_d_7d_s(opt_info * o)
{
return (o->v[3].d_7d_f(opt_sc(o), real(slot_value(o->v[1].p))));
}
static s7_double opt_d_d_f(opt_info * o)
{
return (o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_d_f_abs(opt_info * o)
{
return (abs_d_d(o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_d_f_sin(opt_info * o)
{
return (sin_d_d(o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_d_f_cos(opt_info * o)
{
return (cos_d_d(o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_7d_f(opt_info * o)
{
return (o->v[3].d_7d_f(opt_sc(o), o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_7d_f_divide(opt_info * o)
{
return (divide_d_7d(opt_sc(o), o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_7pi_ss_fvref_unchecked(opt_info * o);
static s7_double opt_abs_d_ss_fvref(opt_info * o)
{
opt_info *o1 = o->v[4].o1;
return (abs_d_d
(float_vector
(slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p)))));
}
static bool d_d_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_d_t func;
s7_d_7d_t func7 = NULL;
int32_t start = sc->pc;
func = s7_d_d_function(s_func);
if (!func)
func7 = s7_d_7d_function(s_func);
if ((func) || (func7)) {
s7_pointer p;
if (func)
opc->v[3].d_d_f = func;
else
opc->v[3].d_7d_f = func7;
if (is_small_real(cadr(car_x))) {
if ((!is_t_real(cadr(car_x))) && /* (random 1) != (random 1.0) */
((car(car_x) == sc->random_symbol) ||
(car(car_x) == sc->sin_symbol) ||
(car(car_x) == sc->cos_symbol)))
return_false(sc, car_x);
opc->v[1].x = s7_number_to_real(sc, cadr(car_x));
opc->v[0].fd = (func) ? opt_d_d_c : opt_d_7d_c;
return (true);
}
p = opt_float_symbol(sc, cadr(car_x));
if ((p) && (!has_methods(slot_value(p)))) {
opc->v[1].p = p;
opc->v[0].fd =
(func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) :
opt_d_7d_s;
return (true);
}
opc->v[4].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x))) {
opc->v[0].fd =
(func) ? ((func == abs_d_d) ? opt_d_d_f_abs
: ((func ==
sin_d_d) ? opt_d_d_f_sin : ((func ==
cos_d_d) ?
opt_d_d_f_cos :
opt_d_d_f)))
: ((func7 ==
divide_d_7d) ? opt_d_7d_f_divide : opt_d_7d_f);
opc->v[5].fd = opc->v[4].o1->v[0].fd;
if ((func == abs_d_d)
&& (opc->v[5].fd == opt_d_7pi_ss_fvref_unchecked))
opc->v[0].fd = opt_abs_d_ss_fvref;
return (true);
}
pc_fallback(sc, start);
}
return_false(sc, car_x);
}
/* -------- d_v -------- */
static s7_double opt_d_v(opt_info * o)
{
return (o->v[3].d_v_f(o->v[5].obj));
}
static bool d_v_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_pointer sig;
s7_d_v_t flt_func;
flt_func = s7_d_v_function(s_func);
if (!flt_func)
return_false(sc, car_x);
sig = c_function_signature(s_func);
if ((is_pair(sig)) && (is_symbol(cadr(sig))) && (is_symbol(cadr(car_x)))) { /* look for (oscil g) */
s7_pointer slot;
slot = opt_types_match(sc, cadr(sig), cadr(car_x));
if (slot) {
opc->v[1].p = slot;
opc->v[5].obj = (void *) c_object_value(slot_value(slot));
opc->v[3].d_v_f = flt_func;
opc->v[0].fd = opt_d_v;
return (true);
}
}
return_false(sc, car_x);
}
/* -------- d_p -------- */
static s7_double opt_d_p_s(opt_info * o)
{
return (o->v[3].d_p_f(slot_value(o->v[1].p)));
}
static s7_double opt_d_p_f(opt_info * o)
{
return (o->v[3].d_p_f(o->v[5].fp(o->v[4].o1)));
}
static bool d_p_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_p_t dpf; /* mostly clm gens */
int32_t start = sc->pc;
dpf = s7_d_p_function(s_func);
if (!dpf)
return_false(sc, car_x);
opc->v[3].d_p_f = dpf;
if (is_symbol(cadr(car_x))) {
s7_pointer slot;
slot = opt_simple_symbol(sc, cadr(car_x));
if (!slot)
return_false(sc, car_x);
opc->v[1].p = slot;
opc->v[0].fd = opt_d_p_s;
return (true);
}
opc->v[4].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) {
opc->v[0].fd = opt_d_p_f;
opc->v[5].fp = opc->v[4].o1->v[0].fp;
return (true);
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- d_7pi -------- */
static s7_double opt_d_7pi_sc(opt_info * o)
{
return (o->v[3].d_7pi_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].i));
}
static s7_double opt_d_7pi_ss(opt_info * o)
{
return (o->v[3].d_7pi_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))));
}
static s7_double opt_d_7pi_sf(opt_info * o)
{
return (o->v[3].d_7pi_f(opt_sc(o), slot_value(o->v[1].p),
o->v[11].fi(o->v[10].o1)));
}
static s7_double opt_d_7pi_ss_fvref(opt_info * o)
{
return (float_vector_ref_d_7pi
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))));
}
static s7_double opt_d_7pi_ss_fvref_unchecked(opt_info * o)
{
return (float_vector
(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));
}
static s7_double opt_d_7pi_ff(opt_info * o)
{
s7_pointer seq;
seq = o->v[5].fp(o->v[4].o1);
return (o->v[3].d_7pi_f(opt_sc(o), seq, o->v[9].fi(o->v[8].o1)));
}
static bool d_7pi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
/* float-vector-ref is checked for a 1D float-vector arg, but other callers should do type checking */
int32_t start = sc->pc;
s7_d_7pi_t ifunc;
ifunc = s7_d_7pi_function(s_func); /* ifunc: float_vector_ref_d_7pi, s_func: global_value(sc->float_vector_ref_symbol) */
if (!ifunc)
return_false(sc, car_x);
opc->v[3].d_7pi_f = ifunc;
if (is_symbol(cadr(car_x))) { /* (float-vector-ref v i) */
s7_pointer arg2, p, obj;
opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet);
if (!is_slot(opc->v[1].p))
return_false(sc, car_x);
obj = slot_value(opc->v[1].p);
if ((is_target_or_its_alias
(car(car_x), s_func, sc->float_vector_ref_symbol))
&& ((!is_float_vector(obj)) || (vector_rank(obj) > 1)))
return_false(sc, car_x);
arg2 = caddr(car_x);
if (!is_pair(arg2)) {
if (is_t_integer(arg2)) {
opc->v[2].i = integer(arg2);
opc->v[0].fd = opt_d_7pi_sc;
return (true);
}
p = opt_integer_symbol(sc, arg2);
if (!p)
return_false(sc, car_x);
opc->v[2].p = p;
opc->v[0].fd = opt_d_7pi_ss;
if (is_target_or_its_alias
(car(car_x), s_func, sc->float_vector_ref_symbol)) {
if (step_end_fits(opc->v[2].p, vector_length(obj)))
opc->v[0].fd = opt_d_7pi_ss_fvref_unchecked;
else
opc->v[0].fd = opt_d_7pi_ss_fvref;
}
return (true);
}
if (int_optimize(sc, cddr(car_x))) {
opc->v[0].fd = opt_d_7pi_sf;
opc->v[10].o1 = sc->opts[start];
opc->v[11].fi = opc->v[10].o1->v[0].fi;
return (true);
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && ((!is_float_vector(cadr(car_x))) || (vector_rank(cadr(car_x)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */
return_false(sc, car_x);
if (cell_optimize(sc, cdr(car_x))) {
opt_info *o2 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[0].fd = opt_d_7pi_ff;
opc->v[4].o1 = sc->opts[start];
opc->v[5].fp = sc->opts[start]->v[0].fp;
opc->v[8].o1 = o2;
opc->v[9].fi = o2->v[0].fi;
return (true);
}
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- d_ip -------- */
static s7_double opt_d_ip_ss(opt_info * o)
{
return (o->
v[3].d_ip_f(integer(slot_value(o->v[1].p)),
slot_value(o->v[2].p)));
}
static bool d_ip_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_ip_t pfunc;
pfunc = s7_d_ip_function(s_func);
if ((pfunc) && (is_symbol(caddr(car_x)))) {
s7_pointer p;
p = opt_integer_symbol(sc, cadr(car_x));
if (p) {
opc->v[3].d_ip_f = pfunc;
opc->v[1].p = p;
opc->v[2].p = lookup_slot_from(caddr(car_x), sc->curlet);
if (is_slot(opc->v[2].p)) { /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */
opc->v[0].fd = opt_d_ip_ss;
return (true);
}
}
}
return_false(sc, car_x);
}
/* -------- d_pd -------- */
static s7_double opt_d_pd_sf(opt_info * o)
{
return (o->
v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_pd_ss(opt_info * o)
{
return (o->
v[3].d_pd_f(slot_value(o->v[1].p),
real(slot_value(o->v[2].p))));
}
static bool d_pd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
if (is_symbol(cadr(car_x))) {
s7_d_pd_t func;
func = s7_d_pd_function(s_func);
if (func) {
s7_pointer p, arg2 = caddr(car_x);
int32_t start = sc->pc;
opc->v[3].d_pd_f = func;
opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet);
if (!is_slot(opc->v[1].p))
return_false(sc, car_x);
p = opt_float_symbol(sc, arg2);
if (p) {
opc->v[2].p = p;
opc->v[0].fd = opt_d_pd_ss;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x))) {
opc->v[0].fd = opt_d_pd_sf;
opc->v[11].fd = opc->v[10].o1->v[0].fd;
return (true);
}
pc_fallback(sc, start);
}
}
return_false(sc, car_x);
}
/* -------- d_vd -------- */
static s7_double opt_d_vd_c(opt_info * o)
{
return (o->v[3].d_vd_f(o->v[5].obj, o->v[2].x));
}
static s7_double opt_d_vd_s(opt_info * o)
{
return (o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p))));
}
static s7_double opt_d_vd_f(opt_info * o)
{
return (o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1)));
}
static s7_double opt_d_vd_o(opt_info * o)
{
return (o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));
}
static s7_double opt_d_vd_o1_mul(opt_info * o)
{
return (o->v[3].d_vd_f(o->v[5].obj,
real(slot_value(o->v[2].p)) *
o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_vd_o1(opt_info * o)
{
return (o->v[3].d_vd_f(o->v[5].obj,
o->v[4].d_dd_f(real(slot_value(o->v[2].p)),
o->v[11].fd(o->v[10].o1))));
}
static s7_double opt_d_vd_o2(opt_info * o)
{
return (o->v[4].d_vd_f(o->v[6].obj,
o->v[5].d_vd_f(o->v[2].obj,
real(slot_value(o->v[3].p)))));
}
static s7_double opt_d_vd_o3(opt_info * o)
{
return (o->v[3].d_vd_f(o->v[5].obj,
o->v[4].d_dd_f(o->v[6].x,
real(slot_value(o->v[2].p)))));
}
static s7_double opt_d_vd_ff(opt_info * o)
{
return (o->v[3].d_vd_f(o->v[5].obj,
o->v[2].d_vd_f(o->v[4].obj,
o->v[11].fd(o->v[10].o1))));
}
static s7_double opt_d_dd_cs(opt_info * o);
static s7_double opt_d_dd_sf_mul(opt_info * o);
static s7_double opt_d_dd_sf_add(opt_info * o);
static s7_double opt_d_dd_sf(opt_info * o);
static bool d_vd_f_combinable(s7_scheme * sc, int32_t start)
{
opt_info *opc = sc->opts[start - 1], *o1 = sc->opts[start];
if (o1->v[0].fd == opt_d_v) {
opc->v[2].p = o1->v[1].p;
opc->v[6].obj = o1->v[5].obj;
opc->v[4].d_v_f = o1->v[3].d_v_f;
opc->v[0].fd = opt_d_vd_o;
backup_pc(sc);
return (true);
}
if (o1->v[0].fd == opt_d_vd_s) {
opc->v[6].obj = opc->v[5].obj;
opc->v[4].d_vd_f = opc->v[3].d_vd_f; /* room for symbols */
opc->v[2].obj = o1->v[5].obj;
opc->v[5].d_vd_f = o1->v[3].d_vd_f;
opc->v[3].p = o1->v[2].p;
opc->v[7].p = o1->v[1].p;
opc->v[0].fd = opt_d_vd_o2;
backup_pc(sc);
return (true);
}
if (o1->v[0].fd == opt_d_dd_cs) {
opc->v[4].d_dd_f = o1->v[3].d_dd_f;
opc->v[6].x = o1->v[2].x;
opc->v[2].p = o1->v[1].p;
opc->v[0].fd = opt_d_vd_o3;
backup_pc(sc);
return (true);
}
if ((o1->v[0].fd == opt_d_dd_sf_mul) || (o1->v[0].fd == opt_d_dd_sf)
|| (o1->v[0].fd == opt_d_dd_sf_add)) {
opc->v[2].p = o1->v[1].p;
opc->v[4].d_dd_f = o1->v[3].d_dd_f;
opc->v[0].fd =
(o1->v[0].fd ==
opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1;
opc->v[11].fd = o1->v[5].fd;
opc->v[10].o1 = o1->v[4].o1;
return (true);
}
if (o1->v[0].fd == opt_d_vd_f) {
opc->v[2].d_vd_f = o1->v[3].d_vd_f;
opc->v[4].obj = o1->v[5].obj;
opc->v[6].p = o1->v[1].p;
opc->v[0].fd = opt_d_vd_ff;
opc->v[11].fd = o1->v[9].fd;
opc->v[10].o1 = o1->v[8].o1;
return (true);
}
return_false(sc, NULL);
}
static bool d_vd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_pointer sig;
s7_d_vd_t vfunc;
if (!is_symbol(cadr(car_x)))
return_false(sc, car_x);
vfunc = s7_d_vd_function(s_func);
if (!vfunc)
return_false(sc, car_x);
sig = c_function_signature(s_func);
if ((is_pair(sig)) && (is_symbol(cadr(sig)))) {
s7_pointer slot;
slot = opt_types_match(sc, cadr(sig), cadr(car_x));
if (slot) {
s7_pointer arg2 = caddr(car_x);
int32_t start = sc->pc;
opc->v[3].d_vd_f = vfunc;
if (!is_pair(arg2)) {
opc->v[1].p = slot;
opc->v[5].obj = (void *) c_object_value(slot_value(slot));
if (is_small_real(arg2)) {
opc->v[2].x = s7_number_to_real(sc, arg2);
opc->v[0].fd = opt_d_vd_c;
return (true);
}
opc->v[2].p = lookup_slot_from(arg2, sc->curlet);
if (is_slot(opc->v[2].p)) {
if (is_t_real(slot_value(opc->v[2].p))) {
opc->v[0].fd = opt_d_vd_s;
return (true);
}
if (!float_optimize(sc, cddr(car_x)))
return_false(sc, car_x);
if (d_vd_f_combinable(sc, start))
return (true);
opc->v[0].fd = opt_d_vd_f;
opc->v[8].o1 = sc->opts[start];
opc->v[9].fd = sc->opts[start]->v[0].fd;
return (true);
}
} else { /* is pair arg2 */
if (float_optimize(sc, cddr(car_x))) {
opc->v[1].p = slot;
opc->v[5].obj =
(void *) c_object_value(slot_value(slot));
if (d_vd_f_combinable(sc, start))
return (true);
opc->v[0].fd = opt_d_vd_f;
opc->v[8].o1 = sc->opts[start];
opc->v[9].fd = sc->opts[start]->v[0].fd;
return (true);
}
pc_fallback(sc, start);
}
}
}
return_false(sc, car_x);
}
/* -------- d_id -------- */
static s7_double opt_d_id_sf(opt_info * o)
{
return (o->v[3].d_id_f(integer(slot_value(o->v[1].p)),
o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_id_sc(opt_info * o)
{
return (o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[2].x));
}
static s7_double opt_d_id_sfo1(opt_info * o)
{
return (o->v[3].d_id_f(integer(slot_value(o->v[1].p)),
o->v[5].d_v_f(o->v[2].obj)));
}
static s7_double opt_d_id_sfo(opt_info * o)
{
return (o->v[4].d_id_f(integer(slot_value(o->v[1].p)),
o->v[5].d_vd_f(o->v[6].obj,
real(slot_value(o->v[3].p)))));
}
static s7_double opt_d_id_cf(opt_info * o)
{
return (o->v[3].d_id_f(o->v[1].i, o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_id_ff(opt_info * o)
{
s7_int x1;
x1 = o->v[9].fi(o->v[8].o1);
return (o->v[3].d_id_f(x1, o->v[11].fd(o->v[10].o1)));
}
static bool d_id_sf_combinable(s7_scheme * sc, opt_info * opc)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if (o1->v[0].fd == opt_d_vd_s) {
opc->v[4].d_id_f = opc->v[3].d_id_f;
opc->v[2].p = o1->v[1].p;
opc->v[6].obj = o1->v[5].obj;
opc->v[5].d_vd_f = o1->v[3].d_vd_f;
opc->v[3].p = o1->v[2].p;
opc->v[0].fd = opt_d_id_sfo;
backup_pc(sc);
return (true);
}
if (o1->v[0].fd == opt_d_v) {
opc->v[6].p = o1->v[1].p;
opc->v[2].obj = o1->v[5].obj;
opc->v[5].d_v_f = o1->v[3].d_v_f;
opc->v[0].fd = opt_d_id_sfo1;
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static bool d_id_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_pointer p;
int32_t start = sc->pc;
s7_d_id_t flt_func;
flt_func = s7_d_id_function(s_func);
if (!flt_func)
return_false(sc, car_x);
opc->v[3].d_id_f = flt_func;
p = opt_integer_symbol(sc, cadr(car_x));
if (p) {
opc->v[1].p = p;
if (is_t_real(caddr(car_x))) {
opc->v[0].fd = opt_d_id_sc;
opc->v[2].x = real(caddr(car_x));
return (true);
}
if (float_optimize(sc, cddr(car_x))) {
if (d_id_sf_combinable(sc, opc))
return (true);
opc->v[0].fd = opt_d_id_sf;
opc->v[4].o1 = sc->opts[start];
opc->v[5].fd = sc->opts[start]->v[0].fd;
return (true);
}
pc_fallback(sc, start);
}
if (is_t_integer(cadr(car_x))) {
if (float_optimize(sc, cddr(car_x))) {
opc->v[0].fd = opt_d_id_cf;
opc->v[1].i = integer(cadr(car_x));
opc->v[4].o1 = sc->opts[start];
opc->v[5].fd = sc->opts[start]->v[0].fd;
return (true);
}
pc_fallback(sc, start);
}
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[9].fi = opc->v[8].o1->v[0].fi;
opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x))) {
opc->v[11].fd = opc->v[10].o1->v[0].fd;
opc->v[0].fd = opt_d_id_ff;
return (true);
}
pc_fallback(sc, start);
}
return_false(sc, car_x);
}
/* -------- d_dd -------- */
static s7_double opt_d_dd_cc(opt_info * o)
{
return (o->v[3].d_dd_f(o->v[1].x, o->v[2].x));
}
static s7_double opt_d_dd_cs(opt_info * o)
{
return (o->v[3].d_dd_f(o->v[2].x, real(slot_value(o->v[1].p))));
}
static s7_double opt_d_dd_sc(opt_info * o)
{
return (o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));
}
static s7_double opt_d_dd_sc_sub(opt_info * o)
{
return (real(slot_value(o->v[1].p)) - o->v[2].x);
}
static s7_double opt_d_dd_ss(opt_info * o)
{
return (o->v[3].d_dd_f(real(slot_value(o->v[1].p)),
real(slot_value(o->v[2].p))));
}
static s7_double opt_d_dd_ss_add(opt_info * o)
{
return (real(slot_value(o->v[1].p)) + real(slot_value(o->v[2].p)));
}
static s7_double opt_d_dd_ss_mul(opt_info * o)
{
return (real(slot_value(o->v[1].p)) * real(slot_value(o->v[2].p)));
}
static s7_double opt_d_dd_cf(opt_info * o)
{
return (o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_dd_1f_subtract(opt_info * o)
{
return (1.0 - o->v[5].fd(o->v[4].o1));
}
static s7_double opt_d_dd_fc(opt_info * o)
{
return (o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));
}
#if WITH_GMP
static s7_double opt_subtract_random_f_f(opt_info * o)
{
return (o->v[1].x * next_random(opt_sc(o)) - o->v[2].x);
}
#else
static s7_double opt_subtract_random_f_f(opt_info * o)
{
return (o->v[1].x * next_random(opt_sc(o)->default_rng) - o->v[2].x);
}
#endif
static s7_double opt_d_dd_fc_add(opt_info * o)
{
return (o->v[5].fd(o->v[4].o1) + o->v[2].x);
}
static s7_double opt_d_dd_fc_fvref_add(opt_info * o)
{
return (o->v[2].x +
float_vector(slot_value(o->v[4].o1->v[1].p),
integer(slot_value(o->v[4].o1->v[2].p))));
}
static s7_double opt_d_dd_fc_subtract(opt_info * o)
{
return (o->v[5].fd(o->v[4].o1) - o->v[2].x);
}
static s7_double opt_d_dd_sf(opt_info * o)
{
return (o->
v[3].d_dd_f(real(slot_value(o->v[1].p)),
o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_dd_sf_mul(opt_info * o)
{
return (real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));
}
static s7_double opt_d_dd_sf_add(opt_info * o)
{
return (real(slot_value(o->v[1].p)) + o->v[5].fd(o->v[4].o1));
}
static s7_double opt_d_dd_sf_sub(opt_info * o)
{
return (real(slot_value(o->v[1].p)) - o->v[5].fd(o->v[4].o1));
}
static s7_double opt_d_7dd_cc(opt_info * o)
{
return (o->v[3].d_7dd_f(opt_sc(o), o->v[1].x, o->v[2].x));
}
static s7_double opt_d_7dd_cs(opt_info * o)
{
return (o->
v[3].d_7dd_f(opt_sc(o), o->v[2].x,
real(slot_value(o->v[1].p))));
}
static s7_double opt_d_7dd_sc(opt_info * o)
{
return (o->
v[3].d_7dd_f(opt_sc(o), real(slot_value(o->v[1].p)),
o->v[2].x));
}
static s7_double opt_d_7dd_ss(opt_info * o)
{
return (o->v[3].d_7dd_f(opt_sc(o), real(slot_value(o->v[1].p)),
real(slot_value(o->v[2].p))));
}
static s7_double opt_d_7dd_cf(opt_info * o)
{
return (o->v[3].d_7dd_f(opt_sc(o), o->v[1].x, o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_7dd_fc(opt_info * o)
{
return (o->v[3].d_7dd_f(opt_sc(o), o->v[5].fd(o->v[4].o1), o->v[2].x));
}
static s7_double opt_d_7dd_sf(opt_info * o)
{
return (o->v[3].d_7dd_f(opt_sc(o), real(slot_value(o->v[1].p)),
o->v[5].fd(o->v[4].o1)));
}
static s7_double opt_d_7pii_scs(opt_info * o);
static s7_double opt_d_dd_sf_mul_fvref(opt_info * o)
{
opt_info *o1 = o->v[4].o1;
return (real(slot_value(o->v[1].p)) *
float_vector_ref_d_7pii(opt_sc(o1), slot_value(o1->v[1].p),
o1->v[2].i,
integer(slot_value(o1->v[3].p))));
}
static s7_double opt_d_dd_sfo(opt_info * o)
{
return (o->v[4].d_dd_f(real(slot_value(o->v[1].p)),
o->v[5].d_7pi_f(opt_sc(o),
slot_value(o->v[2].p),
integer(slot_value
(o->v[3].p)))));
}
static s7_double opt_d_7dd_sfo(opt_info * o)
{
return (o->v[4].d_7dd_f(opt_sc(o), real(slot_value(o->v[1].p)),
o->v[5].d_7pi_f(opt_sc(o),
slot_value(o->v[2].p),
integer(slot_value
(o->v[3].p)))));
}
static bool d_dd_sf_combinable(s7_scheme * sc, opt_info * opc,
s7_d_dd_t func)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if ((o1->v[0].fd == opt_d_7pi_ss)
|| (o1->v[0].fd == opt_d_7pi_ss_fvref)
|| (o1->v[0].fd == opt_d_7pi_ss_fvref_unchecked)) {
if (func) {
opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */
opc->v[0].fd = opt_d_dd_sfo;
} else {
opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; /* need room for 3 symbols */
opc->v[0].fd = opt_d_7dd_sfo;
}
opc->v[2].p = o1->v[1].p;
opc->v[3].p = o1->v[2].p;
opc->v[5].d_7pi_f = o1->v[3].d_7pi_f;
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static s7_double opt_d_dd_fs(opt_info * o)
{
return (o->
v[3].d_dd_f(o->v[5].fd(o->v[4].o1),
real(slot_value(o->v[1].p))));
}
static s7_double opt_d_dd_fs_mul(opt_info * o)
{
return (o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p)));
}
static s7_double opt_d_dd_fs_add(opt_info * o)
{
return (o->v[5].fd(o->v[4].o1) + real(slot_value(o->v[1].p)));
}
static s7_double opt_d_dd_fs_sub(opt_info * o)
{
return (o->v[5].fd(o->v[4].o1) - real(slot_value(o->v[1].p)));
}
static s7_double opt_d_7dd_fs(opt_info * o)
{
return (o->v[3].d_7dd_f(opt_sc(o), o->v[5].fd(o->v[4].o1),
real(slot_value(o->v[1].p))));
}
static s7_double opt_d_dd_fs_add_fvref(opt_info * o)
{
opt_info *o1 = o->v[4].o1;
return (real(slot_value(o->v[1].p)) +
float_vector_ref_d_7pii(opt_sc(o1), slot_value(o1->v[1].p),
o1->v[2].i,
integer(slot_value(o1->v[3].p))));
}
static s7_double opt_d_dd_fso(opt_info * o)
{
return (o->
v[4].d_dd_f(o->
v[5].d_7pi_f(opt_sc(o), slot_value(o->v[2].p),
integer(slot_value(o->v[3].p))),
real(slot_value(o->v[1].p))));
}
static s7_double opt_d_7dd_fso(opt_info * o)
{
return (o->v[4].d_7dd_f(opt_sc(o),
o->v[5].d_7pi_f(opt_sc(o),
slot_value(o->v[2].p),
integer(slot_value
(o->v[3].p))),
real(slot_value(o->v[1].p))));
}
static bool d_dd_fs_combinable(s7_scheme * sc, opt_info * opc,
s7_d_dd_t func)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if ((o1->v[0].fd == opt_d_7pi_ss)
|| (o1->v[0].fd == opt_d_7pi_ss_fvref)
|| (o1->v[0].fd == opt_d_7pi_ss_fvref_unchecked)) {
if (func) {
opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */
opc->v[0].fd = opt_d_dd_fso;
} else {
opc->v[4].d_7dd_f = opc->v[3].d_7dd_f;
opc->v[0].fd = opt_d_7dd_fso;
}
opc->v[2].p = o1->v[1].p;
opc->v[3].p = o1->v[2].p;
opc->v[5].d_7pi_f = o1->v[3].d_7pi_f;
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static s7_double opt_d_dd_ff(opt_info * o)
{
s7_double x1;
x1 = o->v[9].fd(o->v[8].o1);
return (o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_mul(opt_info * o)
{
s7_double x1;
x1 = o->v[9].fd(o->v[8].o1);
return (x1 * o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_dd_ff_square(opt_info * o)
{
s7_double x1;
x1 = o->v[9].fd(o->v[8].o1);
return (x1 * x1);
}
static s7_double opt_d_dd_ff_add(opt_info * o)
{
s7_double x1;
x1 = o->v[5].fd(o->v[4].o1);
return (x1 + o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_dd_ff_add_mul(opt_info * o)
{
s7_double x1, x2;
x1 = o->v[5].fd(o->v[4].o1);
x2 = o->v[9].fd(o->v[8].o1);
return (x1 + (x2 * o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_add_fv_ref(opt_info * o)
{
s7_double x1;
x1 = o->v[5].fd(o->v[4].o1);
return (x1 +
float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[6].p),
o->v[9].fi(o->v[8].o1)));
}
static s7_double opt_d_dd_ff_sub(opt_info * o)
{
s7_double x1;
x1 = o->v[5].fd(o->v[4].o1);
return (x1 - o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_7dd_ff(opt_info * o)
{
s7_double x1;
x1 = o->v[9].fd(o->v[8].o1);
return (o->v[3].d_7dd_f(opt_sc(o), x1, o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_o1(opt_info * o)
{
s7_double x1;
x1 = o->v[2].d_v_f(o->v[1].obj);
return (o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_mul1(opt_info * o)
{
return (o->v[2].d_v_f(o->v[1].obj) * o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_dd_ff_o2(opt_info * o)
{
s7_double x1;
x1 = o->v[4].d_v_f(o->v[1].obj);
return (o->v[3].d_dd_f(x1, o->v[5].d_v_f(o->v[2].obj)));
}
static s7_double opt_d_dd_ff_mul2(opt_info * o)
{
return (o->v[4].d_v_f(o->v[1].obj) * o->v[5].d_v_f(o->v[2].obj));
}
static s7_double opt_d_dd_ff_o3(opt_info * o)
{
s7_double x1;
x1 = o->v[5].d_v_f(o->v[1].obj);
return (o->v[4].d_dd_f(x1,
o->v[6].d_vd_f(o->v[2].obj,
real(slot_value(o->v[3].p)))));
}
static s7_double opt_d_dd_fff(opt_info * o)
{
s7_double x1, x2;
x1 = o->v[3 + 4].d_dd_f(o->v[3 + 5].d_7pi_f(opt_sc(o), slot_value(o->v[3 + 2].p), integer(slot_value(o->v[3 + 3].p))), real(slot_value(o->v[3 + 1].p))); /* dd_fso */
x2 = o->v[8 + 4].d_dd_f(o->v[8 + 5].d_7pi_f(opt_sc(o), slot_value(o->v[8 + 2].p), integer(slot_value(o->v[8 + 3].p))), real(slot_value(o->v[8 + 1].p))); /* dd_fso */
return (o->v[3].d_dd_f(x1, x2));
}
static s7_double opt_d_mm_fff(opt_info * o)
{
s7_double x1, x2;
x1 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[3 + 2].p),
integer(slot_value(o->v[3 + 3].p))) *
real(slot_value(o->v[3 + 1].p));
x2 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[8 + 2].p),
integer(slot_value(o->v[8 + 3].p))) *
real(slot_value(o->v[8 + 1].p));
return (o->v[3].d_dd_f(x1, x2));
}
static s7_double opt_d_dd_fff_rev(opt_info * o)
{ /* faster with opt_sc(o)? */
s7_double x1, x2;
x1 = o->v[3 + 4].d_dd_f(real(slot_value(o->v[3 + 1].p)),
o->v[3 + 5].d_7pi_f(opt_sc(o),
slot_value(o->v[3 + 2].p),
integer(slot_value
(o->v[3 + 3].p))));
x2 = o->v[8 + 4].d_dd_f(real(slot_value(o->v[8 + 1].p)),
o->v[8 + 5].d_7pi_f(opt_sc(o),
slot_value(o->v[8 + 2].p),
integer(slot_value
(o->v[8 + 3].p))));
return (o->v[3].d_dd_f(x1, x2));
}
static s7_double opt_d_dd_ff_o4(opt_info * o)
{
s7_double x1;
x1 = o->v[2].d_v_f(o->v[1].obj);
return (o->v[3].d_dd_f(x1,
o->v[7].d_vd_f(o->v[5].obj,
o->v[4].d_v_f(o->v[6].obj))));
}
static s7_double opt_d_dd_ff_mul4(opt_info * o)
{
return (o->v[2].d_v_f(o->v[1].obj) *
o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));
}
static s7_double opt_d_7pii_sss(opt_info * o);
static s7_double opt_d_dd_ff_mul_sss(opt_info * o)
{
s7_double x1;
s7_int i1, i2;
s7_pointer v;
opt_info *o1 = o->v[8].o1;
v = slot_value(o1->v[1].p);
i1 = integer(slot_value(o1->v[2].p));
i2 = integer(slot_value(o1->v[3].p));
x1 = float_vector_ref_d_7pii(opt_sc(o1), v, i1, i2);
o1 = o->v[10].o1;
v = slot_value(o1->v[1].p);
i1 = integer(slot_value(o1->v[2].p)); /* in (* (A i j) (B j k)) we could reuse i2->i1 (flipping args below) */
i2 = integer(slot_value(o1->v[3].p));
return (x1 * float_vector_ref_d_7pii(opt_sc(o1), v, i1, i2));
}
static bool finish_dd_fso(opt_info * opc, opt_info * o1, opt_info * o2)
{
opc->v[3 + 1].p = o1->v[1].p;
opc->v[3 + 2].p = o1->v[2].p;
opc->v[3 + 3].p = o1->v[3].p;
opc->v[3 + 4].d_dd_f = o1->v[4].d_dd_f;
opc->v[3 + 5].d_7pi_f = o1->v[5].d_7pi_f;
opc->v[8 + 1].p = o2->v[1].p;
opc->v[8 + 2].p = o2->v[2].p;
opc->v[8 + 3].p = o2->v[3].p;
opc->v[8 + 4].d_dd_f = o2->v[4].d_dd_f;
opc->v[8 + 5].d_7pi_f = o2->v[5].d_7pi_f;
return (true);
}
static bool d_dd_ff_combinable(s7_scheme * sc, opt_info * opc,
int32_t start)
{
opt_info *o1 = opc->v[8].o1, *o2 = opc->v[10].o1;
if (o1->v[0].fd == opt_d_v) {
/* opc->v[3] is in use */
if ((o2->v[0].fd == opt_d_v) && (sc->pc == start + 2)) {
opc->v[1].obj = o1->v[5].obj;
opc->v[6].p = o1->v[1].p;
opc->v[4].d_v_f = o1->v[3].d_v_f;
opc->v[2].obj = o2->v[5].obj;
opc->v[7].p = o2->v[1].p;
opc->v[5].d_v_f = o2->v[3].d_v_f;
opc->v[0].fd =
(opc->v[3].d_dd_f ==
multiply_d_dd) ? opt_d_dd_ff_mul2 : opt_d_dd_ff_o2;
sc->pc -= 2;
return (true);
}
if ((o2->v[0].fd == opt_d_vd_s) && (sc->pc == start + 2)) {
opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* make room for symbols */
opc->v[1].obj = o1->v[5].obj;
opc->v[7].p = o1->v[1].p;
opc->v[5].d_v_f = o1->v[3].d_v_f;
opc->v[2].obj = o2->v[5].obj;
opc->v[8].p = o2->v[1].p;
opc->v[6].d_vd_f = o2->v[3].d_vd_f;
opc->v[3].p = o2->v[2].p;
opc->v[0].fd = opt_d_dd_ff_o3;
sc->pc -= 2;
return (true);
}
if ((o2->v[0].fd == opt_d_vd_o) && (sc->pc == start + 2)) {
opc->v[1].obj = o1->v[5].obj;
opc->v[8].p = o1->v[1].p;
opc->v[2].d_v_f = o1->v[3].d_v_f;
opc->v[7].d_vd_f = o2->v[3].d_vd_f;
opc->v[4].d_v_f = o2->v[4].d_v_f;
opc->v[5].obj = o2->v[5].obj;
opc->v[9].p = o2->v[1].p;
opc->v[6].obj = o2->v[6].obj;
opc->v[10].p = o2->v[2].p;
opc->v[0].fd =
(opc->v[3].d_dd_f ==
multiply_d_dd) ? opt_d_dd_ff_mul4 : opt_d_dd_ff_o4;
sc->pc -= 2;
return (true);
}
opc->v[1].obj = o1->v[5].obj;
opc->v[4].p = o1->v[1].p;
opc->v[2].d_v_f = o1->v[3].d_v_f;
opc->v[0].fd =
(opc->v[3].d_dd_f ==
multiply_d_dd) ? opt_d_dd_ff_mul1 : opt_d_dd_ff_o1;
return (true);
}
if (o1->v[0].fd == opt_d_dd_fso) {
if (o2->v[0].fd == opt_d_dd_fso) {
if ((o1->v[4].d_dd_f == multiply_d_dd) &&
(o2->v[4].d_dd_f == multiply_d_dd) &&
(o1->v[5].d_7pi_f == float_vector_ref_d_7pi) &&
(o2->v[5].d_7pi_f == float_vector_ref_d_7pi))
opc->v[0].fd = opt_d_mm_fff; /* a placeholder (never called) */
else
opc->v[0].fd = opt_d_dd_fff;
return (finish_dd_fso(opc, o1, o2));
}
}
if (o1->v[0].fd == opt_d_dd_sfo) {
if (o2->v[0].fd == opt_d_dd_sfo) {
if ((o1->v[4].d_dd_f == multiply_d_dd) &&
(o2->v[4].d_dd_f == multiply_d_dd) &&
(o1->v[5].d_7pi_f == float_vector_ref_d_7pi) &&
(o2->v[5].d_7pi_f == float_vector_ref_d_7pi))
opc->v[0].fd = opt_d_mm_fff; /* multiply is commutative */
else
opc->v[0].fd = opt_d_dd_fff_rev;
return (finish_dd_fso(opc, o1, o2));
}
}
return_false(sc, NULL);
}
static s7_double opt_d_dd_cfo(opt_info * o)
{
return (o->v[3].d_dd_f(o->v[2].x, o->v[4].d_v_f(o->v[1].obj)));
}
static s7_double opt_d_7dd_cfo(opt_info * o)
{
return (o->
v[3].d_7dd_f(opt_sc(o), o->v[2].x,
o->v[4].d_v_f(o->v[1].obj)));
}
static s7_double opt_d_dd_cfo1(opt_info * o)
{
return (o->v[3].d_dd_f(o->v[4].x,
o->v[5].d_vd_f(o->v[6].obj,
real(slot_value(o->v[2].p)))));
}
static s7_double opt_d_7dd_cfo1(opt_info * o)
{
return (o->v[3].d_7dd_f(opt_sc(o), o->v[4].x,
o->v[5].d_vd_f(o->v[6].obj,
real(slot_value(o->v[2].p)))));
}
static bool d_dd_call_combinable(s7_scheme * sc, opt_info * opc,
s7_d_dd_t func)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if (o1->v[0].fd == opt_d_v) {
opc->v[2].x = opc->v[1].x;
opc->v[6].p = o1->v[1].p;
opc->v[1].obj = o1->v[5].obj;
opc->v[4].d_v_f = o1->v[3].d_v_f;
opc->v[0].fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo;
backup_pc(sc);
return (true);
}
if (o1->v[0].fd == opt_d_vd_s) {
opc->v[4].x = opc->v[1].x;
opc->v[1].p = o1->v[1].p;
opc->v[6].obj = o1->v[5].obj;
opc->v[2].p = o1->v[2].p;
opc->v[5].d_vd_f = o1->v[3].d_vd_f;
opc->v[0].fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1;
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static bool d_dd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x);
int32_t start = sc->pc;
opt_info *o1;
s7_d_dd_t func;
s7_d_7dd_t func7 = NULL;
func = s7_d_dd_function(s_func);
if (!func) {
func7 = s7_d_7dd_function(s_func);
if (!func7)
return_false(sc, car_x);
}
if (func)
opc->v[3].d_dd_f = func;
else
opc->v[3].d_7dd_f = func7;
/* arg1 = real constant */
if (is_small_real(arg1)) {
if (is_small_real(arg2)) {
if ((!is_t_real(arg1)) && (!is_t_real(arg2)))
return_false(sc, car_x);
opc->v[1].x = s7_number_to_real(sc, arg1);
opc->v[2].x = s7_number_to_real(sc, arg2);
opc->v[0].fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc;
return (true);
}
slot = opt_float_symbol(sc, arg2);
if (slot) {
opc->v[1].p = slot;
opc->v[2].x = s7_number_to_real(sc, arg1); /* move arg1? */
opc->v[0].fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs;
return (true);
}
if (float_optimize(sc, cddr(car_x))) {
opc->v[1].x = s7_number_to_real(sc, arg1);
if (d_dd_call_combinable(sc, opc, func))
return (true);
opc->v[4].o1 = sc->opts[start];
opc->v[5].fd = sc->opts[start]->v[0].fd;
opc->v[0].fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf;
if ((opc->v[1].x == 1.0) && (func == subtract_d_dd))
opc->v[0].fd = opt_d_dd_1f_subtract;
return (true);
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* arg1 = float symbol */
slot = opt_float_symbol(sc, arg1);
if (slot) {
opc->v[1].p = slot;
if (is_small_real(arg2)) {
opc->v[2].x = s7_number_to_real(sc, arg2);
if (func)
opc->v[0].fd =
(func ==
subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc;
else
opc->v[0].fd = opt_d_7dd_sc;
return (true);
}
slot = opt_float_symbol(sc, arg2);
if (slot) {
opc->v[2].p = slot;
if (func) {
if (func == multiply_d_dd)
opc->v[0].fd = opt_d_dd_ss_mul;
else
opc->v[0].fd =
(func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss;
} else
opc->v[0].fd = opt_d_7dd_ss;
return (true);
}
if (float_optimize(sc, cddr(car_x))) {
if (d_dd_sf_combinable(sc, opc, func))
return (true);
opc->v[4].o1 = sc->opts[start];
opc->v[5].fd = sc->opts[start]->v[0].fd;
if (func) {
opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_sf_mul :
((func == add_d_dd) ? opt_d_dd_sf_add :
((func ==
subtract_d_dd) ? opt_d_dd_sf_sub : opt_d_dd_sf));
if ((func == multiply_d_dd)
&& (opc->v[5].fd == opt_d_7pii_scs))
opc->v[0].fd = opt_d_dd_sf_mul_fvref;
} else
opc->v[0].fd = opt_d_7dd_sf;
return (true);
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* arg1 = float expr or non-float */
o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x))) {
int32_t start2 = sc->pc;
if (is_small_real(arg2)) {
opc->v[2].x = s7_number_to_real(sc, arg2);
opc->v[4].o1 = sc->opts[start];
opc->v[5].fd = sc->opts[start]->v[0].fd;
if (func) {
if (func == add_d_dd) {
opc->v[0].fd =
(opc->v[5].fd ==
opt_d_7pi_ss_fvref_unchecked) ?
opt_d_dd_fc_fvref_add : opt_d_dd_fc_add;
return (true);
}
if (func == subtract_d_dd) {
opc->v[0].fd = opt_d_dd_fc_subtract;
/* if o1->v[0].fd = opt_d_7d_c and its o->v[3].d_7d_f = random_d_7d it's (- (random f1) f2) */
if ((opc == sc->opts[sc->pc - 2]) &&
(sc->opts[start]->v[0].fd == opt_d_7d_c) &&
(sc->opts[start]->v[3].d_7d_f == random_d_7d)) {
opc->v[0].fd = opt_subtract_random_f_f;
opc->v[1].x = sc->opts[start]->v[1].x; /* random arg */
backup_pc(sc);
}
} else
opc->v[0].fd = opt_d_dd_fc;
} else
opc->v[0].fd = opt_d_7dd_fc;
return (true);
}
slot = opt_float_symbol(sc, arg2);
if (slot) {
opc->v[1].p = slot;
if (d_dd_fs_combinable(sc, opc, func))
return (true);
opc->v[4].o1 = sc->opts[start];
opc->v[5].fd = sc->opts[start]->v[0].fd;
if (func) {
opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_fs_mul :
((func == add_d_dd) ? opt_d_dd_fs_add :
((func ==
subtract_d_dd) ? opt_d_dd_fs_sub : opt_d_dd_fs));
if ((func == add_d_dd) && (opc->v[5].fd == opt_d_7pii_scs))
opc->v[0].fd = opt_d_dd_fs_add_fvref;
} else
opc->v[0].fd = opt_d_7dd_fs;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x))) {
opc->v[8].o1 = o1;
opc->v[9].fd = o1->v[0].fd;
opc->v[11].fd = opc->v[10].o1->v[0].fd;
if (func) {
if (d_dd_ff_combinable(sc, opc, start))
return (true);
opc->v[0].fd = opt_d_dd_ff;
if (func == multiply_d_dd) {
if (arg1 == arg2)
opc->v[0].fd = opt_d_dd_ff_square;
else if ((opc->v[9].fd == opt_d_7pii_sss) && (opc->v[11].fd == opt_d_7pii_sss) && (o1->v[4].d_7pii_f == float_vector_ref_d_7pii)) /* currently redundant */
opc->v[0].fd = opt_d_dd_ff_mul_sss;
else
opc->v[0].fd = opt_d_dd_ff_mul;
return (true);
} else {
opt_info *o2 = sc->opts[start2]; /* this is opc->v[10].o1 */
if (func == add_d_dd) {
if (o2->v[0].fd == opt_d_dd_ff_mul) {
opc->v[0].fd = opt_d_dd_ff_add_mul;
opc->v[4].o1 = o1; /* add first arg */
opc->v[5].fd = o1->v[0].fd;
opc->v[8].o1 = o2->v[8].o1; /* mul first arg */
opc->v[9].fd = o2->v[9].fd;
opc->v[10].o1 = o2->v[10].o1; /* mul second arg */
opc->v[11].fd = o2->v[11].fd;
return (true);
}
if ((o2->v[0].fd == opt_d_7pi_sf) &&
(o2->v[3].d_7pi_f == float_vector_ref_d_7pi)) {
opc->v[0].fd = opt_d_dd_ff_add_fv_ref;
opc->v[6].p = o2->v[1].p;
opc->v[8].o1 = o2->v[10].o1; /* sc->opts[start2 + 1]; */
opc->v[9].fi = o2->v[11].fi; /* sc->opts[start2 + 1]->v[0].fi; */
} else {
opc->v[0].fd = opt_d_dd_ff_add;
opc->v[10].o1 = o2;
opc->v[11].fd = o2->v[0].fd;
}
opc->v[4].o1 = o1; /* sc->opts[start]; */
opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */
return (true);
}
if (func == subtract_d_dd) {
opc->v[0].fd = opt_d_dd_ff_sub;
opc->v[4].o1 = o1; /* sc->opts[start]; */
opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */
opc->v[10].o1 = o2;
opc->v[11].fd = o2->v[0].fd;
return (true);
}
}
} else
opc->v[0].fd = opt_d_7dd_ff;
return (true);
}
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- d_ddd -------- */
static s7_double opt_d_ddd_sss(opt_info * o)
{
return (o->v[4].d_ddd_f(real(slot_value(o->v[1].p)),
real(slot_value(o->v[2].p)),
real(slot_value(o->v[3].p))));
}
static s7_double opt_d_ddd_ssf(opt_info * o)
{
return (o->v[4].d_ddd_f(real(slot_value(o->v[1].p)),
real(slot_value(o->v[2].p)),
o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_ddd_sff(opt_info * o)
{
s7_double x1, x2;
x1 = o->v[11].fd(o->v[10].o1);
x2 = o->v[9].fd(o->v[8].o1);
return (o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), x1, x2));
}
static s7_double opt_d_ddd_fff(opt_info * o)
{
s7_double x1, x2, x3;
x1 = o->v[11].fd(o->v[10].o1);
x2 = o->v[9].fd(o->v[8].o1);
x3 = o->v[6].fd(o->v[5].o1);
return (o->v[4].d_ddd_f(x1, x2, x3));
}
static s7_double opt_d_ddd_fff1(opt_info * o)
{
s7_double x1, x2, x3;
x1 = o->v[1].d_v_f(o->v[2].obj);
x2 = o->v[3].d_v_f(o->v[4].obj);
x3 = o->v[5].d_v_f(o->v[6].obj);
return (o->v[7].d_ddd_f(x1, x2, x3));
}
static s7_double opt_d_ddd_fff2(opt_info * o)
{
s7_double x1, x2, x3;
x1 = o->v[1].d_v_f(o->v[2].obj);
x2 = o->v[9].fd(o->v[12].o1);
x3 = o->v[6].fd(o->v[5].o1);
return (o->v[7].d_ddd_f(x1, x2, x3));
}
static bool d_ddd_fff_combinable(s7_scheme * sc, opt_info * opc,
int32_t start)
{
opt_info *o1;
if (sc->opts[start]->v[0].fd != opt_d_v)
return_false(sc, NULL);
opc->v[12].o1 = opc->v[8].o1;
opc->v[7].d_ddd_f = opc->v[4].d_ddd_f;
o1 = sc->opts[start];
opc->v[1].d_v_f = o1->v[3].d_v_f;
opc->v[2].obj = o1->v[5].obj;
opc->v[8].p = o1->v[1].p;
if ((sc->opts[start + 1]->v[0].fd == opt_d_v) &&
(sc->opts[start + 2]->v[0].fd == opt_d_v)) {
opc->v[0].fd = opt_d_ddd_fff1;
o1 = sc->opts[start + 1];
opc->v[3].d_v_f = o1->v[3].d_v_f;
opc->v[4].obj = o1->v[5].obj;
opc->v[9].p = o1->v[1].p;
o1 = sc->opts[start + 2];
opc->v[5].d_v_f = o1->v[3].d_v_f;
opc->v[6].obj = o1->v[5].obj;
opc->v[10].p = o1->v[1].p;
sc->pc -= 3;
return (true);
}
opc->v[0].fd = opt_d_ddd_fff2;
opc->v[9].fd = opc->v[12].o1->v[0].fd;
opc->v[6].fd = opc->v[5].o1->v[0].fd;
return (true);
}
static bool d_ddd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
int32_t start = sc->pc;
s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x);
s7_d_ddd_t f;
f = s7_d_ddd_function(s_func);
if (!f)
return_false(sc, car_x);
opc->v[4].d_ddd_f = f;
slot = opt_float_symbol(sc, arg1);
opc->v[10].o1 = sc->opts[start];
if (slot) {
opc->v[1].p = slot;
slot = opt_float_symbol(sc, arg2);
if (slot) {
s7_pointer arg3 = cadddr(car_x);
opc->v[2].p = slot;
slot = opt_float_symbol(sc, arg3);
if (slot) {
opc->v[3].p = slot;
opc->v[0].fd = opt_d_ddd_sss;
return (true);
}
if (float_optimize(sc, cdddr(car_x))) {
opc->v[11].fd = opc->v[10].o1->v[0].fd;
opc->v[0].fd = opt_d_ddd_ssf;
return (true);
}
pc_fallback(sc, start);
}
if (float_optimize(sc, cddr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdddr(car_x))) {
opc->v[0].fd = opt_d_ddd_sff;
opc->v[11].fd = opc->v[10].o1->v[0].fd;
opc->v[9].fd = opc->v[8].o1->v[0].fd;
return (true);
}
}
pc_fallback(sc, start);
}
if (float_optimize(sc, cdr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x))) {
opc->v[5].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdddr(car_x))) {
if (d_ddd_fff_combinable(sc, opc, start))
return (true);
opc->v[0].fd = opt_d_ddd_fff;
opc->v[11].fd = opc->v[10].o1->v[0].fd;
opc->v[9].fd = opc->v[8].o1->v[0].fd;
opc->v[6].fd = opc->v[5].o1->v[0].fd;
return (true);
}
}
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- d_7pid -------- */
static s7_double opt_d_7pid_ssf(opt_info * o)
{
return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[11].fd(o->v[10].o1)));
}
static s7_pointer opt_d_7pid_ssf_nr(opt_info * o)
{
o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[11].fd(o->v[10].o1));
return (NULL);
}
static s7_double opt_d_7pid_sss(opt_info * o)
{
return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
real(slot_value(o->v[3].p))));
}
static s7_double opt_d_7pid_ssc(opt_info * o)
{
return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)), o->v[3].x));
}
static s7_double opt_d_7pid_sff(opt_info * o)
{
s7_int pos;
pos = o->v[11].fi(o->v[10].o1);
return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p), pos,
o->v[9].fd(o->v[8].o1)));
}
static s7_double opt_d_7pid_sso(opt_info * o)
{
return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[5].d_v_f(o->v[3].obj)));
}
static s7_double opt_d_7pid_ss_ss(opt_info * o)
{
return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[3].d_7pi_f(opt_sc(o),
slot_value(o->v[5].p),
integer(slot_value
(o->v[6].p)))));
}
static s7_double opt_d_7pid_ssfo(opt_info * o)
{
s7_pointer fv = slot_value(o->v[1].p);
return (o->v[4].d_7pid_f(opt_sc(o), fv, integer(slot_value(o->v[2].p)),
o->v[6].d_dd_f(o->v[5].d_7pi_f(opt_sc(o), fv,
integer
(slot_value
(o->v[3].p))),
real(slot_value(o->v[8].p)))));
}
static s7_double opt_d_7pid_ssfo_fv(opt_info * o)
{
s7_double val;
s7_double *els = float_vector_floats(slot_value(o->v[1].p));
val =
o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))],
real(slot_value(o->v[8].p)));
els[integer(slot_value(o->v[2].p))] = val;
return (val);
}
static s7_pointer opt_d_7pid_ssfo_fv_nr(opt_info * o)
{ /* these next are variations on (float-vector-set! s (float-vector-ref s...)) */
s7_double *els = float_vector_floats(slot_value(o->v[1].p));
els[integer(slot_value(o->v[2].p))] =
o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))],
real(slot_value(o->v[8].p)));
return (NULL);
}
static s7_pointer opt_d_7pid_ssfo_fv_add_nr(opt_info * o)
{
s7_double *els = float_vector_floats(slot_value(o->v[1].p));
els[integer(slot_value(o->v[2].p))] =
els[integer(slot_value(o->v[3].p))] + real(slot_value(o->v[8].p));
return (NULL);
}
static s7_pointer opt_d_7pid_ssfo_fv_sub_nr(opt_info * o)
{
s7_double *els = float_vector_floats(slot_value(o->v[1].p));
els[integer(slot_value(o->v[2].p))] =
els[integer(slot_value(o->v[3].p))] - real(slot_value(o->v[8].p));
return (NULL);
}
static bool d_7pid_ssf_combinable(s7_scheme * sc, opt_info * opc)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if (o1->v[0].fd == opt_d_v) {
opc->v[6].p = o1->v[1].p;
opc->v[3].obj = o1->v[5].obj;
opc->v[5].d_v_f = o1->v[3].d_v_f;
opc->v[0].fd = opt_d_7pid_sso;
backup_pc(sc);
return (true);
}
if ((o1->v[0].fd == opt_d_7pi_ss)
|| (o1->v[0].fd == opt_d_7pi_ss_fvref)
|| (o1->v[0].fd == opt_d_7pi_ss_fvref_unchecked)) {
opc->v[3].d_7pi_f = o1->v[3].d_7pi_f;
opc->v[5].p = o1->v[1].p;
opc->v[6].p = o1->v[2].p;
opc->v[0].fd = opt_d_7pid_ss_ss;
backup_pc(sc);
return (true);
}
if ((o1->v[0].fd == opt_d_dd_fso) && (opc->v[1].p == o1->v[2].p)) {
/* opc: pid_ssf: o->v[4].d_7pid_f(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fd(o1))
* o1: d_dd_fso: o->v[4].d_dd_f(o->v[5].d_7pi_f(slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p))))
*/
opc->v[6].d_dd_f = o1->v[4].d_dd_f;
opc->v[5].d_7pi_f = o1->v[5].d_7pi_f;
opc->v[3].p = o1->v[3].p;
opc->v[8].p = o1->v[1].p;
opc->v[0].fd = opt_d_7pid_ssfo;
if ((opc->v[5].d_7pi_f == float_vector_ref_d_7pi) &&
((opc->v[4].d_7pid_f == float_vector_set_unchecked)
|| (opc->v[4].d_7pid_f == float_vector_set_d_7pid)))
opc->v[0].fd = opt_d_7pid_ssfo_fv; /* actually if either is *_d, we need to check the indices */
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static bool opt_float_vector_set(s7_scheme * sc, opt_info * opc,
s7_pointer v, s7_pointer indexp1,
s7_pointer indexp2, s7_pointer indexp3,
s7_pointer valp);
static bool d_7pid_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_7pid_t f;
f = s7_d_7pid_function(s_func);
if ((f) && (is_symbol(cadr(car_x)))) {
s7_pointer slot, head = car(car_x);
int32_t start = sc->pc;
opc->v[4].d_7pid_f = f;
if (is_target_or_its_alias
(head, s_func, sc->float_vector_set_symbol))
return (opt_float_vector_set
(sc, opc, cadr(car_x), cddr(car_x), NULL, NULL,
cdddr(car_x)));
opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet);
opc->v[10].o1 = sc->opts[start];
if (is_slot(opc->v[1].p)) {
slot = opt_integer_symbol(sc, caddr(car_x));
if (slot) {
opc->v[2].p = slot;
slot = opt_float_symbol(sc, cadddr(car_x));
if (slot) {
opc->v[3].p = slot;
opc->v[0].fd = opt_d_7pid_sss;
return (true);
}
if (float_optimize(sc, cdddr(car_x))) {
opc->v[11].fd = sc->opts[start]->v[0].fd;
if (d_7pid_ssf_combinable(sc, opc))
return (true);
opc->v[0].fd = opt_d_7pid_ssf;
return (true);
}
pc_fallback(sc, start);
}
if (int_optimize(sc, cddr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdddr(car_x))) {
opc->v[0].fd = opt_d_7pid_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fd = opc->v[8].o1->v[0].fd;
return (true);
}
}
pc_fallback(sc, start);
}
}
return_false(sc, car_x);
}
/* -------- d_7pii -------- */
/* currently this can only be float_vector_ref_d_7pii (d_7pii is not exported at this time) */
static s7_double opt_d_7pii_sss(opt_info * o)
{ /* o->v[4].d_7pii_f */
return (float_vector_ref_d_7pii
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p))));
}
static s7_double opt_d_7pii_sss_unchecked(opt_info * o)
{
s7_pointer v = slot_value(o->v[1].p);
return (float_vector
(v,
((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) +
integer(slot_value(o->v[3].p)))));
}
static s7_double opt_d_7pii_scs(opt_info * o)
{
return (float_vector_ref_d_7pii
(opt_sc(o), slot_value(o->v[1].p), o->v[2].i,
integer(slot_value(o->v[3].p))));
}
static s7_double opt_d_7pii_sff(opt_info * o)
{
return (float_vector_ref_d_7pii
(opt_sc(o), slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1),
o->v[9].fi(o->v[8].o1)));
}
static bool d_7pii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_7pii_t ifunc;
ifunc = s7_d_7pii_function(s_func);
if ((ifunc == float_vector_ref_d_7pii) && (is_symbol(cadr(car_x)))) {
s7_pointer slot;
int32_t start = sc->pc;
opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet);
if ((!is_slot(opc->v[1].p)) ||
(!is_float_vector(slot_value(opc->v[1].p))) ||
(vector_rank(slot_value(opc->v[1].p)) != 2))
return_false(sc, car_x);
opc->v[4].d_7pii_f = ifunc; /* currently pointless */
slot = opt_integer_symbol(sc, cadddr(car_x));
if (slot) {
opc->v[3].p = slot;
slot = opt_integer_symbol(sc, caddr(car_x));
if (slot) {
opc->v[2].p = slot;
opc->v[0].fd = opt_d_7pii_sss;
if ((step_end_fits
(opc->v[2].p,
vector_dimension(slot_value(opc->v[1].p), 0)))
&&
(step_end_fits
(opc->v[3].p,
vector_dimension(slot_value(opc->v[1].p), 1))))
opc->v[0].fd = opt_d_7pii_sss_unchecked;
return (true);
}
if (is_t_integer(caddr(car_x))) {
opc->v[2].i = integer(caddr(car_x));
opc->v[0].fd = opt_d_7pii_scs;
return (true);
}
}
opc->v[10].o1 = sc->opts[start];
if (int_optimize(sc, cddr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdddr(car_x))) {
opc->v[0].fd = opt_d_7pii_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
return (true);
}
}
pc_fallback(sc, start);
}
return_false(sc, car_x);
}
/* -------- d_7piid -------- */
/* currently only float_vector_set */
static s7_double opt_d_7piid_sssf(opt_info * o)
{ /* o->v[5].d_7piid_f and below */
return (float_vector_set_d_7piid
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)), o->v[9].fd(o->v[8].o1)));
}
static s7_double opt_d_7piid_sssc(opt_info * o)
{
return (float_vector_set_d_7piid
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)), o->v[4].x));
}
static s7_double opt_d_7piid_scsf(opt_info * o)
{
return (float_vector_set_d_7piid
(opt_sc(o), slot_value(o->v[1].p), o->v[2].i,
integer(slot_value(o->v[3].p)), o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_7piid_sfff(opt_info * o)
{
s7_int i1, i2;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
return (float_vector_set_d_7piid
(opt_sc(o), slot_value(o->v[1].p), i1, i2,
o->v[4].fd(o->v[3].o1)));
}
static s7_double opt_d_7piid_sssf_unchecked(opt_info * o)
{ /* this could be subsumed by the call above if we were using o->v[5] or o->v[0].fd */
s7_int i1, i2;
s7_pointer vect = slot_value(o->v[1].p);
s7_double val;
i1 = integer(slot_value(o->v[2].p));
i2 = integer(slot_value(o->v[3].p));
val = o->v[9].fd(o->v[8].o1);
float_vector(vect, (i1 * (vector_offset(vect, 0)) + i2)) = val;
return (val);
}
static bool d_7piid_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_7piid_t f;
f = s7_d_7piid_function(s_func);
if ((f) && (is_symbol(cadr(car_x)))) {
opc->v[4].d_7piid_f = f;
if (is_target_or_its_alias
(car(car_x), s_func, sc->float_vector_set_symbol))
return (opt_float_vector_set
(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), NULL,
cddddr(car_x)));
}
return_false(sc, car_x);
}
/* -------- d_7piii -------- */
static s7_double opt_d_7piii_ssss(opt_info * o)
{
return (float_vector_ref_d_7piii
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)),
integer(slot_value(o->v[5].p))));
}
static s7_double opt_d_7piii_ssss_unchecked(opt_info * o)
{
s7_pointer v = slot_value(o->v[1].p);
s7_int i1, i2;
i1 = integer(slot_value(o->v[2].p)) * vector_offset(v, 0);
i2 = integer(slot_value(o->v[3].p)) * vector_offset(v, 1); /* offsets accumulate */
return (float_vector(v, (i1 + i2 + integer(slot_value(o->v[5].p)))));
}
static bool d_7piii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_7piii_t ifunc;
ifunc = s7_d_7piii_function(s_func);
if ((ifunc == float_vector_ref_d_7piii) && (is_symbol(cadr(car_x)))) {
s7_pointer slot;
opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet);
if ((!is_slot(opc->v[1].p)) ||
(!is_float_vector(slot_value(opc->v[1].p))) ||
(vector_rank(slot_value(opc->v[1].p)) != 3))
return_false(sc, car_x);
opc->v[4].d_7piii_f = ifunc; /* currently ignored */
slot = opt_integer_symbol(sc, car(cddddr(car_x)));
if (slot) {
opc->v[5].p = slot;
slot = opt_integer_symbol(sc, cadddr(car_x));
if (slot) {
opc->v[3].p = slot;
slot = opt_integer_symbol(sc, caddr(car_x));
if (slot) {
s7_pointer vect = slot_value(opc->v[1].p);
opc->v[2].p = slot;
opc->v[0].fd = opt_d_7piii_ssss;
if ((step_end_fits
(opc->v[2].p, vector_dimension(vect, 0)))
&&
(step_end_fits
(opc->v[3].p, vector_dimension(vect, 1)))
&&
(step_end_fits
(opc->v[5].p, vector_dimension(vect, 2))))
opc->v[0].fd = opt_d_7piii_ssss_unchecked;
return (true);
}
}
}
}
return (false);
}
/* -------- d_7piiid -------- */
static s7_double opt_d_7piiid_ssssf(opt_info * o)
{
return (float_vector_set_d_7piiid
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)),
integer(slot_value(o->v[5].p)), o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_7piiid_ssssf_unchecked(opt_info * o)
{
s7_int i1, i2, i3;
s7_pointer vect = slot_value(o->v[1].p);
s7_double val;
i1 = integer(slot_value(o->v[2].p)) * vector_offset(vect, 0);
i2 = integer(slot_value(o->v[3].p)) * vector_offset(vect, 1);
i3 = integer(slot_value(o->v[5].p));
val = o->v[11].fd(o->v[10].o1);
float_vector(vect, (i1 + i2 + i3)) = val;
return (val);
}
static bool d_7piiid_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_7piiid_t f;
f = s7_d_7piiid_function(s_func);
if ((f == float_vector_set_d_7piiid) && (is_symbol(cadr(car_x)))) {
opc->v[4].d_7piiid_f = f;
if (is_target_or_its_alias
(car(car_x), s_func, sc->float_vector_set_symbol))
return (opt_float_vector_set
(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x),
cddddr(car_x), cdr(cddddr(car_x))));
}
return (false);
}
static bool opt_float_vector_set(s7_scheme * sc, opt_info * opc,
s7_pointer v, s7_pointer indexp1,
s7_pointer indexp2, s7_pointer indexp3,
s7_pointer valp)
{
s7_pointer settee;
settee = lookup_slot_from(v, sc->curlet);
if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) {
s7_pointer slot, vect = slot_value(settee);
int32_t start = sc->pc;
opc->v[1].p = settee;
if (!is_float_vector(vect))
return_false(sc, NULL);
opc->v[10].o1 = sc->opts[start];
if ((!indexp2) && (vector_rank(vect) == 1)) {
opc->v[4].d_7pid_f = float_vector_set_d_7pid;
slot = opt_integer_symbol(sc, car(indexp1));
if (slot) {
opc->v[2].p = slot;
if (step_end_fits(opc->v[2].p, vector_length(vect)))
opc->v[4].d_7pid_f = float_vector_set_unchecked;
slot = opt_float_symbol(sc, car(valp));
if (slot) {
opc->v[3].p = slot;
opc->v[0].fd = opt_d_7pid_sss;
return (true);
}
if (is_small_real(car(valp))) {
opc->v[3].x = s7_real(car(valp));
opc->v[0].fd = opt_d_7pid_ssc;
return (true);
}
if (float_optimize(sc, valp)) {
opc->v[11].fd = sc->opts[start]->v[0].fd;
if (d_7pid_ssf_combinable(sc, opc))
return (true);
opc->v[0].fd = opt_d_7pid_ssf;
return (true);
}
pc_fallback(sc, start);
}
if (int_optimize(sc, indexp1)) {
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, valp)) {
opc->v[0].fd = opt_d_7pid_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fd = opc->v[8].o1->v[0].fd;
return (true);
}
}
return_false(sc, NULL);
}
if ((indexp2) && (!indexp3) && (vector_rank(vect) == 2)) {
opc->v[5].d_7piid_f = float_vector_set_d_7piid;
/* could check for step_end/end-ok here for both indices, but the d_7pii* functions currently assume fv_d_7piid
* perhaps set a different fd? so opc->v[0].fd = fvset_unchecked_d_7piid or whatever
*/
slot = opt_integer_symbol(sc, car(indexp2));
if (slot) {
opc->v[3].p = slot;
if (is_t_integer(car(indexp1))) {
if (!float_optimize(sc, valp))
return_false(sc, NULL);
opc->v[0].fd = opt_d_7piid_scsf;
opc->v[2].i = integer(car(indexp1));
opc->v[11].fd = opc->v[10].o1->v[0].fd;
return (true);
}
slot = opt_integer_symbol(sc, car(indexp1));
if (slot) {
opc->v[2].p = slot;
if (is_small_real(car(valp))) {
opc->v[0].fd = opt_d_7piid_sssc;
opc->v[4].x = s7_real(car(valp));
return (true);
}
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, valp)) {
opc->v[0].fd = opt_d_7piid_sssf;
opc->v[9].fd = opc->v[8].o1->v[0].fd;
if ((step_end_fits
(opc->v[2].p, vector_dimension(vect, 0)))
&&
(step_end_fits
(opc->v[3].p, vector_dimension(vect, 1))))
opc->v[0].fd = opt_d_7piid_sssf_unchecked;
return (true);
}
pc_fallback(sc, start);
}
}
if (int_optimize(sc, indexp1)) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp2)) {
opc->v[3].o1 = sc->opts[sc->pc];
if (float_optimize(sc, valp)) {
opc->v[0].fd = opt_d_7piid_sfff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
opc->v[4].fd = opc->v[3].o1->v[0].fd;
return (true);
}
}
}
return_false(sc, NULL);
}
if ((indexp3) && (vector_rank(vect) == 3)) {
opc->v[4].d_7piiid_f = float_vector_set_d_7piiid;
slot = opt_integer_symbol(sc, car(indexp3));
if (slot) {
opc->v[5].p = slot;
slot = opt_integer_symbol(sc, car(indexp2));
if (slot) {
opc->v[3].p = slot;
slot = opt_integer_symbol(sc, car(indexp1));
if (slot) {
opc->v[2].p = slot;
if (float_optimize(sc, valp)) {
opc->v[0].fd = opt_d_7piiid_ssssf;
opc->v[11].fd = sc->opts[start]->v[0].fd;
if ((step_end_fits
(opc->v[2].p, vector_dimension(vect, 0)))
&&
(step_end_fits
(opc->v[3].p, vector_dimension(vect, 1)))
&&
(step_end_fits
(opc->v[5].p, vector_dimension(vect, 2))))
opc->v[0].fd =
opt_d_7piiid_ssssf_unchecked;
return (true);
}
}
}
}
}
}
return_false(sc, NULL);
}
/* -------- d_vid -------- */
static s7_double opt_d_vid_ssf(opt_info * o)
{
return (o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)),
o->v[11].fd(o->v[10].o1)));
}
static inline s7_double opt_fmv(opt_info * o)
{
/* d_vid_ssf -> d_dd_ff_o1 -> d_vd_o1 -> d_dd_ff_o3, this is a placeholder */
opt_info *o1, *o2, *o3;
s7_double amp_env, index_env, vib;
o1 = o->v[12].o1; /* o2 below */
o2 = o->v[13].o1; /* o3 below */
o3 = o->v[14].o1; /* o1 below */
amp_env = o1->v[2].d_v_f(o1->v[1].obj);
vib = real(slot_value(o2->v[2].p));
index_env = o3->v[5].d_v_f(o3->v[1].obj);
return (o->v[4].d_vid_f(o->v[5].obj,
integer(slot_value(o->v[2].p)),
amp_env * o2->v[3].d_vd_f(o2->v[5].obj,
vib +
(index_env *
o3->v[6].
d_vd_f(o3->v[2].obj,
vib)))));
}
static bool d_vid_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
if ((is_symbol(cadr(car_x))) && (is_symbol(caddr(car_x)))) {
s7_pointer sig;
s7_d_vid_t flt;
flt = s7_d_vid_function(s_func);
if (!flt)
return_false(sc, car_x);
opc->v[4].d_vid_f = flt;
sig = c_function_signature(s_func);
if (is_pair(sig)) {
int32_t start = sc->pc;
s7_pointer vslot;
vslot = opt_types_match(sc, cadr(sig), cadr(car_x));
if (vslot) {
s7_pointer slot;
opc->v[0].fd = opt_d_vid_ssf;
opc->v[1].p = vslot;
opc->v[10].o1 = sc->opts[start];
slot = opt_integer_symbol(sc, caddr(car_x));
if ((slot) && (float_optimize(sc, cdddr(car_x)))) {
opt_info *o2;
opc->v[2].p = slot;
opc->v[5].obj =
(void *) c_object_value(slot_value(vslot));
opc->v[11].fd = opc->v[10].o1->v[0].fd;
o2 = sc->opts[start];
if (o2->v[0].fd == opt_d_dd_ff_mul1) {
opt_info *o3 = sc->opts[start + 2];
if (o3->v[0].fd == opt_d_vd_o1) {
opt_info *o1 = sc->opts[start + 4];
if ((o1->v[0].fd == opt_d_dd_ff_o3) &&
(o1->v[4].d_dd_f == multiply_d_dd) &&
(o3->v[4].d_dd_f == add_d_dd)) {
opc->v[0].fd = opt_fmv; /* a placeholder -- see below */
opc->v[12].o1 = o2;
opc->v[13].o1 = o3;
opc->v[14].o1 = o1;
}
}
}
return (true);
}
}
pc_fallback(sc, start);
}
}
return_false(sc, car_x);
}
/* -------- d_vdd -------- */
static s7_double opt_d_vdd_ff(opt_info * o)
{
s7_double x1, x2;
x1 = o->v[11].fd(o->v[10].o1);
x2 = o->v[9].fd(o->v[8].o1);
return (o->v[4].d_vdd_f(o->v[5].obj, x1, x2));
}
static bool d_vdd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_vdd_t flt;
flt = s7_d_vdd_function(s_func);
if (flt) {
s7_pointer sig = c_function_signature(s_func);
opc->v[4].d_vdd_f = flt;
if (is_pair(sig)) {
s7_pointer slot;
slot = opt_types_match(sc, cadr(sig), cadr(car_x));
if (slot) {
int32_t start = sc->pc;
opc->v[10].o1 = sc->opts[start];
if (float_optimize(sc, cddr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdddr(car_x))) {
opc->v[11].fd = opc->v[10].o1->v[0].fd;
opc->v[9].fd = opc->v[8].o1->v[0].fd;
opc->v[1].p = slot;
opc->v[5].obj =
(void *) c_object_value(slot_value(slot));
opc->v[0].fd = opt_d_vdd_ff;
return (true);
}
}
pc_fallback(sc, start);
}
}
}
return_false(sc, car_x);
}
/* -------- d_dddd -------- */
static s7_double opt_d_dddd_ffff(opt_info * o)
{
s7_double x1, x2, x3, x4;
x1 = o->v[11].fd(o->v[10].o1);
x2 = o->v[9].fd(o->v[8].o1);
x3 = o->v[5].fd(o->v[4].o1);
x4 = o->v[3].fd(o->v[2].o1);
return (o->v[1].d_dddd_f(x1, x2, x3, x4));
}
static bool d_dddd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_d_dddd_t f;
f = s7_d_dddd_function(s_func);
if (!f)
return_false(sc, car_x);
opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x))) {
opc->v[4].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdddr(car_x))) {
opc->v[2].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddddr(car_x))) {
opc->v[1].d_dddd_f = f;
opc->v[0].fd = opt_d_dddd_ffff;
opc->v[11].fd = opc->v[10].o1->v[0].fd;
opc->v[9].fd = opc->v[8].o1->v[0].fd;
opc->v[5].fd = opc->v[4].o1->v[0].fd;
opc->v[3].fd = opc->v[2].o1->v[0].fd;
return (true);
}
}
}
}
return_false(sc, car_x);
}
/* -------- d_add|multiply|subtract_any ------- */
static s7_double opt_d_add_any_f(opt_info * o)
{
s7_double sum = 0.0;
int32_t i;
for (i = 0; i < o->v[1].i; i++) {
opt_info *o1;
o1 = o->v[i + 2].o1;
sum += o1->v[0].fd(o1);
}
return (sum);
}
static s7_double opt_d_multiply_any_f(opt_info * o)
{
s7_double sum = 1.0;
int32_t i;
for (i = 0; i < o->v[1].i; i++) {
opt_info *o1;
o1 = o->v[i + 2].o1;
sum *= o1->v[0].fd(o1);
}
return (sum);
}
static bool d_add_any_ok(s7_scheme * sc, opt_info * opc, s7_pointer car_x,
int32_t len)
{
s7_pointer head = car(car_x);
int32_t start = sc->pc;
if ((head == sc->add_symbol) || (head == sc->multiply_symbol)) {
s7_pointer p;
int32_t cur_len;
for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12);
p = cdr(p), cur_len++) {
opc->v[cur_len + 2].o1 = sc->opts[sc->pc];
if (!float_optimize(sc, p))
break;
}
if (is_null(p)) {
opc->v[1].i = cur_len;
opc->v[0].fd =
(head ==
sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f;
return (true);
}
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- d_syntax -------- */
static s7_double opt_set_d_d_f(opt_info * o)
{
s7_double x;
x = o->v[3].fd(o->v[2].o1);
slot_set_value(o->v[1].p, make_real(opt_sc(o), x));
return (x);
}
static s7_double opt_set_d_d_fm(opt_info * o)
{
s7_double x;
x = o->v[3].fd(o->v[2].o1);
real(slot_value(o->v[1].p)) = x;
return (x);
}
static bool d_syntax_ok(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
if ((len == 3) && (car(car_x) == sc->set_symbol)) {
opt_info *opc;
opc = alloc_opo(sc);
if (is_symbol(cadr(car_x))) {
s7_pointer settee;
if (is_immutable(cadr(car_x)))
return_false(sc, car_x);
settee = lookup_slot_from(cadr(car_x), sc->curlet);
if ((is_slot(settee)) &&
(!is_immutable(settee)) && ((!slot_has_setter(settee))
|| (slot_setter(settee) !=
initial_value(sc->
is_float_symbol))))
/* ttl.scm experiment: if setter is float? (sin float) is a float so we can float_optimize this */
{
opt_info *o1 = sc->opts[sc->pc];
opc->v[1].p = settee;
if ((!is_t_integer(caddr(car_x))) &&
(is_t_real(slot_value(settee))) &&
(float_optimize(sc, cddr(car_x)))) {
opc->v[0].fd =
(is_mutable_number(slot_value(opc->v[1].p))) ?
opt_set_d_d_fm : opt_set_d_d_f;
opc->v[2].o1 = o1;
opc->v[3].fd = o1->v[0].fd;
return (true);
}
}
} else /* if is_pair(settee) get setter */
if ((is_pair(cadr(car_x))) &&
(is_symbol(caadr(car_x))) && (is_pair(cdadr(car_x)))) {
if (is_null(cddadr(car_x)))
return (opt_float_vector_set
(sc, opc, caadr(car_x), cdadr(car_x), NULL, NULL,
cddr(car_x)));
if (is_null(cdddr(cadr(car_x))))
return (opt_float_vector_set
(sc, opc, caadr(car_x), cdadr(car_x),
cddadr(car_x), NULL, cddr(car_x)));
}
}
return_false(sc, car_x);
}
static bool d_implicit_ok(s7_scheme * sc, s7_pointer s_slot,
s7_pointer car_x, int32_t len)
{
s7_pointer slot, obj = slot_value(s_slot);
opt_info *opc;
if (is_float_vector(obj)) {
/* implicit float-vector-ref */
if ((len == 2) && (vector_rank(obj) == 1)) {
opc = alloc_opo(sc);
opc->v[1].p = s_slot;
opc->v[3].d_7pi_f = float_vector_ref_d_7pi;
slot = opt_integer_symbol(sc, cadr(car_x));
if (slot) {
opc->v[2].p = slot;
if (step_end_fits(opc->v[2].p, vector_length(obj)))
opc->v[0].fd = opt_d_7pi_ss_fvref_unchecked;
else
opc->v[0].fd = opt_d_7pi_ss_fvref;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (!int_optimize(sc, cdr(car_x)))
return_false(sc, car_x);
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[0].fd = opt_d_7pi_sf;
return (true);
}
if ((len == 3) && (vector_rank(obj) == 2)) {
opc = alloc_opo(sc);
opc->v[1].p = s_slot;
opc->v[4].d_7pii_f = float_vector_ref_d_7pii;
slot = opt_integer_symbol(sc, cadr(car_x));
if (slot) {
opc->v[2].p = slot;
slot = opt_integer_symbol(sc, caddr(car_x));
if (slot) {
opc->v[3].p = slot;
opc->v[0].fd = opt_d_7pii_sss;
if ((step_end_fits
(opc->v[2].p, vector_dimension(obj, 0)))
&&
(step_end_fits
(opc->v[3].p, vector_dimension(obj, 1))))
opc->v[0].fd = opt_d_7pii_sss_unchecked;
return (true);
}
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[0].fd = opt_d_7pii_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
return (true);
}
}
}
if ((len == 4) && (vector_rank(obj) == 3)) {
opc = alloc_opo(sc);
opc->v[1].p = s_slot;
opc->v[4].d_7piii_f = float_vector_ref_d_7piii;
slot = opt_integer_symbol(sc, cadr(car_x));
if (slot) {
opc->v[2].p = slot;
slot = opt_integer_symbol(sc, caddr(car_x));
if (slot) {
opc->v[3].p = slot;
slot = opt_integer_symbol(sc, cadddr(car_x));
if (slot) {
opc->v[5].p = slot;
opc->v[0].fd = opt_d_7piii_ssss;
if ((step_end_fits
(opc->v[2].p, vector_dimension(obj, 0)))
&&
(step_end_fits
(opc->v[3].p, vector_dimension(obj, 1)))
&&
(step_end_fits
(opc->v[5].p, vector_dimension(obj, 2))))
opc->v[0].fd = opt_d_7piii_ssss_unchecked;
return (true);
}
}
}
}
}
if ((is_c_object(obj)) && (len == 2)) {
s7_d_7pi_t func;
s7_pointer getf;
getf = c_object_getf(sc, obj);
if (is_c_function(getf)) { /* default is #f */
func = s7_d_7pi_function(getf);
if (func) {
opc = alloc_opo(sc);
opc->v[1].p = s_slot;
opc->v[4].obj = (void *) c_object_value(obj);
opc->v[3].d_7pi_f = func;
slot = opt_integer_symbol(sc, cadr(car_x));
if (slot) {
opc->v[0].fd = opt_d_7pi_ss;
opc->v[2].p = slot;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[0].fd = opt_d_7pi_sf;
return (true);
}
}
}
}
return_false(sc, car_x);
}
/* -------------------------------- bool opts -------------------------------- */
static bool opt_b_s(opt_info * o)
{
return (slot_value(o->v[1].p) != opt_sc(o)->F);
}
static bool opt_bool_not_pair(s7_scheme * sc, s7_pointer car_x)
{
s7_pointer p;
if (!is_symbol(car_x))
return_false(sc, car_x); /* i.e. use cell_optimize */
p = opt_simple_symbol(sc, car_x);
if ((p) && (s7_is_boolean(slot_value(p)))) {
opt_info *opc;
opc = alloc_opo(sc);
opc->v[1].p = p;
opc->v[0].fb = opt_b_s;
return (true);
}
return_false(sc, car_x);
}
/* -------- b_idp -------- */
static bool opt_b_i_s(opt_info * o)
{
return (o->v[2].b_i_f(integer(slot_value(o->v[1].p))));
}
static bool opt_b_i_f(opt_info * o)
{
return (o->v[2].b_i_f(o->v[11].fi(o->v[10].o1)));
}
static bool opt_b_d_s(opt_info * o)
{
return (o->v[2].b_d_f(real(slot_value(o->v[1].p))));
}
static bool opt_b_d_f(opt_info * o)
{
return (o->v[2].b_d_f(o->v[11].fd(o->v[10].o1)));
}
static bool opt_b_p_s(opt_info * o)
{
return (o->v[2].b_p_f(slot_value(o->v[1].p)));
}
static bool opt_b_p_f(opt_info * o)
{
return (o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));
}
static bool opt_b_7p_s(opt_info * o)
{
return (o->v[2].b_7p_f(opt_sc(o), slot_value(o->v[1].p)));
}
static bool opt_b_7p_f(opt_info * o)
{
return (o->v[2].b_7p_f(opt_sc(o), o->v[4].fp(o->v[3].o1)));
}
static bool opt_b_d_s_is_positive(opt_info * o)
{
return (real(slot_value(o->v[1].p)) > 0.0);
}
static bool opt_b_p_s_is_integer(opt_info * o)
{
return (s7_is_integer(slot_value(o->v[1].p)));
}
static bool opt_b_p_s_is_pair(opt_info * o)
{
return (is_pair(slot_value(o->v[1].p)));
}
static bool opt_b_p_f_is_string(opt_info * o)
{
return (s7_is_string(o->v[4].fp(o->v[3].o1)));
}
static bool opt_b_7p_s_iter_at_end(opt_info * o)
{
return (iterator_is_at_end(slot_value(o->v[1].p)));
}
static bool opt_zero_mod(opt_info * o)
{
s7_int x = integer(slot_value(o->v[1].p));
return ((x % o->v[2].i) == 0);
}
static bool b_idp_ok(s7_scheme * sc, s7_pointer s_func, s7_pointer car_x,
s7_pointer arg_type)
{
int32_t cur_index;
s7_b_p_t bpf = NULL;
s7_b_7p_t bpf7 = NULL;
opt_info *opc;
opc = alloc_opo(sc);
cur_index = sc->pc;
if (arg_type == sc->is_integer_symbol) {
s7_b_i_t bif;
bif = s7_b_i_function(s_func);
if (bif) {
opc->v[2].b_i_f = bif;
if (is_symbol(cadr(car_x))) {
opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet);
opc->v[0].fb = opt_b_i_s;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opt_info *o1 = sc->opts[sc->pc - 1];
if ((car(car_x) == sc->is_zero_symbol) &&
(o1->v[0].fi == opt_i_ii_sc) &&
(o1->v[3].i_ii_f == modulo_i_ii_unchecked)) {
opc->v[0].fb = opt_zero_mod;
opc->v[1].p = o1->v[1].p;
opc->v[2].i = o1->v[2].i;
backup_pc(sc);
return (true);
}
opc->v[0].fb = opt_b_i_f;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
return (true);
}
}
} else if (arg_type == sc->is_float_symbol) {
s7_b_d_t bdf;
bdf = s7_b_d_function(s_func);
if (bdf) {
opc->v[2].b_d_f = bdf;
if (is_symbol(cadr(car_x))) {
opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet);
opc->v[0].fb =
(bdf ==
is_positive_d) ? opt_b_d_s_is_positive : opt_b_d_s;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x))) {
opc->v[0].fb = opt_b_d_f;
opc->v[11].fd = opc->v[10].o1->v[0].fd;
return (true);
}
}
}
pc_fallback(sc, cur_index);
bpf = s7_b_p_function(s_func);
if (!bpf)
bpf7 = s7_b_7p_function(s_func);
if ((bpf) || (bpf7)) {
if (bpf)
opc->v[2].b_p_f = bpf;
else
opc->v[2].b_7p_f = bpf7;
if (is_symbol(cadr(car_x))) {
s7_pointer p;
p = opt_simple_symbol(sc, cadr(car_x));
if (!p)
return_false(sc, car_x);
opc->v[1].p = p;
opc->v[0].fb =
(bpf) ? ((bpf == s7_is_integer) ? opt_b_p_s_is_integer
: ((bpf ==
s7_is_pair) ? opt_b_p_s_is_pair : opt_b_p_s))
: (((bpf7 == iterator_is_at_end_b_7p)
&& (is_iterator(slot_value(p)))) ?
opt_b_7p_s_iter_at_end : opt_b_7p_s);
return (true);
}
opc->v[3].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) {
opc->v[0].fb =
(bpf) ? ((bpf == s7_is_string) ? opt_b_p_f_is_string :
opt_b_p_f) : opt_b_7p_f;
opc->v[4].fp = opc->v[3].o1->v[0].fp;
return (true);
}
}
return_false(sc, car_x);
}
/* -------- b_pp -------- */
static s7_pointer opt_arg_type(s7_scheme * sc, s7_pointer argp)
{
s7_pointer slot, arg = car(argp);
if (is_pair(arg)) {
if (is_symbol(car(arg))) {
if ((is_global(car(arg))) ||
((is_slot(global_slot(car(arg)))) &&
(lookup_slot_from(car(arg), sc->curlet) ==
global_slot(car(arg))))) {
s7_pointer a_func = global_value(car(arg));
if (is_c_function(a_func)) {
s7_pointer sig = c_function_signature(a_func);
if (is_pair(sig)) {
if ((car(sig) == sc->is_integer_symbol) ||
((is_pair(car(sig)))
&&
(direct_memq
(sc->is_integer_symbol, car(sig)))))
return (sc->is_integer_symbol);
if ((car(sig) == sc->is_float_symbol) ||
((is_pair(car(sig)))
&&
(direct_memq(sc->is_float_symbol, car(sig)))))
return (sc->is_float_symbol);
if ((car(sig) == sc->is_real_symbol) ||
(car(sig) == sc->is_number_symbol)) {
int32_t start = sc->pc;
if (int_optimize(sc, argp)) {
pc_fallback(sc, start);
return (sc->is_integer_symbol);
}
if (float_optimize(sc, argp)) {
pc_fallback(sc, start);
return (sc->is_float_symbol);
}
pc_fallback(sc, start);
}
return (car(sig)); /* we want the function's return type in this context */
}
}
}
slot = lookup_slot_from(car(arg), sc->curlet);
if ((is_slot(slot)) && (is_sequence(slot_value(slot)))) {
s7_pointer sig;
sig = s7_signature(sc, slot_value(slot));
if (is_pair(sig))
return (car(sig));
}
}
return (sc->T);
}
if (is_symbol(arg)) {
slot = opt_simple_symbol(sc, arg);
if (!slot)
return (sc->T);
#if WITH_GMP
if (is_big_number(slot_value(slot)))
return (sc->T);
if ((is_t_integer(slot_value(slot))) &&
(integer(slot_value(slot)) > QUOTIENT_INT_LIMIT))
return (sc->T);
if ((is_t_real(slot_value(slot))) &&
(real(slot_value(slot)) > QUOTIENT_FLOAT_LIMIT))
return (sc->T);
#endif
return (s7_type_of(sc, slot_value(slot)));
}
return (s7_type_of(sc, arg));
}
static bool opt_b_pp_ff(opt_info * o)
{
s7_pointer p1;
p1 = o->v[9].fp(o->v[8].o1);
return (o->v[3].b_pp_f(p1, o->v[11].fp(o->v[10].o1)));
}
static bool opt_b_7pp_ff(opt_info * o)
{
s7_pointer p1;
p1 = o->v[9].fp(o->v[8].o1);
return (o->v[3].b_7pp_f(opt_sc(o), p1, o->v[11].fp(o->v[10].o1)));
}
static bool opt_b_pp_sf(opt_info * o)
{
return (o->
v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));
}
static bool opt_b_pp_fs(opt_info * o)
{
return (o->
v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));
}
static bool opt_b_pp_ss(opt_info * o)
{
return (o->v[3].b_pp_f(slot_value(o->v[1].p), slot_value(o->v[2].p)));
}
static bool opt_b_pp_sc(opt_info * o)
{
return (o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[2].p));
}
static bool opt_b_pp_sfo(opt_info * o)
{
return (o->v[3].b_pp_f(slot_value(o->v[1].p),
o->v[4].p_p_f(opt_sc(o),
slot_value(o->v[2].p))));
}
static bool opt_b_7pp_sf(opt_info * o)
{
return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p),
o->v[11].fp(o->v[10].o1)));
}
static bool opt_b_7pp_fs(opt_info * o)
{
return (o->v[3].b_7pp_f(opt_sc(o), o->v[11].fp(o->v[10].o1),
slot_value(o->v[1].p)));
}
static bool opt_b_7pp_ss(opt_info * o)
{
return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p),
slot_value(o->v[2].p)));
}
static bool opt_b_7pp_ss_lt(opt_info * o)
{
return (lt_b_7pp
(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p)));
}
static bool opt_b_7pp_ss_gt(opt_info * o)
{
return (gt_b_7pp
(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p)));
}
static bool opt_b_7pp_ss_char_lt(opt_info * o)
{
return (char_lt_b_7pp
(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p)));
}
static bool opt_b_7pp_sc(opt_info * o)
{
return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].p));
}
static bool opt_b_7pp_sfo(opt_info * o)
{
return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p),
o->v[4].p_p_f(opt_sc(o),
slot_value(o->v[2].p))));
}
static bool opt_is_equal_sfo(opt_info * o)
{
return (s7_is_equal
(opt_sc(o), slot_value(o->v[1].p),
o->v[4].p_p_f(opt_sc(o), slot_value(o->v[2].p))));
}
static bool opt_is_equivalent_sfo(opt_info * o)
{
return (is_equivalent_1
(opt_sc(o), slot_value(o->v[1].p),
o->v[4].p_p_f(opt_sc(o), slot_value(o->v[2].p)), NULL));
}
static bool opt_b_pp_sf_char_eq(opt_info * o)
{
return (slot_value(o->v[1].p) == o->v[11].fp(o->v[10].o1));
} /* lt above checks for char args */
static bool opt_b_pp_ff_char_eq(opt_info * o)
{
return (o->v[9].fp(o->v[8].o1) == o->v[11].fp(o->v[10].o1));
}
static bool opt_car_equal_sf(opt_info * o)
{
s7_pointer p = slot_value(o->v[2].p);
return (s7_is_equal
(opt_sc(o), slot_value(o->v[1].p),
(is_pair(p)) ? car(p) : g_car(opt_sc(o),
set_plist_1(opt_sc(o), p))));
}
static bool opt_car_equivalent_sf(opt_info * o)
{
s7_pointer p = slot_value(o->v[2].p);
return (is_equivalent_1
(opt_sc(o), slot_value(o->v[1].p),
(is_pair(p)) ? car(p) : g_car(opt_sc(o),
set_plist_1(opt_sc(o), p)),
NULL));
}
static bool opt_b_7pp_car_sf(opt_info * o)
{
s7_pointer p = slot_value(o->v[2].p);
return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p),
(is_pair(p)) ? car(p) : g_car(opt_sc(o),
set_plist_1
(opt_sc(o),
p))));
}
static s7_pointer opt_p_substring_uncopied_ssf(opt_info * o)
{ /* "inline" here rather than copying below is much slower? */
return (substring_uncopied_p_pii(opt_sc(o), slot_value(o->v[1].p),
s7_integer_checked(opt_sc(o),
slot_value(o->
v
[2].p)),
s7_integer_checked(opt_sc(o),
o->v[6].fp(o->
v
[5].o1))));
}
static bool opt_substring_equal_sf(opt_info * o)
{
return (scheme_strings_are_equal
(slot_value(o->v[1].p),
opt_p_substring_uncopied_ssf(o->v[10].o1)));
}
static s7_pointer opt_p_p_s(opt_info * o);
static bool b_pp_sf_combinable(s7_scheme * sc, opt_info * opc,
bool bpf_case)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if (o1->v[0].fp == opt_p_p_s) {
opc->v[2].p = o1->v[1].p;
opc->v[4].p_p_f = o1->v[2].p_p_f;
if (bpf_case)
opc->v[0].fb = opt_b_pp_sfo;
else if (opc->v[4].p_p_f == car_p_p)
opc->v[0].fb =
((opc->v[3].b_7pp_f ==
s7_is_equal) ? opt_car_equal_sf : ((opc->
v[3].b_7pp_f ==
s7_is_equivalent)
?
opt_car_equivalent_sf
:
opt_b_7pp_car_sf));
else
opc->v[0].fb =
((opc->v[3].b_7pp_f ==
s7_is_equal) ? opt_is_equal_sfo : ((opc->
v[3].b_7pp_f ==
s7_is_equivalent)
?
opt_is_equivalent_sfo
: opt_b_7pp_sfo));
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static bool opt_b_pp_ffo(opt_info * o)
{
s7_pointer b1;
b1 = o->v[4].p_p_f(opt_sc(o), slot_value(o->v[1].p));
return (o->
v[3].b_pp_f(b1,
o->v[5].p_p_f(opt_sc(o), slot_value(o->v[2].p))));
}
static bool opt_b_pp_ffo_is_eq(opt_info * o)
{
s7_pointer b1, b2;
b1 = o->v[4].p_p_f(opt_sc(o), slot_value(o->v[1].p));
b2 = o->v[5].p_p_f(opt_sc(o), slot_value(o->v[2].p));
return ((b1 == b2) || ((is_unspecified(b1)) && (is_unspecified(b2))));
}
static bool opt_b_7pp_ffo(opt_info * o)
{
s7_pointer b1;
b1 = o->v[4].p_p_f(opt_sc(o), slot_value(o->v[1].p));
return (o->v[3].b_7pp_f(opt_sc(o), b1,
o->v[5].p_p_f(opt_sc(o),
slot_value(o->v[2].p))));
}
static bool opt_b_cadr_cadr(opt_info * o)
{
s7_pointer p1 = slot_value(o->v[1].p), p2 = slot_value(o->v[2].p);
p1 = ((is_pair(p1))
&& (is_pair(cdr(p1)))) ? cadr(p1) : g_cadr(opt_sc(o),
set_plist_1(opt_sc(o),
p1));
p2 = ((is_pair(p2))
&& (is_pair(cdr(p2)))) ? cadr(p2) : g_cadr(opt_sc(o),
set_plist_1(opt_sc(o),
p2));
return (o->v[3].b_7pp_f(opt_sc(o), p1, p2));
}
static bool b_pp_ff_combinable(s7_scheme * sc, opt_info * opc,
bool bpf_case)
{
if ((sc->pc > 2) && (opc == sc->opts[sc->pc - 3])) {
opt_info *o1 = sc->opts[sc->pc - 2], *o2 = sc->opts[sc->pc - 1];
if ((o1->v[0].fp == opt_p_p_s) && (o2->v[0].fp == opt_p_p_s)) {
opc->v[1].p = o1->v[1].p;
opc->v[4].p_p_f = o1->v[2].p_p_f;
opc->v[2].p = o2->v[1].p;
opc->v[5].p_p_f = o2->v[2].p_p_f;
opc->v[0].fb =
(bpf_case) ? ((opc->v[3].b_pp_f == s7_is_eq) ?
opt_b_pp_ffo_is_eq : opt_b_pp_ffo)
: (((opc->v[4].p_p_f == cadr_p_p)
&& (opc->v[5].p_p_f =
cadr_p_p)) ? opt_b_cadr_cadr : opt_b_7pp_ffo);
sc->pc -= 2;
return (true);
}
}
return_false(sc, NULL);
}
static void check_b_types(s7_scheme * sc, opt_info * opc,
s7_pointer s_func, s7_pointer car_x,
bool (*fb)(opt_info * o))
{
if (s7_b_pp_unchecked_function(s_func)) {
s7_pointer arg1_type, arg2_type, call_sig =
c_function_signature(s_func);
arg1_type = opt_arg_type(sc, cdr(car_x));
arg2_type = opt_arg_type(sc, cddr(car_x));
if ((cadr(call_sig) == arg1_type) && /* not car(arg1_type) here: (string>? (string) (read-line)) */
(caddr(call_sig) == arg2_type)) {
opc->v[0].fb = fb;
opc->v[3].b_pp_f = s7_b_pp_unchecked_function(s_func);
}
}
#if 0
if ((arg2_type == sc->is_integer_symbol) && s7_b_pi_function(s_func)) {
/* opc->v[0].fb = opt_b_pi */
fprintf(stderr, " pi: %s\n", display(car_x));
}
#endif
}
static bool b_pp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, s7_pointer arg1, s7_pointer arg2,
bool bpf_case)
{
int32_t cur_index = sc->pc;
opt_info *o1;
/* v[3] is set when we get here */
if ((is_symbol(arg1)) && (is_symbol(arg2))) {
opc->v[1].p = opt_simple_symbol(sc, arg1);
opc->v[2].p = opt_simple_symbol(sc, arg2);
if ((opc->v[1].p) && (opc->v[2].p)) {
s7_b_7pp_t b7f;
b7f = (bpf_case) ? NULL : opc->v[3].b_7pp_f;
opc->v[0].fb = (bpf_case) ? opt_b_pp_ss :
((b7f ==
lt_b_7pp) ? opt_b_7pp_ss_lt : ((b7f ==
gt_b_7pp) ?
opt_b_7pp_ss_gt
: ((b7f ==
char_lt_b_7pp) ?
opt_b_7pp_ss_char_lt :
opt_b_7pp_ss)));
return (true);
}
}
if (is_symbol(arg1)) {
opc->v[1].p = opt_simple_symbol(sc, arg1);
if (!opc->v[1].p)
return_false(sc, car_x);
if ((!is_symbol(arg2)) && (!is_pair(arg2))) {
opc->v[2].p = arg2;
opc->v[0].fb = (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc;
check_b_types(sc, opc, s_func, car_x, opt_b_pp_sc);
return (true);
}
if (cell_optimize(sc, cddr(car_x))) {
if (!b_pp_sf_combinable(sc, opc, bpf_case)) {
opc->v[10].o1 = sc->opts[cur_index];
opc->v[11].fp = opc->v[10].o1->v[0].fp;
opc->v[0].fb = (bpf_case) ? opt_b_pp_sf : opt_b_7pp_sf;
check_b_types(sc, opc, s_func, car_x, opt_b_pp_sf); /* this finds b_pp_unchecked cases */
if ((opc->v[11].fp == opt_p_substring_uncopied_ssf)
&& (opc->v[3].b_pp_f == string_eq_b_unchecked))
opc->v[0].fb = opt_substring_equal_sf;
if (opc->v[3].b_pp_f == char_eq_b_unchecked)
opc->v[0].fb = opt_b_pp_sf_char_eq;
}
return (true);
}
pc_fallback(sc, cur_index);
} else if ((is_symbol(arg2)) && (is_pair(arg1))) {
opc->v[10].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) {
opc->v[1].p = lookup_slot_from(arg2, sc->curlet);
if ((!is_slot(opc->v[1].p)) ||
(has_methods(slot_value(opc->v[1].p))))
return_false(sc, car_x);
opc->v[11].fp = opc->v[10].o1->v[0].fp;
opc->v[0].fb = (bpf_case) ? opt_b_pp_fs : opt_b_7pp_fs;
check_b_types(sc, opc, s_func, car_x, opt_b_pp_fs);
return (true);
}
pc_fallback(sc, cur_index);
}
/* fprintf(stderr, "%d %s %s\n", __LINE__, display(opt_arg_type(sc, cdr(car_x))), display(opt_arg_type(sc, cddr(car_x)))); */
o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) {
opc->v[10].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
if (b_pp_ff_combinable(sc, opc, bpf_case))
return (true);
opc->v[0].fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff;
opc->v[8].o1 = o1;
opc->v[9].fp = o1->v[0].fp;
opc->v[11].fp = opc->v[10].o1->v[0].fp;
check_b_types(sc, opc, s_func, car_x, opt_b_pp_ff);
if (opc->v[3].b_pp_f == char_eq_b_unchecked)
opc->v[0].fb = opt_b_pp_ff_char_eq;
return (true);
}
}
return_false(sc, car_x);
}
/* -------- b_pi -------- */
static bool opt_b_pi_fs(opt_info * o)
{
return (o->v[2].b_pi_f(opt_sc(o), o->v[11].fp(o->v[10].o1),
integer(slot_value(o->v[1].p))));
}
static bool opt_b_pi_fs_num_eq(opt_info * o)
{
return (num_eq_b_pi
(opt_sc(o), o->v[11].fp(o->v[10].o1),
integer(slot_value(o->v[1].p))));
}
static bool opt_b_pi_fi(opt_info * o)
{
return (o->
v[2].b_pi_f(opt_sc(o), o->v[11].fp(o->v[10].o1), o->v[1].i));
}
#if 0
static bool opt_b_pi_ff(opt_info * o)
{
s7_pointer p1;
p1 = o->v[9].fp(o->v[8].o1);
return (o->v[3].b_pi_f(opt_sc(o), p1, o->v[11].fi(o->v[10].o1)));
}
#endif
static bool b_pi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, s7_pointer arg2)
{
s7_b_pi_t bpif;
bpif = s7_b_pi_function(s_func);
if (bpif) {
if (is_symbol(arg2))
opc->v[1].p = lookup_slot_from(arg2, sc->curlet); /* slot checked in opt_arg_type */
else
opc->v[1].i = integer(arg2);
opc->v[10].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) {
opc->v[2].b_pi_f = bpif;
if (is_symbol(arg2)) /* not pair? arg2 in bool_optimize */
opc->v[0].fb =
(bpif ==
num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs;
else
opc->v[0].fb = opt_b_pi_fi;
opc->v[11].fp = opc->v[10].o1->v[0].fp;
return (true);
}
}
return_false(sc, car_x);
}
/* -------- b_dd -------- */
static bool opt_b_dd_ss(opt_info * o)
{
return (o->v[3].b_dd_f(real(slot_value(o->v[1].p)),
real(slot_value(o->v[2].p))));
}
static bool opt_b_dd_ss_lt(opt_info * o)
{
return (real(slot_value(o->v[1].p)) < real(slot_value(o->v[2].p)));
}
static bool opt_b_dd_ss_gt(opt_info * o)
{
return (real(slot_value(o->v[1].p)) > real(slot_value(o->v[2].p)));
}
static bool opt_b_dd_sc(opt_info * o)
{
return (o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));
}
static bool opt_b_dd_sc_lt(opt_info * o)
{
return (real(slot_value(o->v[1].p)) < o->v[2].x);
}
static bool opt_b_dd_sc_geq(opt_info * o)
{
return (real(slot_value(o->v[1].p)) >= o->v[2].x);
}
static bool opt_b_dd_sc_eq(opt_info * o)
{
return (real(slot_value(o->v[1].p)) == o->v[2].x);
}
static bool opt_b_dd_sf(opt_info * o)
{
return (o->
v[3].b_dd_f(real(slot_value(o->v[1].p)),
o->v[11].fd(o->v[10].o1)));
}
static bool opt_b_dd_fs(opt_info * o)
{
return (o->
v[3].b_dd_f(o->v[11].fd(o->v[10].o1),
real(slot_value(o->v[1].p))));
}
static bool opt_b_dd_fs_gt(opt_info * o)
{
return (o->v[11].fd(o->v[10].o1) > real(slot_value(o->v[1].p)));
}
static bool opt_b_dd_fc(opt_info * o)
{
return (o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x));
}
static bool opt_b_dd_ff(opt_info * o)
{
s7_double x1, x2;
x1 = o->v[11].fd(o->v[10].o1);
x2 = o->v[9].fd(o->v[8].o1);
return (o->v[3].b_dd_f(x1, x2));
}
static bool b_dd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, s7_pointer arg1, s7_pointer arg2)
{
s7_b_dd_t bif;
int32_t cur_index = sc->pc;
bif = s7_b_dd_function(s_func);
if (!bif)
return_false(sc, car_x);
opc->v[3].b_dd_f = bif;
if (is_symbol(arg1)) {
opc->v[1].p = lookup_slot_from(arg1, sc->curlet);
if (is_symbol(arg2)) {
opc->v[2].p = lookup_slot_from(arg2, sc->curlet);
opc->v[0].fb =
(bif ==
lt_b_dd) ? opt_b_dd_ss_lt : ((bif ==
gt_b_dd) ? opt_b_dd_ss_gt :
opt_b_dd_ss);
return (true);
}
if (is_t_real(arg2)) {
opc->v[2].x = s7_number_to_real(sc, arg2);
opc->v[0].fb =
(bif ==
lt_b_dd) ? opt_b_dd_sc_lt : ((bif ==
geq_b_dd) ? opt_b_dd_sc_geq
: ((bif ==
num_eq_b_dd) ?
opt_b_dd_sc_eq :
opt_b_dd_sc));
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x))) {
opc->v[11].fd = opc->v[10].o1->v[0].fd;
opc->v[0].fb = opt_b_dd_sf;
return (true);
}
}
pc_fallback(sc, cur_index);
opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x))) {
opc->v[11].fd = opc->v[10].o1->v[0].fd;
if (is_symbol(arg2)) {
opc->v[1].p = lookup_slot_from(arg2, sc->curlet);
opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs;
return (true);
}
if (is_small_real(arg2)) {
opc->v[1].x = s7_number_to_real(sc, arg2);
opc->v[0].fb = opt_b_dd_fc;
return (true);
}
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x))) {
opc->v[9].fd = opc->v[8].o1->v[0].fd;
opc->v[0].fb = opt_b_dd_ff;
return (true);
}
}
pc_fallback(sc, cur_index);
return_false(sc, car_x);
}
/* -------- b_ii -------- */
static bool opt_b_ii_ss(opt_info * o)
{
return (o->v[3].b_ii_f(integer(slot_value(o->v[1].p)),
integer(slot_value(o->v[2].p))));
}
static bool opt_b_ii_ss_lt(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) <
integer(slot_value(o->v[2].p)));
}
static bool opt_b_ii_ss_gt(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) >
integer(slot_value(o->v[2].p)));
}
static bool opt_b_ii_ss_leq(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) <=
integer(slot_value(o->v[2].p)));
}
static bool opt_b_ii_ss_geq(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) >=
integer(slot_value(o->v[2].p)));
}
static bool opt_b_ii_ss_eq(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) ==
integer(slot_value(o->v[2].p)));
}
static bool opt_b_ii_sc(opt_info * o)
{
return (o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));
}
static bool opt_b_ii_sc_lt(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) < o->v[2].i);
}
static bool opt_b_ii_sc_leq(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) <= o->v[2].i);
}
static bool opt_b_ii_sc_gt(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) > o->v[2].i);
}
static bool opt_b_ii_sc_geq(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) >= o->v[2].i);
}
static bool opt_b_ii_sc_eq(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) == o->v[2].i);
}
static bool opt_b_ii_sc_lt_2(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) < 2);
}
static bool opt_b_ii_sc_lt_1(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) < 1);
}
static bool opt_b_ii_sc_lt_0(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) < 0);
}
static bool opt_b_ii_sc_leq_0(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) <= 0);
}
static bool opt_b_ii_sc_gt_0(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) > 0);
}
static bool opt_b_ii_sc_geq_0(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) >= 0);
}
static bool opt_b_ii_sc_eq_0(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) == 0);
}
static bool opt_b_ii_sc_eq_1(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) == 1);
}
static bool opt_b_7ii_ss(opt_info * o)
{
return (o->v[3].b_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)),
integer(slot_value(o->v[2].p))));
}
static bool opt_b_7ii_sc(opt_info * o)
{
return (o->
v[3].b_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)),
o->v[2].i));
}
static bool opt_b_7ii_sc_bit(opt_info * o)
{
return ((integer(slot_value(o->v[1].p)) &
((int64_t) (1LL << o->v[2].i))) != 0);
}
static bool opt_b_ii_ff(opt_info * o)
{
s7_int i1, i2;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
return (o->v[3].b_ii_f(i1, i2));
}
static bool opt_b_ii_fs(opt_info * o)
{
return (o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1),
integer(slot_value(o->v[2].p))));
}
static bool opt_b_ii_sf(opt_info * o)
{
return (o->v[3].b_ii_f(integer(slot_value(o->v[1].p)),
o->v[11].fi(o->v[10].o1)));
}
static bool opt_b_ii_sf_eq(opt_info * o)
{
return (integer(slot_value(o->v[1].p)) == o->v[11].fi(o->v[10].o1));
}
static bool opt_b_ii_fc(opt_info * o)
{
return (o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));
}
static bool opt_b_ii_fc_eq(opt_info * o)
{
return (o->v[11].fi(o->v[10].o1) == o->v[2].i);
}
static bool b_ii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, s7_pointer arg1, s7_pointer arg2)
{
s7_b_ii_t bif;
s7_b_7ii_t b7if = NULL;
bif = s7_b_ii_function(s_func);
if (!bif) {
b7if = s7_b_7ii_function(s_func);
if (!b7if)
return_false(sc, car_x);
}
if (bif)
opc->v[3].b_ii_f = bif;
else
opc->v[3].b_7ii_f = b7if;
if (is_symbol(arg1)) {
opc->v[1].p = lookup_slot_from(arg1, sc->curlet);
if (is_symbol(arg2)) {
opc->v[2].p = lookup_slot_from(arg2, sc->curlet);
opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt :
((bif == leq_b_ii) ? opt_b_ii_ss_leq :
((bif == gt_b_ii) ? opt_b_ii_ss_gt :
((bif == geq_b_ii) ? opt_b_ii_ss_geq :
((bif == num_eq_b_ii) ? opt_b_ii_ss_eq :
((bif) ? opt_b_ii_ss : opt_b_7ii_ss)))));
return (true);
}
if (is_t_integer(arg2)) {
s7_int i2 = integer(arg2);
opc->v[2].i = i2;
opc->v[0].fb =
(bif ==
num_eq_b_ii) ? ((i2 ==
0) ? opt_b_ii_sc_eq_0 : ((i2 ==
1) ?
opt_b_ii_sc_eq_1
:
opt_b_ii_sc_eq))
: ((bif ==
lt_b_ii) ? ((i2 ==
0) ? opt_b_ii_sc_lt_0 : ((i2 ==
1) ?
opt_b_ii_sc_lt_1
: ((i2 ==
2) ?
opt_b_ii_sc_lt_2
:
opt_b_ii_sc_lt)))
: ((bif ==
gt_b_ii) ? ((i2 ==
0) ? opt_b_ii_sc_gt_0 : opt_b_ii_sc_gt)
: ((bif ==
leq_b_ii) ? ((i2 ==
0) ? opt_b_ii_sc_leq_0 :
opt_b_ii_sc_leq) : ((bif ==
geq_b_ii)
? ((i2 ==
0) ?
opt_b_ii_sc_geq_0
:
opt_b_ii_sc_geq)
: (((b7if ==
logbit_b_7ii)
&& (i2 >= 0)
&& (i2 <
S7_INT_BITS))
?
opt_b_7ii_sc_bit
: ((bif) ?
opt_b_ii_sc
:
opt_b_7ii_sc))))));
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if ((bif) && (int_optimize(sc, cddr(car_x)))) {
opc->v[0].fb =
(bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
return (true);
}
return_false(sc, car_x);
}
if (!bif)
return_false(sc, car_x);
if (is_symbol(arg2)) {
opc->v[10].o1 = sc->opts[sc->pc];
if (!int_optimize(sc, cdr(car_x)))
return_false(sc, car_x);
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[2].p = lookup_slot_from(arg2, sc->curlet);
opc->v[0].fb = opt_b_ii_fs;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[11].fi = opc->v[10].o1->v[0].fi;
if (is_t_integer(arg2)) {
opc->v[2].i = integer(arg2);
opc->v[0].fb =
(bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc;
return (true);
}
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[9].fi = opc->v[8].o1->v[0].fi;
opc->v[0].fb = opt_b_ii_ff;
return (true);
}
}
return_false(sc, car_x);
}
/* -------- b_or|and -------- */
static bool opt_and_bb(opt_info * o)
{
return ((o->v[3].fb(o->v[2].o1)) ? o->v[11].fb(o->v[10].o1) : false);
}
static bool opt_and_any_b(opt_info * o)
{
int32_t i;
for (i = 0; i < o->v[1].i; i++) {
opt_info *o1;
o1 = o->v[i + 3].o1;
if (!o1->v[0].fb(o1))
return (false);
}
return (true);
}
static bool opt_or_bb(opt_info * o)
{
return ((o->v[3].fb(o->v[2].o1)) ? true : o->v[11].fb(o->v[10].o1));
}
static bool opt_or_any_b(opt_info * o)
{
int32_t i;
for (i = 0; i < o->v[1].i; i++) {
opt_info *o1;
o1 = o->v[i + 3].o1;
if (o1->v[0].fb(o1))
return (true);
}
return (false);
}
static bool opt_b_or_and(s7_scheme * sc, s7_pointer car_x, int32_t len,
int32_t is_and)
{
opt_info *opc;
s7_pointer p;
int32_t i;
opc = alloc_opo(sc);
if (len == 3) {
opt_info *o1 = sc->opts[sc->pc];
if (bool_optimize_nw(sc, cdr(car_x))) {
opt_info *o2 = sc->opts[sc->pc];
if (bool_optimize_nw(sc, cddr(car_x))) {
opc->v[10].o1 = o2;
opc->v[11].fb = o2->v[0].fb;
opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb;
opc->v[2].o1 = o1;
opc->v[3].fb = o1->v[0].fb;
return (true);
}
}
return_false(sc, car_x);
}
opc->v[1].i = (len - 1);
for (i = 0, p = cdr(car_x); (is_pair(p)) && (i < 12); i++, p = cdr(p)) {
opc->v[i + 3].o1 = sc->opts[sc->pc];
if (!bool_optimize_nw(sc, p))
break;
}
if (!is_null(p))
return_false(sc, car_x);
opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b;
return (true);
}
static bool opt_b_and(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
return (opt_b_or_and(sc, car_x, len, true));
}
static bool opt_b_or(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
return (opt_b_or_and(sc, car_x, len, false));
}
/* ---------------------------------------- cell opts ---------------------------------------- */
static s7_pointer opt_p_c(opt_info * o)
{
return (o->v[1].p);
}
static s7_pointer opt_p_s(opt_info * o)
{
return (slot_value(o->v[1].p));
}
static bool opt_cell_not_pair(s7_scheme * sc, s7_pointer car_x)
{
s7_pointer p;
opt_info *opc;
if (!is_symbol(car_x)) {
opc = alloc_opo(sc);
opc->v[1].p = car_x;
opc->v[0].fp = opt_p_c;
return (true);
}
p = opt_simple_symbol(sc, car_x);
if (!p)
return_false(sc, car_x);
opc = alloc_opo(sc);
opc->v[1].p = p;
opc->v[0].fp = opt_p_s;
return (true);
}
/* -------- p -------- */
#define is_opt_safe(P) ((optimize_op(P) >= OP_SAFE_C_S) && (!is_unknown_op(optimize_op(P))))
#define cf_call(Sc, Car_x, S_func, Num) \
(((is_optimized(Car_x)) && (is_opt_safe(Car_x))) ? fn_proc(Car_x) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, Car_x, false)))
static s7_pointer opt_p_f(opt_info * o)
{
return (o->v[1].p_f(opt_sc(o)));
}
static s7_pointer opt_p_call(opt_info * o)
{
return (o->v[1].call(opt_sc(o), opt_sc(o)->nil));
}
static bool p_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_p_t func;
func = s7_p_function(s_func);
if (func) {
opc->v[1].p_f = func;
opc->v[0].fp = opt_p_f;
return (true);
}
if ((is_safe_procedure(s_func)) &&
(c_function_required_args(s_func) == 0)) {
opc->v[1].call = cf_call(sc, car_x, s_func, 0);
opc->v[0].fp = opt_p_call;
return (true);
}
return_false(sc, car_x);
}
/* -------- p_p -------- */
static s7_pointer opt_p_p_c(opt_info * o)
{
return (o->v[2].p_p_f(opt_sc(o), o->v[1].p));
}
static s7_pointer opt_p_i_c(opt_info * o)
{
return (make_integer(opt_sc(o), o->v[2].i_i_f(o->v[1].i)));
}
static s7_pointer opt_p_7i_c(opt_info * o)
{
return (make_integer(opt_sc(o), o->v[2].i_7i_f(opt_sc(o), o->v[1].i)));
}
static s7_pointer opt_p_d_c(opt_info * o)
{
return (make_real(opt_sc(o), o->v[2].d_d_f(o->v[1].x)));
}
static s7_pointer opt_p_7d_c(opt_info * o)
{
return (make_real(opt_sc(o), o->v[2].d_7d_f(opt_sc(o), o->v[1].x)));
}
static s7_pointer opt_p_p_s(opt_info * o)
{
return (o->v[2].p_p_f(opt_sc(o), slot_value(o->v[1].p)));
}
static s7_pointer opt_p_p_s_abs(opt_info * o)
{
return (abs_p_p(opt_sc(o), slot_value(o->v[1].p)));
}
static s7_pointer opt_p_p_s_cdr(opt_info * o)
{
s7_pointer p = slot_value(o->v[1].p);
return ((is_pair(p)) ? cdr(p) : cdr_p_p(opt_sc(o), p));
}
static s7_pointer opt_p_p_s_iterate(opt_info * o)
{
return (iterate_p_p(opt_sc(o), slot_value(o->v[1].p)));
}
static s7_pointer opt_p_p_f(opt_info * o)
{
return (o->v[2].p_p_f(opt_sc(o), o->v[4].fp(o->v[3].o1)));
}
static s7_pointer opt_p_p_f1(opt_info * o)
{
return (o->v[2].p_p_f(opt_sc(o),
o->v[3].p_p_f(opt_sc(o),
slot_value(o->v[1].p))));
}
static s7_pointer opt_p_7d_c_random(opt_info * o)
{
return (make_real(opt_sc(o), random_d_7d(opt_sc(o), o->v[1].x)));
}
static s7_pointer opt_p_p_f_exp(opt_info * o)
{
return (exp_p_p(opt_sc(o), o->v[4].fp(o->v[3].o1)));
}
static bool p_p_f_combinable(s7_scheme * sc, opt_info * opc)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if (o1->v[0].fp == opt_p_p_s) {
opc->v[3].p_p_f = o1->v[2].p_p_f;
opc->v[1].p = o1->v[1].p;
opc->v[0].fp = opt_p_p_f1;
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static s7_pointer opt_p_call_f(opt_info * o)
{
return (o->v[2].call(opt_sc(o),
set_plist_1(opt_sc(o), o->v[5].fp(o->v[4].o1))));
}
static s7_pointer opt_p_call_s(opt_info * o)
{
return (o->v[2].call(opt_sc(o),
set_plist_1(opt_sc(o), slot_value(o->v[1].p))));
}
static s7_pointer opt_p_call_c(opt_info * o)
{
return (o->v[2].call(opt_sc(o), set_plist_1(opt_sc(o), o->v[1].p)));
}
static bool p_p_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_p_p_t ppf;
int32_t start = sc->pc;
if (is_t_integer(cadr(car_x))) {
s7_i_i_t iif;
s7_i_7i_t i7if;
opc->v[1].i = integer(cadr(car_x));
iif = s7_i_i_function(s_func);
if (iif) {
opc->v[2].i_i_f = iif;
opc->v[0].fp = opt_p_i_c;
return (true);
}
i7if = s7_i_7i_function(s_func);
if (i7if) {
opc->v[2].i_7i_f = i7if;
opc->v[0].fp = opt_p_7i_c;
return (true);
}
}
if (is_t_real(cadr(car_x))) {
s7_d_d_t ddf;
s7_d_7d_t d7df;
opc->v[1].x = real(cadr(car_x));
ddf = s7_d_d_function(s_func);
if (ddf) {
opc->v[2].d_d_f = ddf;
opc->v[0].fp = opt_p_d_c;
return (true);
}
d7df = s7_d_7d_function(s_func);
if (d7df) {
opc->v[2].d_7d_f = d7df;
opc->v[0].fp =
(d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c;
return (true);
}
}
ppf = s7_p_p_function(s_func);
if (ppf) {
opt_info *o1;
opc->v[2].p_p_f = ppf;
if ((ppf == symbol_to_string_p_p) &&
(is_optimized(car_x)) &&
(fn_proc(car_x) == g_symbol_to_string_uncopied))
opc->v[2].p_p_f = symbol_to_string_uncopied_p;
if (is_symbol(cadr(car_x))) {
opc->v[1].p = opt_simple_symbol(sc, cadr(car_x));
if (!opc->v[1].p)
return_false(sc, car_x);
opc->v[0].fp =
(ppf ==
abs_p_p) ? opt_p_p_s_abs : ((ppf ==
cdr_p_p) ? opt_p_p_s_cdr
: ((ppf ==
iterate_p_p) ?
opt_p_p_s_iterate :
opt_p_p_s));
return (true);
}
if (!is_pair(cadr(car_x))) {
opc->v[1].p = cadr(car_x);
opc->v[0].fp = opt_p_p_c;
return (true);
}
o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) {
if (!p_p_f_combinable(sc, opc)) {
opc->v[0].fp = opt_p_p_f;
if (ppf == exp_p_p)
opc->v[0].fp = opt_p_p_f_exp;
else if (caadr(car_x) == sc->string_ref_symbol) {
if (opc->v[2].p_p_f == char_upcase_p_p)
opc->v[2].p_p_f = char_upcase_p_p_unchecked;
else if (opc->v[2].p_p_f == is_char_whitespace_p_p)
opc->v[2].p_p_f = is_char_whitespace_p_p_unchecked;
}
opc->v[3].o1 = o1;
opc->v[4].fp = o1->v[0].fp;
}
return (true);
}
}
pc_fallback(sc, start);
if ((is_safe_procedure(s_func)) &&
(c_function_required_args(s_func) <= 1) &&
(c_function_all_args(s_func) >= 1)) {
s7_pointer slot;
opc->v[2].call = cf_call(sc, car_x, s_func, 1);
if (is_symbol(cadr(car_x))) {
slot = opt_simple_symbol(sc, cadr(car_x));
if (slot) {
opc->v[1].p = slot;
opc->v[0].fp = opt_p_call_s;
return (true);
}
} else {
opt_info *o1;
if (!is_pair(cadr(car_x))) {
opc->v[1].p = cadr(car_x);
opc->v[0].fp = opt_p_call_c;
return (true);
}
o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) {
opc->v[0].fp = opt_p_call_f;
opc->v[4].o1 = o1;
opc->v[5].fp = o1->v[0].fp;
return (true);
}
}
}
return_false(sc, car_x);
}
/* -------- p_i -------- */
static s7_pointer opt_p_i_s(opt_info * o)
{
return (o->v[2].p_i_f(opt_sc(o), integer(slot_value(o->v[1].p))));
}
static s7_pointer opt_p_i_f(opt_info * o)
{
return (o->v[2].p_i_f(opt_sc(o), o->v[4].fi(o->v[3].o1)));
}
static s7_pointer opt_p_i_f_intc(opt_info * o)
{
return (integer_to_char_p_i(opt_sc(o), o->v[4].fi(o->v[3].o1)));
}
static bool p_i_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, int32_t pstart)
{
s7_pointer p;
s7_p_i_t ifunc;
ifunc = s7_p_i_function(s_func);
if (!ifunc)
return_false(sc, car_x);
p = opt_integer_symbol(sc, cadr(car_x));
if (p) {
opc->v[1].p = p;
opc->v[2].p_i_f = ifunc;
opc->v[0].fp = opt_p_i_s;
return (true);
}
if (int_optimize(sc, cdr(car_x))) {
opc->v[2].p_i_f = ifunc;
opc->v[0].fp =
(ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f;
opc->v[3].o1 = sc->opts[pstart];
opc->v[4].fi = sc->opts[pstart]->v[0].fi;
return (true);
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
/* -------- p_ii -------- */
static s7_pointer opt_p_ii_ss(opt_info * o)
{
return (o->v[3].p_ii_f(opt_sc(o), integer(slot_value(o->v[1].p)),
integer(slot_value(o->v[2].p))));
}
static s7_pointer opt_p_ii_fs(opt_info * o)
{
return (o->v[3].p_ii_f(opt_sc(o), o->v[11].fi(o->v[10].o1),
integer(slot_value(o->v[2].p))));
}
static s7_pointer opt_p_ii_ff_divide(opt_info * o)
{
return (s7_make_ratio
(opt_sc(o), o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));
}
static s7_pointer opt_p_ii_ff(opt_info * o)
{
s7_int i1;
i1 = o->v[11].fi(o->v[10].o1);
return (o->v[3].p_ii_f(opt_sc(o), i1, o->v[9].fi(o->v[8].o1)));
}
static bool p_ii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, int32_t pstart)
{
s7_pointer p2;
s7_p_ii_t ifunc;
ifunc = s7_p_ii_function(s_func);
if (!ifunc)
return_false(sc, car_x);
p2 = opt_integer_symbol(sc, caddr(car_x));
if (p2) {
s7_pointer p1;
p1 = opt_integer_symbol(sc, cadr(car_x));
if (p1) {
opc->v[1].p = p1;
opc->v[2].p = p2;
opc->v[3].p_ii_f = ifunc;
opc->v[0].fp = opt_p_ii_ss;
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[2].p = p2;
opc->v[3].p_ii_f = ifunc;
opc->v[0].fp = opt_p_ii_fs;
return (true);
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
opc->v[3].p_ii_f = ifunc;
opc->v[0].fp =
(ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff;
return (true);
}
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
/* -------- p_d -------- */
static s7_pointer opt_p_d_s(opt_info * o)
{
return (o->v[2].p_d_f(opt_sc(o),
real_to_double(opt_sc(o), slot_value(o->v[1].p),
"p_d")));
}
static s7_pointer opt_p_d_f(opt_info * o)
{
return (o->v[2].p_d_f(opt_sc(o), o->v[4].fd(o->v[3].o1)));
}
static bool p_d_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, int32_t pstart)
{
s7_pointer p;
opt_info *o1;
s7_p_d_t ifunc;
ifunc = s7_p_d_function(s_func);
if (!ifunc)
return_false(sc, car_x);
p = opt_float_symbol(sc, cadr(car_x));
if (p) {
opc->v[1].p = p;
opc->v[2].p_d_f = ifunc;
opc->v[0].fp = opt_p_d_s;
return (true);
}
if ((is_number(cadr(car_x))) && (!is_t_real(cadr(car_x))))
return_false(sc, car_x);
o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x))) {
opc->v[2].p_d_f = ifunc;
opc->v[0].fp = opt_p_d_f;
opc->v[3].o1 = o1;
opc->v[4].fd = o1->v[0].fd;
return (true);
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
/* -------- p_dd -------- */
static s7_pointer opt_p_dd_sc(opt_info * o)
{
return (o->v[3].p_dd_f(opt_sc(o),
real_to_double(opt_sc(o), slot_value(o->v[1].p),
"p_dd"), o->v[2].x));
}
static s7_pointer opt_p_dd_cs(opt_info * o)
{
return (o->v[3].p_dd_f(opt_sc(o), o->v[2].x,
real_to_double(opt_sc(o), slot_value(o->v[1].p),
"p_dd")));
}
static s7_pointer opt_p_dd_cc(opt_info * o)
{
return (o->v[3].p_dd_f(opt_sc(o), o->v[1].x, o->v[2].x));
}
static bool p_dd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, int32_t pstart)
{
s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x);
s7_p_dd_t ifunc;
ifunc = s7_p_dd_function(s_func);
if (!ifunc)
return_false(sc, car_x);
if (is_t_real(arg2)) {
if (is_t_real(arg1)) {
opc->v[1].x = real(arg1);
opc->v[2].x = real(arg2);
opc->v[3].p_dd_f = ifunc;
opc->v[0].fp = opt_p_dd_cc;
return (true);
}
slot = opt_real_symbol(sc, arg1);
if (slot) {
opc->v[2].x = real(arg2);
opc->v[1].p = slot;
opc->v[3].p_dd_f = ifunc;
opc->v[0].fp = opt_p_dd_sc;
return (true);
}
}
if (is_t_real(arg1)) {
slot = opt_real_symbol(sc, arg2);
if (slot) {
opc->v[2].x = real(arg1);
opc->v[1].p = slot;
opc->v[3].p_dd_f = ifunc;
opc->v[0].fp = opt_p_dd_cs;
return (true);
}
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
/* -------- p_pi -------- */
static s7_pointer opt_p_pi_ss(opt_info * o)
{
return (o->v[3].p_pi_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))));
}
static s7_pointer opt_p_pi_ss_sref(opt_info * o)
{
return (string_ref_p_pi_unchecked
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))));
}
static s7_pointer opt_p_pi_ss_vref(opt_info * o)
{
return (normal_vector_ref_p_pi_unchecked
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))));
}
static s7_pointer opt_p_pi_ss_lref(opt_info * o)
{
return (list_ref_p_pi_unchecked
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p))));
}
static s7_pointer opt_p_pi_sc(opt_info * o)
{
return (o->v[3].p_pi_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].i));
}
static s7_pointer opt_p_pi_sc_lref(opt_info * o)
{
return (list_ref_p_pi_unchecked
(opt_sc(o), slot_value(o->v[1].p), o->v[2].i));
}
static s7_pointer opt_p_pi_sf(opt_info * o)
{
return (o->v[3].p_pi_f(opt_sc(o), slot_value(o->v[1].p),
o->v[5].fi(o->v[4].o1)));
}
static s7_pointer opt_p_pi_sf_sref(opt_info * o)
{
return (string_ref_p_pi_unchecked
(opt_sc(o), slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));
}
static s7_pointer opt_p_pi_fc(opt_info * o)
{
return (o->v[3].p_pi_f(opt_sc(o), o->v[5].fp(o->v[4].o1), o->v[2].i));
}
/* use a unique name for this use of denominator (need to remember that any such integer should be new (i.e. mutable, not a small int) */
#define do_loop_end(A) denominator(T_Int(A))
#define set_do_loop_end(A, B) denominator(T_Int(A)) = B
static void check_unchecked(s7_scheme * sc, s7_pointer obj,
s7_pointer slot, opt_info * opc,
s7_pointer expr)
{
switch (type(obj)) { /* can't use funcs here (opc->v[3].p_pi_f et al) because there are so many, and copy depends on this choice */
case T_STRING:
if (((!expr) || (car(expr) == sc->string_ref_symbol))
&& (do_loop_end(slot_value(slot)) <= string_length(obj)))
opc->v[3].p_pi_f = string_ref_unchecked;
break;
case T_BYTE_VECTOR:
if (((!expr) || (car(expr) == sc->byte_vector_ref_symbol)
|| (car(expr) == sc->vector_ref_symbol))
&& (do_loop_end(slot_value(slot)) <= byte_vector_length(obj)))
opc->v[3].p_pi_f = byte_vector_ref_unchecked_p;
break;
case T_VECTOR:
if (((!expr) || (car(expr) == sc->vector_ref_symbol))
&& (do_loop_end(slot_value(slot)) <= vector_length(obj)))
opc->v[3].p_pi_f = vector_ref_unchecked;
break;
case T_FLOAT_VECTOR:
if (((!expr) || (car(expr) == sc->float_vector_ref_symbol)
|| (car(expr) == sc->vector_ref_symbol))
&& (do_loop_end(slot_value(slot)) <= vector_length(obj)))
opc->v[3].p_pi_f = float_vector_ref_unchecked_p;
break;
case T_INT_VECTOR:
if (((!expr) || (car(expr) == sc->int_vector_ref_symbol)
|| (car(expr) == sc->vector_ref_symbol))
&& (do_loop_end(slot_value(slot)) <= vector_length(obj)))
opc->v[3].p_pi_f = int_vector_ref_unchecked_p;
break;
}
}
static bool p_pi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer sig, s7_pointer car_x)
{
s7_pointer obj = NULL, slot1, checker = NULL;
opt_info *o1;
s7_p_pi_t func;
func = s7_p_pi_function(s_func);
if (!func)
return_false(sc, car_x);
/* here we know cadr is a symbol */
slot1 = opt_simple_symbol(sc, cadr(car_x));
if (!slot1)
return_false(sc, car_x);
if ((is_any_vector(slot_value(slot1))) &&
(vector_rank(slot_value(slot1)) > 1))
return_false(sc, car_x);
opc->v[3].p_pi_f = func;
opc->v[1].p = slot1;
if (is_symbol(cadr(sig)))
checker = cadr(sig);
if ((s7_p_pi_unchecked_function(s_func)) && (checker)) {
obj = slot_value(opc->v[1].p);
if ((is_string(obj)) || (is_pair(obj)) || (is_any_vector(obj))) {
if (((is_string(obj)) && (checker == sc->is_string_symbol)) ||
((is_any_vector(obj)) && (checker == sc->is_vector_symbol))
|| ((is_pair(obj)) && (checker == sc->is_pair_symbol))
|| ((is_byte_vector(obj))
&& (checker == sc->is_byte_vector_symbol)))
opc->v[3].p_pi_f =
(is_normal_vector(obj)) ?
normal_vector_ref_p_pi_unchecked :
s7_p_pi_unchecked_function(s_func);
}
}
slot1 = opt_integer_symbol(sc, caddr(car_x));
if (slot1) {
opc->v[0].fp =
(opc->v[3].p_pi_f ==
string_ref_p_pi_unchecked) ? opt_p_pi_ss_sref : ((opc->
v[3].p_pi_f
==
normal_vector_ref_p_pi_unchecked)
?
opt_p_pi_ss_vref
: ((opc->v
[3].p_pi_f
==
list_ref_p_pi_unchecked)
?
opt_p_pi_ss_lref
:
opt_p_pi_ss));
opc->v[2].p = slot1;
if ((obj) && (is_step_end(slot1)))
check_unchecked(sc, obj, slot1, opc, car_x);
return (true);
}
if (is_t_integer(caddr(car_x))) {
opc->v[2].i = integer(caddr(car_x));
opc->v[0].fp =
(opc->v[3].p_pi_f ==
list_ref_p_pi_unchecked) ? opt_p_pi_sc_lref : opt_p_pi_sc;
return (true);
}
o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[0].fp =
(opc->v[3].p_pi_f ==
string_ref_p_pi_unchecked) ? opt_p_pi_sf_sref : opt_p_pi_sf;
opc->v[4].o1 = o1;
opc->v[5].fi = o1->v[0].fi;
return (true);
}
return_false(sc, car_x);
}
static s7_pointer opt_p_pi_fco(opt_info * o)
{
return (o->v[3].p_pi_f(opt_sc(o),
o->v[4].p_p_f(opt_sc(o), slot_value(o->v[1].p)),
o->v[2].i));
}
static bool p_pi_fc_combinable(s7_scheme * sc, opt_info * opc)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if (o1->v[0].fp == opt_p_p_s) {
opc->v[4].p_p_f = o1->v[2].p_p_f;
opc->v[1].p = o1->v[1].p;
opc->v[0].fp = opt_p_pi_fco;
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
/* -------- p_pp -------- */
static s7_pointer opt_p_pp_ss(opt_info * o)
{
return (o->v[3].p_pp_f(opt_sc(o), slot_value(o->v[1].p),
slot_value(o->v[2].p)));
}
static s7_pointer opt_p_pp_sc(opt_info * o)
{
return (o->v[3].p_pp_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].p));
}
static s7_pointer opt_p_pp_cs(opt_info * o)
{
return (o->v[3].p_pp_f(opt_sc(o), o->v[2].p, slot_value(o->v[1].p)));
}
static s7_pointer opt_p_pp_sf(opt_info * o)
{
return (o->v[3].p_pp_f(opt_sc(o), slot_value(o->v[1].p),
o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pp_fs(opt_info * o)
{
return (o->v[3].p_pp_f(opt_sc(o), o->v[5].fp(o->v[4].o1),
slot_value(o->v[1].p)));
}
static s7_pointer opt_p_pp_fc(opt_info * o)
{
return (o->v[3].p_pp_f(opt_sc(o), o->v[5].fp(o->v[4].o1), o->v[2].p));
}
static s7_pointer opt_p_pp_cc(opt_info * o)
{
return (o->v[3].p_pp_f(opt_sc(o), o->v[1].p, o->v[2].p));
}
static s7_pointer opt_set_car_pp_ss(opt_info * o)
{
return (inline_set_car
(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p)));
}
static s7_pointer opt_p_pp_sf_add(opt_info * o)
{
return (add_p_pp
(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pp_sf_sub(opt_info * o)
{
return (subtract_p_pp
(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pp_sf_set_car(opt_info * o)
{
return (inline_set_car
(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pp_sf_set_cdr(opt_info * o)
{
return (inline_set_cdr
(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pp_sf_href(opt_info * o)
{
return (s7_hash_table_ref
(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pp_fs_vref(opt_info * o)
{
return (vector_ref_p_pp
(opt_sc(o), o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));
}
static s7_pointer opt_p_pp_fs_cons(opt_info * o)
{
return (cons
(opt_sc(o), o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));
}
static s7_pointer opt_p_pp_ff(opt_info * o)
{
s7_pointer p1;
p1 = o->v[11].fp(o->v[10].o1);
opt_sc(o)->temp2 = p1; /* feeble GC protection */
return (o->v[3].p_pp_f(opt_sc(o), p1, o->v[9].fp(o->v[8].o1)));
}
static bool p_pp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, int32_t pstart)
{
s7_pointer slot;
s7_p_pp_t func;
func = s7_p_pp_function(s_func);
if (!func)
return_false(sc, car_x);
opc->v[3].p_pp_f = func;
if (is_symbol(cadr(car_x))) {
slot = opt_simple_symbol(sc, cadr(car_x));
if (!slot) {
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
if ((is_any_vector(slot_value(slot))) &&
(vector_rank(slot_value(slot)) > 1)) {
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
opc->v[1].p = slot;
if ((func == hash_table_ref_p_pp)
&& (is_hash_table(slot_value(slot))))
opc->v[3].p_pp_f = s7_hash_table_ref;
if (is_symbol(caddr(car_x))) {
opc->v[2].p = opt_simple_symbol(sc, caddr(car_x));
if (opc->v[2].p) {
opc->v[0].fp =
(func ==
set_car_p_pp) ? opt_set_car_pp_ss : opt_p_pp_ss;
return (true);
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
if ((!is_pair(caddr(car_x))) ||
(is_proper_quote(sc, caddr(car_x)))) {
opc->v[2].p =
(!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x);
opc->v[0].fp = opt_p_pp_sc;
return (true);
}
if (cell_optimize(sc, cddr(car_x))) {
opc->v[0].fp =
(func ==
add_p_pp) ? opt_p_pp_sf_add : ((func ==
subtract_p_pp) ?
opt_p_pp_sf_sub
: ((func ==
set_car_p_pp) ?
opt_p_pp_sf_set_car
: ((func ==
set_cdr_p_pp) ?
opt_p_pp_sf_set_cdr
: ((opc->
v[3].p_pp_f ==
s7_hash_table_ref)
? opt_p_pp_sf_href
: opt_p_pp_sf))));
opc->v[4].o1 = sc->opts[pstart];
opc->v[5].fp = sc->opts[pstart]->v[0].fp;
return (true);
}
} else {
opt_info *o1 = sc->opts[sc->pc];
if ((!is_pair(cadr(car_x))) || (is_proper_quote(sc, cadr(car_x)))) {
opc->v[1].p =
(!is_pair(cadr(car_x))) ? cadr(car_x) : cadadr(car_x);
if ((!is_symbol(caddr(car_x)))
&& ((!is_pair(caddr(car_x)))
|| (is_proper_quote(sc, caddr(car_x))))) {
opc->v[2].p =
(!is_pair(caddr(car_x))) ? caddr(car_x) :
cadaddr(car_x);
opc->v[0].fp = opt_p_pp_cc;
return (true);
}
if (is_symbol(caddr(car_x))) {
opc->v[2].p = opc->v[1].p;
opc->v[1].p = opt_simple_symbol(sc, caddr(car_x));
if (opc->v[1].p) {
opc->v[0].fp = opt_p_pp_cs;
return (true);
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
}
if (cell_optimize(sc, cdr(car_x))) {
if (is_symbol(caddr(car_x))) {
opc->v[1].p = opt_simple_symbol(sc, caddr(car_x));
if (opc->v[1].p) {
opc->v[0].fp =
(func ==
vector_ref_p_pp) ? opt_p_pp_fs_vref : ((func ==
cons_p_pp)
?
opt_p_pp_fs_cons
:
opt_p_pp_fs);
opc->v[4].o1 = o1;
opc->v[5].fp = o1->v[0].fp;
return (true);
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
if ((!is_pair(caddr(car_x))) ||
(is_proper_quote(sc, caddr(car_x)))) {
if (is_t_integer(caddr(car_x))) {
s7_p_pi_t ifunc;
ifunc = s7_p_pi_function(s_func);
if (ifunc) {
opc->v[2].i = integer(caddr(car_x));
opc->v[3].p_pi_f = ifunc;
if (!p_pi_fc_combinable(sc, opc)) {
opc->v[0].fp = opt_p_pi_fc;
opc->v[4].o1 = o1;
opc->v[5].fp = o1->v[0].fp;
}
return (true);
}
}
opc->v[2].p =
(!is_pair(caddr(car_x))) ? caddr(car_x) :
cadaddr(car_x);
opc->v[0].fp = opt_p_pp_fc;
opc->v[4].o1 = o1;
opc->v[5].fp = o1->v[0].fp;
return (true);
}
opc->v[8].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opc->v[10].o1 = o1;
opc->v[11].fp = o1->v[0].fp;
opc->v[9].fp = opc->v[8].o1->v[0].fp;
opc->v[0].fp = opt_p_pp_ff;
return (true);
}
}
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
/* -------- p_call_pp -------- */
static s7_pointer opt_p_call_ff(opt_info * o)
{
s7_pointer po2;
s7_scheme *sc = opt_sc(o);
gc_protect_via_stack(sc, o->v[11].fp(o->v[10].o1));
po2 = o->v[9].fp(o->v[8].o1);
po2 = o->v[3].call(sc, set_plist_2(sc, stack_protected1(sc), po2));
unstack(sc);
return (po2);
}
static s7_pointer opt_p_call_fs(opt_info * o)
{
s7_pointer po1;
po1 = o->v[11].fp(o->v[10].o1);
return (o->v[3].call(opt_sc(o),
set_plist_2(opt_sc(o), po1,
slot_value(o->v[1].p))));
}
static s7_pointer opt_p_call_sf(opt_info * o)
{
s7_pointer po1;
po1 = o->v[11].fp(o->v[10].o1);
return (o->v[3].call(opt_sc(o),
set_plist_2(opt_sc(o), slot_value(o->v[1].p),
po1)));
}
static s7_pointer opt_p_call_sc(opt_info * o)
{
return (o->v[3].call(opt_sc(o),
set_plist_2(opt_sc(o), slot_value(o->v[1].p),
o->v[2].p)));
}
static s7_pointer opt_p_call_ss(opt_info * o)
{
return (o->v[3].call(opt_sc(o),
set_plist_2(opt_sc(o), slot_value(o->v[1].p),
slot_value(o->v[2].p))));
}
static bool p_call_pp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x, int32_t pstart)
{
if ((is_safe_procedure(s_func)) &&
(c_function_required_args(s_func) <= 2) &&
(c_function_all_args(s_func) >= 2)) {
/* if optimized, we want to use the current fn_proc (to take advantage of fixups like substring_temp),
* but those same fixups are incorrect for this context if op_safe_c_c related.
*/
opc->v[3].call = cf_call(sc, car_x, s_func, 2);
if (is_symbol(cadr(car_x))) {
opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet);
if ((is_slot(opc->v[1].p)) &&
(!has_methods(slot_value(opc->v[1].p)))) {
if (is_symbol(caddr(car_x))) {
opc->v[2].p = opt_simple_symbol(sc, caddr(car_x));
if (opc->v[2].p) {
opc->v[0].fp = opt_p_call_ss;
return (true);
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
if (!is_pair(caddr(car_x))) {
opc->v[2].p = caddr(car_x);
opc->v[0].fp = opt_p_call_sc;
return (true);
}
if (cell_optimize(sc, cddr(car_x))) {
opc->v[10].o1 = sc->opts[pstart];
opc->v[11].fp = opc->v[10].o1->v[0].fp;
opc->v[0].fp = opt_p_call_sf;
return (true);
}
} else {
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
}
opc->v[10].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) {
opc->v[11].fp = opc->v[10].o1->v[0].fp;
if (is_symbol(caddr(car_x))) {
opc->v[1].p = opt_simple_symbol(sc, caddr(car_x));
if (opc->v[1].p) {
opc->v[0].fp = opt_p_call_fs;
return (true);
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
opc->v[8].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opc->v[9].fp = opc->v[8].o1->v[0].fp;
opc->v[0].fp = opt_p_call_ff;
return (true);
}
}
}
pc_fallback(sc, pstart);
return_false(sc, car_x);
}
/* -------- p_pip --------*/
static s7_pointer opt_p_pip_ssf(opt_info * o)
{
return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pip_ssf_sset(opt_info * o)
{
return (string_set_unchecked
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pip_ssf_vset(opt_info * o)
{
return (vector_set_p_pip_unchecked
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_pip_sss(opt_info * o)
{
return (o->v[4].p_pip_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
slot_value(o->v[3].p)));
}
static s7_pointer opt_p_pip_sss_vset(opt_info * o)
{
return (vector_set_p_pip_unchecked
(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));
}
static s7_pointer opt_p_pip_ssc(opt_info * o)
{
return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)), o->v[4].p));
}
static s7_pointer opt_p_pip_c(opt_info * o)
{
return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[5].p_p_f(opt_sc(o), o->v[4].p)));
}
static s7_pointer opt_p_pip_sff(opt_info * o)
{
s7_int i1;
i1 = o->v[11].fi(o->v[10].o1);
return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p), i1,
o->v[9].fp(o->v[8].o1)));
}
static s7_pointer opt_p_pip_sff_lset(opt_info * o)
{
s7_int i1;
i1 = o->v[11].fi(o->v[10].o1);
return (list_set_p_pip_unchecked
(opt_sc(o), slot_value(o->v[1].p), i1,
o->v[9].fp(o->v[8].o1)));
}
static s7_pointer opt_p_pip_sso(opt_info * o)
{
return (o->v[5].p_pip_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[6].p_pi_f(opt_sc(o),
slot_value(o->v[3].p),
integer(slot_value
(o->v[4].p)))));
}
static s7_pointer opt_p_pip_ssf1(opt_info * o)
{
return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[4].p_p_f(opt_sc(o),
o->v[6].fp(o->v[5].o1))));
}
static bool p_pip_ssf_combinable(s7_scheme * sc, opt_info * opc,
int32_t start)
{
opt_info *o1;
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
o1 = sc->opts[sc->pc - 1];
if ((o1->v[0].fp == opt_p_pi_ss)
|| (o1->v[0].fp == opt_p_pi_ss_sref)
|| (o1->v[0].fp == opt_p_pi_ss_vref)
|| (o1->v[0].fp == opt_p_pi_ss_lref)) {
opc->v[5].p_pip_f = opc->v[3].p_pip_f;
opc->v[6].p_pi_f = o1->v[3].p_pi_f;
opc->v[3].p = o1->v[1].p;
opc->v[4].p = o1->v[2].p;
opc->v[0].fp = opt_p_pip_sso;
backup_pc(sc);
return (true);
}
if (o1->v[0].fp == opt_p_p_c) {
opc->v[5].p_p_f = o1->v[2].p_p_f;
opc->v[4].p = o1->v[1].p;
backup_pc(sc);
opc->v[0].fp = opt_p_pip_c;
return (true);
}
}
o1 = sc->opts[start];
if (o1->v[0].fp != opt_p_p_f)
return_false(sc, NULL);
opc->v[4].p_p_f = o1->v[2].p_p_f;
opc->v[5].o1 = sc->opts[start + 1];
opc->v[6].fp = sc->opts[start + 1]->v[0].fp;
opc->v[0].fp = opt_p_pip_ssf1;
return (true);
}
static bool p_pip_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_p_pip_t func;
s7_pointer obj, slot1, sig, checker = NULL;
func = s7_p_pip_function(s_func);
if (!func)
return_false(sc, car_x);
sig = c_function_signature(s_func);
if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_symbol(cadr(sig))))
checker = cadr(sig);
/* here we know cadr is a symbol */
slot1 = lookup_slot_from(cadr(car_x), sc->curlet);
if ((!is_slot(slot1)) ||
(has_methods(slot_value(slot1))) ||
(is_immutable(slot_value(slot1))))
return_false(sc, car_x);
if ((is_any_vector(slot_value(slot1))) &&
(vector_rank(slot_value(slot1)) > 1))
return_false(sc, car_x);
opc->v[1].p = slot1;
obj = slot_value(opc->v[1].p);
opc->v[3].p_pip_f = func;
if ((s7_p_pip_unchecked_function(s_func)) && (checker)) {
if ((is_normal_vector(obj)) && (checker == sc->is_vector_symbol))
opc->v[3].p_pip_f =
(is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked :
vector_set_p_pip_unchecked;
else if ((is_pair(obj)) && (checker == sc->is_pair_symbol)) /* avoid dumb mismatch in val_type and sig below, #t integer:any? and integer? integer:any? */
opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func);
else {
s7_pointer val_type;
val_type = opt_arg_type(sc, cdddr(car_x));
if ((val_type == cadddr(sig)) &&
(((is_string(obj)) && (checker == sc->is_string_symbol)) ||
((is_float_vector(obj))
&& (checker == sc->is_float_vector_symbol))
|| ((is_int_vector(obj))
&& (checker == sc->is_int_vector_symbol))
|| ((is_byte_vector(obj))
&& (checker == sc->is_byte_vector_symbol))))
opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func);
}
}
if (is_symbol(caddr(car_x))) {
s7_pointer slot2;
int32_t start = sc->pc;
slot2 = opt_integer_symbol(sc, caddr(car_x));
if (slot2) {
opc->v[2].p = slot2;
if (is_step_end(slot2))
switch (type(obj)) {
case T_VECTOR:
if (do_loop_end(slot_value(slot2)) <=
vector_length(obj))
opc->v[3].p_pip_f =
(is_typed_vector(obj)) ?
typed_vector_set_unchecked :
vector_set_unchecked;
break;
case T_INT_VECTOR:
if (do_loop_end(slot_value(slot2)) <=
vector_length(obj))
opc->v[3].p_pip_f = int_vector_set_unchecked_p;
break;
case T_FLOAT_VECTOR:
if (do_loop_end(slot_value(slot2)) <=
vector_length(obj))
opc->v[3].p_pip_f = float_vector_set_unchecked_p;
break;
case T_STRING:
if (do_loop_end(slot_value(slot2)) <=
string_length(obj))
opc->v[3].p_pip_f = string_set_unchecked;
break;
case T_BYTE_VECTOR:
if (do_loop_end(slot_value(slot2)) <=
vector_length(obj))
opc->v[3].p_pip_f = byte_vector_set_unchecked_p;
break;
} /* T_PAIR here would require list_length check which sort of defeats the purpose */
if (is_symbol(cadddr(car_x))) {
s7_pointer val_slot;
val_slot = opt_simple_symbol(sc, cadddr(car_x));
if (val_slot) {
opc->v[4].p_pip_f = opc->v[3].p_pip_f;
opc->v[3].p = val_slot;
opc->v[0].fp =
(opc->v[4].p_pip_f ==
vector_set_p_pip_unchecked) ? opt_p_pip_sss_vset :
opt_p_pip_sss;
return (true);
}
} else
if ((!is_pair(cadddr(car_x))) ||
(is_proper_quote(sc, cadddr(car_x)))) {
opc->v[4].p =
(is_pair(cadddr(car_x))) ? cadr(cadddr(car_x)) :
cadddr(car_x);
opc->v[0].fp = opt_p_pip_ssc;
return (true);
}
if (cell_optimize(sc, cdddr(car_x))) {
if (p_pip_ssf_combinable(sc, opc, start))
return (true);
opc->v[0].fp =
(opc->v[3].p_pip_f ==
string_set_unchecked) ? opt_p_pip_ssf_sset
: ((opc->v[3].p_pip_f == vector_set_p_pip_unchecked)
? opt_p_pip_ssf_vset : opt_p_pip_ssf);
opc->v[4].o1 = sc->opts[start];
opc->v[5].fp = sc->opts[start]->v[0].fp;
return (true);
}
}
} else { /* not symbol caddr */
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdddr(car_x))) {
opc->v[0].fp =
(opc->v[3].p_pip_f ==
list_set_p_pip_unchecked) ? opt_p_pip_sff_lset :
opt_p_pip_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fp = opc->v[8].o1->v[0].fp;
return (true);
}
}
}
return_false(sc, car_x);
}
/* -------- p_piip -------- */
static s7_pointer opt_p_piip_sssf(opt_info * o)
{
return (o->v[5].p_piip_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)),
o->v[11].fp(o->v[10].o1)));
}
static s7_pointer vector_set_piip_sssf_unchecked(opt_info * o)
{
s7_pointer val, v = slot_value(o->v[1].p);
val = o->v[11].fp(o->v[10].o1);
vector_element(v,
((integer(slot_value(o->v[2].p)) *
vector_offset(v,
0)) + integer(slot_value(o->v[3].p)))) =
val;
return (val);
}
static s7_pointer opt_p_piip_sssc(opt_info * o)
{
return (o->v[5].p_piip_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)), o->v[4].p));
}
static s7_pointer opt_p_piip_sfff(opt_info * o)
{
s7_int i1, i2;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
return (o->v[5].p_piip_f(opt_sc(o), slot_value(o->v[1].p), i1, i2, o->v[3].fp(o->v[4].o1))); /* v[3] because v[5] is already in use */
}
static bool p_piip_to_sx(s7_scheme * sc, opt_info * opc,
s7_pointer indexp1, s7_pointer indexp2,
s7_pointer valp, s7_pointer obj)
{
s7_pointer slot;
slot = opt_integer_symbol(sc, car(indexp2));
if (!slot)
return_false(sc, indexp1);
opc->v[3].p = slot;
slot = opt_integer_symbol(sc, car(indexp1));
if (slot) {
opc->v[2].p = slot;
if ((is_symbol(car(valp))) || (is_unquoted_pair(car(valp)))) {
opc->v[10].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, valp))
return_false(sc, indexp1);
opc->v[11].fp = opc->v[10].o1->v[0].fp;
opc->v[0].fp = opt_p_piip_sssf;
if ((is_normal_vector(obj)) &&
(step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) &&
(step_end_fits(opc->v[3].p, vector_dimension(obj, 1))))
opc->v[0].fp = vector_set_piip_sssf_unchecked;
return (true);
}
opc->v[0].fp = opt_p_piip_sssc;
opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp);
return (true);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp1)) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp2)) {
opc->v[4].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, valp)) {
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
opc->v[3].fp = opc->v[4].o1->v[0].fp;
opc->v[0].fp = opt_p_piip_sfff;
return (true);
}
}
}
return_false(sc, indexp1);
}
static bool p_piip_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
/* this currently assumes s_func == vector-set! because there aren't any other p_piip functions(!) */
s7_p_piip_t func;
func = s7_p_piip_function(s_func);
if ((func) && (is_symbol(cadr(car_x)))) {
s7_pointer slot1, obj;
slot1 = lookup_slot_from(cadr(car_x), sc->curlet);
if (!is_slot(slot1))
return_false(sc, car_x);
obj = slot_value(slot1);
if ((has_methods(obj)) || (is_immutable(obj)))
return_false(sc, car_x);
if ((is_any_vector(obj)) && /* vector_set_p_piip calls vector_setter(obj) */
(vector_rank(obj) == 2)) {
opc->v[1].p = slot1;
opc->v[5].p_piip_f = vector_set_p_piip;
return (p_piip_to_sx
(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x),
obj));
}
}
return_false(sc, car_x);
}
/* -------- p_pii -------- */
static s7_pointer opt_p_pii_sss(opt_info * o)
{
return (o->v[4].p_pii_f(opt_sc(o), slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p))));
}
static s7_pointer opt_p_pii_sff(opt_info * o)
{
s7_int i1, i2;
i1 = o->v[11].fi(o->v[10].o1);
i2 = o->v[9].fi(o->v[8].o1);
return (o->v[4].p_pii_f(opt_sc(o), slot_value(o->v[1].p), i1, i2));
}
static s7_pointer vector_ref_pii_sss_unchecked(opt_info * o)
{
s7_pointer v = slot_value(o->v[1].p);
return (vector_element
(v,
((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) +
integer(slot_value(o->v[3].p)))));
}
static bool p_pii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_p_pii_t func;
func = s7_p_pii_function(s_func);
if ((func) && (is_symbol(cadr(car_x)))) {
s7_pointer slot1, obj;
slot1 = lookup_slot_from(cadr(car_x), sc->curlet);
if (!is_slot(slot1))
return_false(sc, car_x);
obj = slot_value(slot1);
if ((has_methods(obj)) || (is_immutable(obj)))
return_false(sc, car_x);
if ((is_normal_vector(obj)) && (vector_rank(obj) == 2)) {
s7_pointer slot, indexp1 = cddr(car_x), indexp2 = cdddr(car_x);
opc->v[1].p = slot1;
opc->v[4].p_pii_f = vector_ref_p_pii;
slot = opt_integer_symbol(sc, car(indexp2));
if (slot) {
opc->v[3].p = slot;
slot = opt_integer_symbol(sc, car(indexp1));
if (slot) {
opc->v[2].p = slot;
opc->v[0].fp = opt_p_pii_sss;
/* normal vector rank 2 (see above) */
if ((step_end_fits
(opc->v[2].p,
vector_dimension(slot_value(opc->v[1].p), 0)))
&&
(step_end_fits
(opc->v[3].p,
vector_dimension(slot_value(opc->v[1].p), 1))))
opc->v[0].fp = vector_ref_pii_sss_unchecked;
return (true);
}
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp1)) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp2)) {
opc->v[0].fp = opt_p_pii_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
return (true);
}
}
}
}
return_false(sc, car_x);
}
/* -------- p_ppi -------- */
static s7_pointer opt_p_ppi_psf(opt_info * o)
{
return (o->v[3].p_ppi_f(opt_sc(o), o->v[2].p, slot_value(o->v[1].p),
o->v[5].fi(o->v[4].o1)));
}
static s7_pointer opt_p_ppi_psf_cpos(opt_info * o)
{
return (char_position_p_ppi
(opt_sc(o), o->v[2].p, slot_value(o->v[1].p),
o->v[5].fi(o->v[4].o1)));
}
static bool p_ppi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
int32_t start = sc->pc;
s7_p_ppi_t ifunc;
ifunc = s7_p_ppi_function(s_func);
if (!ifunc)
return_false(sc, car_x);
opc->v[3].p_ppi_f = ifunc;
if ((is_character(cadr(car_x))) &&
(is_symbol(caddr(car_x))) && (int_optimize(sc, cdddr(car_x)))) {
s7_pointer slot;
slot = opt_simple_symbol(sc, caddr(car_x));
if (slot) {
opc->v[2].p = cadr(car_x);
opc->v[1].p = slot;
opc->v[0].fp =
(ifunc ==
char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf;
opc->v[4].o1 = sc->opts[start];
opc->v[5].fi = sc->opts[start]->v[0].fi;
return (true);
}
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- p_ppp -------- */
static s7_pointer opt_p_ppp_ssf(opt_info * o)
{
return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p),
slot_value(o->v[2].p),
o->v[5].fp(o->v[4].o1)));
}
static s7_pointer opt_p_ppp_hash_table_increment(opt_info * o)
{
return (fx_hash_table_increment_1
(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p),
o->v[5].p));
}
static s7_pointer opt_p_ppp_sfs(opt_info * o)
{
return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p),
o->v[5].fp(o->v[4].o1),
slot_value(o->v[2].p)));
}
static s7_pointer opt_p_ppp_scs(opt_info * o)
{
return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p), o->v[4].p,
slot_value(o->v[2].p)));
}
static s7_pointer opt_p_ppp_scs_eset(opt_info * o)
{
return (let_set_1
(opt_sc(o), slot_value(o->v[1].p), o->v[4].p,
slot_value(o->v[2].p)));
}
static s7_pointer opt_p_ppp_sss(opt_info * o)
{
return (o->v[4].p_ppp_f(opt_sc(o), slot_value(o->v[1].p),
slot_value(o->v[2].p), slot_value(o->v[3].p)));
}
static s7_pointer opt_p_ppp_sss_mul(opt_info * o)
{
return (multiply_p_ppp
(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p),
slot_value(o->v[3].p)));
}
static s7_pointer opt_p_ppp_sss_hset(opt_info * o)
{
return (s7_hash_table_set
(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p),
slot_value(o->v[3].p)));
}
static s7_pointer opt_p_ppp_ssc(opt_info * o)
{
return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p),
slot_value(o->v[2].p), o->v[4].p));
}
static s7_pointer opt_p_ppp_sff(opt_info * o)
{
s7_pointer po1;
po1 = o->v[11].fp(o->v[10].o1);
return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p), po1,
o->v[9].fp(o->v[8].o1)));
}
static s7_pointer opt_p_ppp_fff(opt_info * o)
{
s7_pointer res;
s7_scheme *sc = opt_sc(o);
gc_protect_2_via_stack(sc, T_Pos(o->v[11].fp(o->v[10].o1)),
T_Pos(o->v[9].fp(o->v[8].o1)));
res =
o->v[3].p_ppp_f(sc, stack_protected1(sc), stack_protected2(sc),
o->v[5].fp(o->v[4].o1));
unstack(sc);
return (res);
}
static bool p_ppp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer car_x)
{
s7_pointer arg1 = cadr(car_x), arg2 = caddr(car_x), arg3 =
cadddr(car_x);
int32_t start = sc->pc;
s7_p_ppp_t func;
func = s7_p_ppp_function(s_func);
if (!func)
return_false(sc, car_x);
opc->v[3].p_ppp_f = func;
if (is_symbol(arg1)) { /* dealt with at the top -> p1 */
s7_pointer slot, obj;
opt_info *o1;
slot = lookup_slot_from(arg1, sc->curlet);
if ((!is_slot(slot)) || (has_methods(slot_value(slot))))
return_false(sc, car_x);
obj = slot_value(slot);
if ((is_any_vector(obj)) && (vector_rank(obj) > 1))
return_false(sc, car_x);
if (is_target_or_its_alias
(car(car_x), s_func, sc->hash_table_set_symbol)) {
if ((!is_hash_table(obj)) || (is_immutable(obj)))
return_false(sc, car_x);
} else
if ((is_target_or_its_alias
(car(car_x), s_func, sc->let_set_symbol))
&& ((!is_let(obj)) || (is_immutable(obj))))
return_false(sc, car_x);
opc->v[1].p = slot;
if ((func == hash_table_set_p_ppp) && (is_hash_table(obj)))
opc->v[3].p_ppp_f = s7_hash_table_set;
if (is_symbol(arg2)) {
slot = opt_simple_symbol(sc, arg2);
if (slot) {
opc->v[2].p = slot;
if (is_symbol(arg3)) {
slot = opt_simple_symbol(sc, arg3);
if (slot) {
s7_p_ppp_t func1;
func1 = opc->v[3].p_ppp_f;
opc->v[4].p_ppp_f = func1;
opc->v[3].p = slot;
opc->v[0].fp =
(func1 ==
multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1
==
s7_hash_table_set)
?
opt_p_ppp_sss_hset
:
opt_p_ppp_sss);
return (true);
}
} else if ((!is_pair(arg3)) || (is_proper_quote(sc, arg3))) {
opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3;
opc->v[0].fp = opt_p_ppp_ssc;
return (true);
}
if (optimize_op(car_x) == HOP_HASH_TABLE_INCREMENT) {
opc->v[0].fp = opt_p_ppp_hash_table_increment;
opc->v[5].p = car_x;
return (true);
}
if (cell_optimize(sc, cdddr(car_x))) {
opc->v[4].o1 = sc->opts[start];
opc->v[5].fp = opc->v[4].o1->v[0].fp;
opc->v[0].fp = opt_p_ppp_ssf;
return (true);
}
pc_fallback(sc, start);
}
}
if ((is_proper_quote(sc, arg2)) && (is_symbol(arg3))) {
s7_pointer val_slot;
val_slot = opt_simple_symbol(sc, arg3);
if (val_slot) {
opc->v[4].p = cadr(arg2);
opc->v[2].p = val_slot;
opc->v[0].fp = opt_p_ppp_scs;
if (opc->v[3].p_ppp_f == s7_let_set) {
if (is_symbol(cadr(arg2))) /* checked is_let, has_methods and is_immutable above */
opc->v[0].fp = opt_p_ppp_scs_eset;
else
return_false(sc, car_x);
}
return (true);
}
}
o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opt_info *o2 = sc->opts[sc->pc];
if (is_symbol(arg3)) {
s7_pointer val_slot;
val_slot = opt_simple_symbol(sc, arg3);
if (val_slot) {
opc->v[2].p = val_slot;
opc->v[0].fp = opt_p_ppp_sfs; /* hset case goes through the case below */
opc->v[4].o1 = o1;
opc->v[5].fp = o1->v[0].fp;
return (true);
}
}
if (cell_optimize(sc, cdddr(car_x))) {
opc->v[0].fp = opt_p_ppp_sff;
opc->v[10].o1 = o1;
opc->v[11].fp = o1->v[0].fp;
opc->v[8].o1 = o2;
opc->v[9].fp = o2->v[0].fp;
return (true);
}
}
} else {
opc->v[10].o1 = sc->opts[start];
if (cell_optimize(sc, cdr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opc->v[4].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdddr(car_x))) {
opc->v[0].fp = opt_p_ppp_fff;
opc->v[11].fp = opc->v[10].o1->v[0].fp;
opc->v[9].fp = opc->v[8].o1->v[0].fp;
opc->v[5].fp = opc->v[4].o1->v[0].fp;
return (true);
}
}
}
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- p_call_ppp -------- */
static s7_pointer opt_p_call_sss(opt_info * o)
{
return (o->v[4].call(opt_sc(o),
set_plist_3(opt_sc(o), slot_value(o->v[1].p),
slot_value(o->v[2].p),
slot_value(o->v[3].p))));
}
static s7_pointer opt_p_call_css(opt_info * o)
{
return (o->v[4].call(opt_sc(o),
set_plist_3(opt_sc(o), o->v[1].p,
slot_value(o->v[2].p),
slot_value(o->v[3].p))));
}
static s7_pointer opt_p_call_ssf(opt_info * o)
{
return (o->v[4].call(opt_sc(o),
set_plist_3(opt_sc(o), slot_value(o->v[1].p),
slot_value(o->v[2].p),
o->v[6].fp(o->v[5].o1))));
}
static s7_pointer opt_p_call_ppp(opt_info * o)
{
s7_pointer res;
s7_scheme *sc = opt_sc(o);
gc_protect_2_via_stack(sc, o->v[4].fp(o->v[3].o1),
o->v[6].fp(o->v[5].o1));
res = o->v[11].fp(o->v[10].o1); /* not combinable into next */
res =
o->v[2].call(sc,
set_plist_3(sc, stack_protected1(sc),
stack_protected2(sc), res));
unstack(sc);
return (res);
}
static bool p_call_ppp_ok(s7_scheme * sc, opt_info * opc,
s7_pointer s_func, s7_pointer car_x)
{
int32_t start = sc->pc;
if ((is_safe_procedure(s_func)) &&
(c_function_required_args(s_func) <= 3) &&
(c_function_all_args(s_func) >= 3)) {
s7_pointer slot, arg = cadr(car_x);
opt_info *o1 = sc->opts[sc->pc];
if (!is_pair(arg)) {
if (is_symbol(arg)) {
slot = opt_simple_symbol(sc, arg);
if (slot)
opc->v[1].p = slot;
else
return_false(sc, car_x); /* no need for pc_fallback here, I think */
} else
opc->v[1].p = arg;
arg = caddr(car_x);
if (is_symbol(arg)) {
slot = opt_simple_symbol(sc, arg);
if (slot) {
opc->v[2].p = slot;
arg = cadddr(car_x);
if (is_symbol(arg)) {
slot = opt_simple_symbol(sc, arg);
if (slot) {
opc->v[3].p = slot;
opc->v[4].call = cf_call(sc, car_x, s_func, 3);
opc->v[0].fp =
(is_slot(opc->v[1].p)) ? opt_p_call_sss :
opt_p_call_css;
return (true);
}
} else if ((is_slot(opc->v[1].p))
&& (cell_optimize(sc, cdddr(car_x)))) {
opc->v[4].call = cf_call(sc, car_x, s_func, 3);
opc->v[0].fp =
(opc->v[4].call ==
g_substring_uncopied) ?
opt_p_substring_uncopied_ssf : opt_p_call_ssf;
opc->v[5].o1 = o1;
opc->v[6].fp = o1->v[0].fp;
return (true);
}
}
}
}
if (cell_optimize(sc, cdr(car_x))) {
opt_info *o2 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opt_info *o3 = sc->opts[sc->pc];
if (cell_optimize(sc, cdddr(car_x))) {
opc->v[2].call = cf_call(sc, car_x, s_func, 3);
opc->v[0].fp = opt_p_call_ppp;
opc->v[3].o1 = o1;
opc->v[4].fp = o1->v[0].fp;
opc->v[5].o1 = o2;
opc->v[6].fp = o2->v[0].fp;
opc->v[10].o1 = o3;
opc->v[11].fp = o3->v[0].fp;
return (true);
}
}
}
}
pc_fallback(sc, start);
return_false(sc, car_x);
}
/* -------- p_call_any -------- */
#define P_CALL_O1 3
static s7_pointer opt_p_call_any(opt_info * o)
{
s7_pointer arg, val;
int32_t i;
s7_scheme *sc = opt_sc(o);
val = safe_list_if_possible(sc, o->v[1].i);
if (in_heap(val))
gc_protect_via_stack(sc, val);
for (i = 0, arg = val; i < o->v[1].i; i++, arg = cdr(arg)) {
opt_info *o1 = o->v[i + P_CALL_O1].o1;
set_car(arg, o1->v[0].fp(o1));
}
arg = o->v[2].call(sc, val);
if (in_heap(val))
unstack(sc);
else
clear_list_in_use(val);
return (arg);
}
static bool p_call_any_ok(s7_scheme * sc, opt_info * opc,
s7_pointer s_func, s7_pointer car_x, int32_t len)
{
if ((len < (NUM_VUNIONS - P_CALL_O1)) &&
(is_safe_procedure(s_func)) &&
(c_function_required_args(s_func) <= (len - 1)) &&
(c_function_all_args(s_func) >= (len - 1))) {
s7_pointer p; /* (vector-set! v k i 2) gets here */
int32_t pctr;
opc->v[1].i = (len - 1);
for (pctr = P_CALL_O1, p = cdr(car_x); is_pair(p);
pctr++, p = cdr(p)) {
opc->v[pctr].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
break;
}
if (is_null(p)) {
opc->v[0].fp = opt_p_call_any;
opc->v[2].call = cf_call(sc, car_x, s_func, len - 1);
return (true);
}
}
return_false(sc, car_x);
}
/* -------- p_fx_any -------- */
static s7_pointer opt_p_fx_any(opt_info * o)
{
return (o->v[1].call(opt_sc(o), o->v[2].p));
}
static bool p_fx_any_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func,
s7_pointer x)
{
s7_function f;
f = (has_fx(x)) ? fx_proc(x) : fx_choose(sc, x, sc->curlet,
let_symbol_is_safe);
if (!f)
return_false(sc, x);
opc->v[0].fp = opt_p_fx_any;
opc->v[1].call = f;
opc->v[2].p = car(x);
return (true);
}
/* -------- p_implicit -------- */
static bool p_implicit_ok(s7_scheme * sc, s7_pointer s_slot,
s7_pointer car_x, int32_t len)
{
s7_pointer obj = slot_value(s_slot);
opt_info *opc;
int32_t start;
if ((!is_sequence(obj)) || (len < 2))
return_false(sc, car_x);
opc = alloc_opo(sc);
opc->v[1].p = s_slot;
start = sc->pc;
if (len == 2) {
switch (type(obj)) {
case T_PAIR:
opc->v[3].p_pi_f = list_ref_p_pi_unchecked;
break;
case T_HASH_TABLE:
opc->v[3].p_pp_f = s7_hash_table_ref;
break;
case T_LET:
opc->v[3].p_pp_f = s7_let_ref;
break;
case T_STRING:
opc->v[3].p_pi_f = string_ref_p_pi_unchecked;
break;
case T_C_OBJECT:
return_false(sc, car_x); /* no pi_ref because ref assumes pp */
case T_VECTOR:
if (vector_rank(obj) != 1)
return_false(sc, car_x);
opc->v[3].p_pi_f = normal_vector_ref_p_pi_unchecked;
break;
case T_BYTE_VECTOR:
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
if (vector_rank(obj) != 1)
return_false(sc, car_x);
opc->v[3].p_pi_f = vector_ref_p_pi_unchecked;
break;
default:
return_false(sc, car_x);
}
/* now v3.p_pi|pp.f is set */
if (is_symbol(cadr(car_x))) {
s7_pointer slot;
slot = lookup_slot_from(cadr(car_x), sc->curlet);
if (is_slot(slot)) {
opc->v[2].p = slot;
if ((!is_hash_table(obj)) && /* these because opt_int below */
(!is_let(obj))) {
if (!is_t_integer(slot_value(slot)))
return_false(sc, car_x); /* I think this reflects that a non-int index is an error for list-ref et al */
opc->v[0].fp = opt_p_pi_ss;
if (is_step_end(opc->v[2].p))
check_unchecked(sc, obj, opc->v[2].p, opc, NULL);
return (true);
}
opc->v[0].fp = opt_p_pp_ss;
return (true);
}
} else {
if ((!is_hash_table(obj)) && (!is_let(obj))) {
opt_info *o1;
if (is_t_integer(cadr(car_x))) {
opc->v[2].i = integer(cadr(car_x));
opc->v[0].fp = opt_p_pi_sc;
return (true);
}
o1 = sc->opts[sc->pc];
if (!int_optimize(sc, cdr(car_x)))
return_false(sc, car_x);
opc->v[0].fp = opt_p_pi_sf;
opc->v[4].o1 = o1;
opc->v[5].fi = o1->v[0].fi;
return (true);
}
if (cell_optimize(sc, cdr(car_x))) {
opc->v[0].fp = opt_p_pp_sf;
opc->v[4].o1 = sc->opts[start];
opc->v[5].fp = sc->opts[start]->v[0].fp;
return (true);
}
}
} /* len==2 */
else { /* len > 2 */
if ((is_normal_vector(obj)) && (len == 3)
&& (vector_rank(obj) == 2)) {
s7_pointer slot;
slot = opt_integer_symbol(sc, caddr(car_x));
if (slot) {
opc->v[3].p = slot;
slot = opt_integer_symbol(sc, cadr(car_x));
if (slot) {
opc->v[2].p = slot;
opc->v[4].p_pii_f = vector_ref_p_pii;
opc->v[0].fp = opt_p_pii_sss;
if ((step_end_fits
(opc->v[2].p, vector_dimension(obj, 0)))
&&
(step_end_fits
(opc->v[3].p, vector_dimension(obj, 1))))
opc->v[0].fp = vector_ref_pii_sss_unchecked;
return (true);
}
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x))) {
opc->v[0].fp = opt_p_pii_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
/* opc->v[1].p set above */
opc->v[4].p_pii_f = vector_ref_p_pii_direct;
return (true);
}
}
pc_fallback(sc, start);
}
if (len < (NUM_VUNIONS - 4)) { /* mimic p_call_any_ok */
int32_t pctr;
s7_pointer p;
opc->v[1].i = len;
for (pctr = 3, p = car_x; is_pair(p); pctr++, p = cdr(p)) {
opc->v[pctr].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
break;
}
if (is_null(p)) {
/* todo??: here we know the vector rank/type, probably can handle the new value type, and maybe indices/dimensions,
* so at least forgo the vec type/rank + immutable checks, the *_set cases are from p_call_any_ok called in cell_optimize
*/
opc->v[0].fp = opt_p_call_any;
switch (type(obj)) { /* string can't happen here (no multidimensional strings) */
case T_PAIR:
opc->v[2].call = g_list_ref;
break;
case T_HASH_TABLE:
opc->v[2].call = g_hash_table_ref;
break;
/* case T_LET: opc->v[2].call = g_let_ref; break; *//* this doesn't handle implicit indices via g_let_ref! apply_let */
case T_INT_VECTOR:
opc->v[2].call = g_int_vector_ref;
break;
case T_BYTE_VECTOR:
opc->v[2].call = g_byte_vector_ref;
break;
case T_FLOAT_VECTOR:
opc->v[2].call = g_float_vector_ref;
break;
case T_VECTOR:
opc->v[2].call = g_vector_ref;
break;
default:
return_false(sc, car_x);
}
return (true);
}
}
}
return_false(sc, car_x);
}
/* -------- cell_quote -------- */
static bool opt_cell_quote(s7_scheme * sc, s7_pointer car_x)
{
opt_info *opc;
if (!is_null(cddr(car_x)))
return_false(sc, car_x);
opc = alloc_opo(sc);
opc->v[1].p = cadr(car_x);
opc->v[0].fp = opt_p_c;
return (true);
}
/* -------- cell_set -------- */
static s7_pointer opt_set_p_p_f(opt_info * o)
{
s7_pointer x;
x = o->v[4].fp(o->v[3].o1);
slot_set_value(o->v[1].p, x);
return (x);
}
static s7_pointer opt_set_p_i_s(opt_info * o)
{
s7_pointer val = slot_value(o->v[2].p);
if (is_mutable_integer(val))
val = make_integer(opt_sc(o), integer(val));
slot_set_value(o->v[1].p, val);
return (val);
}
static s7_pointer opt_set_p_i_f(opt_info * o)
{
s7_pointer x;
x = make_integer(opt_sc(o), o->v[6].fi(o->v[5].o1));
slot_set_value(o->v[1].p, x);
return (x);
}
static s7_pointer opt_set_p_d_s(opt_info * o)
{
s7_pointer val = slot_value(o->v[2].p);
if (is_mutable_number(val))
val = make_real(opt_sc(o), real(val));
slot_set_value(o->v[1].p, val);
return (val);
}
static s7_pointer opt_set_p_d_f(opt_info * o)
{
s7_pointer x;
x = make_real(opt_sc(o), o->v[5].fd(o->v[4].o1));
slot_set_value(o->v[1].p, x);
return (x);
}
static s7_pointer opt_set_p_d_f_sf_add(opt_info * o)
{
s7_pointer x;
x = make_real(opt_sc(o), opt_d_dd_sf_add(o->v[4].o1));
slot_set_value(o->v[1].p, x);
return (x);
}
static s7_pointer opt_set_p_d_f_mm_add(opt_info * o)
{
s7_double x1, x2;
x1 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[4].p),
integer(slot_value(o->v[5].p))) *
real(slot_value(o->v[3].p));
x2 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[10].p),
integer(slot_value(o->v[11].p))) *
real(slot_value(o->v[9].p));
slot_set_value(o->v[1].p, make_real(opt_sc(o), x1 + x2));
return (slot_value(o->v[1].p));
}
static s7_pointer opt_set_p_d_f_mm_subtract(opt_info * o)
{
s7_double x1, x2;
x1 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[4].p),
integer(slot_value(o->v[5].p))) *
real(slot_value(o->v[3].p));
x2 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[10].p),
integer(slot_value(o->v[11].p))) *
real(slot_value(o->v[9].p));
slot_set_value(o->v[1].p, make_real(opt_sc(o), x1 - x2));
return (slot_value(o->v[1].p));
}
static s7_pointer opt_set_p_c(opt_info * o)
{
slot_set_value(o->v[1].p, o->v[2].p);
return (o->v[2].p);
}
static s7_pointer opt_set_p_i_fo(opt_info * o)
{
s7_pointer x;
s7_int i;
i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[3].p)));
x = make_integer(opt_sc(o), i);
slot_set_value(o->v[1].p, x);
return (x);
}
static s7_pointer opt_set_p_i_fo_add(opt_info * o)
{
s7_pointer x;
s7_int i;
i = integer(slot_value(o->v[2].p)) + integer(slot_value(o->v[3].p));
x = make_integer(opt_sc(o), i);
slot_set_value(o->v[1].p, x);
return (x);
}
static s7_pointer opt_set_p_i_fo1(opt_info * o)
{
s7_pointer x;
s7_int i;
i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), o->v[3].i);
x = make_integer(opt_sc(o), i);
slot_set_value(o->v[1].p, x);
return (x);
}
static s7_pointer opt_set_p_i_fo1_add(opt_info * o)
{
s7_pointer x;
s7_int i;
i = integer(slot_value(o->v[2].p)) + o->v[3].i;
x = make_integer(opt_sc(o), i);
slot_set_value(o->v[1].p, x);
return (x);
}
static bool set_p_i_f_combinable(s7_scheme * sc, opt_info * opc)
{
if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) {
opt_info *o1 = sc->opts[sc->pc - 1];
if ((o1->v[0].fi == opt_i_ii_ss) ||
(o1->v[0].fi == opt_i_ii_ss_add)) {
opc->v[4].i_ii_f = o1->v[3].i_ii_f;
opc->v[2].p = o1->v[1].p;
opc->v[3].p = o1->v[2].p;
opc->v[0].fp =
(o1->v[0].fi ==
opt_i_ii_ss_add) ? opt_set_p_i_fo_add : opt_set_p_i_fo;
backup_pc(sc);
return (true);
}
if ((o1->v[0].fi == opt_i_ii_sc)
|| (o1->v[0].fi == opt_i_ii_sc_add)
|| (o1->v[0].fi == opt_i_ii_sc_sub)) {
opc->v[4].i_ii_f = o1->v[3].i_ii_f;
opc->v[2].p = o1->v[1].p;
opc->v[3].i = o1->v[2].i;
opc->v[0].fp =
(o1->v[0].fi ==
opt_i_ii_sc_add) ? opt_set_p_i_fo1_add : opt_set_p_i_fo1;
backup_pc(sc);
return (true);
}
}
return_false(sc, NULL);
}
static bool set_p_d_f_combinable(s7_scheme * sc, opt_info * opc)
{
if ((sc->pc > 3) && (opc == sc->opts[sc->pc - 4])) {
opt_info *o1 = sc->opts[sc->pc - 3];
if ((o1->v[0].fd == opt_d_mm_fff) && ((o1->v[3].d_dd_f == add_d_dd)
|| (o1->v[3].d_dd_f ==
subtract_d_dd))) {
opc->v[0].fp =
(o1->v[3].d_dd_f ==
add_d_dd) ? opt_set_p_d_f_mm_add :
opt_set_p_d_f_mm_subtract;
o1 = sc->opts[sc->pc - 2];
opc->v[3].p = o1->v[1].p;
opc->v[4].p = o1->v[2].p;
opc->v[5].p = o1->v[3].p;
o1 = sc->opts[sc->pc - 1];
opc->v[9].p = o1->v[1].p;
opc->v[10].p = o1->v[2].p;
opc->v[11].p = o1->v[3].p;
sc->pc -= 3;
return (true);
}
}
return_false(sc, NULL);
}
static bool is_some_number(s7_scheme * sc, s7_pointer tp)
{
return ((tp == sc->is_integer_symbol) ||
(tp == sc->is_float_symbol) ||
(tp == sc->is_real_symbol) ||
(tp == sc->is_complex_symbol) ||
(tp == sc->is_number_symbol) ||
(tp == sc->is_rational_symbol));
}
static bool check_type_uncertainty(s7_scheme * sc, s7_pointer target,
s7_pointer car_x, opt_info * opc,
int32_t start_pc)
{
s7_pointer code = sc->code;
/* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) car_x) where car_x is the do body, but it can also be for-each etc */
/* maybe the type uncertainty is not a problem */
if ((is_pair(code)) && /* t101-aux-14: (vector-set! !v! 0 (do ((x (list 1 2 3) (cdr x)) (j -1)) ((null? x) j) (set! j (car x)))) */
(is_pair(car(code))) && (is_pair(cdr(code))) && /* weird that code sometimes has nothing to do with car_x -- tree_memq below for reality check */
(is_pair(cadr(code)))) {
s7_int counts;
if ((!has_high_c(code)) && /* only set below */
(s7_tree_memq(sc, car_x, code))) {
if (is_pair(caar(code))) {
s7_pointer p;
counts = tree_count(sc, target, car(code), 0) +
tree_count(sc, target, caadr(code), 0) +
tree_count(sc, target, cddr(code), 0);
for (p = car(code); is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
if ((is_proper_list_2(sc, var)) &&
(car(var) == target))
counts--;
}
} else
counts = tree_count(sc, target, code, 0);
} else
counts = 2;
/* can be from lambda: (lambda (n)...): ((n) (set! sum (+ sum n))) etc */
if (counts <= 2) {
set_has_high_c(code);
pc_fallback(sc, start_pc);
if (cell_optimize(sc, cddr(car_x))) {
opc->v[0].fp = opt_set_p_p_f;
opc->v[3].o1 = sc->opts[start_pc];
opc->v[4].fp = sc->opts[start_pc]->v[0].fp;
return (true);
}
}
}
return_false(sc, car_x);
}
static bool opt_cell_set(s7_scheme * sc, s7_pointer car_x)
{ /* len == 3 here (p_syntax) */
opt_info *opc;
s7_pointer target = cadr(car_x);
opc = alloc_opo(sc);
if (is_symbol(target)) {
s7_pointer settee;
if ((is_constant_symbol(sc, target)) ||
(symbol_has_setter(target)))
return_false(sc, car_x);
settee = lookup_slot_from(target, sc->curlet);
if ((is_slot(settee)) &&
(!is_immutable(settee)) && (!is_syntax(slot_value(settee)))) {
s7_pointer atype, stype;
int32_t start_pc = sc->pc;
opc->v[1].p = settee;
stype = s7_type_of(sc, slot_value(settee));
if (stype == sc->is_integer_symbol) {
if (is_symbol(caddr(car_x))) {
s7_pointer val_slot;
val_slot = opt_integer_symbol(sc, caddr(car_x));
if (val_slot) {
opc->v[2].p = val_slot;
opc->v[0].fp = opt_set_p_i_s;
return (true);
}
} else {
opc->v[5].o1 = sc->opts[sc->pc];
if (!int_optimize(sc, cddr(car_x)))
return (check_type_uncertainty
(sc, target, car_x, opc, start_pc));
if (!set_p_i_f_combinable(sc, opc)) {
opc->v[0].fp = opt_set_p_i_f;
opc->v[6].fi = opc->v[5].o1->v[0].fi;
}
return (true);
}
}
if (stype == sc->is_float_symbol) {
if (is_t_real(caddr(car_x))) {
opc->v[2].p = caddr(car_x);
opc->v[0].fp = opt_set_p_c;
return (true);
}
if (is_symbol(caddr(car_x))) {
s7_pointer val_slot;
val_slot = opt_float_symbol(sc, caddr(car_x));
if (val_slot) {
opc->v[2].p = val_slot;
opc->v[0].fp = opt_set_p_d_s;
return (true);
}
} else {
if ((is_pair(caddr(car_x))) &&
(float_optimize(sc, cddr(car_x)))) {
if (!set_p_d_f_combinable(sc, opc)) {
opc->v[4].o1 = sc->opts[start_pc];
opc->v[5].fd = sc->opts[start_pc]->v[0].fd;
opc->v[0].fp =
(opc->v[5].fd ==
opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add :
opt_set_p_d_f;
}
return (true);
}
return (check_type_uncertainty
(sc, target, car_x, opc, start_pc));
}
}
atype = opt_arg_type(sc, cddr(car_x));
if ((is_some_number(sc, atype)) &&
(!is_some_number(sc, stype)))
return_false(sc, car_x);
if (cell_optimize(sc, cddr(car_x))) {
if ((stype != atype) && (is_symbol(stype)) && (((t_sequence_p[symbol_type(stype)]) && (stype != sc->is_null_symbol) && (stype != sc->is_pair_symbol)) || /* compatible with is_proper_list! */
(stype ==
sc->is_iterator_symbol)))
return_false(sc, car_x);
opc->v[0].fp = opt_set_p_p_f;
opc->v[3].o1 = sc->opts[start_pc];
opc->v[4].fp = sc->opts[start_pc]->v[0].fp;
return (true);
}
}
} else {
if ((is_pair(target)) &&
(is_symbol(car(target))) &&
(is_pair(cdr(target))) &&
((is_null(cddr(target))) || (is_null(cdddr(target)))
|| (is_null(cddddr(target))))) {
s7_pointer s_slot;
s_slot = lookup_slot_from(car(target), sc->curlet);
if (is_slot(s_slot)) {
s7_pointer obj = slot_value(s_slot);
opc->v[1].p = s_slot;
if ( /* (!has_methods(obj)) && *//* not mentioned in d_impicit */
(is_mutable_sequence(obj))) {
s7_pointer index;
switch (type(obj)) {
case T_STRING:
{
s7_pointer val_type;
if (is_pair(cddr(target)))
return_false(sc, car_x);
val_type = opt_arg_type(sc, cddr(car_x));
if (val_type != sc->is_char_symbol)
return_false(sc, car_x);
opc->v[3].p_pip_f = string_set_p_pip_unchecked;
}
break;
case T_VECTOR:
/* is_t_integer below to handle the index */
if (is_null(cddr(target))) {
if (vector_rank(obj) != 1)
return_false(sc, car_x);
opc->v[3].p_pip_f =
(is_typed_vector(obj)) ?
typed_vector_set_p_pip_unchecked :
vector_set_p_pip_unchecked;
} else {
if (vector_rank(obj) != 2)
return_false(sc, car_x);
opc->v[5].p_piip_f =
(is_typed_vector(obj)) ?
typed_vector_set_p_piip_direct :
vector_set_p_piip_direct;
return (p_piip_to_sx
(sc, opc, cdr(target), cddr(target),
cddr(car_x), obj));
}
break;
case T_FLOAT_VECTOR:
if (opt_float_vector_set
(sc, opc, car(target), cdr(target),
(is_null(cddr(target))) ? NULL : cddr(target),
((!is_pair(cddr(target)))
|| (is_null(cdddr(target)))) ? NULL :
cdddr(target), cddr(car_x))) {
opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
return (true);
}
return_false(sc, car_x);
case T_BYTE_VECTOR:
case T_INT_VECTOR:
if (opt_int_vector_set
(sc, -1, opc, car(target), cdr(target),
(is_null(cddr(target))) ? NULL : cddr(target),
cddr(car_x))) {
opc->v[O_WRAP].fi = opc->v[0].fi;
opc->v[0].fp = i_to_p;
return (true);
}
return_false(sc, car_x);
case T_C_OBJECT:
if ((is_null(cddr(target))) &&
(is_c_function(c_object_setf(sc, obj)))) {
/* d_7pid_ok assumes cadr is the target, not car etc */
s7_d_7pid_t func;
func =
s7_d_7pid_function(c_object_setf(sc, obj));
if (func) {
s7_pointer slot;
opc->v[4].d_7pid_f = func;
slot =
opt_integer_symbol(sc, cadr(target));
opc->v[10].o1 = sc->opts[sc->pc];
if (slot) {
if (float_optimize(sc, cddr(car_x))) {
opc->v[O_WRAP].fd = opt_d_7pid_ssf;
opc->v[0].fp = d_to_p; /* cell_optimize, so need to return s7_pointer */
opc->v[2].p = slot;
opc->v[11].fd =
opc->v[10].o1->v[0].fd;
return (true);
}
} else if (int_optimize(sc, cdr(target))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x))) {
opc->v[O_WRAP].fd = opt_d_7pid_sff;
opc->v[11].fi =
opc->v[10].o1->v[0].fi;
opc->v[9].fd =
opc->v[8].o1->v[0].fd;
opc->v[0].fp = d_to_p;
return (true);
}
}
}
}
return_false(sc, car_x);
case T_PAIR:
if (is_pair(cddr(target)))
return_false(sc, car_x);
opc->v[3].p_pip_f = list_set_p_pip_unchecked;
/* an experiment -- is this ever hit in normal code? */
{
s7_pointer val = caddr(car_x);
if ((is_pair(val))
&& (car(val) == sc->add_symbol)
&& (is_t_integer(caddr(val)))
&& (is_null(cdddr(val)))
&& (is_symbol(cadr(target)))
&& (car(target) == (caadr(val)))
&& (is_pair(cdadr(val)))
&& (is_null(cddadr(val)))
&& (cadr(target) == cadadr(val))) {
s7_pointer slot;
index = cadr(target);
slot = opt_simple_symbol(sc, index);
if ((slot)
&& (is_t_integer(slot_value(slot)))) {
opc->v[2].p = slot;
opc->v[3].p = caddr(val);
opc->v[0].fp =
list_increment_p_pip_unchecked;
return (true);
}
}
}
break;
case T_HASH_TABLE:
if (is_pair(cddr(target)))
return_false(sc, car_x);
opc->v[3].p_ppp_f = s7_hash_table_set;
break;
case T_LET:
/* here we know the let is a covered mutable let -- ?? not true if s7-optimize called explicitly */
if ((is_pair(cddr(target))) || (has_methods(obj)))
return_false(sc, car_x);
if ((is_keyword(cadr(target))) ||
((is_quoted_symbol(cadr(target)))))
opc->v[3].p_ppp_f = let_set_1;
else
opc->v[3].p_ppp_f = let_set_p_ppp_2;
break;
default:
return_false(sc, car_x);
}
index = cadr(target);
if (is_symbol(index)) {
s7_pointer slot;
int32_t start = sc->pc;
slot = opt_simple_symbol(sc, index);
if (slot) {
opc->v[2].p = slot;
if ((is_t_integer(slot_value(slot))) &&
(is_step_end(opc->v[2].p))) {
if (is_string(obj)) {
if (do_loop_end
(slot_value(opc->v[2].p)) <=
string_length(obj))
opc->v[3].p_pip_f =
string_set_unchecked;
} else if (is_byte_vector(obj)) {
if (do_loop_end
(slot_value(opc->v[2].p)) <=
byte_vector_length(obj))
opc->v[3].p_pip_f =
byte_vector_set_unchecked_p;
} else if (is_any_vector(obj)) { /* true for all 3 vectors */
if ((is_any_vector(obj)) &&
(do_loop_end
(slot_value(opc->v[2].p)) <=
vector_length(obj))) {
if ((is_normal_vector(obj))
&& (is_typed_vector(obj)))
opc->v[3].p_pip_f =
typed_vector_set_unchecked;
else
opc->v[3].p_pip_f =
vector_set_unchecked;
}
}
}
if (is_symbol(caddr(car_x))) {
s7_pointer val_slot;
s7_p_ppp_t func1;
val_slot =
opt_simple_symbol(sc, caddr(car_x));
if (val_slot) {
if ((is_string(obj)) ||
(is_any_vector(obj)) ||
(is_pair(obj))) {
opc->v[4].p_pip_f =
opc->v[3].p_pip_f;
opc->v[3].p = val_slot;
opc->v[0].fp = opt_p_pip_sss;
return (true);
}
func1 = opc->v[3].p_ppp_f;
opc->v[4].p_ppp_f = func1;
opc->v[3].p = val_slot;
opc->v[0].fp =
(func1 ==
multiply_p_ppp) ?
opt_p_ppp_sss_mul
: ((func1 ==
s7_hash_table_set) ?
opt_p_ppp_sss_hset :
opt_p_ppp_sss);
return (true);
}
} else
if ((!is_pair(caddr(car_x))) ||
(is_proper_quote(sc, caddr(car_x)))) {
if (!is_pair(caddr(car_x)))
opc->v[4].p = caddr(car_x);
else
opc->v[4].p = cadaddr(car_x);
if ((is_string(obj)) ||
(is_any_vector(obj)) ||
(is_pair(obj))) {
opc->v[0].fp = opt_p_pip_ssc;
return (true);
}
opc->v[0].fp = opt_p_ppp_ssc;
return (true);
}
if (cell_optimize(sc, cddr(car_x))) {
opc->v[4].o1 = sc->opts[start];
opc->v[5].fp = sc->opts[start]->v[0].fp;
if ((is_string(obj)) ||
(is_any_vector(obj)) ||
(is_pair(obj))) {
if (p_pip_ssf_combinable
(sc, opc, start))
return (true);
opc->v[0].fp = opt_p_pip_ssf;
return (true);
}
opc->v[0].fp = opt_p_ppp_ssf;
return (true);
}
}
} else {
opt_info *o1;
if ((is_string(obj)) ||
(is_pair(obj)) || (is_any_vector(obj))) {
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(target))) {
opc->v[8].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opc->v[0].fp = opt_p_pip_sff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fp = opc->v[8].o1->v[0].fp;
return (true);
}
}
return_false(sc, car_x);
}
if ((is_proper_quote(sc, cadr(target))) &&
(is_symbol(caddr(car_x)))) {
s7_pointer val_slot;
val_slot = opt_simple_symbol(sc, caddr(car_x));
if (val_slot) {
opc->v[4].p = cadadr(target);
opc->v[2].p = val_slot;
opc->v[0].fp = (opc->v[3].p_ppp_f =
let_set_1) ?
opt_p_ppp_scs_eset : opt_p_ppp_scs;
return (true);
}
}
o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(target))) {
opt_info *o2;
if (is_symbol(caddr(car_x))) {
s7_pointer val_slot;
val_slot =
opt_simple_symbol(sc, caddr(car_x));
if (val_slot) {
opc->v[2].p = val_slot;
opc->v[0].fp = opt_p_ppp_sfs;
opc->v[4].o1 = o1;
opc->v[5].fp = o1->v[0].fp;
return (true);
}
}
o2 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opc->v[0].fp = opt_p_ppp_sff;
opc->v[10].o1 = o1;
opc->v[11].fp = o1->v[0].fp;
opc->v[8].o1 = o2;
opc->v[9].fp = o2->v[0].fp;
return (true);
}
}
}
}
}
}
}
return_false(sc, car_x);
}
/* -------- cell_begin -------- */
static s7_pointer opt_begin_p(opt_info * o)
{
opt_info *o1;
s7_int i, len = o->v[1].i; /* len = 1 if 2 exprs, etc */
for (i = 0; i < len; i++) {
o1 = o->v[i + 2].o1;
o1->v[0].fp(o1);
}
o1 = o->v[i + 2].o1;
return (o1->v[0].fp(o1));
}
static s7_pointer opt_begin_p_1(opt_info * o)
{
o->v[3].fp(o->v[2].o1);
return (o->v[5].fp(o->v[4].o1));
}
static void oo_idp_nr_fixup(opt_info * start)
{
if (start->v[0].fp == d_to_p) {
start->v[0].fp = d_to_p_nr;
if (start->v[O_WRAP].fd == opt_d_7pid_ssf)
start->v[0].fp = opt_d_7pid_ssf_nr;
else if (start->v[O_WRAP].fd == opt_d_7pid_ssfo_fv) {
start->v[0].fp = opt_d_7pid_ssfo_fv_nr;
if (start->v[6].d_dd_f == add_d_dd)
start->v[0].fp = opt_d_7pid_ssfo_fv_add_nr;
else if (start->v[6].d_dd_f == subtract_d_dd)
start->v[0].fp = opt_d_7pid_ssfo_fv_sub_nr;
}
} else if (start->v[0].fp == i_to_p)
start->v[0].fp = i_to_p_nr;
}
static bool opt_cell_begin(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
int32_t i;
opt_info *opc;
s7_pointer p;
if (len > (NUM_VUNIONS - 3))
return_false(sc, car_x);
opc = alloc_opo(sc);
for (i = 2, p = cdr(car_x); is_pair(p); i++, p = cdr(p)) {
opt_info *start = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
return_false(sc, car_x);
if (is_pair(cdr(p)))
oo_idp_nr_fixup(start);
opc->v[i].o1 = start;
}
opc->v[1].i = len - 2;
if (len == 3) {
opc->v[0].fp = opt_begin_p_1;
opc->v[4].o1 = opc->v[3].o1;
opc->v[5].fp = opc->v[4].o1->v[0].fp;
opc->v[3].fp = opc->v[2].o1->v[0].fp;
} else
opc->v[0].fp = opt_begin_p;
return (true);
}
/* -------- cell_when|unless -------- */
static s7_pointer opt_when_p_2(opt_info * o)
{
if (o->v[4].fb(o->v[3].o1)) {
o->v[6].fp(o->v[5].o1);
return (o->v[8].fp(o->v[7].o1));
}
return (opt_sc(o)->unspecified);
}
static s7_pointer opt_when_p(opt_info * o)
{
if (o->v[4].fb(o->v[3].o1)) {
int32_t i, len;
opt_info *o1;
len = o->v[1].i - 1;
for (i = 0; i < len; i++) {
o1 = o->v[i + 5].o1;
o1->v[0].fp(o1);
}
o1 = o->v[i + 5].o1;
return (o1->v[0].fp(o1));
}
return (opt_sc(o)->unspecified);
}
static s7_pointer opt_when_p_1(opt_info * o)
{
opt_info *o1;
if (!o->v[4].fb(o->v[3].o1))
return (opt_sc(o)->unspecified);
o1 = o->v[5].o1;
return (o1->v[0].fp(o1));
}
static s7_pointer opt_unless_p(opt_info * o)
{
opt_info *o1;
int32_t i, len;
if (o->v[4].fb(o->v[3].o1))
return (opt_sc(o)->unspecified);
len = o->v[1].i - 1;
for (i = 0; i < len; i++) {
o1 = o->v[i + 5].o1;
o1->v[0].fp(o1);
}
o1 = o->v[i + 5].o1;
return (o1->v[0].fp(o1));
}
static s7_pointer opt_unless_p_1(opt_info * o)
{
opt_info *o1;
if (o->v[4].fb(o->v[3].o1))
return (opt_sc(o)->unspecified);
o1 = o->v[5].o1;
return (o1->v[0].fp(o1));
}
static bool opt_cell_when(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
s7_pointer p;
int32_t k;
opt_info *opc;
if (len > (NUM_VUNIONS - 6))
return_false(sc, car_x);
opc = alloc_opo(sc);
opc->v[3].o1 = sc->opts[sc->pc];
if (!bool_optimize(sc, cdr(car_x)))
return_false(sc, car_x);
for (k = 5, p = cddr(car_x); is_pair(p); k++, p = cdr(p)) {
opt_info *start = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
return_false(sc, car_x);
if (is_pair(cdr(p)))
oo_idp_nr_fixup(start);
opc->v[k].o1 = start;
}
opc->v[4].fb = opc->v[3].o1->v[0].fb;
opc->v[1].i = len - 2;
if (car(car_x) == sc->when_symbol) {
if (len == 3)
opc->v[0].fp = opt_when_p_1;
else if (len == 4) {
opc->v[0].fp = opt_when_p_2;
opc->v[7].o1 = opc->v[6].o1;
opc->v[8].fp = opc->v[7].o1->v[0].fp;
opc->v[6].fp = opc->v[5].o1->v[0].fp;
} else
opc->v[0].fp = opt_when_p;
} else
opc->v[0].fp = (len == 3) ? opt_unless_p_1 : opt_unless_p;
return (true);
}
/* -------- cell_cond -------- */
#define COND_O1 3
#define COND_CLAUSE_O1 5
static s7_pointer cond_value(opt_info * o)
{
opt_info *o1;
int32_t i, len = o->v[1].i - 1;
for (i = 0; i < len; i++) {
o1 = o->v[i + COND_CLAUSE_O1].o1;
o1->v[0].fp(o1);
}
o1 = o->v[i + COND_CLAUSE_O1].o1;
return (o1->v[0].fp(o1));
}
static s7_pointer opt_cond(opt_info * top)
{
int32_t clause, len = top->v[2].i;
for (clause = 0; clause < len; clause++) {
opt_info *o2, *o1 = top->v[clause + COND_O1].o1;
o2 = o1->v[4].o1;
if (o2->v[0].fb(o2)) {
s7_pointer res;
res = cond_value(o1);
return (res);
}
}
return (top->sc->unspecified);
}
static s7_pointer opt_cond_1(opt_info * o)
{
return ((o->v[5].fb(o->v[4].o1)) ? cond_value(o->v[6].
o1) :
opt_sc(o)->unspecified);
} /* cond as when */
static s7_pointer opt_cond_1b(opt_info * o)
{
return ((o->v[4].o1->v[O_WRAP].fp(o->v[4].o1) !=
opt_sc(o)->F) ? cond_value(o->v[6].
o1) : opt_sc(o)->unspecified);
}
static s7_pointer opt_cond_2(opt_info * o)
{ /* 2 branches, results 1 expr, else */
opt_info *o1;
s7_pointer res;
o1 = (o->v[5].fb(o->v[4].o1)) ? o->v[6].o1 : o->v[7].o1;
res = o1->v[0].fp(o1);
return (res);
}
static bool opt_cell_cond(s7_scheme * sc, s7_pointer car_x)
{
/* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */
s7_pointer p, last_clause = NULL;
opt_info *top;
int32_t branches = 0, max_blen = 0, start_pc;
top = alloc_opo(sc);
start_pc = sc->pc;
for (p = cdr(car_x); is_pair(p); p = cdr(p), branches++) {
opt_info *opc;
s7_pointer clause = car(p), cp;
int32_t blen;
if ((branches >= (NUM_VUNIONS - COND_O1)) || (!is_pair(clause)) || (!is_pair(cdr(clause))) || /* leave the test->result case for later */
(cadr(clause) == sc->feed_to_symbol))
return_false(sc, clause);
last_clause = clause;
top->v[branches + COND_O1].o1 = sc->opts[sc->pc];
opc = alloc_opo(sc);
opc->v[4].o1 = sc->opts[sc->pc];
if (!bool_optimize(sc, clause))
return_false(sc, clause);
for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp)) {
if (blen >= NUM_VUNIONS - COND_CLAUSE_O1)
return_false(sc, cp);
opc->v[blen + COND_CLAUSE_O1].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, cp))
return_false(sc, cp);
}
if (!is_null(cp))
return_false(sc, cp);
opc->v[1].i = blen;
if (max_blen < blen)
max_blen = blen;
opc->v[0].fp = opt_cond; /* a placeholder */
}
if (branches == 1) {
opt_info *o1 = sc->opts[start_pc + 1];
top->v[0].fp = (o1->v[0].fb == p_to_b) ? opt_cond_1b : opt_cond_1;
top->v[4].o1 = o1;
top->v[5].fb = o1->v[0].fb;
top->v[6].o1 = sc->opts[start_pc];
return (true);
}
if (branches == 2) {
if ((max_blen == 1) &&
((car(last_clause) == sc->else_symbol) ||
(car(last_clause) == sc->T))) {
opt_info *o1;
top->v[6].o1 = top->v[COND_O1].o1->v[COND_CLAUSE_O1].o1;
top->v[7].o1 = top->v[COND_O1 + 1].o1->v[COND_CLAUSE_O1].o1;
o1 = sc->opts[start_pc + 1];
top->v[4].o1 = o1;
top->v[5].fb = o1->v[0].fb;
top->v[0].fp = opt_cond_2;
return (true);
}
}
top->v[2].i = branches;
top->v[0].fp = opt_cond;
return (true);
}
/* -------- cell_and|or -------- */
static s7_pointer opt_and_pp(opt_info * o)
{
return ((o->v[11].fp(o->v[10].o1) ==
opt_sc(o)->F) ? opt_sc(o)->F : o->v[9].fp(o->v[8].o1));
}
static s7_pointer opt_and_any_p(opt_info * o)
{
int32_t i;
s7_pointer val = opt_sc(o)->T; /* (and) -> #t */
for (i = 0; i < o->v[1].i; i++) {
opt_info *o1 = o->v[i + 3].o1;
val = o1->v[0].fp(o1);
if (val == opt_sc(o)->F)
return (opt_sc(o)->F);
}
return (val);
}
static s7_pointer opt_or_pp(opt_info * o)
{
s7_pointer val;
val = o->v[11].fp(o->v[10].o1);
return ((val != opt_sc(o)->F) ? val : o->v[9].fp(o->v[8].o1));
}
static s7_pointer opt_or_any_p(opt_info * o)
{
int32_t i;
for (i = 0; i < o->v[1].i; i++) {
s7_pointer val;
opt_info *o1 = o->v[i + 3].o1;
val = o1->v[0].fp(o1);
if (val != opt_sc(o)->F)
return (val);
}
return (opt_sc(o)->F);
}
static bool opt_cell_and(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
opt_info *opc;
opc = alloc_opo(sc);
if (len == 3) {
opc->v[0].fp =
((car(car_x) == sc->or_symbol) ? opt_or_pp : opt_and_pp);
opc->v[10].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, cdr(car_x)))
return_false(sc, car_x);
opc->v[11].fp = opc->v[10].o1->v[0].fp;
opc->v[8].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, cddr(car_x)))
return_false(sc, car_x);
opc->v[9].fp = opc->v[8].o1->v[0].fp;
return (true);
}
if ((len > 1) && (len < (NUM_VUNIONS - 4))) {
s7_pointer p;
int32_t i;
opc->v[1].i = (len - 1);
opc->v[0].fp =
((car(car_x) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p);
for (i = 3, p = cdr(car_x); is_pair(p); i++, p = cdr(p)) {
opc->v[i].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
return_false(sc, car_x);
}
return (true);
}
return_false(sc, car_x);
}
/* -------- cell_if -------- */
static s7_pointer opt_if_bp(opt_info * o)
{
return ((o->v[3].fb(o->v[2].o1)) ? o->v[5].
fp(o->v[4].o1) : opt_sc(o)->unspecified);
}
static s7_pointer opt_if_nbp(opt_info * o)
{
return ((o->v[5].fb(o->v[4].o1)) ? opt_sc(o)->unspecified : o->
v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_bp_pb(opt_info * o)
{ /* p_to_b at outer, p_to_b expanded and moved to o[3] */
return ((o->v[3].fp(o->v[2].o1) !=
opt_sc(o)->F) ? o->v[5].fp(o->v[4].
o1) : opt_sc(o)->unspecified);
}
static s7_pointer opt_if_bp_ii_fc(opt_info * o)
{
return ((o->v[3].
b_ii_f(o->v[11].fi(o->v[10].o1),
o->v[2].i)) ? o->v[5].fp(o->v[4].o1) : opt_sc(o)->
unspecified);
}
static s7_pointer opt_if_nbp_s(opt_info * o)
{
return ((o->v[2].
b_p_f(slot_value(o->v[3].p))) ? opt_sc(o)->unspecified : o->
v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_nbp_sc(opt_info * o)
{ /* b_pp_sc */
return ((o->v[3].b_pp_f(slot_value(o->v[2].p),
o->v[4].p)) ? opt_sc(o)->unspecified : o->
v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_nbp_7sc(opt_info * o)
{ /* b_7pp_sc */
return ((o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[2].p),
o->v[4].p)) ? opt_sc(o)->unspecified : o->
v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_nbp_ss(opt_info * o)
{ /* b_ii_ss */
return ((o->v[3].b_ii_f(integer(slot_value(o->v[2].p)),
integer(slot_value(o->v[4].p)))) ?
opt_sc(o)->unspecified : o->v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_eq_ii_ss(opt_info * o)
{ /* b_ii_ss */
return ((integer(slot_value(o->v[2].p)) ==
integer(slot_value(o->v[4].p))) ? opt_sc(o)->
unspecified : o->v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_nbp_fs(opt_info * o)
{ /* b_pi_fs */
return ((o->v[2].b_pi_f(opt_sc(o), o->v[5].fp(o->v[4].o1),
integer(slot_value(o->v[3].p)))) ?
opt_sc(o)->unspecified : o->v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_nbp_sf(opt_info * o)
{ /* b_pp_sf */
return ((o->v[2].b_pp_f(slot_value(o->v[3].p),
o->v[5].fp(o->v[4].o1))) ? opt_sc(o)->
unspecified : o->v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_nbp_7sf(opt_info * o)
{ /* b_7pp_sf */
return ((o->v[2].b_7pp_f(opt_sc(o), slot_value(o->v[3].p),
o->v[5].fp(o->v[4].
o1))) ? opt_sc(o)->unspecified :
o->v[11].fp(o->v[10].o1));
}
static s7_pointer opt_if_bpp(opt_info * o)
{
return ((o->v[5].fb(o->v[4].o1)) ? o->v[9].fp(o->v[8].o1) : o->
v[11].fp(o->v[10].o1));
}
static bool opt_cell_if(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
opt_info *opc, *bop, *top;
opc = alloc_opo(sc);
bop = sc->opts[sc->pc];
if (len == 3) {
if ((is_proper_list_2(sc, cadr(car_x))) && /* (not arg) */
(caadr(car_x) == sc->not_symbol)) {
if (bool_optimize(sc, cdadr(car_x))) {
top = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opc->v[10].o1 = top;
opc->v[11].fp = top->v[0].fp;
if (bop->v[0].fb == opt_b_p_s) {
opc->v[2].b_p_f = bop->v[2].b_p_f;
opc->v[3].p = bop->v[1].p;
opc->v[0].fp = opt_if_nbp_s;
return (true);
}
if ((bop->v[0].fb == opt_b_pi_fs)
|| (bop->v[0].fb == opt_b_pi_fs_num_eq)) {
opc->v[2].b_pi_f = bop->v[2].b_pi_f;
opc->v[3].p = bop->v[1].p;
opc->v[4].o1 = bop->v[10].o1;
opc->v[5].fp = bop->v[11].fp;
opc->v[0].fp = opt_if_nbp_fs;
return (true);
}
if ((bop->v[0].fb == opt_b_pp_sf) ||
(bop->v[0].fb == opt_b_7pp_sf)) {
opc->v[4].o1 = bop->v[10].o1;
opc->v[5].fp = bop->v[11].fp;
if (bop->v[0].fb == opt_b_pp_sf) {
opc->v[2].b_pp_f = bop->v[3].b_pp_f;
opc->v[0].fp = opt_if_nbp_sf;
} else {
opc->v[2].b_7pp_f = bop->v[3].b_7pp_f;
opc->v[0].fp = opt_if_nbp_7sf;
}
opc->v[3].p = bop->v[1].p;
return (true);
}
if ((bop->v[0].fb == opt_b_pp_sc) ||
(bop->v[0].fb == opt_b_7pp_sc)) {
if (bop->v[0].fb == opt_b_pp_sc) {
opc->v[3].b_pp_f = bop->v[3].b_pp_f;
opc->v[0].fp = opt_if_nbp_sc;
} else {
opc->v[3].b_7pp_f = bop->v[3].b_7pp_f;
opc->v[0].fp = opt_if_nbp_7sc;
}
opc->v[2].p = bop->v[1].p;
opc->v[4].p = bop->v[2].p;
return (true);
}
if ((bop->v[0].fb == opt_b_ii_ss)
|| (bop->v[0].fb == opt_b_ii_ss_eq)
|| (bop->v[0].fb == opt_b_ii_ss_lt)
|| (bop->v[0].fb == opt_b_ii_ss_gt)
|| (bop->v[0].fb == opt_b_ii_ss_leq)
|| (bop->v[0].fb == opt_b_ii_ss_geq)) {
opc->v[3].b_ii_f = bop->v[3].b_ii_f;
opc->v[2].p = bop->v[1].p;
opc->v[4].p = bop->v[2].p;
opc->v[0].fp =
(opc->v[3].b_ii_f ==
num_eq_b_ii) ? opt_if_eq_ii_ss :
opt_if_nbp_ss;
return (true);
}
opc->v[4].o1 = bop;
opc->v[5].fb = bop->v[0].fb;
opc->v[0].fp = opt_if_nbp;
return (true);
}
}
} else if (bool_optimize(sc, cdr(car_x))) {
top = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opc->v[2].o1 = bop;
opc->v[4].o1 = top;
opc->v[5].fp = top->v[0].fp;
if (bop->v[0].fb == p_to_b) {
opc->v[0].fp = opt_if_bp_pb;
opc->v[3].fp = bop->v[O_WRAP].fp;
return (true);
}
if (bop->v[0].fb == opt_b_ii_fc) {
opc->v[2].i = bop->v[2].i;
opc->v[3].b_ii_f = bop->v[3].b_ii_f;
opc->v[11].fi = bop->v[11].fi;
opc->v[10].o1 = bop->v[10].o1;
opc->v[0].fp = opt_if_bp_ii_fc;
return (true);
}
opc->v[0].fp = opt_if_bp;
opc->v[3].fb = bop->v[0].fb;
return (true);
}
}
return_false(sc, car_x);
}
if (len == 4) {
if (bool_optimize(sc, cdr(car_x))) {
top = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x))) {
opt_info *o3 = sc->opts[sc->pc];
opc->v[0].fp = opt_if_bpp;
if (cell_optimize(sc, cdddr(car_x))) {
opc->v[4].o1 = bop;
opc->v[5].fb = bop->v[0].fb;
opc->v[8].o1 = top;
opc->v[9].fp = top->v[0].fp;
opc->v[10].o1 = o3;
opc->v[11].fp = o3->v[0].fp;
return (true);
}
}
}
}
return_false(sc, car_x);
}
/* -------- cell_case -------- */
static bool case_memv(s7_scheme * sc, s7_pointer x, s7_pointer y)
{
s7_pointer z;
if (is_simple(x)) {
for (z = y; is_pair(z); z = cdr(z))
if (x == car(z))
return (true);
return (false);
}
for (z = y; is_pair(z); z = cdr(z))
if (s7_is_eqv(sc, x, car(z)))
return (true);
return (false);
}
#define CASE_O1 3
#define CASE_SEL 2
#define CASE_CLAUSE_O1 4
#define CASE_CLAUSE_KEYS 2
static s7_pointer case_value(s7_scheme * sc, opt_info * top, opt_info * o)
{
opt_info *o1;
int32_t i, len = o->v[1].i - 1;
for (i = 0; i < len; i++) {
o1 = o->v[i + CASE_CLAUSE_O1].o1;
o1->v[0].fp(o1);
}
o1 = o->v[i + CASE_CLAUSE_O1].o1;
return (o1->v[0].fp(o1));
}
static s7_pointer opt_case(opt_info * o)
{
opt_info *o1 = o->v[CASE_SEL].o1;
int32_t ctr, lim;
s7_pointer selector;
selector = o1->v[0].fp(o1);
lim = o->v[1].i;
for (ctr = CASE_O1; ctr < lim; ctr++) {
o1 = o->v[ctr].o1;
if ((o1->v[CASE_CLAUSE_KEYS].p == opt_sc(o)->else_symbol) ||
(case_memv(opt_sc(o), selector, o1->v[CASE_CLAUSE_KEYS].p)))
return (case_value(opt_sc(o), o, o1));
}
return (opt_sc(o)->unspecified);
}
static bool opt_cell_case(s7_scheme * sc, s7_pointer car_x)
{
/* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */
opt_info *top;
s7_pointer p;
int32_t ctr;
top = alloc_opo(sc);
top->v[CASE_SEL].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, cdr(car_x))) /* selector */
return_false(sc, car_x);
for (ctr = CASE_O1, p = cddr(car_x);
(is_pair(p)) && (ctr < NUM_VUNIONS); ctr++, p = cdr(p)) {
opt_info *opc;
s7_pointer clause = car(p), cp;
int32_t blen;
if ((!is_pair(clause)) ||
((!is_pair(car(clause))) && (car(clause) != sc->else_symbol))
|| (!is_pair(cdr(clause)))
|| (cadr(clause) == sc->feed_to_symbol))
return_false(sc, clause);
opc = alloc_opo(sc);
top->v[ctr].o1 = opc;
if (car(clause) == sc->else_symbol) {
if (!is_null(cdr(p)))
return_false(sc, clause);
opc->v[CASE_CLAUSE_KEYS].p = sc->else_symbol;
} else {
if (!s7_is_proper_list(sc, car(clause)))
return_false(sc, clause);
opc->v[CASE_CLAUSE_KEYS].p = car(clause);
}
for (blen = 0, cp = cdr(clause);
(is_pair(cp)) && (blen < (NUM_VUNIONS - CASE_CLAUSE_O1));
blen++, cp = cdr(cp)) {
opc->v[blen + CASE_CLAUSE_O1].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, cp))
return_false(sc, cp);
}
if (!is_null(cp))
return_false(sc, cp);
opc->v[1].i = blen;
opc->v[0].fp = opt_case; /* just a placeholder I hope */
}
if (!is_null(p))
return_false(sc, p);
top->v[1].i = ctr;
top->v[0].fp = opt_case;
return (true);
}
/* -------- cell_let_temporarily -------- */
#define LET_TEMP_O1 5
static s7_pointer opt_let_temporarily(opt_info * o)
{
opt_info *o1;
int32_t i, len;
s7_pointer result;
if (is_immutable_slot(o->v[1].p))
immutable_object_error(opt_sc(o),
set_elist_3(opt_sc(o),
immutable_error_string,
opt_sc
(o)->let_temporarily_symbol,
slot_symbol(o->v[1].p)));
o1 = o->v[4].o1;
o->v[3].p = slot_value(o->v[1].p); /* save and protect old value */
gc_protect_via_stack(opt_sc(o), o->v[3].p);
slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */
len = o->v[2].i - 1;
for (i = 0; i < len; i++) {
o1 = o->v[i + LET_TEMP_O1].o1;
o1->v[0].fp(o1);
}
o1 = o->v[i + LET_TEMP_O1].o1;
result = o1->v[0].fp(o1);
slot_set_value(o->v[1].p, o->v[3].p); /* restore old */
unstack(opt_sc(o));
return (result);
}
static bool opt_cell_let_temporarily(s7_scheme * sc, s7_pointer car_x,
int32_t len)
{
s7_pointer vars;
if (len <= 2)
return_false(sc, car_x);
vars = cadr(car_x);
if ((len < (NUM_VUNIONS - LET_TEMP_O1)) && (is_proper_list_1(sc, vars)) && /* just one var for now */
(is_proper_list_2(sc, car(vars))) && /* and var is (sym val) */
(is_symbol(caar(vars))) &&
(!is_immutable(caar(vars))) &&
(!is_syntactic_symbol(caar(vars)))) {
s7_pointer p;
opt_info *opc;
int32_t i;
opc = alloc_opo(sc);
opc->v[1].p = lookup_slot_from(caaadr(car_x), sc->curlet);
if (!is_slot(opc->v[1].p))
return_false(sc, car_x);
opc->v[4].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, cdaadr(car_x)))
return_false(sc, car_x);
for (i = LET_TEMP_O1, p = cddr(car_x); is_pair(p); i++, p = cdr(p)) {
opc->v[i].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
return_false(sc, car_x);
}
opc->v[2].i = len - 2;
opc->v[0].fp = opt_let_temporarily;
return (true);
}
return_false(sc, car_x);
}
/* -------- cell_do -------- */
#define do_curlet(o) o->v[2].p
#define do_body_length(o) o->v[3].i
#define do_result_length(o) o->v[4].i
static void let_set_has_pending_value(s7_pointer lt)
{
s7_pointer vp;
for (vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp))
slot_set_pending_value(vp, eof_object); /* gc needs a legit value here */
}
static void let_clear_has_pending_value(s7_pointer lt)
{
s7_pointer vp;
for (vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp))
slot_clear_has_pending_value(vp);
}
#define do_any_inits(o) o->v[7].o1
#define do_any_body(o) o->v[10].o1
#define do_any_results(o) o->v[11].o1
#define do_any_test(o) o->v[12].o1
#define do_any_steps(o) o->v[13].o1
static s7_pointer opt_do_any(opt_info * o)
{
/* o->v[2].p=let, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[7].i=inits */
opt_info *o1, *ostart, *body, *inits, *steps, *results;
int32_t i, k;
s7_pointer vp, old_e, result;
s7_scheme *sc = opt_sc(o);
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
sc->curlet = T_Let(do_curlet(o));
/* init */
inits = do_any_inits(o);
for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp);
k++, vp = next_slot(vp)) {
o1 = inits->v[k].o1;
slot_set_value(vp, o1->v[0].fp(o1));
}
ostart = do_any_test(o);
body = do_any_body(o);
results = do_any_results(o);
steps = do_any_steps(o);
let_set_has_pending_value(sc->curlet);
while (true) {
/* end */
if (ostart->v[0].fb(ostart))
break;
/* body */
for (i = 0; i < do_body_length(o); i++) {
o1 = body->v[i].o1;
o1->v[0].fp(o1);
}
/* step (let not let*) */
for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp);
k++, vp = next_slot(vp))
if (has_stepper(vp)) {
o1 = steps->v[k].o1;
slot_simply_set_pending_value(vp, o1->v[0].fp(o1));
}
for (vp = let_slots(sc->curlet); tis_slot(vp); vp = next_slot(vp))
if (has_stepper(vp))
slot_set_value(vp, slot_pending_value(vp));
}
/* result */
result = sc->T;
for (i = 0; i < do_result_length(o); i++) {
o1 = results->v[i].o1;
result = o1->v[0].fp(o1);
}
let_clear_has_pending_value(sc->curlet);
unstack(sc);
set_curlet(sc, old_e);
return (result);
}
static s7_pointer opt_do_step_1(opt_info * o)
{
/* 1 stepper (multi inits perhaps), 1 body, 1 rtn */
opt_info *o1, *ostart, *ostep, *inits, *body;
int32_t k;
s7_pointer vp, old_e, result, stepper = NULL;
s7_scheme *sc = opt_sc(o);
ostep = o->v[9].o1;
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
sc->curlet = T_Let(do_curlet(o));
inits = do_any_inits(o);
for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp);
k++, vp = next_slot(vp)) {
o1 = inits->v[k].o1;
slot_set_value(vp, o1->v[0].fp(o1));
if (has_stepper(vp))
stepper = vp;
}
ostart = do_any_test(o);
body = do_any_body(o);
while (!(ostart->v[0].fb(ostart))) {
body->v[0].fp(body);
slot_set_value(stepper, ostep->v[0].fp(ostep));
}
o1 = do_any_results(o);
result = o1->v[0].fp(o1);
unstack(sc);
set_curlet(sc, old_e);
return (result);
}
static s7_pointer opt_do_step_i(opt_info * o)
{
/* 1 stepper (multi inits perhaps), 1 body, 1 rtn */
opt_info *o1, *ostart, *ostep, *inits, *body;
int32_t k;
s7_pointer vp, old_e, result, stepper = NULL, si;
s7_scheme *sc = opt_sc(o);
s7_int end, incr;
ostep = o->v[9].o1;
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
sc->curlet = T_Let(do_curlet(o));
inits = do_any_inits(o);
for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp);
k++, vp = next_slot(vp)) {
o1 = inits->v[k].o1;
slot_set_value(vp, o1->v[0].fp(o1));
if (has_stepper(vp))
stepper = vp;
}
ostart = do_any_test(o);
body = do_any_body(o);
end = integer(slot_value(ostart->v[2].p));
incr = ostep->v[2].i;
si = make_mutable_integer(sc, integer(slot_value(ostart->v[1].p)));
slot_set_value(stepper, si);
while (integer(si) != end) {
body->v[0].fp(body);
integer(si) += incr;
}
clear_mutable_integer(si);
o1 = do_any_results(o);
result = o1->v[0].fp(o1);
unstack(sc);
set_curlet(sc, old_e);
return (result);
}
#define do_no_vars_test(o) o->v[6].o1
#define do_no_vars_body(o) o->v[7].o1
static s7_pointer opt_do_no_vars(opt_info * o)
{
/* no vars, no return, o->v[2].p=let, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length=0, o->v[6]=end test */
opt_info *ostart;
int32_t len;
s7_pointer old_e;
s7_scheme *sc = opt_sc(o);
bool (*fb)(opt_info * o);
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
set_curlet(sc, do_curlet(o));
len = do_body_length(o);
ostart = do_no_vars_test(o);
fb = ostart->v[0].fb;
if (len == 0) /* titer */
while (!(fb(ostart)));
else {
opt_info *body;
body = do_no_vars_body(o);
while (!(fb(ostart))) { /* tshoot, tfft */
int32_t i;
for (i = 0; i < len; i++) {
opt_info *o1;
o1 = body->v[i].o1;
o1->v[0].fp(o1);
}
}
}
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
#define do_stepper_init(o) o->v[11].o1
static s7_pointer opt_do_1(opt_info * o)
{
/* 1 var, 1 expr, no return */
opt_info *o1, *ostart, *ostep, *body; /* o->v[2].p=let */
s7_pointer vp, old_e;
s7_scheme *sc = opt_sc(o);
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
set_curlet(sc, do_curlet(o));
ostep = o->v[9].o1;
vp = let_slots(do_curlet(o));
o1 = do_stepper_init(o);
slot_set_value(vp, o1->v[0].fp(o1));
ostart = do_any_test(o);
body = do_any_body(o);
if ((o->v[8].i == 1) && (is_t_integer(slot_value(vp)))) {
if ((ostep->v[0].fp == opt_p_ii_ss_add) || /* tmap */
(ostep->v[0].fp == i_to_p)) {
s7_pointer step_val;
step_val = make_mutable_integer(sc, integer(slot_value(vp)));
slot_set_value(vp, step_val);
if (ostep->v[0].fp == opt_p_ii_ss_add)
while (!ostart->v[0].fb(ostart)) {
body->v[0].fp(body);
integer(step_val) = opt_i_ii_ss_add(ostep);
} else
while (!ostart->v[0].fb(ostart)) {
body->v[0].fp(body);
integer(step_val) = ostep->v[O_WRAP].fi(ostep);
}
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
o->v[8].i = 2;
}
while (!(ostart->v[0].fb(ostart))) { /* s7test tref */
body->v[0].fp(body);
slot_set_value(vp, ostep->v[0].fp(ostep));
}
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
#define do_n_body(o) o->v[7].o1
static s7_pointer opt_do_n(opt_info * o)
{
/* 1 var, no return */
opt_info *o1, *ostart, *ostep, *body; /* o->v[2].p=let, o->v[3].i=body length */
int32_t len;
s7_pointer vp, old_e;
s7_scheme *sc = opt_sc(o);
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
set_curlet(sc, do_curlet(o));
ostep = o->v[9].o1;
len = do_body_length(o);
vp = let_slots(do_curlet(o));
o1 = do_stepper_init(o);
slot_set_value(vp, o1->v[0].fp(o1));
ostart = do_any_test(o);
body = do_n_body(o);
if (len == 2) { /* tmac tshoot */
opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1;
while (!(ostart->v[0].fb(ostart))) {
e1->v[0].fp(e1);
e2->v[0].fp(e2);
slot_set_value(vp, ostep->v[0].fp(ostep));
}
} else
while (!ostart->v[0].fb(ostart)) { /* tfft teq */
int32_t i;
for (i = 0; i < len; i++) {
o1 = body->v[i].o1;
o1->v[0].fp(o1);
}
slot_set_value(vp, ostep->v[0].fp(ostep));
}
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
static s7_pointer opt_dotimes_2(opt_info * o)
{
/* 1 var, no return */
opt_info *o1, *body; /* o->v[2].p=let, o->v[3].i=body length, o->v[4].i=return length=0, o->v[6].i=end index, v6.i=end, v7=init */
int32_t len;
s7_int end;
s7_pointer vp, old_e;
s7_scheme *sc = opt_sc(o);
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
set_curlet(sc, do_curlet(o));
len = do_body_length(o);
vp = let_dox1_value(do_curlet(o));
if (is_slot(let_dox_slot2_unchecked(do_curlet(o))))
end = integer(slot_value(let_dox_slot2(do_curlet(o))));
else
end = o->v[6].i;
o1 = do_stepper_init(o);
integer(vp) = integer(o1->v[0].fp(o1));
body = do_n_body(o);
if (len == 2) { /* tmac tmisc */
opt_info *e1, *e2;
e1 = body->v[0].o1;
e2 = body->v[1].o1;
while (integer(vp) < end) {
e1->v[0].fp(e1);
e2->v[0].fp(e2);
integer(vp)++;
}
} else
while (integer(vp) < end) { /* tbig sg */
int32_t i;
for (i = 0; i < len; i++) {
o1 = body->v[i].o1;
o1->v[0].fp(o1);
}
integer(vp)++;
}
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
static s7_pointer opt_do_list_simple(opt_info * o)
{
/* 1 var, 1 expr, no return, step by cdr, end=null? */
opt_info *o1; /* o->v[2].p=let */
s7_pointer vp, old_e;
s7_scheme *sc = opt_sc(o);
s7_pointer(*fp) (opt_info * o);
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
set_curlet(sc, do_curlet(o));
vp = let_slots(do_curlet(o));
o1 = do_stepper_init(o);
slot_set_value(vp, o1->v[0].fp(o1));
o1 = do_any_body(o);
fp = o1->v[0].fp;
if (fp == opt_if_bp) {
while (is_pair(slot_value(vp))) {
if (o1->v[3].fb(o1->v[2].o1))
o1->v[5].fp(o1->v[4].o1);
slot_set_value(vp, cdr(slot_value(vp)));
}
} else
while (!is_null(slot_value(vp))) {
fp(o1);
slot_set_value(vp, cdr(slot_value(vp)));
}
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
static s7_pointer opt_do_very_simple(opt_info * o)
{
/* like simple but step can be direct, v[2].p is a let, v[3].i=end? */
opt_info *o1;
s7_int end;
s7_pointer vp, old_e;
s7_pointer(*f) (opt_info * o);
s7_scheme *sc = opt_sc(o);
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
set_curlet(sc, do_curlet(o));
vp = let_dox1_value(do_curlet(o));
if (is_slot(let_dox_slot2_unchecked(do_curlet(o))))
end = integer(slot_value(let_dox_slot2(do_curlet(o))));
else
end = o->v[3].i;
o1 = do_stepper_init(o);
integer(vp) = integer(o1->v[0].fp(o1));
o1 = do_any_body(o);
f = o1->v[0].fp;
if (f == opt_p_pip_ssf) { /* tref.scm */
opt_info *o2 = o1;
o1 = o2->v[4].o1;
if (o2->v[3].p_pip_f == vector_set_unchecked) {
s7_pointer v = slot_value(o2->v[1].p);
while (integer(vp) < end) {
vector_set_unchecked(o2->sc, v,
integer(slot_value(o2->v[2].p)),
o1->v[0].fp(o1));
integer(vp)++;
}
} else
while (integer(vp) < end) {
o2->v[3].p_pip_f(o2->sc, slot_value(o2->v[1].p),
integer(slot_value(o2->v[2].p)),
o1->v[0].fp(o1));
integer(vp)++;
}
} else {
if (f == opt_p_pip_sso) { /* vector-set from vector-ref (i.e. copy), but treating vector-* as generic */
if (((let_dox_slot1(do_curlet(o)) == o1->v[2].p)
&& (o1->v[2].p == o1->v[4].p))
&& (((o1->v[5].p_pip_f == float_vector_set_unchecked_p)
&& (o1->v[6].p_pi_f == float_vector_ref_unchecked_p))
|| ((o1->v[5].p_pip_f == int_vector_set_unchecked_p)
&& (o1->v[6].p_pi_f == int_vector_ref_unchecked_p))
|| ((o1->v[5].p_pip_f == string_set_unchecked)
&& (o1->v[6].p_pi_f == string_ref_unchecked))
|| ((o1->v[5].p_pip_f == byte_vector_set_unchecked_p)
&& (o1->v[6].p_pi_f ==
byte_vector_ref_unchecked_p)))) {
copy_to_same_type(sc, slot_value(o1->v[1].p),
slot_value(o1->v[3].p), integer(vp), end,
integer(vp));
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
while (integer(vp) < end) {
o1->v[5].p_pip_f(o1->sc, slot_value(o1->v[1].p),
integer(slot_value(o1->v[2].p)),
o1->v[6].p_pi_f(o1->sc,
slot_value(o1->v[3].p),
integer(slot_value
(o1->v[4].p))));
integer(vp)++;
}
} else if ((f == opt_set_p_i_f) && /* tvect.scm */
(is_t_integer(slot_value(o1->v[1].p))) &&
(o1->v[1].p != let_dox_slot1(do_curlet(o)))) {
s7_pointer ival;
opt_info *o2;
s7_int(*fi) (opt_info * o);
ival =
make_mutable_integer(sc, integer(slot_value(o1->v[1].p)));
slot_set_value(o1->v[1].p, ival);
o2 = o1->v[5].o1; /* set_p_i_f: x = make_integer(opt_sc(o), o->v[6].fi(o->v[5].o1)); */
fi = o2->v[0].fi;
while (integer(vp) < end) {
integer(ival) = fi(o2);
integer(vp)++;
}
slot_set_value(o1->v[1].p,
make_integer(sc,
integer(slot_value(o1->v[1].p))));
} else if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */
(o1->v[4].d_7pid_f == float_vector_set_unchecked)) {
s7_pointer fv, ind;
opt_info *o2;
s7_double(*fd) (opt_info * o);
o2 = do_any_body(o1);
fv = slot_value(o1->v[1].p);
ind = o1->v[2].p;
fd = o2->v[0].fd;
while (integer(vp) < end) {
float_vector_set_unchecked(sc, fv,
integer(slot_value(ind)),
fd(o2));
integer(vp)++;
}
} else
while (integer(vp) < end) {
f(o1);
integer(vp)++;
}
}
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
#define do_prepack_end(o) o->v[1].i
#define do_prepack_stepper(o) o->v[6].p
static s7_pointer opt_do_prepackaged(opt_info * o)
{
opt_info *o1;
s7_int end;
s7_pointer vp, old_e;
s7_scheme *sc = opt_sc(o);
old_e = sc->curlet;
s7_gc_protect_via_stack(sc, old_e);
set_curlet(sc, do_curlet(o));
vp = let_dox1_value(do_curlet(o));
if (is_slot(let_dox_slot2_unchecked(do_curlet(o))))
end = integer(slot_value(let_dox_slot2(do_curlet(o))));
else
end = o->v[3].i;
o1 = do_stepper_init(o);
integer(vp) = integer(o1->v[0].fp(o1));
do_prepack_stepper(o) = vp;
do_prepack_end(o) = end;
o->v[7].fp(o); /* call opt_do_i|dpnr below */
unstack(sc);
set_curlet(sc, old_e);
return (sc->T);
}
static s7_pointer opt_do_dpnr(opt_info * o)
{
opt_info *o1;
s7_pointer vp;
s7_int end;
s7_double(*f) (opt_info * o);
end = do_prepack_end(o);
vp = do_prepack_stepper(o);
o1 = do_any_body(o);
f = o1->v[O_WRAP].fd;
while (integer(vp) < end) {
f(o1);
integer(vp)++;
}
return (NULL);
}
static s7_pointer opt_do_ipnr(opt_info * o)
{
opt_info *o1;
s7_pointer vp;
s7_int end;
s7_int(*f) (opt_info * o);
end = do_prepack_end(o);
vp = do_prepack_stepper(o);
o1 = do_any_body(o);
f = o1->v[O_WRAP].fi;
while (integer(vp) < end) {
f(o1);
integer(vp)++;
}
return (NULL);
}
static bool stop_is_safe(s7_scheme * sc, s7_pointer stop, s7_pointer body)
{
/* this could be folded into the cell_optimize traveral */
s7_pointer p;
for (p = body; is_pair(p); p = cdr(p))
if ((is_pair(car(p))) &&
(caar(p) == sc->set_symbol) &&
(is_pair(cdar(p))) && (cadar(p) == stop))
return (!s7_tree_memq(sc, stop, cdr(p)));
return (true);
}
static bool tree_has_setters(s7_scheme * sc, s7_pointer tree)
{
clear_symbol_list(sc);
add_symbol_to_list(sc, sc->set_symbol);
add_symbol_to_list(sc, sc->vector_set_symbol);
add_symbol_to_list(sc, sc->list_set_symbol);
add_symbol_to_list(sc, sc->let_set_symbol);
add_symbol_to_list(sc, sc->hash_table_set_symbol);
add_symbol_to_list(sc, sc->set_car_symbol);
add_symbol_to_list(sc, sc->set_cdr_symbol);
return (tree_set_memq(sc, tree));
}
static bool do_is_safe(s7_scheme * sc, s7_pointer body, s7_pointer stepper,
s7_pointer var_list, bool *has_set);
static bool do_passes_safety_check(s7_scheme * sc, s7_pointer body,
s7_pointer stepper, bool *has_set)
{
if (!is_pair(body))
return (true);
if (!is_safety_checked(body)) {
set_safety_checked(body);
if (!(do_is_safe(sc, body, stepper, sc->nil, has_set)))
set_unsafe_do(body);
}
return (!is_unsafe_do(body));
}
#define SIZE_O NUM_VUNIONS
static bool all_integers(s7_scheme * sc, s7_pointer expr)
{
if ((is_symbol(car(expr))) && (is_all_integer(car(expr)))) {
s7_pointer p;
for (p = cdr(expr); is_pair(p); p = cdr(p))
if (!((is_t_integer(car(p))) || ((is_symbol(car(p)))
&&
(is_t_integer
(slot_value
(lookup_slot_from
(car(p), sc->curlet)))))
|| ((is_pair(car(p))) && (all_integers(sc, car(p))))))
break;
return (is_null(p));
}
return (false);
}
static bool all_floats(s7_scheme * sc, s7_pointer expr)
{
if ((is_symbol(car(expr))) && (is_all_float(car(expr)))) {
s7_pointer p;
for (p = cdr(expr); is_pair(p); p = cdr(p))
if (!((is_t_real(car(p))) || ((is_symbol(car(p)))
&&
(is_t_real
(slot_value
(lookup_slot_from
(car(p), sc->curlet)))))
|| ((is_pair(car(p))) && (all_floats(sc, car(p))))))
break;
return (is_null(p));
}
return (false);
}
static bool opt_cell_do(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
opt_info *opc;
s7_pointer p, end, let = NULL, old_e, stop, ind, ind_step;
int32_t i, k, var_len, body_len, body_index, step_len, rtn_len,
step_pc, init_pc, end_test_pc;
bool has_set = false;
opt_info *init_o[SIZE_O], *step_o[SIZE_O], *body_o[SIZE_O],
*return_o[SIZE_O];
if (len < 3)
return_false(sc, car_x);
if (!s7_is_proper_list(sc, cadr(car_x)))
return_false(sc, car_x);
var_len = proper_list_length(cadr(car_x));
step_len = var_len;
body_len = len - 3;
if (body_len > SIZE_O)
return_false(sc, car_x);
end = caddr(car_x);
if (!is_pair(end))
return_false(sc, car_x);
old_e = sc->curlet;
opc = alloc_opo(sc);
let = make_let(sc, sc->curlet);
push_stack(sc, OP_GC_PROTECT, old_e, let);
/* the vars have to be added to the let before evaluating the inits
* else symbol_id can be > let_id (see "(test (do ((i (do ((i (do ((i 0 (+ i 1)))...")
*/
clear_symbol_list(sc);
for (p = cadr(car_x); is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
if ((is_pair(var)) && (is_symbol(car(var))) && (is_pair(cdr(var)))) {
s7_pointer sym = car(var);
if ((is_constant_symbol(sc, sym)) || (symbol_has_setter(sym)))
return_false(sc, car_x);
if (symbol_is_in_list(sc, sym))
eval_error(sc, "duplicate identifier in do: ~A", 30, var);
add_symbol_to_list(sc, sym);
add_slot(sc, let, sym, sc->undefined);
} else
return_false(sc, car_x);
}
if (tis_slot(let_slots(let)))
let_set_slots(let, reverse_slots(sc, let_slots(let)));
/* inits */
{
s7_pointer slot;
init_pc = sc->pc;
for (k = 0, p = cadr(car_x), slot = let_slots(let);
(is_pair(p)) && (k < SIZE_O);
k++, p = cdr(p), slot = next_slot(slot)) {
s7_pointer var = car(p);
init_o[k] = sc->opts[sc->pc];
if (!cell_optimize(sc, cdr(var))) /* opt init in outer let */
return_false(sc, car_x);
if (is_pair(cddr(var))) {
set_has_stepper(slot);
if (!is_null(cdddr(var)))
return_false(sc, car_x);
} else {
step_len--;
if (!is_null(cddr(var)))
return_false(sc, car_x);
}
/* we can't use slot_set_value(slot, init_o[k]->v[0].fp(init_o[k])) to get the init value here: it might involve side-effects,
* and in some contexts might access variables that aren't set up yet. So, we kludge around...
*/
if (is_symbol(cadr(var)))
slot_set_value(slot,
slot_value(lookup_slot_from
(cadr(var), sc->curlet)));
else if (!is_pair(cadr(var)))
slot_set_value(slot, cadr(var));
else if (is_proper_quote(sc, cadr(var)))
slot_set_value(slot, cadadr(var));
else {
s7_pointer sf;
sf = lookup_checked(sc, caadr(var));
if (is_c_function(sf)) {
s7_pointer sig = c_function_signature(sf);
if (is_pair(sig)) {
if ((car(sig) == sc->is_integer_symbol) ||
((is_pair(car(sig))) &&
(direct_memq
(sc->is_integer_symbol, car(sig))))
|| (all_integers(sc, cadr(var))))
slot_set_value(slot, int_zero);
else if ((car(sig) == sc->is_float_symbol) ||
((is_pair(car(sig))) &&
(direct_memq
(sc->is_float_symbol, car(sig))))
|| (all_floats(sc, cadr(var))))
slot_set_value(slot, real_zero);
/* need for stepper too -- how does it know (+ x 0.1) is float? try (i 0 (floor (+ i 1))) etc */
}
}
}
}
set_curlet(sc, let);
for (p = cadr(car_x); is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
if (is_pair(cddr(var))) {
s7_pointer init_type;
init_type = opt_arg_type(sc, cdr(var));
if (((init_type == sc->is_integer_symbol) ||
(init_type == sc->is_float_symbol)) &&
(opt_arg_type(sc, cddr(var)) != init_type)) {
unstack(sc); /* not pop_stack! */
set_curlet(sc, old_e);
return_false(sc, car_x);
}
}
}
}
/* end test */
end_test_pc = sc->pc;
if (!bool_optimize_nw(sc, end)) {
unstack(sc); /* not pop_stack! */
set_curlet(sc, old_e);
return_false(sc, car_x);
}
stop = car(end);
if ((is_proper_list_3(sc, stop)) &&
((car(stop) == sc->num_eq_symbol) || (car(stop) == sc->geq_symbol)
|| (car(stop) == sc->gt_symbol)) && (is_symbol(cadr(stop)))
&& ((is_t_integer(caddr(stop))) || (is_symbol(caddr(stop))))) {
s7_pointer stop_slot;
stop_slot =
(is_symbol(caddr(stop))) ? opt_integer_symbol(sc,
caddr(stop)) :
sc->nil;
if (stop_slot) {
s7_int lim;
bool set_stop = false;
s7_pointer slot;
lim =
(is_slot(stop_slot)) ? integer(slot_value(stop_slot)) :
integer(caddr(stop));
if (car(stop) == sc->gt_symbol)
lim++;
for (p = cadr(car_x), slot = let_slots(let); is_pair(p);
p = cdr(p), slot = next_slot(slot)) {
/* this could be put off until it is needed (ref/set), but this code is not called much
* another choice: go from init downto 0: init is lim
*/
if (slot_symbol(slot) == cadr(stop))
set_stop = true; /* don't overrule this decision below */
if (has_stepper(slot)) {
s7_pointer var = car(p), step = caddr(var);
if ((is_t_integer(slot_value(slot))) && (is_pair(step)) && (is_pair(cdr(step))) && (car(var) == cadr(stop)) && (car(var) == cadr(step)) && ((car(stop) != sc->num_eq_symbol) || /* else > protects at least the top */
((caddr(step) == int_one) && (car(step) == sc->add_symbol)))) {
set_step_end(slot);
slot_set_value(slot,
make_mutable_integer(sc,
integer
(slot_value
(slot))));
set_do_loop_end(slot_value(slot), lim);
}
}
}
if (!set_stop) {
s7_pointer slot2;
slot2 = opt_integer_symbol(sc, cadr(stop));
if ((slot2) && (stop_is_safe(sc, cadr(stop), cddr(car_x)))) {
set_step_end(slot2);
set_do_loop_end(slot_value(slot2), lim);
}
}
}
}
/* body */
body_index = sc->pc;
for (k = 0, i = 3, p = cdddr(car_x); i < len; k++, i++, p = cdr(p)) {
opt_info *start = sc->opts[sc->pc];
body_o[k] = start;
if (i < 5)
opc->v[i + 7].o1 = start;
if (!cell_optimize(sc, p))
break;
oo_idp_nr_fixup(start);
}
if (!is_null(p)) {
unstack(sc);
set_curlet(sc, old_e);
return_false(sc, car_x);
}
/* we faked up sc->curlet above, so s7_optimize_1 (float_optimize) isn't safe here
* this means if clm nested loops get here, they aren't fully optimized -- fallback into dox would be better
*/
/* steps */
step_pc = sc->pc;
for (k = 0, p = cadr(car_x); is_pair(p); k++, p = cdr(p)) {
s7_pointer var = car(p);
step_o[k] = sc->opts[sc->pc];
if ((is_pair(cddr(var))) && (!cell_optimize(sc, cddr(var))))
break;
}
if (!is_null(p)) {
unstack(sc);
set_curlet(sc, old_e);
return_false(sc, car_x);
}
/* result */
if (!is_list(cdr(end))) {
unstack(sc);
set_curlet(sc, old_e);
return_false(sc, car_x);
}
for (rtn_len = 0, p = cdr(end); (is_pair(p)) && (rtn_len < SIZE_O);
p = cdr(p), rtn_len++) {
return_o[rtn_len] = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
break;
}
if (!is_null(p)) {
unstack(sc);
set_curlet(sc, old_e);
return_false(sc, car_x);
}
do_curlet(opc) = let;
do_body_length(opc) = len - 3;
do_result_length(opc) = rtn_len;
opc->v[9].o1 = sc->opts[step_pc];
set_curlet(sc, old_e);
if ((var_len == 0) && (rtn_len == 0)) {
opt_info *body;
do_no_vars_test(opc) = sc->opts[end_test_pc];
opc->v[0].fp = opt_do_no_vars;
if (body_len > 0) {
body = alloc_opo(sc);
for (k = 0; k < body_len; k++)
body->v[k].o1 = body_o[k];
do_no_vars_body(opc) = body;
}
return (true);
}
opc->v[8].i = 0;
if (body_len == 1) {
s7_pointer expr = cadddr(car_x);
if ((is_pair(expr)) && ((is_safe_setter(car(expr))) || ((car(expr) == sc->set_symbol) && (cadr(expr) != caaadr(car_x))) || /* caadr: (stepper init ...) */
((car(expr) == sc->vector_set_symbol) &&
(is_null(cddddr(expr))) &&
(is_code_constant(sc, cadddr(expr))))))
opc->v[8].i = 1;
}
if ((var_len != 1) || (step_len != 1) || (rtn_len != 0)) {
opt_info *inits;
opc->v[0].fp = ((step_len == 1) && (body_len == 1)
&& (rtn_len == 1)) ? opt_do_step_1 : opt_do_any;
/* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) tmat */
do_any_test(opc) = sc->opts[end_test_pc];
if ((opc->v[0].fp == opt_do_step_1) &&
(opc->v[9].o1->v[0].fp == i_to_p) &&
(opc->v[9].o1->v[O_WRAP].fi == opt_i_ii_sc_add) &&
(do_any_test(opc)->v[0].fb == opt_b_ii_ss_eq))
opc->v[0].fp = opt_do_step_i;
inits = alloc_opo(sc);
for (k = 0; k < var_len; k++)
inits->v[k].o1 = init_o[k];
do_any_inits(opc) = inits;
if (opc->v[0].fp == opt_do_any) {
opt_info *body, *result, *step;
body = alloc_opo(sc);
for (k = 0; k < body_len; k++)
body->v[k].o1 = body_o[k];
do_any_body(opc) = body;
result = alloc_opo(sc);
for (k = 0; k < rtn_len; k++)
result->v[k].o1 = return_o[k];
do_any_results(opc) = result;
step = alloc_opo(sc);
for (k = 0; k < var_len; k++)
step->v[k].o1 = step_o[k];
do_any_steps(opc) = step;
} else {
do_any_body(opc) = sc->opts[body_index];
do_any_results(opc) = return_o[0];
}
return (true);
}
opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n;
p = caadr(car_x);
ind = car(p);
ind_step = caddr(p);
end = caaddr(car_x);
if (body_len == 1) /* opt_do_1 */
do_any_body(opc) = sc->opts[body_index];
else {
opt_info *body;
body = alloc_opo(sc);
for (k = 0; k < body_len; k++)
body->v[k].o1 = body_o[k];
do_n_body(opc) = body;
}
do_stepper_init(opc) = sc->opts[init_pc];
do_any_test(opc) = sc->opts[end_test_pc];
do_any_steps(opc) = sc->opts[step_pc];
if ((is_pair(end)) && /* (= i len|100) */
(cadr(end) == ind) && (is_pair(ind_step))) { /* (+ i 1) */
/* we can't use step_end_ok here yet (not set except for op_dox?) */
if (((car(end) == sc->num_eq_symbol)
|| (car(end) == sc->geq_symbol)) && ((is_symbol(caddr(end)))
||
(is_t_integer
(caddr(end))))
&& (is_null(cdddr(end))) && (car(ind_step) == sc->add_symbol)
&& (cadr(ind_step) == ind) && (caddr(ind_step) == int_one)
&& (is_null(cdddr(ind_step)))
&& (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) {
s7_pointer slot = let_slots(let);
let_set_dox_slot1(let, slot);
let_set_dox_slot2_unchecked(let,
(is_symbol(caddr(end))) ?
lookup_slot_from(caddr(end),
sc->
curlet) :
sc->undefined);
slot_set_value(slot,
make_mutable_integer(sc,
integer(slot_value
(slot))));
opc->v[4].i = body_index;
if (body_len == 1) { /* opt_do_1 */
opt_info *o1;
opc->v[0].fp = opt_do_very_simple;
if (is_t_integer(caddr(end)))
opc->v[3].i = integer(caddr(end));
o1 = sc->opts[body_index];
if (o1->v[0].fp == d_to_p_nr) { /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */
opc->v[0].fp = opt_do_prepackaged;
opc->v[7].fp = opt_do_dpnr;
} else if (o1->v[0].fp == i_to_p_nr) {
opc->v[0].fp = opt_do_prepackaged;
opc->v[7].fp = opt_do_ipnr;
}
} else {
opc->v[0].fp = opt_dotimes_2;
if (is_t_integer(caddr(end)))
opc->v[6].i = integer(caddr(end));
}
} else
if ((car(end) == sc->is_null_symbol) &&
(is_null(cddr(end))) &&
(car(ind_step) == sc->cdr_symbol) &&
(cadr(ind_step) == ind) &&
(is_null(cddr(ind_step))) &&
(body_len == 1) &&
(do_passes_safety_check(sc, cdddr(car_x), ind, &has_set)))
opc->v[0].fp = opt_do_list_simple;
}
return (true);
}
static bool p_syntax(s7_scheme * sc, s7_pointer car_x, int32_t len)
{
opcode_t op;
s7_pointer func;
func = lookup_global(sc, car(car_x));
if (!is_syntax(func)) {
clear_syntactic(car_x);
return (false);
}
/* I think this is the only case where we don't precede syntax_opcode with syntactic_symbol checks */
op = (opcode_t) syntax_opcode(func);
switch (op) {
case OP_QUOTE:
if ((is_pair(cdr(car_x))) && (is_null(cddr(car_x))))
return (opt_cell_quote(sc, car_x));
break;
case OP_SET:
if (len == 3)
return (opt_cell_set(sc, car_x));
break;
case OP_BEGIN:
if (len > 1)
return (opt_cell_begin(sc, car_x, len));
break;
case OP_WHEN:
case OP_UNLESS:
if (len > 2)
return (opt_cell_when(sc, car_x, len));
break;
case OP_COND:
if (len > 1)
return (opt_cell_cond(sc, car_x));
break;
case OP_CASE:
if (len > 2)
return (opt_cell_case(sc, car_x));
break;
case OP_AND:
case OP_OR:
return (opt_cell_and(sc, car_x, len));
case OP_IF:
return (opt_cell_if(sc, car_x, len));
case OP_DO:
return (opt_cell_do(sc, car_x, len));
case OP_LET_TEMPORARILY:
return (opt_cell_let_temporarily(sc, car_x, len));
default: /* lambda let/let* with-let define etc */
break;
}
return_false(sc, car_x);
}
/* -------------------------------------------------------------------------------- */
static bool float_optimize_1(s7_scheme * sc, s7_pointer expr)
{
s7_pointer car_x = car(expr), head;
if (!is_pair(car_x)) /* wrap constants/symbols */
return (opt_float_not_pair(sc, car_x));
head = car(car_x);
if (is_symbol(head)) {
/* get func, check sig, check all args */
s7_pointer s_func, s_slot;
s7_int len;
len = s7_list_length(sc, car_x);
if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x)))
return (d_syntax_ok(sc, car_x, len));
s_slot = lookup_slot_from(head, sc->curlet);
if (!is_slot(s_slot))
return_false(sc, car_x);
s_func = slot_value(s_slot);
if (is_c_function(s_func)) {
opt_info *opc;
opc = alloc_opo(sc);
switch (len) {
case 1:
if (d_ok(sc, opc, s_func))
return (true);
break;
case 2: /* (f v) or (f d): (env e) or (abs x) */
if ((d_d_ok(sc, opc, s_func, car_x)) ||
(d_v_ok(sc, opc, s_func, car_x)) ||
(d_p_ok(sc, opc, s_func, car_x)))
return (true);
break;
case 3:
if ((d_dd_ok(sc, opc, s_func, car_x)) ||
(d_id_ok(sc, opc, s_func, car_x)) ||
(d_vd_ok(sc, opc, s_func, car_x)) ||
(d_pd_ok(sc, opc, s_func, car_x)) ||
(d_ip_ok(sc, opc, s_func, car_x)) ||
(d_7pi_ok(sc, opc, s_func, car_x)))
return (true);
break;
case 4:
if ((d_ddd_ok(sc, opc, s_func, car_x)) ||
(d_7pid_ok(sc, opc, s_func, car_x)) ||
(d_vid_ok(sc, opc, s_func, car_x)) ||
(d_vdd_ok(sc, opc, s_func, car_x)) ||
(d_7pii_ok(sc, opc, s_func, car_x)))
return (true);
break;
case 5:
if ((d_dddd_ok(sc, opc, s_func, car_x)) ||
(d_7piid_ok(sc, opc, s_func, car_x)) ||
(d_7piii_ok(sc, opc, s_func, car_x)))
return (true);
break;
case 6:
if (d_7piiid_ok(sc, opc, s_func, car_x))
return (true);
break;
default:
if (d_add_any_ok(sc, opc, car_x, len))
return (true);
break;
}
} else {
/* this is not good -- we're evaluating the macro body! Need something much smarter or ensure body simplicity and safety (no side-effects etc) */
if ((is_macro(s_func)) && (!no_cell_opt(expr)))
return (float_optimize(sc, set_plist_1(sc, s7_macroexpand(sc, s_func, cdar(expr))))); /* is this use of plist safe? */
return (d_implicit_ok(sc, s_slot, car_x, len));
}
}
return_false(sc, car_x);
}
static bool float_optimize(s7_scheme * sc, s7_pointer expr)
{
return ((float_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));
}
static bool int_optimize_1(s7_scheme * sc, s7_pointer expr)
{
s7_pointer car_x = car(expr), head;
if (!is_pair(car_x)) /* wrap constants/symbols */
return (opt_int_not_pair(sc, car_x));
head = car(car_x);
if (is_symbol(head)) {
s7_pointer s_func, s_slot;
s7_int len;
len = s7_list_length(sc, car_x);
if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x)))
return (i_syntax_ok(sc, car_x, len));
s_slot = lookup_slot_from(head, sc->curlet);
if (!is_slot(s_slot))
return_false(sc, car_x);
s_func = slot_value(s_slot);
if (is_c_function(s_func)) {
opt_info *opc;
opc = alloc_opo(sc);
switch (len) {
case 2:
if (i_idp_ok(sc, opc, s_func, car_x))
return (true);
break;
case 3:
if ((i_ii_ok(sc, opc, s_func, car_x)) ||
(i_7pi_ok(sc, opc, s_func, car_x)))
return (true);
break;
case 4:
if ((i_iii_ok(sc, opc, s_func, car_x)) ||
(i_7pii_ok(sc, opc, s_func, car_x)))
return (true);
break;
case 5:
{
int32_t pstart = sc->pc;
if (i_7piii_ok(sc, opc, s_func, car_x))
return (true);
pc_fallback(sc, pstart);
}
/* break; */
default:
if (((head == sc->add_symbol) ||
(head == sc->multiply_symbol)) &&
(i_add_any_ok(sc, opc, car_x)))
return (true);
break;
}
} else {
if ((is_macro(s_func)) && (!no_cell_opt(expr)))
return (int_optimize
(sc,
set_plist_1(sc,
s7_macroexpand(sc, s_func,
cdar(expr)))));
return (i_implicit_ok(sc, s_slot, car_x, len));
}
}
return_false(sc, car_x);
}
static bool int_optimize(s7_scheme * sc, s7_pointer expr)
{
return ((int_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));
}
static bool cell_optimize_1(s7_scheme * sc, s7_pointer expr)
{
s7_pointer car_x = car(expr), head;
if (!is_pair(car_x)) /* wrap constants/symbols */
return (opt_cell_not_pair(sc, car_x));
head = car(car_x);
if (is_symbol(head)) {
s7_pointer s_func, s_slot;
s7_int len;
len = s7_list_length(sc, car_x);
if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x))) /* this can be wrong! */
return (p_syntax(sc, car_x, len));
s_slot = lookup_slot_from(head, sc->curlet);
if (!is_slot(s_slot))
return_false(sc, car_x);
s_func = slot_value(s_slot);
if (is_c_function(s_func)) {
opt_info *opc;
s7_pointer sig = c_function_signature(s_func);
int32_t pstart;
opc = alloc_opo(sc);
pstart = sc->pc;
switch (len) {
case 1:
if (p_ok(sc, opc, s_func, car_x))
return (true);
break;
case 2:
if ((p_i_ok(sc, opc, s_func, car_x, sc->pc)) ||
(p_d_ok(sc, opc, s_func, car_x, sc->pc)) ||
(p_p_ok(sc, opc, s_func, car_x)))
return (true);
break;
case 3:
{
s7_i_ii_t ifunc;
if (is_symbol(cadr(car_x))) {
if ((is_pair(sig)) &&
(is_pair(cdr(sig))) &&
(is_pair(cddr(sig))) &&
(caddr(sig) == sc->is_integer_symbol)) {
if (p_pi_ok(sc, opc, s_func, sig, car_x))
return (true);
if ((car(sig) == sc->is_float_symbol) ||
(car(sig) == sc->is_real_symbol)) {
s7_d_7pi_t f;
f = s7_d_7pi_function(s_func);
if (f) {
sc->pc = pstart - 1;
if (float_optimize(sc, expr)) {
opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
return (true);
}
}
}
}
pc_fallback(sc, pstart);
}
ifunc = s7_i_ii_function(s_func);
sc->pc = pstart - 1;
if ((ifunc) && (int_optimize(sc, expr))) {
opc->v[O_WRAP].fi = opc->v[0].fi;
opc->v[0].fp = i_to_p;
if (opc->v[O_WRAP].fi == opt_i_ii_ss_add)
opc->v[0].fp = opt_p_ii_ss_add;
return (true);
}
pc_fallback(sc, pstart);
if ((p_ii_ok(sc, opc, s_func, car_x, pstart)) ||
(p_dd_ok(sc, opc, s_func, car_x, pstart)) ||
(p_pp_ok(sc, opc, s_func, car_x, pstart)) ||
(p_call_pp_ok(sc, opc, s_func, car_x, pstart)))
return (true);
}
break;
case 4:
if (is_symbol(cadr(car_x))) {
if ((is_pair(sig)) &&
(is_pair(cdr(sig))) &&
(is_pair(cddr(sig))) &&
(caddr(sig) == sc->is_integer_symbol)) {
if (p_pii_ok(sc, opc, s_func, car_x))
return (true);
if (p_pip_ok(sc, opc, s_func, car_x))
return (true);
if (((car(sig) == sc->is_float_symbol) ||
(car(sig) == sc->is_real_symbol)) &&
(s7_d_7pid_function(s_func)) &&
(d_7pid_ok(sc, opc, s_func, car_x))) {
/* if d_7pid is ok, we need d_to_p for cell_optimize */
opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
return (true);
}
sc->pc = pstart - 1;
if ((car(sig) == sc->is_integer_symbol) &&
(s7_i_7pii_function(s_func)) &&
(i_7pii_ok(sc, alloc_opo(sc), s_func, car_x)))
{
opc->v[O_WRAP].fi = opc->v[0].fi;
opc->v[0].fp = i_to_p;
return (true);
}
}
pc_fallback(sc, pstart);
}
if ((p_ppi_ok(sc, opc, s_func, car_x)) ||
(p_ppp_ok(sc, opc, s_func, car_x)) ||
(p_call_ppp_ok(sc, opc, s_func, car_x)))
return (true);
break;
case 5:
if ((is_target_or_its_alias
(head, s_func, sc->float_vector_set_symbol))
&& (d_7piid_ok(sc, opc, s_func, car_x))) {
opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p; /* as above, if d_7piid is ok, we need d_to_p for cell_optimize */
return (true);
}
if ((is_target_or_its_alias
(head, s_func, sc->float_vector_ref_symbol))
&& (d_7piii_ok(sc, opc, s_func, car_x))) {
opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
return (true);
}
if (i_7piii_ok(sc, opc, s_func, car_x)) {
opc->v[O_WRAP].fi = opc->v[0].fi;
opc->v[0].fp = i_to_p;
return (true);
}
if (is_target_or_its_alias
(head, s_func, sc->int_vector_set_symbol))
return_false(sc, car_x);
if (p_piip_ok(sc, opc, s_func, car_x))
return (true);
pc_fallback(sc, pstart);
if (p_call_any_ok(sc, opc, s_func, car_x, len))
return (true);
break;
case 6:
if ((is_target_or_its_alias
(head, s_func, sc->float_vector_set_symbol))
&& (d_7piiid_ok(sc, opc, s_func, car_x))) {
opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
return (true);
}
default: /* >3D vector-set etc */
if (p_call_any_ok(sc, opc, s_func, car_x, len))
return (true);
break;
}
} else {
if (is_closure(s_func)) {
opt_info *opc;
opc = alloc_opo(sc);
if (p_fx_any_ok(sc, opc, s_func, expr))
return (true);
}
if (is_macro(s_func))
return_false(sc, car_x); /* macroexpand+cell_optimize here restarts the optimize process */
return (p_implicit_ok(sc, s_slot, car_x, len));
}
}
return_false(sc, car_x);
}
static bool cell_optimize(s7_scheme * sc, s7_pointer expr)
{
return ((cell_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));
}
static bool bool_optimize_nw_1(s7_scheme * sc, s7_pointer expr)
{
s7_pointer car_x = car(expr), head;
if (!is_pair(car_x)) /* wrap constants/symbols */
return (opt_bool_not_pair(sc, car_x));
head = car(car_x);
if (is_symbol(head)) {
s7_pointer s_func;
s7_int len;
len = s7_list_length(sc, car_x);
if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x))) {
if (head == sc->and_symbol)
return (opt_b_and(sc, car_x, len));
if (head == sc->or_symbol)
return (opt_b_or(sc, car_x, len));
return_false(sc, car_x);
}
s_func = lookup_unexamined(sc, head);
if (!s_func)
return_false(sc, car_x);
if (is_c_function(s_func)) {
if (symbol_id(head) != 0) /* (float-vector? (block)) -- both safe c_funcs, but this is a method invocation */
return_false(sc, car_x);
switch (len) {
case 2:
return (b_idp_ok
(sc, s_func, car_x, opt_arg_type(sc, cdr(car_x))));
case 3:
{
s7_b_pp_t bpf;
s7_b_7pp_t bpf7 = NULL;
bpf = s7_b_pp_function(s_func);
if (!bpf)
bpf7 = s7_b_7pp_function(s_func);
if ((bpf) || (bpf7)) {
opt_info *opc;
s7_pointer sig1, sig2, arg1 = cadr(car_x), arg2 =
caddr(car_x);
opc = alloc_opo(sc);
sig1 = opt_arg_type(sc, cdr(car_x));
sig2 = opt_arg_type(sc, cddr(car_x));
if (sig2 == sc->is_integer_symbol) {
int32_t cur_index = sc->pc;
if ((sig1 == sc->is_integer_symbol) &&
(b_ii_ok
(sc, opc, s_func, car_x, arg1, arg2)))
return (true);
pc_fallback(sc, cur_index);
if ((!is_pair(arg2)) &&
(b_pi_ok(sc, opc, s_func, car_x, arg2)))
return (true);
pc_fallback(sc, cur_index);
}
if ((sig1 == sc->is_float_symbol) &&
(sig2 == sc->is_float_symbol) &&
(b_dd_ok(sc, opc, s_func, car_x, arg1, arg2)))
return (true);
if (bpf)
opc->v[3].b_pp_f = bpf;
else
opc->v[3].b_7pp_f = bpf7;
return (b_pp_ok
(sc, opc, s_func, car_x, arg1, arg2,
bpf != NULL));
}
}
break;
default:
break;
}
} else if (is_macro(s_func))
return_false(sc, car_x);
}
return_false(sc, car_x);
}
static bool bool_optimize_nw(s7_scheme * sc, s7_pointer expr)
{
return ((bool_optimize_nw_1(sc, expr)) && (sc->pc < OPTS_SIZE));
}
static bool bool_optimize(s7_scheme * sc, s7_pointer expr)
{
int32_t start = sc->pc;
opt_info *wrapper;
if (bool_optimize_nw(sc, expr))
return (true);
pc_fallback(sc, start);
wrapper = sc->opts[start];
if (!cell_optimize(sc, expr))
return_false(sc, NULL);
if (wrapper->v[O_WRAP].fp) /* (when (+ i 1) ...) */
return_false(sc, NULL);
wrapper->v[O_WRAP].fp = wrapper->v[0].fp;
wrapper->v[0].fb = p_to_b;
return (true);
}
static s7_pfunc s7_bool_optimize(s7_scheme * sc, s7_pointer expr)
{
sc->pc = 0;
if ((bool_optimize(sc, expr)) && (sc->pc < OPTS_SIZE))
return_true(sc, opt_bool_any, expr);
return_null(sc, expr);
}
/* snd-sig.c experiment */
static s7_double opt_float_any(s7_scheme * sc)
{
return (sc->opts[0]->v[0].fd(sc->opts[0]));
}
s7_float_function s7_float_optimize(s7_scheme * sc, s7_pointer expr)
{
sc->pc = 0;
if ((float_optimize(sc, expr)) && (sc->pc < OPTS_SIZE))
return (opt_float_any);
return (NULL);
}
static s7_pfunc s7_optimize_1(s7_scheme * sc, s7_pointer expr, bool nr)
{
if ((!is_pair(expr)) || (no_cell_opt(expr)) || (sc->debug != 0))
return (NULL);
sc->pc = 0;
if (!no_int_opt(expr)) {
if (int_optimize(sc, expr))
return ((nr) ? opt_int_any_nr : opt_wrap_int);
pc_fallback(sc, 0);
set_no_int_opt(expr);
}
if (!no_float_opt(expr)) {
if (float_optimize(sc, expr))
return_true(sc, (nr) ? opt_float_any_nr : opt_wrap_float,
expr);
pc_fallback(sc, 0);
set_no_float_opt(expr);
}
if (!no_bool_opt(expr)) {
if (bool_optimize_nw(sc, expr))
return_true(sc, (nr) ? opt_bool_any_nr : opt_wrap_bool, expr);
pc_fallback(sc, 0);
set_no_bool_opt(expr);
}
if (cell_optimize(sc, expr))
return_true(sc, (nr) ? opt_cell_any_nr : opt_wrap_cell, expr);
set_no_cell_opt(expr); /* checked above */
return_null(sc, expr);
}
s7_pfunc s7_optimize(s7_scheme * sc, s7_pointer expr)
{
return (s7_optimize_1(sc, expr, false));
}
s7_pfunc s7_optimize_nr(s7_scheme * sc, s7_pointer expr)
{
return (s7_optimize_1(sc, expr, true));
}
static s7_pointer g_optimize(s7_scheme * sc, s7_pointer args)
{
s7_pfunc f;
s7_pointer code = car(args);
f = s7_optimize(sc, code);
return ((f) ? f(sc) : sc->undefined);
}
static s7_pfunc s7_cell_optimize(s7_scheme * sc, s7_pointer expr, bool nr)
{
sc->pc = 0;
if ((cell_optimize(sc, expr)) && (sc->pc < OPTS_SIZE))
return ((nr) ? opt_cell_any_nr : opt_wrap_cell);
return (NULL);
}
/* ---------------- bool funcs (an experiment) ---------------- */
typedef bool (*s7_bfunc)(s7_scheme * sc, s7_pointer expr);
static bool fb_lt_ss(s7_scheme * sc, s7_pointer expr)
{
s7_pointer x, y;
x = lookup(sc, cadr(expr));
y = lookup(sc, opt2_sym(cdr(expr)));
return (((is_t_integer(x))
&& (is_t_integer(y))) ? (integer(x) <
integer(y)) : lt_b_7pp(sc, x, y));
}
static bool fb_num_eq_ss(s7_scheme * sc, s7_pointer expr)
{
s7_pointer x, y;
x = lookup(sc, cadr(expr));
y = lookup(sc, opt2_sym(cdr(expr)));
return (((is_t_integer(x))
&& (is_t_integer(y))) ? (integer(x) ==
integer(y)) : num_eq_b_7pp(sc, x,
y));
}
static bool fb_num_eq_s0(s7_scheme * sc, s7_pointer expr)
{
s7_pointer x;
x = lookup(sc, cadr(expr));
return ((is_t_integer(x)) ? (integer(x) == 0) :
num_eq_b_7pp(sc, x, int_zero));
}
static bool fb_num_eq_s0f(s7_scheme * sc, s7_pointer expr)
{
s7_pointer x;
x = lookup(sc, cadr(expr));
return ((is_t_real(x)) ? (real(x) == 0.0) :
num_eq_b_7pp(sc, x, real_zero));
}
static bool fb_gt_tu(s7_scheme * sc, s7_pointer expr)
{
s7_pointer x, y;
x = t_lookup(sc, cadr(expr), expr);
y = u_lookup(sc, opt2_sym(cdr(expr)), expr);
return (((is_t_integer(x))
&& (is_t_integer(y))) ? (integer(x) >
integer(y)) : gt_b_7pp(sc, x, y));
}
static bool fb_gt_ss(s7_scheme * sc, s7_pointer expr)
{
s7_pointer x, y;
x = s_lookup(sc, cadr(expr), expr);
y = s_lookup(sc, opt2_sym(cdr(expr)), expr);
return (((is_t_integer(x))
&& (is_t_integer(y))) ? (integer(x) >
integer(y)) : gt_b_7pp(sc, x, y));
}
static bool fb_geq_ss(s7_scheme * sc, s7_pointer expr)
{
s7_pointer x, y;
x = s_lookup(sc, cadr(expr), expr);
y = s_lookup(sc, opt2_sym(cdr(expr)), expr);
return (((is_t_integer(x))
&& (is_t_integer(y))) ? (integer(x) >=
integer(y)) : geq_b_7pp(sc, x, y));
}
static bool fb_leq_ss(s7_scheme * sc, s7_pointer expr)
{
s7_pointer x, y;
x = s_lookup(sc, cadr(expr), expr);
y = s_lookup(sc, opt2_sym(cdr(expr)), expr);
return (((is_t_integer(x))
&& (is_t_integer(y))) ? (integer(x) <=
integer(y)) : leq_b_7pp(sc, x, y));
}
static s7_pointer fx_to_fb(s7_scheme * sc, s7_function fx)
{ /* eventually parallel arrays? */
if (fx == fx_num_eq_ss)
return ((s7_pointer) fb_num_eq_ss);
if (fx == fx_lt_ss)
return ((s7_pointer) fb_lt_ss);
if (fx == fx_gt_ss)
return ((s7_pointer) fb_gt_ss);
if (fx == fx_leq_ss)
return ((s7_pointer) fb_leq_ss);
if (fx == fx_geq_ss)
return ((s7_pointer) fb_geq_ss);
if (fx == fx_gt_tu)
return ((s7_pointer) fb_gt_tu);
if (fx == fx_num_eq_s0)
return ((s7_pointer) fb_num_eq_s0);
if (fx == fx_num_eq_s0f)
return ((s7_pointer) fb_num_eq_s0f);
return (NULL);
}
/* when_b cond? do end-test? num_eq_vs|us */
/* ---------------------------------------- for-each ---------------------------------------- */
static Inline 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 let */
counter_set_slots(x, sc->nil); /* local let slots before body is evalled */
stack_set_has_counters(sc->stack);
return (x);
}
static s7_pointer make_iterators(s7_scheme * sc, s7_pointer args)
{
s7_pointer 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_pair(p); p = cdr(p)) {
s7_pointer 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;
return (proper_list_reverse_in_place(sc, sc->z));
}
static s7_pointer seq_init(s7_scheme * sc, s7_pointer seq)
{
if (is_float_vector(seq))
return (real_zero);
if (is_string(seq))
return (chars[65]);
if ((is_int_vector(seq)) || (is_byte_vector(seq)))
return (int_zero);
return (sc->F);
}
#define MUTLIM 32 /* was 1000 */
#define for_each_any_list(Code) \
do { \
for (x = seq, y = x; is_pair(x); ) \
{ \
slot_set_value(slot, car(x)); \
Code; \
x = cdr(x); \
if (is_pair(x)) \
{ \
slot_set_value(slot, car(x)); \
Code; \
y = cdr(y); x = cdr(x); \
if (x == y) break; \
}}} while (0)
static s7_pointer g_for_each_closure(s7_scheme * sc, s7_pointer f,
s7_pointer seq)
{ /* one sequence arg */
s7_pointer body = closure_body(f);
if (!no_cell_opt(body)) { /* if at top level we often get an unoptimized (not safe) function here that can be cell_optimized below */
s7_pfunc func;
s7_pointer old_e = sc->curlet, pars = closure_args(f), val, slot;
val = seq_init(sc, seq);
sc->curlet =
make_let_with_slot(sc, closure_let(f),
(is_pair(car(pars))) ? caar(pars) :
car(pars), val);
slot = let_slots(sc->curlet);
if (is_null(cdr(body)))
func = s7_optimize_nr(sc, body);
else if (is_null(cddr(body))) { /* 3 sometimes works */
set_ulist_1(sc, sc->begin_symbol, body);
func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); /* was list_1 via cons 8-Apr-21, true=nr */
} else
func = NULL;
if (func) {
s7_int(*fi) (opt_info * o);
opt_info *o;
if (is_pair(seq)) {
s7_pointer x, y;
if (func == opt_cell_any_nr) { /* this block saves less than 0.5% */
o = sc->opts[0];
for_each_any_list(o->v[0].fp(o));
} else
for_each_any_list(func(sc));
return (sc->unspecified);
}
if (is_float_vector(seq)) {
s7_double *vals = float_vector_floats(seq);
s7_int i, len = vector_length(seq);
if ((len > MUTLIM) && (!tree_has_setters(sc, body))) {
s7_pointer sv;
sv = s7_make_mutable_real(sc, 0.0);
slot_set_value(slot, sv);
if (func == opt_float_any_nr) {
s7_double(*fd) (opt_info * o);
o = sc->opts[0];
fd = o->v[0].fd;
for (i = 0; i < len; i++) {
real(sv) = vals[i];
fd(o);
}
} else if (func == opt_cell_any_nr) {
s7_pointer(*fp) (opt_info * o);
o = sc->opts[0];
fp = o->v[0].fp;
if (fp == opt_unless_p_1)
for (i = 0; i < len; i++) {
real(sv) = vals[i];
if (!(o->v[4].fb(o->v[3].o1)))
o->v[5].o1->v[0].fp(o->v[5].o1);
} else
for (i = 0; i < len; i++) {
real(sv) = vals[i];
fp(o);
}
} else
for (i = 0; i < len; i++) {
real(sv) = vals[i];
func(sc);
}
} else
for (i = 0; i < len; i++) {
slot_set_value(slot, make_real(sc, vals[i]));
func(sc);
}
return (sc->unspecified);
}
if (is_int_vector(seq)) {
s7_int *vals = int_vector_ints(seq);
s7_int i, len = vector_length(seq);
if ((len > MUTLIM) && (!tree_has_setters(sc, body))) {
s7_pointer sv;
sv = make_mutable_integer(sc, 0);
slot_set_value(slot, sv);
/* since there are no setters, the inner step is also mutable if there is one.
* func=opt_cell_any_nr, sc->opts[0]->v[0].fp(sc->opts[0]) fp=opt_do_1 -> mutable version
*/
if (func == opt_int_any_nr) {
o = sc->opts[0];
fi = o->v[0].fi;
for (i = 0; i < len; i++) {
integer(sv) = vals[i];
fi(o);
}
} else
for (i = 0; i < len; i++) {
integer(sv) = vals[i];
func(sc);
}
} else
for (i = 0; i < len; i++) {
slot_set_value(slot, make_integer(sc, vals[i]));
func(sc);
}
return (sc->unspecified);
}
if (is_normal_vector(seq)) {
s7_pointer *vals = vector_elements(seq);
s7_int i, len = vector_length(seq);
if (func == opt_cell_any_nr) {
s7_pointer(*fp) (opt_info * o);
o = sc->opts[0];
fp = o->v[0].fp;
for (i = 0; i < len; i++) {
slot_set_value(slot, vals[i]);
fp(o);
}
} else
for (i = 0; i < len; i++) {
slot_set_value(slot, vals[i]);
func(sc);
}
return (sc->unspecified);
}
if (is_string(seq)) {
const char *str = string_value(seq);
s7_int i, len = string_length(seq);
for (i = 0; i < len; i++) {
slot_set_value(slot, chars[(uint8_t) (str[i])]);
func(sc);
}
return (sc->unspecified);
}
if (is_byte_vector(seq)) {
uint8_t *vals = byte_vector_bytes(seq);
s7_int i, len = vector_length(seq);
if (func == opt_int_any_nr) {
o = sc->opts[0];
fi = o->v[0].fi;
for (i = 0; i < len; i++) {
slot_set_value(slot, small_int(vals[i]));
fi(o);
}
} else
for (i = 0; i < len; i++) {
slot_set_value(slot, small_int(vals[i]));
func(sc);
}
return (sc->unspecified);
}
sc->z = seq;
if (!is_iterator(sc->z))
sc->z = s7_make_iterator(sc, sc->z);
seq = sc->z;
push_stack_no_let(sc, OP_GC_PROTECT, seq, f);
sc->z = sc->nil;
if (func == opt_cell_any_nr) {
s7_pointer(*fp) (opt_info * o);
o = sc->opts[0];
fp = o->v[0].fp;
while (true) {
slot_set_value(slot, s7_iterate(sc, seq));
if (iterator_is_at_end(seq)) {
unstack(sc);
return (sc->unspecified);
}
fp(o);
}
}
if (func == opt_int_any_nr) {
o = sc->opts[0];
fi = o->v[0].fi;
while (true) {
slot_set_value(slot, s7_iterate(sc, seq));
if (iterator_is_at_end(seq)) {
unstack(sc);
return (sc->unspecified);
}
fi(o);
}
}
while (true) {
slot_set_value(slot, s7_iterate(sc, seq));
if (iterator_is_at_end(seq)) {
unstack(sc);
return (sc->unspecified);
}
func(sc);
}
} /* we never get here -- the while loops above exit via return #<unspecified> */
else { /* not func -- unneeded "else" but otherwise confusing code */
set_no_cell_opt(body);
set_curlet(sc, old_e);
}
}
if ((!is_closure_star(f)) && (is_null(cdr(body))) && (is_pair(seq))) {
s7_pointer c;
c = make_counter(sc, seq);
counter_set_result(c, seq);
push_stack(sc, OP_FOR_EACH_2, c, f);
return (sc->unspecified);
}
sc->z = seq;
if (!is_iterator(sc->z))
sc->z = s7_make_iterator(sc, sc->z);
push_stack(sc, OP_FOR_EACH_1, make_counter(sc, sc->z), f);
sc->z = sc->nil;
return (sc->unspecified);
}
static s7_pointer g_for_each_closure_2(s7_scheme * sc, s7_pointer f,
s7_pointer seq_1, s7_pointer seq_2)
{
s7_pointer body = closure_body(f);
/* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(sc->code), display(seq1), display(seq2)); */
if (!no_cell_opt(body)) {
s7_pfunc fnc;
s7_pointer olde = sc->curlet, pars =
closure_args(f), val_1, val_2, slot_1, slot_2;
val_1 = seq_init(sc, seq_1);
val_2 = seq_init(sc, seq_2);
sc->curlet = make_let_with_two_slots(sc, closure_let(f),
(is_pair(car(pars))) ?
caar(pars) : car(pars), val_1,
(is_pair(cadr(pars))) ?
cadar(pars) : cadr(pars),
val_2);
slot_1 = let_slots(sc->curlet);
slot_2 = next_slot(slot_1);
if (is_null(cdr(body)))
fnc = s7_optimize_nr(sc, body);
else if (is_null(cddr(body))) {
set_ulist_1(sc, sc->begin_symbol, body);
fnc = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true);
} else
fnc = NULL;
if (fnc) {
if ((is_pair(seq_1)) && (is_pair(seq_2))) {
s7_pointer fast_1, slow_1, fast_2, slow_2;
for (fast_1 = seq_1, slow_1 = seq_1, fast_2 =
seq_2, slow_2 = seq_2;
(is_pair(fast_1)) && (is_pair(fast_2));
fast_1 = cdr(fast_1), slow_1 = cdr(slow_1), fast_2 =
cdr(fast_2), slow_2 = cdr(slow_2)) {
slot_set_value(slot_1, car(fast_1));
slot_set_value(slot_2, car(fast_2));
fnc(sc);
if ((is_pair(cdr(fast_1))) && (is_pair(cdr(fast_2)))) {
fast_1 = cdr(fast_1);
if (fast_1 == slow_1)
break;
fast_2 = cdr(fast_2);
if (fast_2 == slow_2)
break;
slot_set_value(slot_1, car(fast_1));
slot_set_value(slot_2, car(fast_2));
fnc(sc);
}
}
set_curlet(sc, olde);
return (sc->unspecified);
} else if ((is_any_vector(seq_1)) && (is_any_vector(seq_2))) {
s7_int i, len = vector_length(seq_1);
if (len > vector_length(seq_2))
len = vector_length(seq_2);
for (i = 0; i < len; i++) {
slot_set_value(slot_1,
vector_getter(seq_1) (sc, seq_1, i));
slot_set_value(slot_2,
vector_getter(seq_2) (sc, seq_2, i));
fnc(sc);
}
set_curlet(sc, olde);
return (sc->unspecified);
} else if ((is_string(seq_1)) && (is_string(seq_2))) {
s7_int i, len = string_length(seq_1);
const char *s_1 = string_value(seq_1), *s_2 =
string_value(seq_2);
if (len > string_length(seq_2))
len = string_length(seq_2);
for (i = 0; i < len; i++) {
slot_set_value(slot_1, chars[(uint8_t) (s_1[i])]);
slot_set_value(slot_2, chars[(uint8_t) (s_2[i])]);
fnc(sc);
}
set_curlet(sc, olde);
return (sc->unspecified);
} else {
set_no_cell_opt(body);
set_curlet(sc, olde);
}
} else { /* not fnc */
set_no_cell_opt(body);
set_curlet(sc, olde);
}
}
sc->z =
list_1(sc,
(is_iterator(seq_2)) ? seq_2 : s7_make_iterator(sc, seq_2));
sc->z =
cons(sc,
(is_iterator(seq_1)) ? seq_1 : s7_make_iterator(sc, seq_1),
sc->z);
push_stack(sc, OP_FOR_EACH,
cons_unchecked(sc, sc->z, make_list(sc, 2, sc->nil)), f);
sc->z = sc->nil;
return (sc->unspecified);
}
static inline bool for_each_arg_is_null(s7_scheme * sc, s7_pointer args)
{
s7_pointer p;
bool got_nil = false;
for (p = args; is_pair(p); p = cdr(p)) {
s7_pointer obj = car(p);
if (!is_mappable(obj)) {
if (is_null(obj))
got_nil = true;
else
return (simple_wrong_type_argument_with_type
(sc, sc->for_each_symbol, obj, a_sequence_string));
}
}
return (got_nil);
}
static s7_pointer g_for_each(s7_scheme * sc, s7_pointer args)
{
#define H_for_each "(for-each proc object . objects) applies proc to each element of the objects traversed in parallel. \
Each object can be a list, string, vector, hash-table, or any other sequence."
#define Q_for_each s7_make_circular_signature(sc, 2, 3, sc->is_unspecified_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol)
s7_pointer f = car(args);
s7_int len;
bool arity_ok = false;
/* try the normal case first */
sc->value = f;
len = proper_list_length(cdr(args));
if (is_closure(f)) { /* not lambda* that might get confused about arg names */
if ((len == 1) &&
(is_pair(closure_args(f))) && (is_null(cdr(closure_args(f)))))
arity_ok = true;
} else if (!is_applicable(f))
return (method_or_bust_with_type
(sc, f, sc->for_each_symbol, args,
something_applicable_string, 1));
if ((!arity_ok) && (!s7_is_aritable(sc, f, len)))
return (s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_4(sc,
wrap_string(sc,
"for-each ~A: ~A argument~P?",
27), f, make_integer(sc,
len),
make_integer(sc, len))));
if (for_each_arg_is_null(sc, cdr(args)))
return (sc->unspecified);
/* if function is safe c func, do the for-each locally */
if ((is_c_function(f)) && (is_safe_procedure(f))) {
s7_function func;
s7_pointer iters;
s7_p_p_t fp = s7_p_p_function(f);
if ((fp) && (len == 1)) {
if (is_pair(cadr(args))) {
s7_pointer fast, slow;
for (fast = cadr(args), slow = cadr(args); is_pair(fast);
fast = cdr(fast), slow = cdr(slow)) {
fp(sc, car(fast));
if (is_pair(cdr(fast))) {
fast = cdr(fast);
if (fast == slow)
break;
fp(sc, car(fast));
}
return (sc->unspecified);
}
} else if (is_any_vector(cadr(args))) {
s7_int i, vlen;
s7_pointer v = cadr(args);
vlen = vector_length(v);
for (i = 0; i < vlen; i++)
fp(sc, vector_getter(v) (sc, v, i));
return (sc->unspecified);
} else if (is_string(cadr(args))) {
s7_int i, slen;
s7_pointer str = cadr(args);
const char *s;
s = string_value(str);
slen = string_length(str);
for (i = 0; i < slen; i++)
fp(sc, chars[(uint8_t) (s[i])]);
return (sc->unspecified);
}
}
func = c_function_call(f); /* presumably this is either display/write, or method call? */
sc->z = make_iterators(sc, args);
sc->z = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil));
push_stack_no_let(sc, OP_GC_PROTECT, sc->args, sc->z); /* temporary GC protection */
if (len == 1) {
s7_pointer 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)) {
/* not pop_stack here since that can clobber sc->code et al, and if this for-each call is
* being treated as safe, fn_proc(for-each) assumes everywhere that sc->code is left alone.
*/
unstack(sc); /* free_cell(sc, x); *//* 16-Jan-19 */
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))) {
unstack(sc);
return (sc->unspecified);
}
}
func(sc, cdr(iters));
}
}
/* if closure call is straightforward, use OP_FOR_EACH_1 */
if ((len == 1) &&
(((is_closure(f)) &&
(closure_arity_to_int(sc, f) == 1) &&
(!is_constant_symbol(sc, car(closure_args(f))))) ||
((is_closure_star(f)) &&
(closure_star_arity_to_int(sc, f) == 1) &&
(!is_constant_symbol
(sc,
(is_pair(car(closure_args(f)))) ? caar(closure_args(f)) :
car(closure_args(f)))))))
return (g_for_each_closure(sc, f, cadr(args)));
push_stack(sc, OP_FOR_EACH,
cons_unchecked(sc, make_iterators(sc, args),
make_list(sc, len, sc->nil)), f);
sc->z = sc->nil;
return (sc->unspecified);
}
static bool op_for_each(s7_scheme * sc)
{
s7_pointer x, y, 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;
free_cell(sc, sc->args);
return (true);
}
}
push_stack_direct(sc, OP_FOR_EACH);
if (needs_copied_args(sc->code))
sc->args = copy_proper_list(sc, saved_args);
else
sc->args = saved_args;
return (false);
}
/* for-each et al remake the local let, but that's only needed if the local let is exported,
* and that can only happen through make-closure in various guises and curlet.
* owlet captures, but it would require a deliberate error to use it in this context.
* c_objects call object_set_let but that requires a prior curlet or sublet. So we have
* sc->capture_let_counter that is incremented every time 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 let. But that reuse assumes no new slots were added (by define etc), because
* update_let* only update the symbol_id's they expect, and that can happen even in op_for_each_2.
*/
static Inline bool op_for_each_1(s7_scheme * sc)
{
s7_pointer counter = sc->args, p, arg, code;
p = counter_list(counter);
arg = s7_iterate(sc, p);
if (iterator_is_at_end(p)) {
sc->value = sc->unspecified;
free_cell(sc, counter);
return (true);
}
code = T_Clo(sc->code);
if (counter_capture(counter) != sc->capture_let_counter) {
s7_pointer sym = car(closure_args(code));
sc->curlet =
make_let_with_slot(sc, closure_let(code),
(is_symbol(sym)) ? sym : car(sym), arg);
counter_set_let(counter, sc->curlet);
counter_set_slots(counter, let_slots(sc->curlet));
counter_set_capture(counter, sc->capture_let_counter);
} else {
let_set_slots(counter_let(counter), counter_slots(counter)); /* this is needed (unless safe_closure but that costs more to check than this set) */
sc->curlet = update_let_with_slot(sc, counter_let(counter), arg);
}
push_stack(sc, OP_FOR_EACH_1, counter, code);
sc->code = T_Pair(closure_body(code));
return (false);
}
static Inline bool op_for_each_2(s7_scheme * sc)
{
s7_pointer c = sc->args, lst;
lst = counter_list(c);
if (!is_pair(lst)) { /* '(1 2 . 3) as arg? -- counter_list can be anything here */
sc->value = sc->unspecified;
free_cell(sc, c); /* not sc->args = sc->nil; */
return (true);
}
counter_set_list(c, cdr(lst));
if (sc->cur_op == OP_FOR_EACH_3) {
counter_set_result(c, cdr(counter_result(c)));
if (counter_result(c) == counter_list(c)) {
sc->value = sc->unspecified;
free_cell(sc, c); /* not sc->args = sc->nil; */
return (true);
}
push_stack_direct(sc, OP_FOR_EACH_2);
} else
push_stack_direct(sc, OP_FOR_EACH_3);
if (counter_capture(c) != sc->capture_let_counter) {
sc->curlet =
make_let_with_slot(sc, closure_let(sc->code),
car(closure_args(sc->code)), car(lst));
counter_set_let(c, sc->curlet);
counter_set_slots(c, let_slots(sc->curlet));
counter_set_capture(c, sc->capture_let_counter);
} else {
let_set_slots(counter_let(c), counter_slots(c));
sc->curlet = update_let_with_slot(sc, counter_let(c), car(lst));
}
sc->code = car(closure_body(sc->code));
return (false);
}
/* ---------------------------------------- map ---------------------------------------- */
static s7_pointer g_map_closure(s7_scheme * sc, s7_pointer f,
s7_pointer seq)
{ /* one sequence argument */
s7_pointer body = closure_body(f);
sc->value = f;
if (!no_cell_opt(body)) {
s7_pfunc func = NULL;
s7_pointer old_e = sc->curlet, pars = closure_args(f), val, slot;
val = seq_init(sc, seq);
sc->curlet =
make_let_with_slot(sc, closure_let(f),
(is_pair(car(pars))) ? caar(pars) :
car(pars), val);
slot = let_slots(sc->curlet);
if (is_null(cdr(body)))
func = s7_cell_optimize(sc, body, false);
else if (is_null(cddr(body))) {
set_ulist_1(sc, sc->begin_symbol, body);
func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */
} else
func = NULL;
if (func) {
s7_pointer z;
sc->v = sc->nil;
push_stack_no_let(sc, OP_GC_PROTECT, f, seq);
if (is_pair(seq)) {
s7_pointer fast, slow;
for (fast = seq, slow = seq; is_pair(fast);
fast = cdr(fast), slow = cdr(slow)) {
slot_set_value(slot, car(fast));
z = func(sc);
if (z != sc->no_value)
sc->v = cons(sc, z, sc->v);
if (is_pair(cdr(fast))) {
fast = cdr(fast);
if (fast == slow)
break;
slot_set_value(slot, car(fast));
z = func(sc);
if (z != sc->no_value)
sc->v = cons(sc, z, sc->v);
}
}
unstack(sc);
return (proper_list_reverse_in_place(sc, sc->v));
}
if (is_float_vector(seq)) {
s7_double *vals = float_vector_floats(seq);
s7_int i, len = vector_length(seq);
for (i = 0; i < len; i++) {
slot_set_value(slot, make_real(sc, vals[i]));
z = func(sc);
if (z != sc->no_value)
sc->v = cons(sc, z, sc->v);
}
unstack(sc);
return (proper_list_reverse_in_place(sc, sc->v));
}
if (is_int_vector(seq)) {
s7_int *vals = int_vector_ints(seq);
s7_int i, len = vector_length(seq);
for (i = 0; i < len; i++) {
slot_set_value(slot, make_integer(sc, vals[i]));
z = func(sc);
if (z != sc->no_value)
sc->v = cons(sc, z, sc->v);
}
unstack(sc);
return (proper_list_reverse_in_place(sc, sc->v));
}
if (is_normal_vector(seq)) {
s7_pointer *vals = vector_elements(seq);
s7_int i, len = vector_length(seq);
for (i = 0; i < len; i++) {
slot_set_value(slot, vals[i]);
z = func(sc);
if (z != sc->no_value)
sc->v = cons(sc, z, sc->v);
}
unstack(sc);
return (proper_list_reverse_in_place(sc, sc->v));
}
if (is_string(seq)) {
s7_int i, len = string_length(seq);
const char *str = string_value(seq);
for (i = 0; i < len; i++) {
slot_set_value(slot, chars[(uint8_t) (str[i])]);
z = func(sc);
if (z != sc->no_value)
sc->v = cons(sc, z, sc->v);
}
unstack(sc);
return (proper_list_reverse_in_place(sc, sc->v));
}
}
set_no_cell_opt(body);
set_curlet(sc, old_e);
}
if (is_closure_star(f)) {
sc->z = make_iterators(sc, set_plist_2(sc, sc->nil, seq));
push_stack(sc, OP_MAP, make_counter(sc, sc->z), f);
sc->z = sc->nil;
return (sc->nil);
}
if ((is_null(cdr(body))) && (is_pair(seq))) {
closure_set_map_list(f, seq);
push_stack(sc, OP_MAP_2, make_counter(sc, seq), f);
return (sc->unspecified);
}
sc->z = (!is_iterator(seq)) ? s7_make_iterator(sc, seq) : seq;
push_stack(sc, OP_MAP_1, make_counter(sc, sc->z), f);
sc->z = sc->nil;
return (sc->nil);
}
static s7_pointer g_map_closure_2(s7_scheme * sc, s7_pointer f,
s7_pointer seq1, s7_pointer seq2)
{
s7_pointer body = closure_body(f);
/* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(sc->code), display(seq1), display(seq2)); */
if (!no_cell_opt(body)) {
s7_pfunc func;
s7_pointer old_e = sc->curlet, pars =
closure_args(f), val1, val2, slot1, slot2;
val1 = seq_init(sc, seq1);
val2 = seq_init(sc, seq2);
sc->curlet = make_let_with_two_slots(sc, closure_let(f),
(is_pair(car(pars))) ?
caar(pars) : car(pars), val1,
(is_pair(cadr(pars))) ?
cadar(pars) : cadr(pars),
val2);
slot1 = let_slots(sc->curlet);
slot2 = next_slot(slot1);
if (is_null(cdr(body)))
func = s7_cell_optimize(sc, body, false);
else if (is_null(cddr(body))) {
set_ulist_1(sc, sc->begin_symbol, body);
func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false);
} else
func = NULL;
if (func) {
s7_pointer val;
if ((is_pair(seq1)) && (is_pair(seq2))) {
s7_pointer fast1, slow1, fast2, slow2;
sc->v = sc->nil;
for (fast1 = seq1, slow1 = seq1, fast2 = seq2, slow2 =
seq2; (is_pair(fast1)) && (is_pair(fast2));
fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 =
cdr(fast2), slow2 = cdr(slow2)) {
slot_set_value(slot1, car(fast1));
slot_set_value(slot2, car(fast2));
val = func(sc);
if (val != sc->no_value)
sc->v = cons(sc, val, sc->v);
if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) {
fast1 = cdr(fast1);
if (fast1 == slow1)
break;
fast2 = cdr(fast2);
if (fast2 == slow2)
break;
slot_set_value(slot1, car(fast1));
slot_set_value(slot2, car(fast2));
val = func(sc);
if (val != sc->no_value)
sc->v = cons(sc, val, sc->v);
}
}
set_curlet(sc, old_e);
return (proper_list_reverse_in_place(sc, sc->v));
} else if ((is_any_vector(seq1)) && (is_any_vector(seq2))) {
s7_int i, len = vector_length(seq1);
if (len > vector_length(seq2))
len = vector_length(seq2);
sc->v = sc->nil;
for (i = 0; i < len; i++) {
slot_set_value(slot1,
vector_getter(seq1) (sc, seq1, i));
slot_set_value(slot2,
vector_getter(seq2) (sc, seq2, i));
val = func(sc);
if (val != sc->no_value)
sc->v = cons(sc, val, sc->v);
}
set_curlet(sc, old_e);
return (proper_list_reverse_in_place(sc, sc->v));
} else if ((is_string(seq1)) && (is_string(seq2))) {
s7_int i, len = string_length(seq1);
const char *s1 = string_value(seq1), *s2 =
string_value(seq2);
if (len > string_length(seq2))
len = string_length(seq2);
sc->v = sc->nil;
for (i = 0; i < len; i++) {
slot_set_value(slot1, chars[(uint8_t) (s1[i])]);
slot_set_value(slot2, chars[(uint8_t) (s2[i])]);
val = func(sc);
if (val != sc->no_value)
sc->v = cons(sc, val, sc->v);
}
set_curlet(sc, old_e);
return (proper_list_reverse_in_place(sc, sc->v));
} else {
set_no_cell_opt(body);
set_curlet(sc, old_e);
}
} else { /* not func */
set_no_cell_opt(body);
set_curlet(sc, old_e);
}
}
sc->z =
list_1(sc,
(is_iterator(seq2)) ? seq2 : s7_make_iterator(sc, seq2));
sc->z =
cons(sc, (is_iterator(seq1)) ? seq1 : s7_make_iterator(sc, seq1),
sc->z);
push_stack(sc, OP_MAP, make_counter(sc, sc->z), f);
sc->z = sc->nil;
return (sc->unspecified);
}
static s7_pointer g_map(s7_scheme * sc, s7_pointer args)
{
#define H_map "(map proc object . objects) applies proc to a list made up of the next element of each of its arguments, returning \
a list of the results. Its arguments can be lists, vectors, strings, hash-tables, or any applicable objects."
#define Q_map s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol)
s7_pointer p, f = car(args);
s7_int len;
bool got_nil = false;
for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++)
if (!is_mappable(car(p))) {
if (is_null(car(p)))
got_nil = true;
else
return (simple_wrong_type_argument_with_type
(sc, sc->map_symbol, car(p), a_sequence_string));
}
switch (type(f)) {
case T_C_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
if ((c_function_required_args(f) > len) ||
(c_function_all_args(f) < len))
return (s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_4(sc,
wrap_string(sc,
"map ~A: ~A argument~P?",
22), f,
wrap_integer1(sc, len),
wrap_integer2(sc, len))));
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
/* if function is safe c func, do the map locally */
if (got_nil)
return (sc->nil);
if (is_safe_procedure(f)) {
s7_pointer val, val1, old_args, iter_list;
s7_function func = c_function_call(f);
if (is_pair(cadr(args))) {
if (len == 1) {
s7_p_p_t fp = s7_p_p_function(f);
if (fp) {
s7_pointer fast, slow;
val = list_1_unchecked(sc, sc->nil);
push_stack_no_let_no_code(sc, OP_GC_PROTECT, val);
for (fast = cadr(args), slow = cadr(args);
is_pair(fast);
fast = cdr(fast), slow = cdr(slow)) {
s7_pointer z;
z = fp(sc, car(fast));
if (z != sc->no_value)
set_car(val, cons(sc, z, car(val)));
if (is_pair(cdr(fast))) {
fast = cdr(fast);
if (fast == slow)
break;
z = fp(sc, car(fast));
if (z != sc->no_value)
set_car(val, cons(sc, z, car(val)));
}
}
unstack(sc);
return (proper_list_reverse_in_place
(sc, car(val)));
}
}
if ((len == 2) && (is_pair(caddr(args)))) {
s7_p_pp_t fp = s7_p_pp_function(f);
if (fp) {
s7_pointer fast1, slow1, fast2, slow2;
val = list_1_unchecked(sc, sc->nil);
push_stack_no_let_no_code(sc, OP_GC_PROTECT, val);
for (fast1 = cadr(args), slow1 =
cadr(args), fast2 = caddr(args), slow2 =
caddr(args);
(is_pair(fast1)) && (is_pair(fast2));
fast1 = cdr(fast1), slow1 =
cdr(slow1), fast2 = cdr(fast2), slow2 =
cdr(slow2)) {
s7_pointer z;
z = fp(sc, car(fast1), car(fast2));
if (z != sc->no_value)
set_car(val, cons(sc, z, car(val)));
if ((is_pair(cdr(fast1)))
&& (is_pair(cdr(fast2)))) {
fast1 = cdr(fast1);
if (fast1 == slow1)
break;
fast2 = cdr(fast2);
if (fast2 == slow2)
break;
z = fp(sc, car(fast1), car(fast2));
if (z != sc->no_value)
set_car(val, cons(sc, z, car(val)));
}
}
unstack(sc);
return (proper_list_reverse_in_place
(sc, car(val)));
}
}
}
if ((is_string(cadr(args))) && (len == 1)) {
s7_p_p_t fp = s7_p_p_function(f);
if (fp) {
s7_int i, len;
s7_pointer val, str = cadr(args);
const char *s;
val = list_1_unchecked(sc, sc->nil);
push_stack_no_let_no_code(sc, OP_GC_PROTECT, val);
s = string_value(str);
len = string_length(str);
for (i = 0; i < len; i++) {
s7_pointer z;
z = fp(sc, chars[(uint8_t) (s[i])]);
if (z != sc->no_value)
set_car(val, cons(sc, z, car(val)));
}
unstack(sc);
return (proper_list_reverse_in_place(sc, car(val)));
}
}
if ((is_any_vector(cadr(args))) && (len == 1)) {
s7_p_p_t fp = s7_p_p_function(f);
if (fp) {
s7_int i, len;
s7_pointer val, vec = cadr(args);
val = list_1_unchecked(sc, sc->nil);
push_stack_no_let_no_code(sc, OP_GC_PROTECT, val);
len = vector_length(vec);
for (i = 0; i < len; i++) {
s7_pointer z;
z = fp(sc, vector_getter(vec) (sc, vec, i));
if (z != sc->no_value)
set_car(val, cons(sc, z, car(val)));
}
unstack(sc);
return (proper_list_reverse_in_place(sc, car(val)));
}
}
sc->z = make_iterators(sc, args);
val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil));
iter_list = sc->z;
old_args = sc->args;
/* func = c_function_call(f); */
push_stack_no_let(sc, OP_GC_PROTECT, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */
sc->z = sc->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))) {
unstack(sc);
/* free_cell(sc, car(x)); *//* 16-Jan-19 iterator in circular list -- see s7test */
sc->args = T_Pos(old_args);
return (proper_list_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)));
}
}
else /* not safe procedure */
if ((f == global_value(sc->values_symbol)) &&
(len == 1) && (!has_methods(cadr(args)))) { /* iterator should be ok here -- object_to_list can handle it */
p = object_to_list(sc, cadr(args));
if (p != cadr(args))
return (p);
}
break;
case T_CLOSURE:
case T_CLOSURE_STAR:
{
int32_t fargs;
fargs =
(is_closure(f)) ? closure_arity_to_int(sc,
f) :
closure_star_arity_to_int(sc, f);
if ((len == 1) && (fargs == 1)
&&
(!is_constant_symbol
(sc,
(is_pair(car(closure_args(f)))) ? caar(closure_args(f)) :
car(closure_args(f))))) {
if (got_nil)
return (sc->nil);
if (is_closure_star(f))
return (g_map_closure(sc, f, cadr(args)));
/* don't go to OP_MAP_2 here! It assumes no recursion */
sc->z =
(!is_iterator(cadr(args))) ? s7_make_iterator(sc,
cadr
(args)) :
cadr(args);
push_stack(sc, OP_MAP_1, make_counter(sc, sc->z), f);
sc->z = sc->nil;
symbol_increment_ctr(car(closure_args(f)));
return (sc->nil);
}
if (((fargs >= 0) && (fargs < len)) ||
((is_closure(f)) && (abs(fargs) > len)))
return (s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_4(sc,
wrap_string(sc,
"map ~A: ~A argument~P?",
22), f,
wrap_integer1(sc, len),
wrap_integer2(sc, len))));
if (got_nil)
return (sc->nil);
}
break;
default:
if (!is_applicable(f))
return (method_or_bust_with_type
(sc, f, sc->map_symbol, args,
something_applicable_string, 1));
if ((!is_pair(f)) && (!s7_is_aritable(sc, f, len)))
return (s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_4(sc,
wrap_string(sc,
"map ~A: ~A argument~P?",
22), f,
wrap_integer1(sc, len),
wrap_integer2(sc, len))));
if (got_nil)
return (sc->nil);
break;
}
sc->z = make_iterators(sc, args);
push_stack(sc, OP_MAP, make_counter(sc, sc->z), f);
sc->z = sc->nil;
return (sc->nil);
}
static bool op_map(s7_scheme * sc)
{
s7_pointer y, 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 =
proper_list_reverse_in_place(sc, counter_result(sc->args));
free_cell(sc, sc->args); /* not sc->args = sc->nil; */
return (true);
}
sc->x = cons(sc, x, sc->x);
}
sc->x = proper_list_reverse_in_place(sc, sc->x);
push_stack_direct(sc, OP_MAP_GATHER);
sc->args = sc->x;
sc->x = sc->nil;
if (needs_copied_args(sc->code))
sc->args = copy_proper_list(sc, sc->args);
return (false);
}
static bool op_map_1(s7_scheme * sc)
{
s7_pointer x, args = sc->args, p, code = sc->code;
p = counter_list(args);
x = s7_iterate(sc, p);
if (iterator_is_at_end(p)) {
sc->value = proper_list_reverse_in_place(sc, counter_result(args));
free_cell(sc, sc->args); /* not sc->args = sc->nil; */
return (true);
}
push_stack_direct(sc, OP_MAP_GATHER_1);
if (counter_capture(args) != sc->capture_let_counter) {
sc->curlet =
make_let_with_slot(sc, closure_let(code),
car(closure_args(code)), x);
counter_set_let(args, sc->curlet);
counter_set_slots(args, let_slots(sc->curlet));
counter_set_capture(args, sc->capture_let_counter);
} else {
/* the counter_slots field saves the original local let slot(s) representing the function
* argument. If the function has internal defines, they get added to the front of the
* slots list, but update_let_with_slot (maybe stupidly) assumes only the one original
* slot exists when it updates its symbol_id from the (possibly changed) let_id. So,
* a subsequent reference to the parameter name causes "unbound variable", or a segfault
* if the check has been optimized away. I think each function call should start with
* the original let slots, so counter_slots saves that pointer, and resets it here.
*/
let_set_slots(counter_let(args), counter_slots(args));
sc->curlet = update_let_with_slot(sc, counter_let(args), x);
}
sc->code = T_Pair(closure_body(code));
return (false);
}
static bool op_map_2(s7_scheme * sc)
{
s7_pointer x, c = sc->args, p, code = sc->code;
p = counter_list(c);
if (!is_pair(p)) {
sc->value = proper_list_reverse_in_place(sc, counter_result(c));
free_cell(sc, sc->args); /* not sc->args = sc->nil; */
return (true);
}
x = car(p);
counter_set_list(c, cdr(p));
if (sc->cur_op == OP_MAP_GATHER_3) {
closure_set_map_list(code, cdr(closure_map_list(code)));
/* this depends on code (the function) being non-recursive, else closure_setter gets stepped on */
if (closure_map_list(code) == counter_list(c)) {
sc->value =
proper_list_reverse_in_place(sc, counter_result(c));
free_cell(sc, c); /* not sc->args = sc->nil; */
return (true);
}
push_stack_direct(sc, OP_MAP_GATHER_2);
} else
push_stack_direct(sc, OP_MAP_GATHER_3);
if (counter_capture(c) != sc->capture_let_counter) {
sc->curlet =
make_let_with_slot(sc, closure_let(code),
car(closure_args(code)), x);
counter_set_let(c, sc->curlet);
counter_set_slots(c, let_slots(sc->curlet));
counter_set_capture(c, sc->capture_let_counter);
} else {
let_set_slots(counter_let(c), counter_slots(c)); /* needed -- see comment under for-each above */
sc->curlet = update_let_with_slot(sc, counter_let(c), x);
}
sc->code = car(closure_body(code));
return (false);
}
/* -------------------------------- multiple-values -------------------------------- */
#if S7_DEBUGGING
#define T_Mut(p) T_Mut_1(p, __func__, __LINE__)
static s7_pointer T_Mut_1(s7_pointer p, const char *func, int line)
{
if ((is_pair(p)) && ((is_immutable(p)) || (!in_heap(p)))) /* might be nil */
fprintf(stderr, "%s[%d]: immutable list: %p\n", func, line, p);
return (p);
}
#else
#define T_Mut(p) p
#endif
static s7_pointer splice_in_values(s7_scheme * sc, s7_pointer args)
{
int64_t top;
s7_pointer x;
top = current_stack_top(sc) - 1; /* stack_end - stack_start if negative, we're in big trouble */
if (SHOW_EVAL_OPS)
safe_print(fprintf
(stderr, "%s[%d]: splice %s %s\n", __func__, __LINE__,
op_names[stack_op(sc->stack, top)], display_80(args)));
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 is not safe to simply reverse args and tack the current stacked args onto its (new) end,
* setting stacked args to cdr of reversed-args and returning car because the list (args)
* can be some variable's value in a macro expansion via ,@ and reversing it in place
* (all this to avoid consing), clobbers the variable's value.
*/
for (x = args; is_not_null(cdr(x)); x = cdr(x))
stack_args(sc->stack, top) =
cons(sc, car(x), T_Mut(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 go to a different branch here
*/
case OP_ANY_CLOSURE_NP_2:
stack_element(sc->stack, top) =
(s7_pointer) OP_ANY_CLOSURE_NP_MV_1;
goto FP_MV;
case OP_ANY_C_NP_2:
stack_element(sc->stack, top) = (s7_pointer) OP_ANY_C_NP_MV_1;
goto FP_MV;
case OP_ANY_C_NP_1:
case OP_ANY_CLOSURE_NP_1:
stack_element(sc->stack, top) = (s7_pointer) (stack_op(sc->stack, top) + 1); /* replace with mv version */
case OP_ANY_C_NP_MV_1:
case OP_ANY_CLOSURE_NP_MV_1:
FP_MV:
if ((is_immutable(args)) || /* (let () (define (func) (with-output-to-string (lambda () (apply-values (write '(1 2)))))) (func) (func)) */
(needs_copied_args(args))) {
clear_needs_copied_args(args);
args = copy_proper_list(sc, args);
}
set_multiple_value(args);
return (args);
case OP_SAFE_C_SSP_1:
stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_SSP_MV_1;
return (args);
case OP_SAFE_C_SP_1:
case OP_SAFE_CONS_SP_1:
case OP_SAFE_LIST_SP_1:
case OP_SAFE_ADD_SP_1:
case OP_SAFE_MULTIPLY_SP_1:
stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_SP_MV;
return (args);
case OP_SAFE_C_PS_1:
stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PS_MV;
return (args);
case OP_SAFE_C_PC_1:
stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PC_MV;
return (args);
case OP_SAFE_C_PA_1:
stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PA_MV;
return (args);
case OP_C_P_1:
case OP_SAFE_C_P_1:
stack_element(sc->stack, top) = (s7_pointer) OP_C_P_MV;
return (args);
case OP_C_AP_1:
stack_element(sc->stack, top) = (s7_pointer) OP_C_AP_MV;
sc->value = args;
return (args);
case OP_SAFE_CLOSURE_P_1:
case OP_CLOSURE_P_1:
case OP_SAFE_CLOSURE_P_A_1:
case OP_SAFE_CLOSURE_AP_1:
case OP_CLOSURE_AP_1:
case OP_SAFE_CLOSURE_PP_1:
case OP_CLOSURE_PP_1:
case OP_SAFE_CLOSURE_PA_1:
case OP_CLOSURE_PA_1: /* arity is 2, we have 2 args, this has to be an error (see optimize_closure_dotted_args) */
case OP_ANY_CLOSURE_3P_1:
case OP_ANY_CLOSURE_3P_2:
case OP_ANY_CLOSURE_3P_3:
case OP_ANY_CLOSURE_4P_1:
case OP_ANY_CLOSURE_4P_2:
case OP_ANY_CLOSURE_4P_3:
case OP_ANY_CLOSURE_4P_4:
return (s7_error
(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string,
stack_code(sc->stack, top), sc->value)));
case OP_SAFE_C_PP_1:
stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PP_3_MV;
return (args);
case OP_SAFE_C_PP_5:
stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PP_6_MV;
return (args);
case OP_SAFE_C_3P_1:
case OP_SAFE_C_3P_2:
case OP_SAFE_C_3P_3:
stack_element(sc->stack, top) =
(s7_pointer) (stack_op(sc->stack, top) + 3);
case OP_SAFE_C_3P_1_MV:
case OP_SAFE_C_3P_2_MV:
case OP_SAFE_C_3P_3_MV:
return (cons(sc, sc->unused, copy_proper_list(sc, 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),
T_Mut(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: /* symbol is sc->code after pop */
case OP_SET1:
case OP_SET_FROM_LET_TEMP: /* (set! var (values 1 2 3)) */
case OP_SET_FROM_SETTER:
eval_error_with_caller2(sc, "~A: can't set ~A to ~S", 22,
sc->set_symbol, stack_code(sc->stack, top),
set_ulist_1(sc, sc->values_symbol, args));
case OP_SET_PAIR_P_1:
eval_error(sc, "too many values to set! ~S", 26,
set_ulist_1(sc, sc->values_symbol, args));
case OP_INCREMENT_SP_1: /* slot is in stack_args(top), args is the values list */
stack_element(sc->stack, top) = (s7_pointer) OP_INCREMENT_SP_MV;
return (args);
case OP_LET1: /* (let ((var (values 1 2 3))) ...) */
{
s7_pointer p, let_code, vars, sym;
p = stack_args(sc->stack, top);
for (let_code = p; is_pair(cdr(let_code));
let_code = cdr(let_code));
for (vars = caar(let_code); is_pair(cdr(p));
p = cdr(p), vars = cdr(vars));
sym = caar(vars);
eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23,
sc->let_symbol, sym, set_ulist_1(sc,
sc->values_symbol,
args));
/* stack_args: ((((x (values 1 2))) x)) in (let ((x (values 1 2))) x)
* (1 (((x 1) (y (values 1 2))) x)) in (let ((x 1) (y (values 1 2))) x)
*/
}
case OP_LET_ONE_NEW_1:
case OP_LET_ONE_P_NEW_1:
eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23,
sc->let_symbol,
opt2_sym(stack_code(sc->stack, top)),
set_ulist_1(sc, sc->values_symbol, args));
case OP_LET_ONE_OLD_1:
case OP_LET_ONE_P_OLD_1:
eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23,
sc->let_symbol,
slot_symbol(let_slots
(opt3_let
(stack_code
(sc->stack, top)))),
set_ulist_1(sc, sc->values_symbol, args));
case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */
eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23,
sc->let_star_symbol,
caar(stack_code(sc->stack, top)),
set_ulist_1(sc, sc->values_symbol, args));
case OP_LETREC1: /* here sc->args is the slot about to receive a value */
eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23,
sc->letrec_symbol,
slot_symbol(stack_args(sc->stack, top)),
set_ulist_1(sc, sc->values_symbol, args));
case OP_LETREC_STAR1:
eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23,
sc->letrec_star_symbol,
slot_symbol(stack_args(sc->stack, top)),
set_ulist_1(sc, sc->values_symbol, args));
case OP_AND_P1:
case OP_AND_SAFE_P_REST: /* from OP_AND_SAFE_P1 or P2 */
for (x = args; is_not_null(cdr(x)); x = cdr(x))
if (car(x) == sc->F)
return (sc->F);
return (car(x));
case OP_OR_P1:
for (x = args; is_not_null(cdr(x)); x = cdr(x))
if (car(x) != sc->F)
return (car(x));
return (car(x));
case OP_IF1: /* (if (values ...) ...) */
case OP_IF_PP:
case OP_IF_PPP:
case OP_IF_PR:
case OP_IF_PRR:
case OP_WHEN_PP:
case OP_UNLESS_PP:
case OP_WITH_LET1:
case OP_CASE_G_G:
case OP_CASE_G_S:
case OP_CASE_E_G:
case OP_CASE_E_S:
case OP_CASE_S_G:
case OP_CASE_S_S:
case OP_CASE_I_S:
case OP_COND1:
case OP_COND1_SIMPLE:
return (car(args));
case OP_DYNAMIC_UNWIND:
case OP_DYNAMIC_UNWIND_PROFILE:
{
s7_pointer old_value = sc->value;
bool mv = is_multiple_value(args);
if (mv)
clear_multiple_value(args);
sc->value = cons(sc, sc->values_symbol, args);
dynamic_unwind(sc, stack_code(sc->stack, top), stack_args(sc->stack, top)); /* func (curlet) */
sc->value = old_value;
if (mv)
set_multiple_value(args);
sc->stack_end -= 4; /* either op is possible I think */
return (splice_in_values(sc, args));
}
case OP_BARRIER:
pop_stack(sc);
return (splice_in_values(sc, args));
case OP_GC_PROTECT:
sc->stack_end -= 4;
return (splice_in_values(sc, args));
case OP_BEGIN_HOOK:
case OP_BEGIN_NO_HOOK:
case OP_BEGIN_2_UNCHECKED:
case OP_SIMPLE_DO_STEP:
case OP_DOX_STEP_O:
case OP_DOX_STEP:
case OP_FLUSH_VALUES:
/* 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_DEACTIVATE_GOTO: /* (+ (call-with-exit (lambda (ret) (values 1 2 3)))) */
call_exit_active(stack_args(sc->stack, top)) = false;
case OP_CATCH:
case OP_CATCH_1:
case OP_CATCH_2:
case OP_CATCH_ALL: /* (+ (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) returns multiple values.
* these need to be read in order into the current reader lists (we'll assume OP_READ_LIST is next in the stack.
* and that it will be expecting the next arg entry in sc->value).
*/
top -= 4;
for (x = args; is_not_null(cdr(x)); x = cdr(x))
stack_args(sc->stack, top) =
cons(sc, car(x), T_Mut(stack_args(sc->stack, top)));
pop_stack(sc); /* need GC protection in loop above, so do this afterwards */
return (car(x)); /* sc->value from OP_READ_LIST point of view */
case OP_EVAL_DONE:
if (stack_op(sc->stack, (top - 4)) == OP_NO_VALUES)
return (s7_error
(sc, sc->error_symbol,
set_elist_1(sc,
wrap_string(sc,
"function-port should not return multiple-values",
47))));
stack_element(sc->stack, top) = (s7_pointer) OP_SPLICE_VALUES; /* tricky -- continue from eval_done with the current splice */
stack_args(sc->stack, top) = args;
push_stack_op(sc, OP_EVAL_DONE);
return (args);
default:
/* fprintf(stderr, "%s[%d]: splice on: %s\n", __func__, __LINE__, op_names[stack_op(sc->stack, top)]); */
break;
}
/* let it meander back up the call chain until someone knows where to splice it
* the is_immutable check protects against setting the multiple value bit on (say) sc->hash_table_signature
*/
if (is_immutable(args))
args = copy_proper_list(sc, args); /* copy needed else (apply values x) where x is a list can leave the mv bit on for x's value */
if (needs_copied_args(args)) {
clear_needs_copied_args(args);
args = copy_proper_list(sc, args);
}
set_multiple_value(args);
return (args);
}
/* -------------------------------- values -------------------------------- */
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);
if (is_null(cdr(args)))
return (car(args));
set_needs_copied_args(args);
/* copy needed: see s7test (test `(,x ,@y ,x) '(3 a b c 3)) -> (append (list-values x (apply-values y)) x), and apply_values calls s7_values directly */
return (splice_in_values(sc, args));
}
#define g_values s7_values
static s7_pointer values_p(s7_scheme * sc)
{
return (sc->no_value);
}
static s7_pointer values_p_p(s7_scheme * sc, s7_pointer p)
{
return (p);
}
static s7_pointer values_chooser(s7_scheme * sc, s7_pointer f,
int32_t args, s7_pointer expr, bool ops)
{
if (args > 1)
return (sc->values_uncopied); /* splice_in_values */
return (f);
}
/* -------------------------------- list-values -------------------------------- */
static s7_pointer g_list_values(s7_scheme * sc, s7_pointer args)
{
#define H_list_values "(list-values ...) returns its arguments in a list (internal to quasiquote)"
#define Q_list_values s7_make_circular_signature(sc, 1, 2, sc->is_list_symbol, sc->T)
/* list-values can't be replaced by list(-n) because (list-values (values)) -> () and anything can be #<no-values> (see s7test) */
/* but (list-values <circular-list>) will complain or get into an infinite recursion in copy_tree, so it should not use copy_tree */
s7_pointer x;
bool checked = false;
for (x = args; is_pair(x); x = cdr(x))
if (is_pair(car(x))) {
if (is_checked(car(x)))
checked = true;
} else if (car(x) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */
break;
if (is_null(x)) {
if (!checked) { /* (!tree_has_definers(sc, args)) seems to work, reduces copy_tree calls slightly, but costs more than it saves in tgen */
s7_pointer p;
for (p = args; is_pair(p); p = cdr(p))
if (is_immutable(p))
return (copy_proper_list(sc, args));
return (args);
}
sc->u = args;
check_free_heap_size(sc, 8192);
if (sc->safety > NO_SAFETY) {
if (!tree_is_cyclic(sc, args)) /* we're copying to clear optimizations I think, and a cyclic list here can't be optimized */
args = cons_unchecked(sc, /* since list-values is a safe function, args can be immutable, which should not be passed through the copy */
(is_unquoted_pair(car(args))) ?
copy_tree_with_type(sc,
car(args)) :
car(args),
(is_unquoted_pair(cdr(args))) ?
copy_tree_with_type(sc,
cdr(args)) :
cdr(args));
} else
args = copy_tree(sc, args); /* not copy_any_list here -- see comment below */
sc->u = sc->nil;
return (args);
}
/* if a macro expands into a recursive function with a macro argument as its body (or reasonable facsimile thereof),
* and the safety (as in safe_closure) of the body changes from safe to unsafe, then (due to the checked bits
* protecting against cycles in optimize_expression|syntax), the possible safe_closure call will not be fixed,
* the safe_closure's assumption about the saved local let will be violated, and we'll get "<arg> unbound" (see tgen.scm).
* clear_all_optimizations assumes its argument has no cycles, and automatically calling copy_tree slows
* everything down intolerably, so if the checked bit is on in a macro expansion, that means we're re-expanding this macro,
* and therefore have to copy the tree. But isn't that only the case if the macro expands into closures?
*/
{
s7_pointer p, tp, np;
if (is_null(args))
return (sc->nil);
while (car(args) == sc->no_value) {
args = cdr(args);
if (is_null(args))
return (sc->nil);
}
tp = list_1(sc, car(args));
sc->y = tp;
for (p = cdr(args), np = tp; is_pair(p); p = cdr(p))
if (car(p) != sc->no_value) {
set_cdr(np, list_1(sc, car(p)));
np = cdr(np);
}
sc->y = sc->nil;
return (tp);
}
}
/* -------------------------------- apply-values -------------------------------- */
static s7_pointer g_apply_values(s7_scheme * sc, s7_pointer args)
{
#define H_apply_values "(apply-values var) applies values to var. This is an internal function."
#define Q_apply_values s7_make_signature(sc, 2, sc->T, sc->is_list_symbol)
s7_pointer x;
/* apply-values takes 1 arg: ,@a -> (apply-values a) */
if (is_null(args))
return (sc->no_value);
x = car(args);
if (is_null(x))
return (sc->no_value);
if (!s7_is_proper_list(sc, x))
return (apply_list_error(sc, args));
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
* one surprising twist: write/display return their first argument directly, so (apply-values (write `(+ x 1))) is the same as (apply-values `(+ x 1))
* If this is in a function body, and the function is called twice, it is self-modifying code and behaves in unexpected ways.
*/
/* -------------------------------- quasiquote -------------------------------- */
static bool is_simple_code(s7_scheme * sc, s7_pointer form)
{
/* if nested with quasiquotes say 20 levels, this is really slow, but to tag intermediate results burns up 2 type bits */
s7_pointer tmp, slow;
for (tmp = form, slow = form; is_pair(tmp);
tmp = cdr(tmp), slow = cdr(slow)) {
if (is_pair(car(tmp))) {
if (!is_simple_code(sc, car(tmp)))
return (false);
} else if (car(tmp) == sc->unquote_symbol)
return (false);
tmp = cdr(tmp);
if (!is_pair(tmp))
return (is_null(tmp));
if (tmp == slow)
return (false);
if (is_pair(car(tmp))) {
if (!is_simple_code(sc, car(tmp)))
return (false);
} else if (car(tmp) == sc->unquote_symbol)
return (false);
}
return (is_null(tmp));
}
/* since the reader expands unquote et al, and the printer does not unexpand them, the standard scheme quine in s7 is:
* ((lambda (x) (list-values x (list-values 'quote x))) '(lambda (x) (list-values x (list-values 'quote x))))
* but that depends on the "p" in repl...
*/
static s7_pointer g_quasiquote_1(s7_scheme * sc, s7_pointer form,
bool check_cycles)
{
#define H_quasiquote "(quasiquote arg) is the same as `arg. If arg is a list, it can contain \
comma (\"unquote\") and comma-atsign (\"apply values\") to pre-evaluate portions of the list. \
unquoted expressions are evaluated and plugged into the list, apply-values evaluates the expression \
and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -> (1 2 3 4)."
if (!is_pair(form)) {
if (is_normal_symbol(form))
return (list_2
(sc,
(is_global(sc->quote_symbol)) ? sc->quote_symbol :
initial_value(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_pair(cdr(form))) { /* (unquote) or (unquote . 1) */
if (is_null(cdr(form)))
eval_error(sc, "unquote: no argument, ~S", 24, form);
else
eval_error(sc, "unquote: stray dot, ~S", 22, form);
}
if (is_not_null(cddr(form)))
eval_error(sc, "unquote: too many arguments, ~S", 31, form);
return (cadr(form));
}
/* it's a list, so return the list with each element handled as above.
* we try to support dotted lists which makes the code much messier.
* if no element of the list is a list or unquote, just return the original quoted
*/
if (((check_cycles) && (tree_is_cyclic(sc, form))) ||
(is_simple_code(sc, form)))
/* we can't lookup sc->quote_symbol because this gets called in op_read_quasiquote (at read-time), and sc->curlet can be junk in that context */
return (list_2
(sc,
(is_global(sc->quote_symbol)) ? sc->quote_symbol :
initial_value(sc->quote_symbol), form));
{
s7_int len, i;
s7_pointer orig, bq, old_scw;
bool dotted = false;
len = s7_list_length(sc, form);
if (len < 0) {
len = -len;
dotted = true;
}
old_scw = sc->w;
s7_gc_protect_via_stack(sc, sc->w);
check_free_heap_size(sc, len);
sc->w = sc->nil;
for (i = 0; i <= len; i++)
sc->w = cons_unchecked(sc, sc->nil, sc->w);
set_car(sc->w, sc->list_values_symbol);
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) etc */
if (!is_pair(cddr(orig))) {
sc->w = old_scw;
unstack(sc);
eval_error(sc, "unquote: no argument, ~S", 24,
form);
}
set_car(bq, g_quasiquote_1(sc, car(orig), false));
set_cdr(bq, sc->nil);
sc->w =
list_3(sc, sc->append_symbol, sc->w, caddr(orig));
break;
} else
set_car(bq, g_quasiquote_1(sc, car(orig), false));
} 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), false));
set_car(bq, g_quasiquote_1(sc, car(orig), false));
sc->w =
list_3(sc, sc->append_symbol, sc->w,
g_quasiquote_1(sc, cdr(orig), false));
/* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */
}
bq = sc->w;
sc->w = old_scw;
unstack(sc);
return (bq);
}
}
static s7_pointer g_quasiquote(s7_scheme * sc, s7_pointer args)
{
/* this is for explicit quasiquote support, not the backquote stuff in macros
* but it is problematic. g_quasiquote_1 above expands (for example) `(+ ,x) into (list (quote +) x),
* so (multiple-value-bind (quote) quasiquote `(+ ,x)) expands to ((lambda (quote) (list '+ x)) quasiquote)
* which is an infinite loop. Guile says syntax error (because it thinks "quote" can't be a parameter name, I think).
*/
return (g_quasiquote_1(sc, car(args), true));
}
/* -------------------------------- choosers -------------------------------- */
static s7_pointer make_function_with_class(s7_scheme * sc, s7_pointer cls,
const char *name, s7_function f,
int32_t required_args,
int32_t optional_args,
bool rest_arg)
{
s7_pointer uf;
if ((S7_DEBUGGING)
&& (!is_safe_procedure(global_value(s7_make_symbol(sc, name)))))
fprintf(stderr, "%s unsafe: %s\n", __func__, name);
uf = s7_make_safe_function(sc, name, f, required_args, optional_args,
rest_arg, NULL);
s7_function_set_class(sc, uf, cls);
c_function_signature(uf) = c_function_signature(cls);
return (uf);
}
static s7_pointer make_unsafe_function_with_class(s7_scheme * sc,
s7_pointer cls,
const char *name,
s7_function f,
int32_t required_args,
int32_t optional_args,
bool rest_arg)
{
s7_pointer uf;
uf = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL); /* was s7_make_safe_function! 14-Dec-20 */
s7_function_set_class(sc, uf, cls);
c_function_signature(uf) = c_function_signature(cls);
return (uf);
}
static s7_pointer set_function_chooser(s7_scheme * sc, s7_pointer sym,
s7_pointer(*chooser) (s7_scheme *
sc,
s7_pointer f,
int32_t args,
s7_pointer
expr,
bool ops))
{
s7_pointer f = global_value(sym);
c_function_chooser(f) = chooser;
return (f);
}
static void init_choosers(s7_scheme * sc)
{
s7_pointer f;
/* + */
f = set_function_chooser(sc, sc->add_symbol, add_chooser);
sc->add_class = c_function_class(f);
sc->add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false);
sc->add_3 = make_function_with_class(sc, f, "+", g_add_3, 3, 0, false);
sc->add_1x =
make_function_with_class(sc, f, "+", g_add_1x, 2, 0, false);
sc->add_x1 =
make_function_with_class(sc, f, "+", g_add_x1, 2, 0, false);
sc->add_i_random =
make_function_with_class(sc, f, "+", g_add_i_random, 2, 0, false);
sc->add_2_ff =
make_function_with_class(sc, f, "+", g_add_2_ff, 2, 0, false);
sc->add_2_ii =
make_function_with_class(sc, f, "+", g_add_2_ii, 2, 0, false);
sc->add_2_if =
make_function_with_class(sc, f, "+", g_add_2_if, 2, 0, false);
sc->add_2_fi =
make_function_with_class(sc, f, "+", g_add_2_fi, 2, 0, false);
sc->add_2_xi =
make_function_with_class(sc, f, "+", g_add_2_xi, 2, 0, false);
sc->add_2_ix =
make_function_with_class(sc, f, "+", g_add_2_ix, 2, 0, false);
sc->add_2_fx =
make_function_with_class(sc, f, "+", g_add_2_fx, 2, 0, false);
sc->add_2_xf =
make_function_with_class(sc, f, "+", g_add_2_xf, 2, 0, false);
/* - */
f = set_function_chooser(sc, sc->subtract_symbol, subtract_chooser);
sc->subtract_class = c_function_class(f);
sc->subtract_1 =
make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false);
sc->subtract_2 =
make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false);
sc->subtract_3 =
make_function_with_class(sc, f, "-", g_subtract_3, 3, 0, false);
sc->subtract_x1 =
make_function_with_class(sc, f, "-", g_subtract_x1, 2, 0, false);
sc->subtract_2f =
make_function_with_class(sc, f, "-", g_subtract_2f, 2, 0, false);
sc->subtract_f2 =
make_function_with_class(sc, f, "-", g_subtract_f2, 2, 0, false);
/* * */
f = set_function_chooser(sc, sc->multiply_symbol, multiply_chooser);
sc->multiply_class = c_function_class(f);
sc->multiply_2 =
make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false);
sc->mul_2_ff =
make_function_with_class(sc, f, "*", g_mul_2_ff, 2, 0, false);
sc->mul_2_ii =
make_function_with_class(sc, f, "*", g_mul_2_ii, 2, 0, false);
sc->mul_2_if =
make_function_with_class(sc, f, "*", g_mul_2_if, 2, 0, false);
sc->mul_2_fi =
make_function_with_class(sc, f, "*", g_mul_2_fi, 2, 0, false);
sc->mul_2_xi =
make_function_with_class(sc, f, "*", g_mul_2_xi, 2, 0, false);
sc->mul_2_ix =
make_function_with_class(sc, f, "*", g_mul_2_ix, 2, 0, false);
sc->mul_2_fx =
make_function_with_class(sc, f, "*", g_mul_2_fx, 2, 0, false);
sc->mul_2_xf =
make_function_with_class(sc, f, "*", g_mul_2_xf, 2, 0, false);
/* / */
f = set_function_chooser(sc, sc->divide_symbol, divide_chooser);
sc->invert_1 =
make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false);
sc->divide_2 =
make_function_with_class(sc, f, "/", g_divide_2, 2, 0, false);
sc->invert_x =
make_function_with_class(sc, f, "/", g_invert_x, 2, 0, false);
sc->divide_by_2 =
make_function_with_class(sc, f, "/", g_divide_by_2, 2, 0, false);
/* = */
f = set_function_chooser(sc, sc->num_eq_symbol, num_eq_chooser);
sc->num_eq_class = c_function_class(f);
sc->num_eq_2 =
make_function_with_class(sc, f, "=", g_num_eq_2, 2, 0, false);
sc->num_eq_xi =
make_function_with_class(sc, f, "=", g_num_eq_xi, 2, 0, false);
sc->num_eq_ix =
make_function_with_class(sc, f, "=", g_num_eq_ix, 2, 0, false);
/* min */
f = set_function_chooser(sc, sc->min_symbol, min_chooser);
sc->min_2 =
make_function_with_class(sc, f, "min", g_min_2, 2, 0, false);
sc->min_3 =
make_function_with_class(sc, f, "min", g_min_3, 3, 0, false);
/* max */
f = set_function_chooser(sc, sc->max_symbol, max_chooser);
sc->max_2 =
make_function_with_class(sc, f, "max", g_max_2, 2, 0, false);
sc->max_3 =
make_function_with_class(sc, f, "max", g_max_3, 3, 0, false);
/* < */
f = set_function_chooser(sc, sc->lt_symbol, less_chooser);
sc->less_xi =
make_function_with_class(sc, f, "<", g_less_xi, 2, 0, false);
sc->less_x0 =
make_function_with_class(sc, f, "<", g_less_x0, 2, 0, false);
sc->less_xf =
make_function_with_class(sc, f, "<", g_less_xf, 2, 0, false);
sc->less_2 =
make_function_with_class(sc, f, "<", g_less_2, 2, 0, false);
/* > */
f = set_function_chooser(sc, sc->gt_symbol, greater_chooser);
sc->greater_xi =
make_function_with_class(sc, f, ">", g_greater_xi, 2, 0, false);
sc->greater_xf =
make_function_with_class(sc, f, ">", g_greater_xf, 2, 0, false);
sc->greater_2 =
make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false);
/* <= */
f = set_function_chooser(sc, sc->leq_symbol, leq_chooser);
sc->leq_xi =
make_function_with_class(sc, f, "<=", g_leq_xi, 2, 0, false);
sc->leq_2 =
make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false);
sc->leq_ixx =
make_function_with_class(sc, f, "<=", g_leq_ixx, 3, 0, false);
/* >= */
f = set_function_chooser(sc, sc->geq_symbol, geq_chooser);
sc->geq_xi =
make_function_with_class(sc, f, ">=", g_geq_xi, 2, 0, false);
sc->geq_xf =
make_function_with_class(sc, f, ">=", g_geq_xf, 2, 0, false);
sc->geq_2 =
make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false);
/* random */
f = set_function_chooser(sc, sc->random_symbol, random_chooser);
sc->random_1 =
make_function_with_class(sc, f, "random", g_random_1, 1, 0, false);
sc->random_i =
make_function_with_class(sc, f, "random", g_random_i, 1, 0, false);
sc->random_f =
make_function_with_class(sc, f, "random", g_random_f, 1, 0, false);
/* defined? */
f = set_function_chooser(sc, sc->is_defined_symbol,
is_defined_chooser);
sc->is_defined_in_rootlet =
make_function_with_class(sc, f, "defined?",
g_is_defined_in_rootlet, 2, 0, false);
/* char=? */
f = set_function_chooser(sc, sc->char_eq_symbol, char_equal_chooser);
sc->simple_char_eq =
make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0,
false);
sc->char_equal_2 =
make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0,
false);
/* char>? */
f = set_function_chooser(sc, sc->char_gt_symbol, char_greater_chooser);
sc->char_greater_2 =
make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0,
false);
/* char<? */
f = set_function_chooser(sc, sc->char_lt_symbol, char_less_chooser);
sc->char_less_2 =
make_function_with_class(sc, f, "char<?", g_char_less_2, 2, 0,
false);
/* read-char */
f = set_function_chooser(sc, sc->read_char_symbol, read_char_chooser);
sc->read_char_1 =
make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0,
false);
/* char-position */
f = set_function_chooser(sc, sc->char_position_symbol,
char_position_chooser);
sc->char_position_csi =
make_function_with_class(sc, f, "char-position",
g_char_position_csi, 2, 1, false);
/* string=? */
f = set_function_chooser(sc, sc->string_eq_symbol,
string_equal_chooser);
sc->string_equal_2 =
make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0,
false);
sc->string_equal_2c =
make_function_with_class(sc, f, "string=?", g_string_equal_2c, 2,
0, false);
/* substring */
sc->substring_uncopied =
s7_make_function(sc, "substring", g_substring_uncopied, 2, 1,
false, NULL);
s7_function_set_class(sc, sc->substring_uncopied,
global_value(sc->substring_symbol));
/* string>? */
f = set_function_chooser(sc, sc->string_gt_symbol,
string_greater_chooser);
sc->string_greater_2 =
make_function_with_class(sc, f, "string>?", g_string_greater_2, 2,
0, false);
/* string<? */
f = set_function_chooser(sc, sc->string_lt_symbol,
string_less_chooser);
sc->string_less_2 =
make_function_with_class(sc, f, "string<?", g_string_less_2, 2, 0,
false);
/* string */
f = set_function_chooser(sc, sc->string_symbol, string_chooser);
sc->string_c1 =
make_function_with_class(sc, f, "string", g_string_c1, 1, 0,
false);
/* string-append */
f = set_function_chooser(sc, sc->string_append_symbol,
string_append_chooser);
sc->string_append_2 =
make_function_with_class(sc, f, "string-append", g_string_append_2,
2, 0, false);
/* string-ref et al */
set_function_chooser(sc, sc->string_ref_symbol,
string_substring_chooser);
set_function_chooser(sc, sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here */
set_function_chooser(sc, sc->string_to_keyword_symbol,
string_substring_chooser);
set_function_chooser(sc, sc->string_downcase_symbol,
string_substring_chooser);
set_function_chooser(sc, sc->string_upcase_symbol,
string_substring_chooser);
/* if the function assumes a null-terminated string, substring needs to return a copy */
#if (!WITH_PURE_S7)
set_function_chooser(sc, sc->string_length_symbol,
string_substring_chooser);
set_function_chooser(sc, sc->string_to_list_symbol,
string_substring_chooser);
#endif
set_function_chooser(sc, sc->string_copy_symbol, string_copy_chooser);
/* symbol->string */
f = global_value(sc->symbol_to_string_symbol);
sc->symbol_to_string_uncopied =
s7_make_function(sc, "symbol->string", g_symbol_to_string_uncopied,
1, 0, false, NULL);
s7_function_set_class(sc, sc->symbol_to_string_uncopied, f);
/* display */
f = set_function_chooser(sc, sc->display_symbol, display_chooser);
sc->display_f =
make_function_with_class(sc, f, "display", g_display_f, 2, 0,
false);
sc->display_2 =
make_function_with_class(sc, f, "display", g_display_2, 2, 0,
false);
/* vector */
f = set_function_chooser(sc, sc->vector_symbol, vector_chooser);
sc->vector_2 =
make_function_with_class(sc, f, "vector", g_vector_2, 2, 0, false);
sc->vector_3 =
make_function_with_class(sc, f, "vector", g_vector_3, 3, 0, false);
/* vector-ref */
f = set_function_chooser(sc, sc->vector_ref_symbol,
vector_ref_chooser);
sc->vector_ref_2 =
make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0,
false);
sc->vector_ref_3 =
make_function_with_class(sc, f, "vector-ref", g_vector_ref_3, 3, 0,
false);
/* vector-set! */
f = set_function_chooser(sc, sc->vector_set_symbol,
vector_set_chooser);
sc->vector_set_3 =
make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3,
0, false);
sc->vector_set_4 =
make_function_with_class(sc, f, "vector-set!", g_vector_set_4, 4,
0, false);
/* float-vector-ref */
f = set_function_chooser(sc, sc->float_vector_ref_symbol,
float_vector_ref_chooser);
sc->fv_ref_2 =
make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_2, 2,
0, false);
sc->fv_ref_3 =
make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_3, 3,
0, false);
/* float-vector-set */
f = set_function_chooser(sc, sc->float_vector_set_symbol,
float_vector_set_chooser);
sc->fv_set_3 =
make_function_with_class(sc, f, "float-vector-set!", g_fv_set_3, 3,
0, false);
sc->fv_set_unchecked =
make_function_with_class(sc, f, "float-vector-set!",
g_fv_set_unchecked, 3, 0, false);
/* int-vector-ref */
f = set_function_chooser(sc, sc->int_vector_ref_symbol,
int_vector_ref_chooser);
sc->iv_ref_2 =
make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_2, 2, 0,
false);
sc->iv_ref_3 =
make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_3, 3, 0,
false);
/* int-vector-set */
f = set_function_chooser(sc, sc->int_vector_set_symbol,
int_vector_set_chooser);
sc->iv_set_3 =
make_function_with_class(sc, f, "int-vector-set!", g_iv_set_3, 3,
0, false);
/* byte-vector-ref */
f = set_function_chooser(sc, sc->byte_vector_ref_symbol,
byte_vector_ref_chooser);
sc->bv_ref_2 =
make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_2, 2,
0, false);
sc->bv_ref_3 =
make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_3, 3,
0, false);
/* byte-vector-set */
f = set_function_chooser(sc, sc->byte_vector_set_symbol,
byte_vector_set_chooser);
sc->bv_set_3 =
make_function_with_class(sc, f, "byte-vector-set!", g_bv_set_3, 3,
0, false);
/* list-set! */
f = set_function_chooser(sc, sc->list_set_symbol, list_set_chooser);
sc->list_set_i =
make_function_with_class(sc, f, "list-set!", g_list_set_i, 3, 0,
false);
/* hash-table-ref */
f = set_function_chooser(sc, sc->hash_table_ref_symbol,
hash_table_ref_chooser);
sc->hash_table_ref_2 =
make_function_with_class(sc, f, "hash-table-ref",
g_hash_table_ref_2, 2, 0, false);
/* hash-table-set! */
set_function_chooser(sc, sc->hash_table_set_symbol,
hash_table_set_chooser);
/* hash-table */
f = set_function_chooser(sc, sc->hash_table_symbol,
hash_table_chooser);
sc->hash_table_2 =
make_function_with_class(sc, f, "hash-table", g_hash_table_2, 2, 0,
false);
/* format */
f = set_function_chooser(sc, sc->format_symbol, format_chooser);
sc->format_f =
make_function_with_class(sc, f, "format", g_format_f, 1, 0, true);
sc->format_no_column =
make_function_with_class(sc, f, "format", g_format_no_column, 1, 0,
true);
sc->format_just_control_string =
make_function_with_class(sc, f, "format",
g_format_just_control_string, 2, 0,
false);
sc->format_as_objstr =
make_function_with_class(sc, f, "format", g_format_as_objstr, 3, 0,
true);
/* list */
f = set_function_chooser(sc, sc->list_symbol, list_chooser);
sc->list_0 =
make_function_with_class(sc, f, "list", g_list_0, 0, 0, false);
sc->list_1 =
make_function_with_class(sc, f, "list", g_list_1, 1, 0, false);
sc->list_2 =
make_function_with_class(sc, f, "list", g_list_2, 2, 0, false);
sc->list_3 =
make_function_with_class(sc, f, "list", g_list_3, 3, 0, false);
sc->list_4 =
make_function_with_class(sc, f, "list", g_list_4, 4, 0, false);
/* append */
f = set_function_chooser(sc, sc->append_symbol, append_chooser);
sc->append_2 =
make_function_with_class(sc, f, "append", g_append_2, 2, 0, false);
/* list-ref */
f = set_function_chooser(sc, sc->list_ref_symbol, list_ref_chooser);
sc->list_ref_at_0 =
make_function_with_class(sc, f, "list", g_list_ref_at_0, 2, 0,
false);
sc->list_ref_at_1 =
make_function_with_class(sc, f, "list", g_list_ref_at_1, 2, 0,
false);
sc->list_ref_at_2 =
make_function_with_class(sc, f, "list", g_list_ref_at_2, 2, 0,
false);
/* assoc */
set_function_chooser(sc, sc->assoc_symbol, assoc_chooser);
/* member */
set_function_chooser(sc, sc->member_symbol, member_chooser);
/* memq */
f = set_function_chooser(sc, sc->memq_symbol, memq_chooser); /* is pure-s7, use member here */
sc->memq_2 =
make_function_with_class(sc, f, "memq", g_memq_2, 2, 0, false);
sc->memq_3 =
make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false);
sc->memq_4 =
make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false);
sc->memq_any =
make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false);
/* tree-set-memq */
f = set_function_chooser(sc, sc->tree_set_memq_symbol,
tree_set_memq_chooser);
sc->tree_set_memq_syms =
make_function_with_class(sc, f, "tree-set-memq", g_tree_set_memq_1,
2, 0, false);
/* eval-string */
set_function_chooser(sc, sc->eval_string_symbol, eval_string_chooser);
/* dynamic-wind */
f = set_function_chooser(sc, sc->dynamic_wind_symbol,
dynamic_wind_chooser);
sc->dynamic_wind_unchecked =
make_unsafe_function_with_class(sc, f, "dynamic-wind",
g_dynamic_wind_unchecked, 3, 0,
false);
/* inlet */
f = set_function_chooser(sc, sc->inlet_symbol, inlet_chooser);
sc->simple_inlet =
make_function_with_class(sc, f, "inlet", g_simple_inlet, 0, 0,
true);
/* let-ref */
f = set_function_chooser(sc, sc->let_ref_symbol, let_ref_chooser);
sc->lint_let_ref =
make_function_with_class(sc, f, "let-ref", g_lint_let_ref, 2, 0,
false);
/* let-set */
f = set_function_chooser(sc, sc->let_set_symbol, let_set_chooser);
sc->lint_let_set =
make_function_with_class(sc, f, "let-set!", g_lint_let_set, 3, 0,
false);
/* values */
f = set_function_chooser(sc, sc->values_symbol, values_chooser);
sc->values_uncopied =
make_unsafe_function_with_class(sc, f, "values", splice_in_values,
0, 0, true);
}
/* ---------------- reader funcs for eval ---------------- */
static void back_up_stack(s7_scheme * sc)
{
opcode_t top_op = stack_op(sc->stack, current_stack_top(sc) - 1);
if (top_op == OP_READ_DOT) {
pop_stack(sc);
top_op = stack_op(sc->stack, current_stack_top(sc) - 1);
}
if ((top_op == OP_READ_VECTOR) ||
(top_op == OP_READ_BYTE_VECTOR) ||
(top_op == OP_READ_INT_VECTOR) ||
(top_op == OP_READ_FLOAT_VECTOR)) {
pop_stack(sc);
top_op = stack_op(sc->stack, current_stack_top(sc) - 1);
}
if (top_op == OP_READ_QUOTE)
pop_stack(sc);
}
static token_t read_sharp(s7_scheme * sc, s7_pointer pt)
{
int32_t 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,
wrap_string(sc,
"unexpected '#' at end of input",
30)));
break;
case '(':
sc->w = int_one;
return (TOKEN_VECTOR);
case 'i':
if (read_sharp(sc, pt) == TOKEN_VECTOR)
return (TOKEN_INT_VECTOR);
backchar('i', pt);
break;
case 'r':
if (read_sharp(sc, pt) == TOKEN_VECTOR)
return (TOKEN_FLOAT_VECTOR);
backchar('r', pt);
break;
case 'u':
if (s7_peek_char(sc, pt) == chars[(int32_t) ('8')]) { /* backwards compatibility: #u8(...) == #u(...) */
int32_t bc;
bc = inchar(pt);
if (s7_peek_char(sc, pt) == chars[(int32_t) ('(')]) {
inchar(pt);
sc->w = int_one;
return (TOKEN_BYTE_VECTOR);
}
backchar(bc, pt);
}
if (read_sharp(sc, pt) == TOKEN_VECTOR)
return (TOKEN_BYTE_VECTOR);
backchar('u', pt);
break;
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
{
/* here we can get an overflow: #1231231231231232131D() */
s7_int dims;
int32_t d, loc = 0;
sc->strbuf[loc++] = (unsigned char) 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,
wrap_string(sc,
"unexpected end of input while reading #n...",
43)));
dig = digits[d];
if (dig >= 10)
break;
dims = dig + (dims * 10);
if (dims <= 0) {
sc->strbuf[loc++] = (unsigned char) d;
s7_error(sc, sc->read_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"reading #~A...: ~A must be a positive integer",
37), wrap_string(sc,
sc->strbuf,
loc),
wrap_integer1(sc, dims)));
}
if (dims > sc->max_vector_dimensions) {
sc->strbuf[loc++] = (unsigned char) d;
sc->strbuf[loc + 1] = '\0';
s7_error(sc, sc->read_error_symbol,
set_elist_4(sc,
wrap_string(sc,
"reading #~A...: ~A is too large, (*s7* 'max-vector-dimensions): ~A",
66), wrap_string(sc,
sc->strbuf,
loc),
wrap_integer1(sc, dims),
wrap_integer2(sc,
sc->max_vector_dimensions)));
}
sc->strbuf[loc++] = (unsigned char) d;
}
sc->strbuf[loc++] = d;
if ((d == 'd') || (d == 'i') || (d == 'r') || (d == 'u')) {
int32_t e;
e = inchar(pt);
if (e == EOF)
s7_error(sc, sc->read_error_symbol,
set_elist_1(sc,
wrap_string(sc,
"unexpected end of input while reading #n()",
42)));
sc->strbuf[loc++] = (unsigned char) e;
if (e == '(') {
sc->w = make_integer(sc, dims);
if (d == 'd')
return (TOKEN_VECTOR);
if (d == 'r')
return (TOKEN_FLOAT_VECTOR);
return ((d ==
'u') ? TOKEN_BYTE_VECTOR : TOKEN_INT_VECTOR);
}
}
/* try to back out */
for (d = loc - 1; d > 0; d--)
backchar(sc->strbuf[d], 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] = (unsigned char) 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,
wrap_string(sc,
"unexpected end of input while reading #!",
40)));
return (token(sc));
}
/* block comments in #| ... |#
* since we ignore everything until the |#, internal semicolon comments are ignored,
* meaning that ;|# is as effective as |#
*/
case '|':
{
const char *str, *orig_str, *p, *pend;
if (is_file_port(pt)) {
char last_char = ' ';
while (true) {
c = fgetc(port_file(pt));
if (c == EOF)
s7_error(sc, sc->read_error_symbol,
set_elist_1(sc,
wrap_string(sc,
"unexpected end of input while reading #|",
40)));
if ((c == '#') && (last_char == '|'))
break;
last_char = c;
if (c == '\n')
port_line_number(pt)++;
}
return (token(sc));
}
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,
wrap_string(sc,
"unexpected end of input while reading #|",
40)));
}
if (p[1] == '#')
break;
str = (const char *) (p + 1);
}
port_position(pt) += (p - orig_str + 2);
/* now count newlines inside the comment */
str = (const char *) orig_str;
pend = p;
while (true) {
p = strchr(str, (int) '\n');
if ((p) && (p < pend)) {
port_line_number(pt)++;
str = (char *) (p + 1);
} else
break;
}
return (token(sc));
}
}
sc->strbuf[0] = (unsigned char) c;
return (TOKEN_SHARP_CONST); /* next stage notices any errors */
}
static token_t read_comma(s7_scheme * sc, s7_pointer pt)
{
int32_t 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)
{
int32_t 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)
{ /* inline here is slower */
int32_t c;
c = port_read_white_space(current_input_port(sc)) (sc,
current_input_port
(sc));
switch (c) {
case '(':
return (TOKEN_LEFT_PAREN);
case ')':
return (TOKEN_RIGHT_PAREN);
case '.':
return (read_dot(sc, current_input_port(sc)));
case '\'':
return (TOKEN_QUOTE);
case ';':
return (port_read_semicolon(current_input_port(sc))
(sc, current_input_port(sc)));
case '"':
return (TOKEN_DOUBLE_QUOTE);
case '`':
return (TOKEN_BACK_QUOTE);
case ',':
return (read_comma(sc, current_input_port(sc)));
case '#':
return (read_sharp(sc, current_input_port(sc)));
case '\0':
case EOF:
return (TOKEN_EOF);
default:
sc->strbuf[0] = (unsigned char) c; /* every TOKEN_ATOM return goes to port_read_name, so we save a backchar/inchar shuffle by starting the read here */
return (TOKEN_ATOM);
}
}
static int32_t read_x_char(s7_scheme * sc, int32_t i, s7_pointer pt)
{
/* possible "\xn...;" char (write creates these things, so we have to read them)
* but we could have crazy input like "\x -- with no trailing double quote
*/
while (true) {
int32_t d1, d2, c;
c = inchar(pt);
if (c == '"') {
backchar(c, pt);
return (i);
}
if (c == ';')
return (i);
if (c == EOF) {
read_error(sc, "#<eof> in midst of hex-char");
return (i);
}
d1 = digits[c];
if (d1 >= 16) {
sc->strbuf[i++] = (unsigned char) c; /* just go on -- maybe a special char is not intended */
return (i);
}
c = inchar(pt);
if (c == '"') {
sc->strbuf[i++] = (unsigned char) d1;
backchar((char) c, pt);
return (i);
}
if (c == EOF) {
read_error(sc, "#<eof> in midst of hex-char");
return (i);
}
if (c == ';') {
sc->strbuf[i++] = (unsigned char) d1;
return (i);
}
d2 = digits[c];
if (d2 >= 16) {
sc->strbuf[i++] = (unsigned char) c; /* just go on -- maybe a special char is not intended */
return (i);
}
sc->strbuf[i++] = (unsigned char) (16 * d1 + d2);
}
return (i);
}
static s7_pointer unknown_string_constant(s7_scheme * sc, int32_t c)
{
/* check *read-error-hook* */
if (hook_has_functions(sc->read_error_hook)) {
s7_pointer result;
result =
s7_call(sc, sc->read_error_hook,
set_plist_2(sc, sc->F, chars[(uint8_t) c]));
if (is_character(result))
return (result);
}
return (sc->T);
}
static s7_pointer read_string_constant(s7_scheme * sc, s7_pointer pt)
{
/* sc->F => error, no check needed here for bad input port and so on */
s7_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 (nil_string);
}
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 == '"') {
s7_int len;
len = s - start;
port_position(pt) += (len + 1);
return (make_string_with_length(sc, start, len));
}
for (; s < end; s++) {
if (*s == '"') { /* switch here no faster */
s7_int len;
len = s - start;
port_position(pt) += (len + 1);
return (make_string_with_length(sc, start, len));
}
if (*s == '\\') {
/* all kinds of special cases here (resultant string is not the current string), so drop to loop below (setting "i") */
s7_int len;
len = (s7_int) (s - start);
if (len > 0) {
if (len >= sc->strbuf_size)
resize_strbuf(sc, len);
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?!? */
int32_t c;
c = port_read_character(pt) (sc, pt);
switch (c) {
case '\n':
port_line_number(pt)++;
sc->strbuf[i++] = (unsigned char) c;
break;
case EOF:
sc->strbuf[(i > 8) ? 8 : i] = '\0';
return (sc->F);
case '"':
return (make_string_with_length(sc, sc->strbuf, i));
case '\\':
c = inchar(pt);
switch (c) {
case EOF:
sc->strbuf[(i > 8) ? 8 : i] = '\0';
return (sc->F);
case '\\':
case '"':
case '|':
sc->strbuf[i++] = (unsigned char) c;
break;
case 'n':
sc->strbuf[i++] = '\n';
break;
case 't':
sc->strbuf[i++] = '\t';
break;
case 'r':
sc->strbuf[i++] = '\r';
break;
case '/':
sc->strbuf[i++] = '/';
break;
case 'b':
sc->strbuf[i++] = (unsigned char) 8;
break;
case 'f':
sc->strbuf[i++] = (unsigned char) 12;
break;
case 'x':
i = read_x_char(sc, i, pt);
break;
default: /* if (!is_white_space(c)) *//* changed 8-Apr-12 */
if ((c != '\n') && (c != '\r')) { /* i.e. line continuation via #\\ at end of line */
s7_pointer result;
result = unknown_string_constant(sc, c);
if (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++] = (unsigned char) c;
break;
}
if (i >= sc->strbuf_size)
resize_strbuf(sc, i);
}
}
static void read_double_quote(s7_scheme * sc)
{
sc->value = read_string_constant(sc, current_input_port(sc));
if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */
string_read_error(sc,
"end of input encountered while in a string");
if (sc->value == sc->T)
read_error(sc,
"unknown backslash usage -- perhaps you meant two backslashes?");
if (sc->safety > IMMUTABLE_VECTOR_SAFETY)
set_immutable(sc->value);
}
static inline bool read_sharp_const(s7_scheme * sc)
{
sc->value =
port_read_sharp(current_input_port(sc)) (sc,
current_input_port(sc));
if (sc->value == sc->no_value) {
/* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*))
* (+ 1 #;(* 2 3) 4)
* so we need to get the next token, act on it without any assumptions about read list
*/
sc->tok = token(sc);
return (true);
}
return (false);
}
static s7_pointer read_expression_read_error(s7_scheme * sc)
{
s7_pointer pt;
pop_stack(sc);
pt = current_input_port(sc);
if ((is_input_port(pt)) &&
(!port_is_closed(pt)) &&
(port_data(pt)) && (port_position(pt) > 0)) {
s7_int start, pos = port_position(pt);
s7_pointer p;
char *msg;
start = pos - 40;
if (start < 0)
start = 0;
p = make_empty_string(sc, 128, '\0');
msg = string_value(p);
memcpy((void *) msg, (void *) "at \"...", 7);
memcpy((void *) (msg + 7), (void *) (port_data(pt) + start),
pos - start);
memcpy((void *) (msg + 7 + pos - start), (void *) "...", 3);
string_length(p) = 7 + pos - start + 3;
return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p)));
}
return (read_error(sc, "stray comma before ')'?")); /* '("a" "b",) */
}
static s7_pointer read_expression(s7_scheme * sc)
{
while (true) {
int32_t c;
switch (sc->tok) {
case TOKEN_EOF:
return (eof_object);
case TOKEN_BYTE_VECTOR:
push_stack_no_let_no_code(sc, OP_READ_BYTE_VECTOR, sc->w);
sc->tok = TOKEN_LEFT_PAREN;
break;
case TOKEN_INT_VECTOR:
push_stack_no_let_no_code(sc, OP_READ_INT_VECTOR, sc->w);
sc->tok = TOKEN_LEFT_PAREN;
break;
case TOKEN_FLOAT_VECTOR:
push_stack_no_let_no_code(sc, OP_READ_FLOAT_VECTOR, sc->w);
sc->tok = TOKEN_LEFT_PAREN;
break;
case TOKEN_VECTOR: /* already read #( -- TOKEN_VECTOR is triggered by #( */
push_stack_no_let_no_code(sc, OP_READ_VECTOR, sc->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(current_input_port(sc));
} 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_let_no_code(sc, OP_READ_LIST, sc->nil);
/* here we need to clear args, but code is ignored */
check_stack_size(sc); /* s7test */
break;
case TOKEN_QUOTE:
push_stack_no_let_no_code(sc, OP_READ_QUOTE, sc->nil);
sc->tok = token(sc);
break;
case TOKEN_BACK_QUOTE:
sc->tok = token(sc);
push_stack_no_let_no_code(sc, OP_READ_QUASIQUOTE, sc->nil);
break;
case TOKEN_COMMA:
push_stack_no_let_no_code(sc, OP_READ_UNQUOTE, sc->nil);
sc->tok = token(sc);
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:
return (read_expression_read_error(sc));
default:
break;
}
break;
case TOKEN_AT_MARK:
push_stack_no_let_no_code(sc, OP_READ_APPLY_VALUES, sc->nil);
sc->tok = token(sc);
break;
case TOKEN_ATOM:
return (port_read_name(current_input_port(sc))
(sc, current_input_port(sc)));
/* If reading list (from lparen), this will finally get us to op_read_list */
case TOKEN_DOUBLE_QUOTE:
read_double_quote(sc);
return (sc->value);
case TOKEN_SHARP_CONST:
return (port_read_sharp(current_input_port(sc))
(sc, current_input_port(sc)));
case TOKEN_DOT: /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */
back_up_stack(sc);
do {
c = inchar(current_input_port(sc));
} 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);
}
static void read_dot_and_expression(s7_scheme * sc)
{
push_stack_no_let_no_code(sc, OP_READ_DOT, sc->args);
sc->tok = token(sc);
sc->value = read_expression(sc);
}
static void read_tok_default(s7_scheme * sc)
{
/* by far the main case here is TOKEN_LEFT_PAREN, but it doesn't save anything to move it to this level */
push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
sc->value = read_expression(sc);
/* check for op_read_list here and explicit pop_stack are slower */
}
static void pair_set_current_input_location(s7_scheme * sc, s7_pointer p)
{
if (current_input_port(sc) != sc->standard_input) { /* (port_file_number(current_input_port(sc)) > 1) -- maybe 0 is legit? */
pair_set_location(p, port_location(current_input_port(sc)));
set_has_location(p); /* current_input_port(sc) above can't be nil(?) -- it falls back on stdin now */
}
}
static int32_t read_atom(s7_scheme * sc, s7_pointer pt)
{
push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
/* check_stack_size(sc); */
sc->value = port_read_name(pt) (sc, pt);
sc->args = list_1(sc, sc->value);
pair_set_current_input_location(sc, sc->args);
return (port_read_white_space(pt) (sc, pt));
}
/* ---------------- *unbound-variable-hook* ---------------- */
static s7_pointer loaded_library(s7_scheme * sc, const char *file)
{
s7_pointer p;
for (p = global_value(sc->libraries_symbol); is_pair(p); p = cdr(p))
if (local_strcmp(file, string_value(caar(p))))
return (cdar(p));
return (sc->nil);
}
static s7_pointer unbound_variable_error(s7_scheme * sc, s7_pointer sym)
{
if (s7_tree_memq(sc, sym, current_code(sc)))
return (s7_error
(sc, sc->unbound_variable_symbol,
set_elist_3(sc,
wrap_string(sc, "unbound variable ~S in ~S",
25), sym, current_code(sc))));
if ((symbol_name(sym)[symbol_name_length(sym) - 1] == ',')
&&
(lookup_unexamined
(sc,
make_symbol_with_length(sc, symbol_name(sym),
symbol_name_length(sym) - 1))))
return (s7_error
(sc, sc->unbound_variable_symbol,
set_elist_2(sc,
wrap_string(sc,
"unbound variable ~S (perhaps a stray comma?)",
44), sym)));
return (s7_error
(sc, sc->unbound_variable_symbol,
set_elist_2(sc, wrap_string(sc, "unbound variable ~S", 19),
sym)));
}
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_let_ref_fallback(sc->curlet)) /* an experiment -- see s7test (with-let *db* (+ int32_t (length str))) */
return (call_let_ref_fallback(sc, sc->curlet, sym));
/* but if the thing we want to hit this fallback happens to exist at a higher level, oops... */
if (sym == sc->unquote_symbol)
eval_error(sc, "unquote (',') occurred outside quasiquote: ~S", 45,
current_code(sc));
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, current_let, 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. We need current_code(sc) so that the possible eventual error
* call can tell where the error occurred, and we need sc->value because it might
* be awaiting addition to sc->args in e.g. OP_EVAL_ARGS5, and then be clobbered
* by the hook function. (+ 1 asdf) will end up evaluating (+ asdf asdf) if sc->value
* is not protected. We also need to save/restore sc->curlet in case s7_load is called.
*/
args = (sc->args) ? sc->args : sc->nil;
code = sc->code;
value = sc->value;
cur_code = current_code(sc);
current_let = sc->curlet;
result = sc->undefined;
x = sc->x;
z = sc->z;
sc->temp7 = cons_unchecked(sc, code, cons_unchecked(sc, args, list_4(sc, value, cur_code, x, z))); /* 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 = list_1(sc, sym); /* the error will say "(sym)" which is not too misleading */
pair_set_current_input_location(sc, cur_code);
}
#if (!DISABLE_AUTOLOAD)
/* check sc->autoload_names */
if ((sc->is_autoloading) && (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 ((!e) || (!is_let(e))) {
if (hook_has_functions(sc->autoload_hook))
s7_apply_function(sc, sc->autoload_hook,
set_plist_2(sc, sym, sc->temp6 =
s7_make_string(sc,
file)));
e = s7_load(sc, file); /* s7_load can return NULL */
}
result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */
if ((result == sc->undefined) && (e) && (is_let(e))) {
result = s7_let_ref(sc, e, sym);
/* I think to be consistent we should add '(sym . result) to the global let */
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 ((sc->is_autoloading) &&
(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. */
if (hook_has_functions(sc->autoload_hook))
s7_apply_function(sc, sc->autoload_hook,
set_plist_2(sc, sym, val));
s7_load(sc, string_value(val));
} else if (is_closure(val)) { /* val should be a function of one argument, the current (calling) environment */
if (hook_has_functions(sc->autoload_hook))
s7_apply_function(sc, sc->autoload_hook,
set_plist_2(sc, sym, val));
s7_call(sc, val, set_ulist_1(sc, sc->curlet, sc->nil));
}
result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */
}
#endif
/* check *unbound-variable-hook* */
if ((result == sc->undefined) &&
(is_procedure(sc->unbound_variable_hook)) &&
(hook_has_functions(sc->unbound_variable_hook))) {
/* (let () (set! (hook-functions *unbound-variable-hook*) (list (lambda (v) _asdf_))) _asdf_) */
s7_pointer old_hook;
bool old_history_enabled;
old_history_enabled = s7_set_history_enabled(sc, false);
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 -- error_hook might be () or #f if we're in error-hook now */
result = s7_call(sc, old_hook, set_plist_1(sc, sym)); /* not s7_apply_function */
sc->unbound_variable_hook = old_hook;
s7_set_history_enabled(sc, old_history_enabled);
}
}
sc->value = T_Pos(value);
sc->args = T_Pos(args);
sc->code = code;
set_curlet(sc, current_let);
sc->x = x;
sc->z = z;
sc->temp7 = sc->nil;
if ((result != sc->undefined) && (result != sc->unspecified))
return (result);
}
return (unbound_variable_error(sc, sym));
}
static bool gx_annotate_arg(s7_scheme * sc, s7_pointer p, s7_pointer e)
{
if (is_gxable(car(p))) {
opcode_t old_op = optimize_op(car(p));
s7_pointer fxf;
set_optimize_op(car(p), old_op + 1);
fxf =
(s7_pointer) fx_choose(sc, p, e,
(is_list(e)) ? pair_symbol_is_safe :
let_symbol_is_safe);
if (fxf) {
set_has_gx(p);
set_opt2(p, fxf, OPT2_FX);
}
set_optimize_op(car(p), old_op);
return (fxf);
}
return (false);
}
static void gx_annotate_args(s7_scheme * sc, s7_pointer args, s7_pointer e)
{
s7_pointer p;
for (p = args; is_pair(p); p = cdr(p))
gx_annotate_arg(sc, p, e);
}
#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr, true))
static void fx_annotate_arg(s7_scheme * sc, s7_pointer arg, s7_pointer e)
{
#if S7_DEBUGGING
s7_function fx;
if (has_fx(arg))
return;
fx = fx_choose(sc, arg, e,
(is_list(e)) ? pair_symbol_is_safe :
let_symbol_is_safe);
if (fx)
set_fx_direct(arg, fx);
#else
if (has_fx(arg))
return;
set_fx(arg,
fx_choose(sc, arg, e,
(is_list(e)) ? pair_symbol_is_safe :
let_symbol_is_safe));
#endif
}
static void fx_annotate_args(s7_scheme * sc, s7_pointer args, s7_pointer e)
{
s7_pointer p;
for (p = args; is_pair(p); p = cdr(p))
#if S7_DEBUGGING
fx_annotate_arg(sc, p, e); /* checks has_fx */
#else
if (!has_fx(p))
set_fx(p,
fx_choose(sc, p, e,
(is_list(e)) ? pair_symbol_is_safe :
let_symbol_is_safe));
#endif
}
static opt_t optimize_thunk(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop, s7_pointer e)
{
if ((hop != 1) && (is_constant_symbol(sc, car(expr))))
hop = 1;
if ((is_closure(func)) || (is_closure_star(func))) {
bool safe_case = is_safe_closure(func);
if (is_immutable(func))
hop = 1;
if (is_null(closure_args(func))) { /* no rest arg funny business */
s7_pointer body = closure_body(func);
set_optimized(expr);
if ((is_null(cdr(body))) && (safe_case) && (is_fxable(sc, car(body)))) { /* fx stuff is not set yet */
fx_annotate_arg(sc, body, e);
set_optimize_op(expr, hop + OP_SAFE_THUNK_A);
set_closure_one_form_fx_arg(func);
set_opt1_lambda_add(expr, func);
return (OPT_T);
}
/* thunks with fully fxable bodies are rare apparently, and the time spent here overwhelms run time gains */
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_THUNK : OP_THUNK));
set_opt1_lambda_add(expr, func);
return (OPT_F);
}
if (is_symbol(closure_args(func))) { /* (define* (f1 . a) ...) called (f1) -- called a closure (not closure*) in define_unchecked */
set_opt1_lambda_add(expr, func);
set_unsafe_optimize_op(expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with no args, I guess */
return (OPT_F);
}
if (is_closure_star(func)) {
set_opt1_lambda_add(expr, func);
set_safe_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_0 :
OP_CLOSURE_STAR_NA));
}
return (OPT_F);
}
if (is_c_function(func)) {
if (c_function_required_args(func) != 0)
return (OPT_F);
if ((hop == 0) && (symbol_id(car(expr)) == 0))
hop = 1;
if (is_safe_procedure(func)) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_NC);
choose_c_function(sc, expr, func, 0);
return (OPT_T);
}
set_unsafe_optimize_op(expr, hop + OP_C);
choose_c_function(sc, expr, func, 0);
return (OPT_F);
}
if (is_c_function_star(func)) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR);
set_c_function(expr, func);
return (OPT_T);
}
return (OPT_F);
}
static opt_t optimize_closure_dotted_args(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop,
int32_t args, s7_pointer e)
{
if ((S7_DEBUGGING) && (!is_symbol(closure_args(func))))
fprintf(stderr, "%s[%d]: %s but %s\n", __func__, __LINE__,
display_80(expr), display(func));
if (fx_count(sc, expr) != args) /* fx_count starts at cdr, args here is the number of exprs in cdr(expr) -- so this means "are all args fxable" */
return (OPT_F);
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), small_int(args));
set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_NA);
set_opt1_lambda_add(expr, func);
return (OPT_F);
}
static int32_t combine_ops(s7_scheme * sc, s7_pointer func,
s7_pointer expr, combine_op_t cop,
s7_pointer e1, s7_pointer e2)
{ /* sc needed for debugger stuff */
int32_t arg_op;
s7_pointer arg;
switch (cop) {
case E_C_P:
arg_op = op_no_hop(e1);
switch (arg_op) {
case OP_SAFE_C_S:
return (OP_SAFE_C_opSq);
case OP_SAFE_C_NC:
return (OP_SAFE_C_opNCq);
case OP_SAFE_C_SC:
return (OP_SAFE_C_opSCq);
case OP_SAFE_C_CS:
return (OP_SAFE_C_opCSq);
case OP_SAFE_C_A:
return (OP_SAFE_C_opAq);
case OP_SAFE_C_AA:
return (OP_SAFE_C_opAAq);
case OP_SAFE_C_AAA:
return (OP_SAFE_C_opAAAq);
case OP_SAFE_C_SS:
set_opt3_sym(expr, cadr(e1));
set_opt1_sym(cdr(expr), caddr(e1));
return (OP_SAFE_C_opSSq);
case OP_SAFE_C_opSq:
set_opt3_pair(expr, cadr(e1));
set_opt3_sym(cdr(expr), cadadr(e1));
return (OP_SAFE_C_op_opSqq);
case OP_SAFE_C_S_opSq:
set_opt3_pair(expr, caddr(e1));
return (OP_SAFE_C_op_S_opSqq);
case OP_SAFE_C_opSq_S:
set_opt3_pair(expr, cadr(e1));
return (OP_SAFE_C_op_opSq_Sq);
}
return (OP_SAFE_C_P); /* this splits out to A in optimize_func one_arg */
case E_C_SP:
arg = e2;
arg_op = op_no_hop(arg);
switch (arg_op) {
case OP_SAFE_C_S:
return (OP_SAFE_C_S_opSq);
case OP_SAFE_C_AA:
return (OP_SAFE_C_S_opAAq);
case OP_SAFE_C_AAA:
return (OP_SAFE_C_S_opAAAq);
case OP_SAFE_C_SC:
set_opt2_con(cdr(expr), caddr(arg));
return (OP_SAFE_C_S_opSCq);
case OP_SAFE_C_CS: /* expr is (* a (- 1 b)), e2 is (- 1 b) */
set_opt2_sym(cdr(expr), caddr(arg));
return (OP_SAFE_C_S_opCSq);
case OP_SAFE_C_SS: /* (* a (- b c)) */
set_opt2_sym(cdr(expr), caddr(arg));
return (OP_SAFE_C_S_opSSq);
case OP_SAFE_C_A:
set_opt3_pair(expr, cdaddr(expr));
return (OP_SAFE_C_S_opAq);
}
return (OP_SAFE_C_SP); /* if fxable -> AA later */
case E_C_PS:
arg = e1;
arg_op = op_no_hop(arg);
switch (arg_op) {
case OP_SAFE_C_S:
set_opt1_sym(cdr(expr), cadr(e1));
set_opt3_sym(expr, e2);
return (OP_SAFE_C_opSq_S);
case OP_SAFE_C_SS:
return (OP_SAFE_C_opSSq_S);
case OP_SAFE_C_CS:
return (OP_SAFE_C_opCSq_S);
case OP_SAFE_C_A:
return (OP_SAFE_C_opAq_S);
case OP_SAFE_C_opSSq:
set_opt1_pair(cdr(expr), cadadr(expr));
set_opt3_pair(expr, cadr(e1));
return (OP_SAFE_C_op_opSSqq_S);
}
return (OP_SAFE_C_PS);
case E_C_PC:
arg = e1;
arg_op = op_no_hop(arg);
switch (arg_op) {
case OP_SAFE_C_S:
set_opt1_sym(cdr(expr), cadr(e1));
set_opt2_con(cdr(expr), e2);
return (OP_SAFE_C_opSq_C);
case OP_SAFE_C_CS:
return (OP_SAFE_C_opCSq_C);
case OP_SAFE_C_SC:
return (OP_SAFE_C_opSCq_C);
case OP_SAFE_C_SS:
set_opt3_con(cdr(expr), caddr(expr));
return (OP_SAFE_C_opSSq_C);
}
set_opt3_con(cdr(expr), caddr(expr));
return (OP_SAFE_C_PC);
case E_C_CP:
arg = e2;
arg_op = op_no_hop(arg);
switch (arg_op) {
case OP_SAFE_C_S:
set_opt3_pair(expr, arg);
return (OP_SAFE_C_C_opSq);
case OP_SAFE_C_SC:
set_opt1_sym(cdr(expr), cadr(arg));
set_opt2_con(cdr(expr), caddr(arg));
return (OP_SAFE_C_C_opSCq);
case OP_SAFE_C_SS:
set_opt1_sym(cdr(expr), cadr(arg));
return (OP_SAFE_C_C_opSSq);
}
return (OP_SAFE_C_CP);
case E_C_PP:
arg = e2;
arg_op = op_no_hop(arg);
switch (arg_op) {
case OP_SAFE_C_S:
if (is_safe_c_s(e1))
return (OP_SAFE_C_opSq_opSq);
if (optimize_op_match(e1, OP_SAFE_C_SS))
return (OP_SAFE_C_opSSq_opSq);
break;
case OP_SAFE_C_SS:
if (optimize_op_match(e1, OP_SAFE_C_SS))
return (OP_SAFE_C_opSSq_opSSq);
if (is_safe_c_s(e1))
return (OP_SAFE_C_opSq_opSSq);
break;
}
return (OP_SAFE_C_PP);
default:
break;
}
return (OP_UNOPT);
}
static bool arg_findable(s7_scheme * sc, s7_pointer arg1, s7_pointer e)
{
if (pair_symbol_is_safe(sc, arg1, e))
return (true); /* includes global_slot check */
return ((!sc->in_with_let) &&
(is_slot(lookup_slot_from(arg1, sc->curlet))));
}
static bool safe_c_aa_to_ag_ga(s7_scheme * sc, s7_pointer arg, int hop)
{
if (fx_proc(cddr(arg)) == fx_s) {
set_opt3_sym(arg, caddr(arg));
set_safe_optimize_op(arg, hop + OP_SAFE_C_AS);
return (true);
}
if (fx_proc(cdr(arg)) == fx_s) {
set_opt3_sym(arg, cadr(arg));
set_safe_optimize_op(arg, hop + OP_SAFE_C_SA);
return (true);
}
if (fx_proc(cddr(arg)) == fx_c) {
set_opt3_con(arg, caddr(arg));
set_safe_optimize_op(arg, hop + OP_SAFE_C_AC);
return (true);
}
if (fx_proc(cdr(arg)) == fx_c) {
set_opt3_con(arg, cadr(arg));
set_safe_optimize_op(arg, hop + OP_SAFE_C_CA);
return (true);
}
if (fx_proc(cddr(arg)) == fx_q) {
set_opt3_con(arg, cadaddr(arg));
set_safe_optimize_op(arg, hop + OP_SAFE_C_AC);
return (true);
}
if (fx_proc(cdr(arg)) == fx_q) {
set_opt3_con(arg, cadadr(arg));
set_safe_optimize_op(arg, hop + OP_SAFE_C_CA);
return (true);
}
return (false);
}
static opt_t check_c_aa(s7_scheme * sc, s7_pointer expr, s7_pointer func,
int32_t hop, s7_pointer e)
{
fx_annotate_args(sc, cdr(expr), e);
if (!safe_c_aa_to_ag_ga(sc, expr, hop)) {
set_optimize_op(expr, hop + OP_SAFE_C_AA);
set_opt3_pair(expr, cddr(expr));
}
choose_c_function(sc, expr, func, 2);
return (OPT_T);
}
static opt_t wrap_bad_args(s7_scheme * sc, s7_pointer func,
s7_pointer expr, int32_t n_args, int32_t hop,
s7_pointer e)
{
set_opt3_arglen(cdr(expr), small_int(n_args));
if (is_c_function(func)) {
set_safe_optimize_op(expr, hop + ((is_safe_procedure(func)) ?
((n_args ==
1) ? OP_SAFE_C_A :
OP_SAFE_C_AA) : ((n_args == 1)
? ((is_semisafe
(func)) ?
OP_CL_A :
OP_C_A)
: ((is_semisafe
(func)) ?
OP_CL_AA :
OP_C_AA))));
if (op_no_hop(expr) == OP_SAFE_C_AA) {
set_opt3_pair(expr, cddr(expr));
if (optimize_op(expr) == HOP_SAFE_C_AA)
return (check_c_aa(sc, expr, func, hop, e));
}
set_c_function(expr, func);
return (OPT_T);
}
if ((is_closure(func)) && (!arglist_has_rest(sc, closure_args(func)))) {
s7_pointer body = closure_body(func);
bool one_form = is_null(cdr(body)), safe_case =
is_safe_closure(func);
set_unsafely_optimized(expr);
set_opt1_lambda_add(expr, func);
if (one_form)
set_optimize_op(expr, hop + ((safe_case) ?
((n_args ==
1) ? OP_SAFE_CLOSURE_A_O :
OP_SAFE_CLOSURE_AA_O) : ((n_args
==
1) ?
OP_CLOSURE_A_O
:
OP_CLOSURE_AA_O)));
else
set_optimize_op(expr, hop + ((safe_case) ?
((n_args ==
1) ? OP_SAFE_CLOSURE_A :
OP_SAFE_CLOSURE_AA) : ((n_args ==
1) ?
OP_CLOSURE_A
:
OP_CLOSURE_AA)));
return (OPT_F);
}
if ((is_closure_star(func)) &&
(lambda_has_simple_defaults(func)) &&
(closure_star_arity_to_int(sc, func) >= n_args) &&
(!arglist_has_rest(sc, closure_args(func)))) {
set_unsafely_optimized(expr);
if (n_args == 1)
set_optimize_op(expr,
((is_safe_closure(func)) ?
OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A));
else if (closure_star_arity_to_int(sc, func) == 2)
set_optimize_op(expr, ((is_safe_closure(func))
? ((is_null(cdr(closure_body(func)))) ?
OP_SAFE_CLOSURE_STAR_AA_O :
OP_SAFE_CLOSURE_STAR_AA) :
OP_CLOSURE_STAR_NA));
else
set_optimize_op(expr,
((is_safe_closure(func)) ?
OP_SAFE_CLOSURE_STAR_NA :
OP_CLOSURE_STAR_NA));
set_opt1_lambda_add(expr, func);
}
return (OPT_F);
}
static inline s7_pointer find_uncomplicated_symbol(s7_scheme * sc,
s7_pointer symbol,
s7_pointer e)
{
s7_pointer x;
int64_t id;
if ((symbol_is_in_list(sc, symbol)) && (direct_memq(symbol, e))) /* it's probably a local variable reference */
return (sc->nil);
/* ((!symbol_is_in_list(sc, symbol)) && (direct_memq(symbol, e))) can happen if there's an intervening lambda:
* (let loop () (with-let (for-each (lambda (a) a) (list))) (loop))
* misses 'loop (it's not in symbol_list when recursive call is encountered) -- tricky to fix
*/
if (is_global(symbol))
return (global_slot(symbol));
/* see 59108 (OP_DEFINE_* in optimize_syntax) -- keyword version of name is used if a definition is
* contingent on some run-time decision, so we're looking here for local defines that might not happen.
* s7test.scm has a test case using acos.
*/
if ((has_keyword(symbol)) &&
(symbol_is_in_list(sc, symbol_to_keyword(sc, symbol))))
return (sc->nil);
id = symbol_id(symbol);
for (x = sc->curlet; id < let_id(x); x = let_outlet(x));
for (; is_let(x); x = let_outlet(x)) {
s7_pointer y;
if (let_id(x) == id)
return (local_slot(symbol));
for (y = let_slots(x); tis_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 is_ok_lambda(s7_scheme * sc, s7_pointer arg2)
{
return ((is_pair(arg2)) &&
(is_lambda(sc, car(arg2))) &&
(is_pair(cdr(arg2))) &&
(is_pair(cddr(arg2))) && (s7_is_proper_list(sc, cddr(arg2))));
}
static opt_t optimize_c_function_one_arg(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop,
int32_t pairs, int32_t symbols,
int32_t quotes, int32_t bad_pairs,
s7_pointer e)
{
s7_pointer arg1 = cadr(expr);
bool func_is_safe = is_safe_procedure(func);
if ((hop == 0)
&& ((is_immutable(func))
|| ((!sc->in_with_let) && (symbol_id(car(expr)) == 0))))
hop = 1;
/* hooboy! if c_function func is immutable or we're not in with-let and func's name's id is zero (so func is global), set hop to 1?? */
if (pairs == 0) {
if (func_is_safe) { /* safe c function */
set_safe_optimize_op(expr,
hop +
((symbols ==
0) ? OP_SAFE_C_NC : OP_SAFE_C_S));
choose_c_function(sc, expr, func, 1);
return (OPT_T);
}
/* c function is not safe */
if (symbols == 0) {
set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); /* OP_C_C never happens */
fx_annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_one);
} else {
set_unsafely_optimized(expr);
if (c_function_call(func) == g_read)
set_optimize_op(expr, hop + OP_READ_S);
else
set_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_S : OP_C_S));
}
choose_c_function(sc, expr, func, 1);
return (OPT_F);
}
/* pairs == 1 */
if (bad_pairs == 0) {
if (func_is_safe) {
int32_t op;
op = combine_ops(sc, func, expr, E_C_P, arg1, NULL);
set_safe_optimize_op(expr, hop + op);
if ((op == OP_SAFE_C_P) && (is_fxable(sc, arg1))) {
set_optimize_op(expr, hop + OP_SAFE_C_A);
fx_annotate_arg(sc, cdr(expr), e);
}
choose_c_function(sc, expr, func, 1);
return (OPT_T);
}
if (is_fxable(sc, arg1)) {
set_unsafe_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_A :
OP_C_A));
fx_annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_one);
choose_c_function(sc, expr, func, 1);
return (OPT_F);
}
} else { /* bad_pairs == 1 */
if (quotes == 1) {
fx_annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_one);
if (func_is_safe) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_A);
choose_c_function(sc, expr, func, 1);
return (OPT_T);
}
set_unsafe_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_A :
OP_C_A));
choose_c_function(sc, expr, func, 1);
return (OPT_F);
}
/* quotes == 0 */
if (!func_is_safe) {
s7_pointer lambda_expr = arg1;
if ((is_ok_lambda(sc, lambda_expr)) && (!direct_memq(car(lambda_expr), e))) { /* (let ((lambda #f)) (call-with-exit (lambda ...))) */
if (((c_function_call(func) == g_call_with_exit) || (c_function_call(func) == g_call_cc) || (c_function_call(func) == g_call_with_output_string)) && (is_proper_list_1(sc, cadr(lambda_expr))) && (is_symbol(caadr(lambda_expr))) && (!is_probably_constant(caadr(lambda_expr)))) { /* (call-with-exit (lambda (pi) ...) */
if (c_function_call(func) == g_call_cc)
set_unsafe_optimize_op(expr, OP_CALL_CC);
else if (c_function_call(func) == g_call_with_exit) {
if (is_null(cdddr(lambda_expr)))
set_unsafe_optimize_op(expr,
hop +
OP_CALL_WITH_EXIT_O);
else
set_unsafe_optimize_op(expr,
hop +
OP_CALL_WITH_EXIT);
} else {
set_unsafe_optimize_op(expr,
OP_CALL_WITH_OUTPUT_STRING);
set_opt2_pair(expr, cddr(lambda_expr));
set_opt3_sym(expr, caadr(lambda_expr));
set_local(caadr(lambda_expr));
return (OPT_F);
}
choose_c_function(sc, expr, func, 1);
set_opt2_pair(expr, cdr(lambda_expr));
set_local(caadr(lambda_expr)); /* check_lambda_args normally handles this, but if hop==1, we'll skip that step */
return (OPT_F);
}
if ((c_function_call(func) == g_with_output_to_string) &&
(is_null(cadr(lambda_expr)))) {
set_unsafe_optimize_op(expr, OP_WITH_OUTPUT_TO_STRING);
set_opt2_pair(expr, cddr(lambda_expr));
return (OPT_F);
}
}
}
}
set_unsafe_optimize_op(expr,
hop + ((func_is_safe) ? OP_SAFE_C_P : OP_C_P));
choose_c_function(sc, expr, func, 1);
return (OPT_F);
}
static bool walk_fxable(s7_scheme * sc, s7_pointer tree)
{
s7_pointer p;
for (p = cdr(tree); is_pair(p); p = cdr(p)) {
s7_pointer q = car(p);
if ((is_pair(q)) && (is_optimized(q))) {
opcode_t op = optimize_op(q);
if (is_safe_c_op(op))
return (true);
if ((op >= OP_TC_AND_A_OR_A_LA) ||
((op >= OP_THUNK) && (op < OP_BEGIN)) ||
(!walk_fxable(sc, q)))
return (false);
}
}
return (true);
}
static bool is_safe_fxable(s7_scheme * sc, s7_pointer p)
{
if (!is_pair(p))
return (true);
if (is_optimized(p)) {
if ((fx_function[optimize_op(p)]) && (walk_fxable(sc, (p))))
return (true);
}
if (is_proper_quote(sc, p))
return (true);
if ((S7_DEBUGGING) && (is_optimized(p))
&& (fx_function[optimize_op(p)]))
fprintf(stderr, "omit %s: %s\n", op_names[optimize_op(p)],
display(p));
return (false);
}
static bool check_tc_when(s7_scheme * sc, s7_pointer name, s7_pointer args,
s7_pointer body)
{
s7_pointer test_expr = cadr(body);
if (is_fxable(sc, test_expr)) {
s7_pointer p;
for (p = cddr(body); is_pair(cdr(p)); p = cdr(p))
if (!is_fxable(sc, car(p)))
break;
if ((is_proper_list_1(sc, p)) &&
(is_proper_list_3(sc, car(p))) && (caar(p) == name)) {
s7_pointer laa = car(p);
if ((is_fxable(sc, cadr(laa))) &&
(is_safe_fxable(sc, caddr(laa)))) {
set_safe_optimize_op(body, OP_TC_WHEN_LAA);
fx_annotate_arg(sc, cdr(body), args);
for (p = cddr(body); is_pair(cdr(p)); p = cdr(p))
fx_annotate_arg(sc, p, args);
fx_annotate_args(sc, cdr(laa), args);
fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false);
return (true);
}
}
}
return (false);
}
static bool check_tc_case(s7_scheme * sc, s7_pointer name, s7_pointer args,
s7_pointer body)
{
/* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */
s7_pointer clauses;
s7_int len;
bool got_else = false, results_fxable = true;
for (clauses = cddr(body), len = 0; is_pair(clauses);
clauses = cdr(clauses), len++) {
s7_pointer clause = car(clauses), result;
if (is_proper_list_1(sc, car(clause))) {
if (!is_simple(caar(clause)))
return (false); /* even if key is a small int, selector might be a mutable alias of that, so = will fail */
set_opt1_any(clauses, caar(clause));
} else {
if ((car(clause) != sc->else_symbol) ||
(!is_null(cdr(clauses))))
return (false);
got_else = true;
}
set_opt2_any(clauses, NULL);
result = cdr(clause);
if (is_null(result))
return (false);
if (is_proper_list_1(sc, result)) {
if (is_fxable(sc, car(result))) {
fx_annotate_arg(sc, result, args);
set_opt2_any(clauses, result);
} else
if ((is_proper_list_2(sc, car(result))) &&
(caar(result) == name) &&
(is_fxable(sc, cadar(result)))) {
set_has_tc(car(result));
set_opt2_any(clauses, car(result));
fx_annotate_arg(sc, cdar(result), args);
} else
results_fxable = false;
} else
results_fxable = false;
if (!opt2_any(clauses)) {
if (car(result) == sc->feed_to_symbol)
return (false);
if (tree_count(sc, name, result, 0) != 0)
return (false);
set_opt2_any(clauses, result);
}
}
if ((!got_else) || (!is_null(clauses)))
return (false);
set_optimize_op(body, OP_TC_CASE_LA);
set_opt3_arglen(cdr(body), small_int((len < 6) ? len : 0));
fx_annotate_arg(sc, cdr(body), args);
fx_tree(sc, cdr(body), car(args), NULL, NULL, true);
if (results_fxable)
set_optimized(body);
return (results_fxable);
}
static bool check_tc_cond(s7_scheme * sc, s7_pointer name, int32_t vars,
s7_pointer args, s7_pointer body)
{
s7_pointer p = cdr(body), clause1 = car(p);
if ((is_proper_list_2(sc, clause1)) && (is_fxable(sc, car(clause1)))) { /* cond_a... */
s7_pointer clause2;
p = cdr(p);
if ((is_pair(p)) && (is_null(cdr(p)))
&& ((caar(p) == sc->else_symbol) || (caar(p) == sc->T))) {
s7_pointer else_clause;
if (((vars != 1) && (vars != 2))
|| (tree_count(sc, name, body, 0) != 1))
return (false);
else_clause = cdar(p);
if (is_proper_list_1(sc, else_clause)) {
bool zs_fxable;
s7_pointer la = car(else_clause);
fx_annotate_arg(sc, clause1, args);
if ((is_pair(la)) && (car(la) == name)
&& (is_pair(cdr(la)))) {
if ((is_fxable(sc, cadr(la)))
&& ((((vars == 1) && (is_null(cddr(la))))
|| ((vars == 2) && (is_pair(cddr(la)))
&& (is_null(cdddr(la)))
&& (is_fxable(sc, caddr(la))))))) {
zs_fxable = is_fxable(sc, cadr(clause1));
set_optimize_op(body,
(vars ==
1) ? OP_TC_COND_A_Z_LA :
OP_TC_COND_A_Z_LAA);
if (zs_fxable)
fx_annotate_arg(sc, cdr(clause1), args);
fx_annotate_args(sc, cdr(la), args);
fx_tree(sc, cdr(body), car(args),
(vars == 1) ? NULL : cadr(args), NULL,
false);
if (zs_fxable)
set_optimized(body);
set_opt1_pair(cdr(body), cdadr(body));
set_opt3_pair(cdr(body), cdadr(caddr(body)));
return (zs_fxable);
}
} else {
la = cadr(clause1);
if ((is_pair(la)) && (car(la) == name)
&& (is_pair(cdr(la)))) {
if ((is_fxable(sc, cadr(la)))
&& (((vars == 1) && (is_null(cddr(la))))
|| ((vars == 2) && (is_pair(cddr(la)))
&& (is_null(cdddr(la)))
&& (is_fxable(sc, caddr(la)))))) {
zs_fxable = is_fxable(sc, car(else_clause));
set_optimize_op(body,
(vars ==
1) ? OP_TC_COND_A_LA_Z :
OP_TC_COND_A_LAA_Z);
if (zs_fxable)
fx_annotate_arg(sc, else_clause, args);
fx_annotate_args(sc, cdr(la), args);
fx_tree(sc, cdr(body), car(args),
(vars == 1) ? NULL : cadr(args), NULL,
false);
if (zs_fxable)
set_optimized(body);
set_opt1_pair(cdr(body), cdaddr(body));
set_opt3_pair(cdr(body), cdadr(cadr(body)));
return (zs_fxable);
}
}
}
}
return (false);
}
if (is_proper_list_2(sc, p)) {
clause2 = car(p);
if ((is_proper_list_2(sc, clause2)) &&
(is_fxable(sc, car(clause2)))) {
s7_pointer else_clause, else_p = cdr(p);
else_clause = car(else_p);
if ((is_proper_list_2(sc, else_clause)) &&
((car(else_clause) == sc->else_symbol)
|| (car(else_clause) == sc->T))) {
bool zs_fxable = true;
if ((vars == 2) && /* ...laa_laa case */
(is_proper_list_3(sc, cadr(clause2)))
&& (caadr(clause2) == name)
&& (is_fxable(sc, cadadr(clause2)))
&& (is_safe_fxable(sc, caddadr(clause2)))
&& (is_proper_list_3(sc, cadr(else_clause)))
&& (caadr(else_clause) == name)
&& (is_fxable(sc, cadadr(else_clause)))
&& (is_safe_fxable(sc, caddadr(else_clause)))) {
set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA);
if (is_fxable(sc, cadr(clause1)))
fx_annotate_args(sc, clause1, args);
else {
fx_annotate_arg(sc, clause1, args);
zs_fxable = false;
}
fx_annotate_arg(sc, clause2, args);
fx_annotate_args(sc, cdadr(clause2), args);
fx_annotate_args(sc, cdadr(else_clause), args);
fx_tree(sc, cdr(body), car(args), cadr(args), NULL,
false);
set_opt3_pair(body, cadr(else_clause));
if (zs_fxable)
set_optimized(body);
return (zs_fxable);
}
if ((tree_count(sc, name, body, 0) == 1) && /* needed to filter out cond_a_a_a_laa_opa_laa */
(((is_pair(cadr(else_clause)))
&& (caadr(else_clause) == name)
&& (is_pair(cdadr(else_clause)))
&& (is_fxable(sc, cadadr(else_clause)))
&&
(((vars == 1) && (is_null(cddadr(else_clause))))
|| ((vars == 2)
&& (is_proper_list_3(sc, cadr(else_clause)))
&& (is_fxable(sc, caddadr(else_clause))))))
|| ((is_pair(cadr(clause2)))
&& (caadr(clause2) == name)
&& (is_pair(cdadr(clause2)))
&& (is_fxable(sc, cadadr(clause2)))
&&
(((vars == 1) && (is_null(cddadr(clause2))))
|| ((vars == 2) && (is_pair(cddadr(clause2)))
&& (is_fxable(sc, caddadr(clause2)))
&& (is_null(cdddr(cadr(clause2))))))))) {
s7_pointer test2 = clause2, la_test = else_clause;
if (vars == 1) {
if ((is_pair(cadr(else_clause)))
&& (caadr(else_clause) == name))
set_optimize_op(body,
OP_TC_COND_A_Z_A_Z_LA);
else {
set_optimize_op(body,
OP_TC_COND_A_Z_A_LA_Z);
test2 = else_clause;
la_test = clause2;
fx_annotate_arg(sc, clause2, args);
}
} else if ((is_pair(cadr(else_clause)))
&& (caadr(else_clause) == name)) {
set_opt3_pair(body, cdadr(else_clause));
set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA);
} else {
set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_Z);
test2 = else_clause;
la_test = clause2;
set_opt3_pair(body, cdadr(la_test));
fx_annotate_arg(sc, clause2, args);
}
if (is_fxable(sc, cadr(clause1)))
fx_annotate_args(sc, clause1, args);
else {
fx_annotate_arg(sc, clause1, args);
zs_fxable = false;
}
if (is_fxable(sc, cadr(test2)))
fx_annotate_args(sc, test2, args);
else {
fx_annotate_arg(sc, test2, args);
zs_fxable = false;
}
fx_annotate_args(sc, cdadr(la_test), args);
fx_tree(sc, cdr(body), car(args),
(vars == 2) ? cadr(args) : NULL, NULL,
false);
if (zs_fxable)
set_optimized(body);
return (zs_fxable);
}
}
}
}
}
return (false);
}
static bool check_tc_let(s7_scheme * sc, s7_pointer name, int32_t vars,
s7_pointer args, s7_pointer body)
{
s7_pointer let_body = caddr(body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */
if (((vars == 2)
&& ((car(let_body) == sc->if_symbol)
|| (car(let_body) == sc->when_symbol)
|| (car(let_body) == sc->unless_symbol))) || ((vars == 1)
&&
(car(let_body)
==
sc->if_symbol)))
{
s7_pointer test_expr = cadr(let_body);
if (is_fxable(sc, test_expr)) {
if ((car(let_body) == sc->if_symbol)
&& (is_pair(cdddr(let_body)))) {
s7_pointer laa = cadddr(let_body);
if ((is_pair(laa)) && /* else caddr is laa and cadddr is z */
(car(laa) == name) &&
(((vars == 1) && (is_proper_list_2(sc, laa))) ||
((vars == 2) && (is_proper_list_3(sc, laa))
&& (is_safe_fxable(sc, caddr(laa)))))
&& (is_fxable(sc, cadr(laa)))) {
bool z_fxable;
set_optimize_op(body,
(vars ==
1) ? OP_TC_LET_IF_A_Z_LA :
OP_TC_LET_IF_A_Z_LAA);
fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */
fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */
fx_annotate_args(sc, cdr(laa), args);
z_fxable = is_fxable(sc, caddr(let_body));
if (z_fxable)
fx_annotate_arg(sc, cddr(let_body), args);
fx_tree(sc, cdaadr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); /* these are references to laa args, applied to the let var binding */
fx_tree(sc, cdr(let_body), car(caadr(body)), NULL,
NULL, false);
fx_tree_outer(sc, cdr(let_body), car(args),
(vars == 1) ? NULL : cadr(args), NULL,
false);
if (z_fxable)
set_optimized(body);
return (z_fxable);
}
} else {
s7_pointer p;
for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p))
if (!is_fxable(sc, car(p)))
break;
if ((is_proper_list_1(sc, p)) &&
(is_proper_list_3(sc, car(p))) && (caar(p) == name)) {
s7_pointer laa = car(p);
if ((is_fxable(sc, cadr(laa))) &&
(is_safe_fxable(sc, caddr(laa)))) {
set_optimize_op(body,
(car(let_body) ==
sc->when_symbol) ?
OP_TC_LET_WHEN_LAA :
OP_TC_LET_UNLESS_LAA);
fx_annotate_arg(sc, cdaadr(body), args); /* outer var */
fx_annotate_arg(sc, cdr(let_body), args); /* test */
for (p = cddr(let_body); is_pair(cdr(p));
p = cdr(p))
fx_annotate_arg(sc, p, args);
fx_annotate_args(sc, cdr(laa), args);
fx_tree(sc, cdaadr(body), car(args), cadr(args), NULL, false); /* these are references to the outer let */
fx_tree(sc, cdr(let_body), car(caadr(body)), NULL,
NULL, false);
fx_tree_outer(sc, cdr(let_body), car(args),
cadr(args), NULL, false);
set_optimized(body);
return (true);
}
}
}
}
} else {
if (car(let_body) == sc->cond_symbol) { /* vars=#loop pars, args=names thereof (arglist) */
s7_pointer p, var_name;
bool all_fxable = true;
for (p = cdr(let_body); is_pair(p); p = cdr(p)) {
s7_pointer clause = car(p);
if ((is_proper_list_2(sc, clause)) && (is_fxable(sc, car(clause)))) { /* test is ok */
s7_pointer result;
if ((!is_pair(cdr(p))) &&
(car(clause) != sc->else_symbol)
&& (car(clause) != sc->T))
return (false);
result = cadr(clause);
if ((is_pair(result)) && (car(result) == name)) { /* result is recursive call */
s7_pointer arg;
s7_int i;
for (i = 0, arg = cdr(result); is_pair(arg);
i++, arg = cdr(arg))
if (!is_fxable(sc, car(arg)))
return (false);
if (i != vars)
return (false);
}
} else
return (false);
}
/* cond form looks ok */
set_optimize_op(body, OP_TC_LET_COND);
set_opt3_arglen(cdr(body), small_int(vars));
fx_annotate_arg(sc, cdaadr(body), args); /* let var */
if (vars > 0)
fx_tree(sc, cdaadr(body), car(args),
(vars > 1) ? cadr(args) : NULL,
(vars > 2) ? caddr(args) : NULL, vars > 3);
var_name = caaadr(body);
for (p = cdr(let_body); is_pair(p); p = cdr(p)) {
s7_pointer clause = car(p), result;
result = cadr(clause);
fx_annotate_arg(sc, clause, args);
if ((is_pair(result)) && (car(result) == name)) {
set_has_tc(cdr(clause));
fx_annotate_args(sc, cdr(result), args);
} else if (is_fxable(sc, result))
fx_annotate_arg(sc, cdr(clause), args);
else
all_fxable = false;
fx_tree(sc, clause, var_name, NULL, NULL, false); /* just 1 let var */
if (vars > 0)
fx_tree_outer(sc, clause, car(args),
(vars > 1) ? cadr(args) : NULL,
(vars > 2) ? caddr(args) : NULL,
vars > 3);
}
if (all_fxable)
set_optimized(body);
return (all_fxable);
}
}
return (false);
}
/* tc lets can be let* or let+vars that don't refer to previous names, and there are more cond/if choices */
static bool check_tc(s7_scheme * sc, s7_pointer name, int32_t vars,
s7_pointer args, s7_pointer body)
{
if (!is_pair(body))
return (false);
if (((vars == 1) || (vars == 2)) &&
((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) &&
(is_pair(cdr(body))) &&
(is_fxable(sc, cadr(body))) && (is_pair(cddr(body)))) {
s7_pointer orx = caddr(body);
if (((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol))
&& (car(body) != car(orx)) && (is_fxable(sc, cadr(orx)))) {
s7_int len;
len = proper_list_length(orx);
if ((len == 3)
|| ((vars == 1) && (len == 4)
&& (tree_count(sc, name, orx, 0) == 1)
&& (is_fxable(sc, caddr(orx))))) {
s7_pointer tc;
tc = (len == 3) ? caddr(orx) : cadddr(orx);
if ((is_pair(tc)) &&
(car(tc) == name) &&
(is_pair(cdr(tc))) &&
(is_fxable(sc, cadr(tc))) &&
(((vars == 1) && (is_null(cddr(tc)))) ||
((vars == 2) && (is_pair(cddr(tc)))
&& (is_null(cdddr(tc)))
&& (is_safe_fxable(sc, caddr(tc)))))) {
if (vars == 1)
set_safe_optimize_op(body,
(car(body) ==
sc->and_symbol) ? ((len ==
3) ?
OP_TC_AND_A_OR_A_LA
:
OP_TC_AND_A_OR_A_A_LA)
: ((len ==
3) ? OP_TC_OR_A_AND_A_LA :
OP_TC_OR_A_AND_A_A_LA));
else
set_safe_optimize_op(body,
(car(body) ==
sc->and_symbol) ?
OP_TC_AND_A_OR_A_LAA :
OP_TC_OR_A_AND_A_LAA);
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, cdr(orx), args);
if (len == 4)
fx_annotate_arg(sc, cddr(orx), args);
fx_annotate_args(sc, cdr(tc), args);
/* if ((fx_proc(cdr(tc)) == fx_c_sca) && (fn_proc(cadr(tc)) == g_substring)) -> g_substring_uncopied); */
/* for that to be safe we need to be sure nothing in the body looks for null-termination (e.g.. string->number) */
fx_tree(sc, cdr(body), car(args),
(vars == 1) ? NULL : cadr(args), NULL, false);
return (true);
}
}
} else {
if ((vars == 1) &&
(car(body) == sc->or_symbol) &&
(is_fxable(sc, orx)) &&
(is_pair(cdddr(body))) && (is_pair(cadddr(body)))) {
s7_pointer and_p = cadddr(body);
if ((is_proper_list_4(sc, and_p)) &&
(car(and_p) == sc->and_symbol) &&
(is_fxable(sc, cadr(and_p))) &&
(is_fxable(sc, caddr(and_p)))) {
s7_pointer la = cadddr(and_p);
if ((is_proper_list_2(sc, la)) &&
(car(la) == name) && (is_fxable(sc, cadr(la)))) {
set_safe_optimize_op(body,
OP_TC_OR_A_A_AND_A_A_LA);
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, cddr(body), args);
fx_annotate_arg(sc, cdr(and_p), args);
fx_annotate_arg(sc, cddr(and_p), args);
fx_annotate_args(sc, cdr(la), args);
fx_tree(sc, cdr(body), car(args), NULL, NULL,
false);
return (true);
}
}
} else {
if ((vars == 1) && (car(body) == sc->and_symbol)
&& (car(orx) == sc->if_symbol)
&& (is_proper_list_4(sc, orx))
&& (is_fxable(sc, cadr(orx)))
&& (tree_count(sc, name, orx, 0) == 1)) {
s7_pointer la;
bool z_first;
z_first = ((is_pair(cadddr(orx)))
&& (car(cadddr(orx)) == name));
la = (z_first) ? cadddr(orx) : caddr(orx);
if ((car(la) == name) && (is_proper_list_2(sc, la))
&& (is_fxable(sc, cadr(la)))) {
bool z_fxable = true;
s7_pointer z;
z = (z_first) ? cddr(orx) : cdddr(orx);
set_optimize_op(body,
(z_first) ? OP_TC_AND_A_IF_A_Z_LA :
OP_TC_AND_A_IF_A_LA_Z);
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, cdr(orx), args);
fx_annotate_arg(sc, cdr(la), args);
if (is_fxable(sc, car(z)))
fx_annotate_arg(sc, z, args);
else
z_fxable = false;
fx_tree(sc, cdr(body), car(args), NULL, NULL,
false);
if (z_fxable)
set_optimized(body);
return (z_fxable);
}
}
}
}
}
if ((vars == 3) && (((car(body) == sc->or_symbol)
&& (is_proper_list_2(sc, cdr(body))))
|| ((car(body) == sc->if_symbol)
&& (is_proper_list_3(sc, cdr(body)))
&& (caddr(body) == sc->T)))
&& (is_fxable(sc, cadr(body)))) {
s7_pointer and_p;
and_p = (car(body) == sc->or_symbol) ? caddr(body) : cadddr(body);
if ((is_proper_list_4(sc, and_p)) &&
(car(and_p) == sc->and_symbol) &&
(is_fxable(sc, cadr(and_p))) &&
(is_fxable(sc, caddr(and_p)))) {
s7_pointer la = cadddr(and_p);
if ((is_proper_list_4(sc, la)) &&
(car(la) == name) &&
(is_fxable(sc, cadr(la))) &&
(is_safe_fxable(sc, caddr(la))) &&
(is_safe_fxable(sc, cadddr(la)))) {
set_safe_optimize_op(body, OP_TC_OR_A_AND_A_A_L3A);
set_opt3_pair(cdr(body),
(car(body) ==
sc->or_symbol) ? cdaddr(body) :
cdr(cadddr(body)));
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, cdr(and_p), args);
fx_annotate_arg(sc, cddr(and_p), args);
fx_annotate_args(sc, cdr(la), args);
fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args),
false);
return (true);
}
}
}
if (((vars >= 1) && (vars <= 3)) &&
(car(body) == sc->if_symbol) && (proper_list_length(body) == 4)) {
s7_pointer test = cadr(body);
if (is_fxable(sc, test)) {
s7_pointer true_p = caddr(body), false_p = cadddr(body);
s7_int false_len, true_len;
true_len = proper_list_length(true_p);
false_len = proper_list_length(false_p);
fx_annotate_arg(sc, cdr(body), args);
if (vars == 1) {
if ((false_len == 2) &&
(car(false_p) == name) &&
(is_fxable(sc, cadr(false_p)))) {
set_optimize_op(body, OP_TC_IF_A_Z_LA);
fx_annotate_arg(sc, cdr(false_p), args); /* arg */
set_opt1_pair(cdr(body), cddr(body));
set_opt3_pair(cdr(body), cdar(cdddr(body)));
if (!is_fxable(sc, true_p))
return (false);
fx_annotate_arg(sc, cddr(body), args); /* result */
fx_tree(sc, cdr(body), car(args), NULL, NULL, false);
set_optimized(body); /* split here and elsewhere from set_optimize_op is deliberate */
return (true);
}
if ((true_len == 2) &&
(car(true_p) == name) &&
(is_fxable(sc, cadr(true_p)))) {
set_optimize_op(body, OP_TC_IF_A_LA_Z);
fx_annotate_arg(sc, cdr(true_p), args); /* arg */
set_opt1_pair(cdr(body), cdddr(body));
set_opt3_pair(cdr(body), cdar(cddr(body)));
if (!is_fxable(sc, false_p))
return (false);
fx_annotate_arg(sc, cdddr(body), args); /* result */
fx_tree(sc, cdr(body), car(args), NULL, NULL, false);
set_optimized(body);
return (true);
}
}
if (vars == 2) {
if ((false_len == 3) &&
(car(false_p) == name) &&
(is_fxable(sc, cadr(false_p))) &&
(is_safe_fxable(sc, caddr(false_p)))) {
set_optimize_op(body, OP_TC_IF_A_Z_LAA);
fx_annotate_args(sc, cdr(false_p), args);
set_opt1_pair(cdr(body), cddr(body)); /* body == code in op, if_z */
set_opt3_pair(cdr(body), cdar(cdddr(body))); /* la */
if (!is_fxable(sc, true_p))
return (false);
fx_annotate_arg(sc, cddr(body), args);
fx_tree(sc, cdr(body), car(args), cadr(args), NULL,
false);
set_optimized(body);
return (true);
}
if ((true_len == 3) &&
(car(true_p) == name) &&
(is_fxable(sc, cadr(true_p))) &&
(is_safe_fxable(sc, caddr(true_p)))) {
set_optimize_op(body, OP_TC_IF_A_LAA_Z);
fx_annotate_args(sc, cdr(true_p), args);
set_opt1_pair(cdr(body), cdddr(body));
set_opt3_pair(cdr(body), cdar(cddr(body)));
if (!is_fxable(sc, false_p))
return (false);
fx_annotate_arg(sc, cdddr(body), args);
fx_tree(sc, cdr(body), car(args), cadr(args), NULL,
false);
set_optimized(body);
return (true);
}
}
if (vars == 3) {
if ((false_len == 4) &&
(car(false_p) == name) &&
(is_fxable(sc, cadr(false_p)))
&& (is_safe_fxable(sc, caddr(false_p)))
&& (is_safe_fxable(sc, cadddr(false_p)))) {
set_optimize_op(body, OP_TC_IF_A_Z_L3A);
fx_annotate_args(sc, cdr(false_p), args);
set_opt1_pair(cdr(body), cddr(body));
set_opt3_pair(cdr(body), cdar(cdddr(body)));
if (!is_fxable(sc, true_p))
return (false);
fx_annotate_arg(sc, cddr(body), args);
fx_tree(sc, cdr(body), car(args), cadr(args),
caddr(args), false);
set_optimized(body);
return (true);
}
if ((true_len == 4) &&
(car(true_p) == name) && (is_fxable(sc, cadr(true_p)))
&& (is_safe_fxable(sc, caddr(true_p)))
&& (is_safe_fxable(sc, cadddr(true_p)))) {
set_optimize_op(body, OP_TC_IF_A_L3A_Z);
fx_annotate_args(sc, cdr(true_p), args);
set_opt1_pair(cdr(body), cdddr(body));
set_opt3_pair(cdr(body), cdar(cddr(body)));
if (!is_fxable(sc, false_p))
return (false);
fx_annotate_arg(sc, cdddr(body), args);
fx_tree(sc, cdr(body), car(args), cadr(args),
caddr(args), false);
set_optimized(body);
return (true);
}
}
if ((false_len == 4) && (car(false_p) == sc->if_symbol)) {
s7_pointer in_test = cadr(false_p), in_true =
caddr(false_p), in_false = cadddr(false_p);
if (is_fxable(sc, in_test)) {
s7_pointer la = NULL, z;
if ((is_pair(in_false)) &&
(car(in_false) == name) &&
(is_pair(cdr(in_false))) &&
(is_fxable(sc, cadr(in_false)))) {
la = in_false;
z = cddr(false_p);
} else
if ((is_pair(in_true)) &&
(car(in_true) == name) &&
(is_pair(cdr(in_true))) &&
(is_fxable(sc, cadr(in_true)))) {
la = in_true;
z = cdddr(false_p);
}
if ((la)
&& ((vars == 3)
|| (!s7_tree_memq(sc, name, car(z))))) {
if (((vars == 1) && (is_null(cddr(la))))
|| ((vars == 2) && (is_pair(cddr(la)))
&& (is_null(cdddr(la)))
&& (is_safe_fxable(sc, caddr(la))))
|| ((vars == 3)
&& (is_proper_list_4(sc, in_true))
&& (car(in_true) == name)
&& (is_proper_list_4(sc, in_false))
&& (is_safe_fxable(sc, caddr(la)))
&& (is_safe_fxable(sc, cadddr(la)))
&& (is_fxable(sc, cadr(in_true)))
&& (is_safe_fxable(sc, caddr(in_true)))
&& (is_safe_fxable(sc, cadddr(in_true))))) {
bool zs_fxable = true;
if (vars == 1)
set_optimize_op(body,
(la ==
in_false) ?
OP_TC_IF_A_Z_IF_A_Z_LA :
OP_TC_IF_A_Z_IF_A_LA_Z);
else if (vars == 2)
set_optimize_op(body,
(la ==
in_false) ?
OP_TC_IF_A_Z_IF_A_Z_LAA :
OP_TC_IF_A_Z_IF_A_LAA_Z);
else
set_optimize_op(body,
OP_TC_IF_A_Z_IF_A_L3A_L3A);
if (is_fxable(sc, true_p)) /* outer (z) result */
fx_annotate_arg(sc, cddr(body), args);
else
zs_fxable = false;
fx_annotate_arg(sc, cdr(false_p), args); /* inner test */
fx_annotate_args(sc, cdr(la), args); /* la arg(s) */
if (vars == 3)
fx_annotate_args(sc, cdr(in_true), args);
else if (is_fxable(sc, car(z)))
fx_annotate_arg(sc, z, args); /* inner (z) result */
else
zs_fxable = false;
if ((has_fx(cddr(body))) && (has_fx(z)))
fx_tree(sc, cdr(body), car(args),
(vars > 1) ? cadr(args) : NULL,
(vars > 2) ? caddr(args) : NULL,
false);
if (zs_fxable)
set_optimized(body);
return (zs_fxable);
}
}
}
}
if ((vars == 2) &&
(false_len == 3) &&
(car(false_p) == sc->let_star_symbol)) {
s7_pointer letv = cadr(false_p), letb, v;
if (!is_pair(letv))
return (false);
letb = caddr(false_p);
for (v = letv; is_pair(v); v = cdr(v))
if (!is_fxable(sc, cadar(v)))
return (false);
if ((is_proper_list_4(sc, letb)) &&
(car(letb) == sc->if_symbol) &&
(is_fxable(sc, cadr(letb)))) {
s7_pointer laa = cadddr(letb);
if ((car(laa) == name) &&
(is_proper_list_3(sc, laa)) &&
(is_fxable(sc, cadr(laa))) &&
(is_safe_fxable(sc, caddr(laa)))) {
bool zs_fxable;
set_safe_optimize_op(body,
OP_TC_IF_A_Z_LET_IF_A_Z_LAA);
fx_annotate_args(sc, cdr(laa), args);
zs_fxable = is_fxable(sc, caddr(letb));
fx_annotate_args(sc, cdr(letb), args);
for (v = letv; is_pair(v); v = cdr(v))
fx_annotate_arg(sc, cdar(v), args);
fx_tree(sc, cdar(letv), car(args), cadr(args), NULL, true); /* first var of let*, second var of let* can't be fx_treed */
fx_tree(sc, cdr(body), car(args), cadr(args), NULL, true); /* these are references to the outer let */
fx_tree(sc, cdr(laa), caar(letv),
(is_pair(cdr(letv))) ? caadr(letv) : NULL,
NULL, true);
fx_tree(sc, cdr(letb), caar(letv),
(is_pair(cdr(letv))) ? caadr(letv) : NULL,
NULL, true);
fx_tree_outer(sc, cddr(letb), car(args),
cadr(args), NULL, true);
if (!is_fxable(sc, caddr(body)))
return (false);
fx_annotate_arg(sc, cddr(body), args);
return (zs_fxable);
}
}
}
}
}
/* let */
if ((is_proper_list_3(sc, body)) && (car(body) == sc->let_symbol) && (is_proper_list_1(sc, cadr(body))) && (is_fxable(sc, cadr(caadr(body)))) && /* let one var is fxable */
(is_pair(caddr(body))))
return (check_tc_let(sc, name, vars, args, body));
/* cond */
if ((car(body) == sc->cond_symbol) && (vars <= 2))
return (check_tc_cond(sc, name, vars, args, body));
/* case */
if ((vars == 1) &&
(car(body) == sc->case_symbol) &&
(is_pair(cdr(body))) && (is_fxable(sc, cadr(body))))
return (check_tc_case(sc, name, args, body));
/* when */
if ((vars == 2) &&
(car(body) == sc->when_symbol) && (is_fxable(sc, cadr(body))))
return (check_tc_when(sc, name, args, body));
return (false);
}
static bool check_recur_if(s7_scheme * sc, s7_pointer name, int32_t vars,
s7_pointer args, s7_pointer body)
{
s7_pointer test = cadr(body);
if (is_fxable(sc, test)) { /* if_(A)... */
s7_pointer true_p, false_p, obody = cddr(body), orig = NULL;
true_p = car(obody); /* if_a_(A)... */
false_p = cadr(obody); /* if_a_a_(if...) */
if ((vars <= 2) &&
(is_fxable(sc, true_p)) && (is_proper_list_4(sc, false_p))) {
if (car(false_p) == sc->if_symbol) {
s7_pointer test2 = cadr(false_p), true2 =
caddr(false_p), false2 = cadddr(false_p);
if ((is_fxable(sc, test2)) && (is_proper_list_3(sc, false2)) && /* opa_laaq or oplaa_laaq */
(is_h_optimized(false2))) { /* the c-op */
s7_pointer la1 = cadr(false2), la2 = caddr(false2);
if ((is_fxable(sc, true2)) &&
(((vars == 1) && (is_proper_list_2(sc, la1))
&& (is_proper_list_2(sc, la2))) || (((vars == 2)
&&
(is_proper_list_3
(sc, la1))
&&
(is_proper_list_3
(sc,
la2)))))
&& (car(la1) == name) && (car(la2) == name)
&& (is_fxable(sc, cadr(la1)))
&& (is_fxable(sc, cadr(la2))) && ((vars == 1)
||
((is_fxable
(sc,
caddr(la1)))
&&
(is_fxable
(sc,
caddr
(la2)))))) {
set_safe_optimize_op(body,
(vars ==
1) ?
OP_RECUR_IF_A_A_IF_A_A_opLA_LAq
:
OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq);
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, obody, args);
fx_annotate_args(sc, cdr(false_p), args);
fx_annotate_args(sc, cdr(la1), args);
fx_annotate_args(sc, cdr(la2), args);
fx_tree(sc, cdr(body), car(args),
(vars == 2) ? cadr(args) : NULL, NULL,
false);
set_opt1_pair(body, cdr(false_p));
set_opt3_pair(body, false2);
set_opt3_pair(false2, cdr(la2));
return (true);
}
if ((vars == 2) && (is_proper_list_3(sc, true2)) && (car(true2) == name) && (is_fxable(sc, cadr(true2))) && (is_fxable(sc, caddr(true2))) && (is_fxable(sc, cadr(false2))) && (is_proper_list_3(sc, la2)) && (car(la2) == name) && /* actually, not needed because func is TC (not RECUR) if not == name */
(is_fxable(sc, cadr(la2))) &&
(is_fxable(sc, caddr(la2)))) {
set_safe_optimize_op(body,
OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq);
fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */
fx_annotate_arg(sc, obody, args); /* if_a_(A)... */
fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_if_(A)... */
fx_annotate_args(sc, cdr(true2), args); /* if_a_a_if_a_l(AA)... */
fx_annotate_arg(sc, cdr(false2), args); /* if_a_a_if_a_laa_op(A).. */
fx_annotate_args(sc, cdr(la2), args); /* if_a_a_if_a_laa_opa_l(AA)q */
fx_tree(sc, cdr(body), car(args), cadr(args), NULL,
false);
set_opt3_pair(body, false2);
set_opt3_pair(false2, la2);
return (true);
}
}
}
if (car(false_p) == sc->and_symbol) {
s7_pointer a1 = cadr(false_p), a2 = caddr(false_p), a3 =
cadddr(false_p);
if ((is_fxable(sc, a1)) && (is_proper_list_3(sc, a2))
&& (is_proper_list_3(sc, a3)) && (car(a2) == name)
&& (car(a3) == name) && (is_fxable(sc, cadr(a2)))
&& (is_fxable(sc, cadr(a3)))
&& (is_fxable(sc, caddr(a2)))
&& (is_fxable(sc, caddr(a3)))) {
set_safe_optimize_op(body,
OP_RECUR_IF_A_A_AND_A_LAA_LAA);
fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */
fx_annotate_arg(sc, cddr(body), args); /* if_a_(A)... */
fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_and_(A)... */
fx_annotate_args(sc, cdr(a2), args); /* if_a_a_and_a_l(AA)... */
fx_annotate_args(sc, cdr(a3), args); /* if_a_a_and_a_laa_l(AA) */
fx_tree(sc, cdr(body), car(args), cadr(args), NULL,
false);
set_opt3_pair(body, false_p);
return (true);
}
}
}
if ((is_fxable(sc, true_p)) &&
(is_pair(false_p)) &&
(is_h_optimized(false_p)) &&
(is_pair(cdr(false_p))) && (is_pair(cddr(false_p))))
orig = false_p;
else if ((is_fxable(sc, false_p)) &&
(is_pair(true_p)) &&
(is_h_optimized(true_p)) &&
(is_pair(cdr(true_p))) && (is_pair(cddr(true_p)))) {
orig = true_p;
/* true_p = false_p; */
false_p = orig;
obody = cdr(obody);
}
if (orig) {
if (is_null(cdddr(false_p))) { /* 2 args to outer (c) func */
if ((is_fxable(sc, cadr(false_p)))
|| (is_fxable(sc, caddr(false_p)))) {
s7_pointer la;
la = (is_fxable(sc, cadr(false_p))) ? caddr(false_p) :
cadr(false_p);
if ((is_pair(la)) && (car(la) == name)
&& (is_pair(cdr(la)))
&& (is_fxable(sc, cadr(la)))) {
if ((vars == 1) && (is_null(cddr(la))))
set_safe_optimize_op(body,
(orig ==
cadddr(body)) ? ((la ==
cadr
(false_p))
?
OP_RECUR_IF_A_A_opLA_Aq
:
OP_RECUR_IF_A_A_opA_LAq)
: ((la ==
cadr(false_p)) ?
OP_RECUR_IF_A_opLA_Aq_A
:
OP_RECUR_IF_A_opA_LAq_A));
else if ((vars == 2) && (is_pair(cddr(la)))
&& (is_fxable(sc, caddr(la)))
&& (is_null(cdddr(la))))
set_safe_optimize_op(body,
(orig ==
cadddr(body)) ?
OP_RECUR_IF_A_A_opA_LAAq :
OP_RECUR_IF_A_opA_LAAq_A);
else {
if ((vars == 3) && (is_pair(cddr(la)))
&& (is_fxable(sc, caddr(la)))
&& (is_pair(cdddr(la)))
&& (is_fxable(sc, cadddr(la)))
&& (is_null(cddddr(la)))
&& (orig == cadddr(body)))
set_safe_optimize_op(body,
OP_RECUR_IF_A_A_opA_L3Aq);
else
return (false);
}
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, obody, args);
fx_annotate_arg(sc,
(la ==
cadr(false_p)) ? cddr(false_p) :
cdr(false_p), args);
fx_annotate_args(sc, cdr(la), args);
fx_tree(sc, cdr(body), car(args),
(vars > 1) ? cadr(args) : NULL,
(vars > 2) ? caddr(args) : NULL, false);
set_opt3_pair(body, false_p);
set_opt3_pair(false_p, la);
return (true);
}
} else {
s7_pointer la1 = cadr(false_p), la2 = caddr(false_p);
if ((vars == 1) && (is_proper_list_2(sc, la1))
&& (is_proper_list_2(sc, la2))
&& (car(la1) == name) && (car(la2) == name)
&& (is_fxable(sc, cadr(la1)))
&& (is_fxable(sc, cadr(la2)))) {
set_safe_optimize_op(body,
(orig ==
cadddr(body)) ?
OP_RECUR_IF_A_A_opLA_LAq :
OP_RECUR_IF_A_opLA_LAq_A);
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, obody, args);
fx_annotate_arg(sc, cdr(la1), args);
fx_annotate_arg(sc, cdr(la2), args);
fx_tree(sc, cdr(body), car(args), NULL, NULL,
false);
set_opt3_pair(body, false_p);
set_opt3_pair(false_p, la2);
return (true);
}
}
} else { /* 3 args to c func */
if ((vars == 1) &&
(is_pair(cdddr(false_p)))
&& (is_null(cddddr(false_p)))) {
s7_pointer la1 = cadr(false_p), la2 =
caddr(false_p), la3 = cadddr(false_p);
if ((is_proper_list_2(sc, la2))
&& (is_proper_list_2(sc, la3))
&& (car(la2) == name)
&& (car(la3) == name) && (is_fxable(sc, cadr(la2)))
&& (is_fxable(sc, cadr(la3)))) {
if ((is_proper_list_2(sc, la1))
&& (car(la1) == name)
&& (is_fxable(sc, cadr(la1)))) {
if (orig != cadddr(body))
return (false);
set_safe_optimize_op(body,
OP_RECUR_IF_A_A_opLA_LA_LAq);
fx_annotate_arg(sc, cdr(la1), args);
} else if (is_fxable(sc, la1)) {
set_safe_optimize_op(body,
(orig ==
cadddr(body)) ?
OP_RECUR_IF_A_A_opA_LA_LAq
:
OP_RECUR_IF_A_opA_LA_LAq_A);
fx_annotate_arg(sc, cdr(false_p), args);
} else
return (false);
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, obody, args);
fx_annotate_arg(sc, cdr(la2), args);
fx_annotate_arg(sc, cdr(la3), args);
fx_tree(sc, cdr(body), car(args), NULL, NULL,
false);
set_opt3_pair(body, false_p);
set_opt3_pair(false_p, la3);
return (true);
}
}
}
}
}
if ((vars == 3) && (is_fxable(sc, test))) {
s7_pointer true_p = caddr(body), false_p = cadddr(body);
if ((is_fxable(sc, true_p)) &&
(is_proper_list_4(sc, false_p)) && (car(false_p) == name)) {
s7_pointer la1, la2, la3, l3a = cdr(false_p);
la1 = car(l3a);
la2 = cadr(l3a);
la3 = caddr(l3a);
if ((is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2))
&& (is_proper_list_4(sc, la3)) && (car(la1) == name)
&& (car(la2) == name) && (car(la3) == name)
&& (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2)))
&& (is_fxable(sc, cadr(la3)))
&& (is_fxable(sc, caddr(la1)))
&& (is_fxable(sc, caddr(la2)))
&& (is_fxable(sc, caddr(la3)))
&& (is_fxable(sc, cadddr(la1)))
&& (is_fxable(sc, cadddr(la2)))
&& (is_fxable(sc, cadddr(la3)))) {
set_safe_optimize_op(body,
OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq);
fx_annotate_args(sc, cdr(la1), args);
fx_annotate_args(sc, cdr(la2), args);
fx_annotate_args(sc, cdr(la3), args);
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, cddr(body), args);
fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args),
false);
set_opt3_pair(body, false_p);
set_opt3_pair(false_p, la3);
return (true);
}
}
}
return (false);
}
static bool check_recur(s7_scheme * sc, s7_pointer name, int32_t vars,
s7_pointer args, s7_pointer body)
{
if ((car(body) == sc->if_symbol) && (proper_list_length(body) == 4))
return (check_recur_if(sc, name, vars, args, body));
if ((car(body) == sc->and_symbol) &&
(vars == 2) &&
(proper_list_length(body) == 3) &&
(proper_list_length(caddr(body)) == 4) &&
(caaddr(body) == sc->or_symbol) && (is_fxable(sc, cadr(body)))) {
s7_pointer la1, la2, or_p = caddr(body);
la1 = caddr(or_p);
la2 = cadddr(or_p);
if ((is_fxable(sc, cadr(or_p))) &&
(proper_list_length(la1) == 3) &&
(proper_list_length(la2) == 3) &&
(car(la1) == name) &&
(car(la2) == name) &&
(is_fxable(sc, cadr(la1))) &&
(is_fxable(sc, caddr(la1))) &&
(is_fxable(sc, cadr(la2))) && (is_fxable(sc, caddr(la2)))) {
set_safe_optimize_op(body, OP_RECUR_AND_A_OR_A_LAA_LAA);
fx_annotate_args(sc, cdr(la1), args);
fx_annotate_args(sc, cdr(la2), args);
fx_annotate_arg(sc, cdr(body), args);
fx_annotate_arg(sc, cdr(or_p), args);
fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false);
set_opt3_pair(body, or_p);
return (true);
}
}
if (car(body) == sc->cond_symbol) {
s7_pointer clause = cadr(body), clause2 = NULL;
if ((is_proper_list_1(sc, (cdr(clause)))) &&
(is_fxable(sc, car(clause))) &&
(is_fxable(sc, cadr(clause)))) {
s7_pointer la_clause = caddr(body);
s7_int len;
len = proper_list_length(body);
if (len == 4) {
if ((is_proper_list_2(sc, la_clause)) &&
(is_fxable(sc, car(la_clause)))) {
clause2 = la_clause;
la_clause = cadddr(body);
} else
return (false);
}
if ((is_proper_list_2(sc, la_clause)) &&
((car(la_clause) == sc->else_symbol)
|| (car(la_clause) == sc->T))
&& (is_pair(cadr(la_clause)))) {
la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a laa) */
if (is_proper_list_2(sc, cdr(la_clause))) {
if (is_h_optimized(la_clause)) {
if ((is_fxable(sc, cadr(la_clause))) &&
((len == 3) ||
((len == 4) && (vars == 2) &&
(is_proper_list_3(sc, cadr(clause2))) &&
(caadr(clause2) == name)))) {
s7_pointer la = caddr(la_clause);
if ((is_pair(la)) &&
(car(la) == name) &&
(is_pair(cdr(la))) &&
(is_fxable(sc, cadr(la))) &&
(((vars == 1) && (is_null(cddr(la)))) ||
((vars == 2) &&
(is_pair(cddr(la))) &&
(is_fxable(sc, caddr(la))) &&
(is_null(cdddr(la)))))) {
if (len == 3)
set_safe_optimize_op(body,
(vars ==
1) ?
OP_RECUR_COND_A_A_opA_LAq
:
OP_RECUR_COND_A_A_opA_LAAq);
else {
s7_pointer laa = cadr(clause2);
if ((is_fxable(sc, cadr(laa))) && /* args to first laa */
(is_fxable(sc, caddr(laa)))) {
set_safe_optimize_op(body,
OP_RECUR_COND_A_A_A_LAA_opA_LAAq);
fx_annotate_arg(sc, clause2, args);
fx_annotate_args(sc, cdr(laa),
args);
} else
return (false);
}
fx_annotate_args(sc, clause, args);
fx_annotate_arg(sc, cdr(la_clause), args);
fx_annotate_args(sc, cdr(la), args);
fx_tree(sc, cdr(body), car(args),
(vars == 1) ? NULL : cadr(args),
NULL, false);
set_opt3_pair(body, la_clause);
set_opt3_pair(la_clause, la);
return (true);
}
} else {
if ((len == 4) &&
(is_fxable(sc, cadr(clause2)))) {
s7_pointer la1 = cadr(la_clause), la2 =
caddr(la_clause);
bool happy = false;
if ((vars == 1) &&
(is_proper_list_2(sc, la1))
&& (is_proper_list_2(sc, la2))
&& (car(la1) == name)
&& (car(la2) == name)
&& (is_fxable(sc, cadr(la1)))
&& (is_fxable(sc, cadr(la2)))) {
set_safe_optimize_op(body,
OP_RECUR_COND_A_A_A_A_opLA_LAq);
fx_annotate_arg(sc, cdr(la1), args);
happy = true;
} else if ((vars == 2) &&
/* (is_fxable(sc, cadr(clause2))) && */
(is_proper_list_3(sc, la2))
&& (car(la2) == name)
&& (is_fxable(sc, cadr(la2)))
&& (is_fxable(sc, caddr(la2)))) {
if (is_fxable(sc, la1)) {
set_safe_optimize_op(body,
OP_RECUR_COND_A_A_A_A_opA_LAAq);
fx_annotate_arg(sc, cdr(la_clause),
args);
happy = true;
} else
if ((is_proper_list_3(sc, la1)) &&
(car(la1) == name) &&
(is_fxable(sc, cadr(la1))) &&
(is_fxable(sc, caddr(la1)))) {
set_safe_optimize_op(body,
OP_RECUR_COND_A_A_A_A_opLAA_LAAq);
fx_annotate_args(sc, cdr(la1),
args);
happy = true;
}
}
if (happy) {
set_opt3_pair(la_clause, cdr(la2));
fx_annotate_args(sc, clause, args);
fx_annotate_args(sc, clause2, args);
fx_annotate_args(sc, cdr(la2), args);
fx_tree(sc, cdr(body), car(args),
(vars ==
1) ? NULL : cadr(args), NULL,
false);
set_opt3_pair(body, la_clause);
return (true);
}
}
}
} else {
if (clause2) {
s7_pointer laa = cadr(clause2);
if ((vars == 2) && (len == 4) &&
(is_proper_list_3(sc, laa))
&& (car(laa) == name)
&& (is_fxable(sc, cadr(laa)))
&& (is_fxable(sc, caddr(laa)))) {
s7_pointer la1 = cadr(la_clause), la2 =
caddr(la_clause);
if ((is_fxable(sc, la1))
&& (is_proper_list_3(sc, la2))
&& (car(la2) == name)
&& (is_fxable(sc, cadr(la2)))
&& (is_fxable(sc, caddr(la2)))) {
set_safe_optimize_op(body,
OP_RECUR_COND_A_A_A_LAA_LopA_LAAq);
fx_annotate_args(sc, clause, args);
fx_annotate_arg(sc, clause2, args);
fx_annotate_args(sc, cdr(laa), args);
fx_annotate_arg(sc, cdr(la_clause),
args);
fx_annotate_args(sc, cdr(la2), args);
fx_tree(sc, cdr(body), car(args),
cadr(args), NULL, false);
set_opt3_pair(body, la_clause);
set_opt3_pair(la_clause, cdr(la2));
return (true);
}
}
}
}
}
}
}
}
return (false);
}
static opt_t fxify_closure_s(s7_scheme * sc, s7_pointer func,
s7_pointer expr, s7_pointer e, int32_t hop)
{
s7_pointer body = closure_body(func);
fx_annotate_arg(sc, body, e);
set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A);
if ((is_pair(car(body))) && (is_pair(cdar(body)))
&& (car(closure_args(func)) == cadar(body))) {
if (optimize_op(car(body)) == HOP_SAFE_C_S)
set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S);
else if (optimize_op(car(body)) == HOP_SAFE_C_SC) {
s7_pointer body_arg2 = caddar(body);
set_opt3_con(cdr(expr),
(is_pair(body_arg2)) ? cadr(body_arg2) :
body_arg2);
set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC);
if ((caar(body) == sc->vector_ref_symbol)
&& (is_global(sc->vector_ref_symbol)))
set_fx_direct(cdr(expr), fx_safe_closure_s_to_vref);
else {
set_fx_direct(cdr(expr), fx_safe_closure_s_to_sc);
if ((is_t_integer(body_arg2)) && (integer(body_arg2) == 1)) {
if (caar(body) == sc->subtract_symbol)
set_fx_direct(cdr(expr),
fx_safe_closure_s_to_sub1);
if (caar(body) == sc->add_symbol)
set_fx_direct(cdr(expr),
fx_safe_closure_s_to_add1);
}
}
}
}
set_closure_one_form_fx_arg(func);
fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false);
return (OPT_T);
}
static bool fxify_closure_a(s7_scheme * sc, s7_pointer func, bool one_form,
bool safe_case, int32_t hop, s7_pointer expr,
s7_pointer e)
{
if (one_form) {
if (safe_case) {
s7_pointer body = closure_body(func);
if (is_fxable(sc, car(body))) {
fx_annotate_arg(sc, body, e);
set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A);
if ((is_pair(car(body))) &&
(optimize_op(car(body)) == HOP_SAFE_C_SC) &&
(car(closure_args(func)) == cadar(body))) {
s7_pointer body_arg2 = caddar(body);
set_opt3_con(cdr(expr),
(is_pair(body_arg2)) ? cadr(body_arg2) :
body_arg2);
set_safe_optimize_op(expr,
hop + OP_SAFE_CLOSURE_A_TO_SC);
if ((caar(body) == sc->vector_ref_symbol)
&& (is_global(sc->vector_ref_symbol)))
set_fx_direct(expr, fx_safe_closure_a_to_vref);
else
set_fx_direct(expr, fx_safe_closure_a_to_sc);
}
set_closure_one_form_fx_arg(func);
fx_tree(sc, body, car(closure_args(func)), NULL, NULL,
false);
return (true);
}
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_O);
} else
set_optimize_op(expr, hop + OP_CLOSURE_A_O);
} else
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A));
return (false);
}
static opt_t optimize_closure_one_arg(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop,
int32_t pairs, int32_t symbols,
int32_t quotes, int32_t bad_pairs,
s7_pointer e)
{
bool one_form, safe_case;
s7_pointer body, arg1 = cadr(expr);
int32_t arit;
arit = closure_arity_to_int(sc, func);
if (arit != 1) {
if ((arit == -1) && (is_symbol(closure_args(func))))
return (optimize_closure_dotted_args
(sc, expr, func, hop, 1, e));
return (OPT_F);
}
safe_case = is_safe_closure(func);
body = closure_body(func);
one_form = is_null(cdr(body));
if (is_immutable(func))
hop = 1;
if (symbols == 1) {
set_opt2_sym(expr, arg1);
set_opt1_lambda_add(expr, func);
if (one_form) {
if (safe_case) {
if (is_fxable(sc, car(body)))
return (fxify_closure_s(sc, func, expr, e, hop));
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_O);
} else
set_optimize_op(expr, hop + OP_CLOSURE_S_O);
} else
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_S :
OP_CLOSURE_S));
set_unsafely_optimized(expr);
return (OPT_F);
}
if (fx_count(sc, expr) == 1) {
set_unsafely_optimized(expr);
set_opt1_lambda_add(expr, func);
fx_annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_one);
if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, e))
return (OPT_T);
set_unsafely_optimized(expr);
return (OPT_F);
}
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_P : OP_CLOSURE_P));
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_one);
set_unsafely_optimized(expr);
if ((safe_case) && (one_form)
&& (is_fxable(sc, car(closure_body(func))))) {
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_P_A); /* other possibilities: 3p fp (ap|pa only get a few hits), but none of these matter much */
fx_annotate_arg(sc, closure_body(func), e);
}
return (OPT_F); /* don't check is_optimized here for OPT_T */
}
static opt_t optimize_func_one_arg(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop,
int32_t pairs, int32_t symbols,
int32_t quotes, int32_t bad_pairs,
s7_pointer e)
{
s7_pointer arg1;
/* very often, expr is already optimized, quoted stuff is counted under "bad_pairs"! as well as quotes */
if (quotes > 0) {
if (direct_memq(sc->quote_symbol, e))
return (OPT_OOPS);
if ((bad_pairs == quotes) &&
(is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr))))
hop = 1;
}
arg1 = cadr(expr);
/* need in_with_let -> search only rootlet not lookup */
if ((symbols == 1) && (!arg_findable(sc, arg1, e))) {
/* wrap the bad arg in a check symbol lookup */
if (s7_is_aritable(sc, func, 1)) {
set_fx_direct(cdr(expr), fx_unsafe_s);
return (wrap_bad_args(sc, func, expr, 1, hop, e));
}
return (OPT_F);
}
if ((is_c_function(func)) &&
(c_function_required_args(func) <= 1) &&
(c_function_all_args(func) >= 1))
return (optimize_c_function_one_arg
(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs,
e));
if (is_closure(func))
return (optimize_closure_one_arg
(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs,
e));
if (is_closure_star(func)) {
if (is_null(closure_args(func)))
return (OPT_F);
if (fx_count(sc, expr) == 1) {
bool safe_case = is_safe_closure(func);
if (is_immutable(func))
hop = 1;
fx_annotate_arg(sc, cdr(expr), e);
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_one);
set_unsafely_optimized(expr);
if ((safe_case) && (is_null(cdr(closure_args(func)))))
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1);
else if (lambda_has_simple_defaults(func)) {
if (arglist_has_rest(sc, closure_args(func)))
set_optimize_op(expr,
hop +
((safe_case) ?
OP_SAFE_CLOSURE_STAR_NA_1 :
OP_CLOSURE_STAR_NA));
else
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_STAR_A :
OP_CLOSURE_STAR_A));
} else
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 :
OP_CLOSURE_STAR_NA));
}
return (OPT_F);
}
if ((is_c_function_star(func)) && (fx_count(sc, expr) == 1) && (c_function_all_args(func) >= 1) && (!is_keyword(arg1))) { /* the only arg should not be a keyword (needs error checks later) */
if ((hop == 0)
&& ((is_immutable(func))
|| ((!sc->in_with_let) && (symbol_id(car(expr)) == 0))))
hop = 1;
set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_A);
fx_annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_one);
set_c_function(expr, func);
return (OPT_T);
}
if (((is_any_vector(func)) || (is_pair(func))) &&
(is_fxable(sc, arg1))) {
set_unsafe_optimize_op(expr,
(is_pair(func) ? OP_IMPLICIT_PAIR_REF_A :
OP_IMPLICIT_VECTOR_REF_A));
fx_annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_one);
return (OPT_T);
}
if ((func == sc->s7_let) && /* (*s7* ...) */
(((quotes == 1) && (is_symbol(cadr(arg1)))) || (is_keyword(arg1)))) {
s7_pointer sym;
sym = (quotes == 1) ? cadr(arg1) : arg1;
if (is_keyword(sym))
sym = keyword_symbol(sym); /* might even be ':print-length */
set_safe_optimize_op(expr, OP_IMPLICIT_S7_LET_REF_S);
set_opt3_sym(expr, sym);
return (OPT_T);
}
if (is_let(func)) {
if ((is_pair(arg1)) && (car(arg1) == sc->quote_symbol)) {
set_opt3_con(expr, cadr(arg1));
set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_C);
return (OPT_T);
}
if (is_fxable(sc, arg1)) {
set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_A);
set_opt3_any(expr, arg1);
fx_annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_one);
return (OPT_T);
}
}
/* unknown_* for other cases is set later(? -- we're getting eval-args...) */
/* op_safe_c_p for (< (values 1 2 3)) op_s_s for (op arg) op_s_c for (op 'x) or (op 1) also op_s_a
* but is it better to wait for unknown* ? These are not hit often at this point (except in s7test).
* do they end up in op_s_a or whatever after unknown*?
*/
return ((is_optimized(expr)) ? OPT_T : OPT_F);
}
static bool unsafe_is_safe(s7_scheme * sc, s7_pointer f, s7_pointer e)
{
if (!is_symbol(f))
return (false);
f = find_uncomplicated_symbol(sc, f, e); /* how to catch local c-funcs here? */
if (!is_slot(f))
return (false);
return ((is_c_function(slot_value(f)))
&& (is_safe_procedure(slot_value(f))));
}
static opt_t set_any_closure_np(s7_scheme * sc, s7_pointer func,
s7_pointer expr, s7_pointer e,
int32_t num_args, opcode_t op)
{
s7_pointer p;
for (p = cdr(expr); is_pair(p); p = cdr(p))
set_fx(p,
fx_choose(sc, p, e,
(is_list(e)) ? pair_symbol_is_safe :
let_symbol_is_safe));
set_opt3_arglen(cdr(expr), make_permanent_integer(num_args));
set_unsafe_optimize_op(expr, op);
set_opt1_lambda_add(expr, func);
return (OPT_F);
}
static bool two_args_ok(s7_scheme * sc, s7_pointer expr, s7_pointer e)
{
if ((is_symbol(car(expr)))
&& ((car(expr) == sc->member_symbol)
|| (car(expr) == sc->assoc_symbol)))
return (true);
return (unsafe_is_safe(sc, cadr(expr), e));
}
static void opt_sp_1(s7_scheme * sc, s7_function g, s7_pointer expr)
{
set_opt1_any(cdr(expr), (s7_pointer) ((intptr_t)
((g ==
g_cons) ? OP_SAFE_CONS_SP_1
: (((g == g_list)
|| (g ==
g_list_2)) ?
OP_SAFE_LIST_SP_1
: (((g == g_multiply)
|| (g ==
g_multiply_2)) ?
OP_SAFE_MULTIPLY_SP_1
: (((g == g_add)
|| (g ==
g_add_2)) ?
OP_SAFE_ADD_SP_1 :
OP_SAFE_C_SP_1))))));
}
static opt_t set_any_c_np(s7_scheme * sc, s7_pointer func, s7_pointer expr,
s7_pointer e, int32_t num_args, opcode_t op)
{
s7_pointer p;
/* fprintf(stderr, "%d %d %d %s %s\n", num_args, is_safe_procedure(func), is_semisafe(func), op_names[op], display_80(expr)); */
/* we get safe/semisafe funcs here of 2 args and up! very few more than 5 */
/* would safe_c_pp work for cl? or should unknown_* deal with op_cl_*? why aren't unknown* used in op_safe_c and op_c?
* 2 | 3 args store on stack rather than consing? then use sc->t2|3 to pass to fn_proc (unless unsafe)
* or use op_stack? error clears this? op-any-c-fp: op_any_c_2p|3p|fp? -- mimic clo_3p|4p?
* all: 3 1 0 any_c_np (* 0.5 (- n 1) y)??
*/
for (p = cdr(expr); is_pair(p); p = cdr(p)) {
set_fx(p,
fx_choose(sc, p, e,
(is_list(e)) ? pair_symbol_is_safe :
let_symbol_is_safe));
if (!has_fx(p))
gx_annotate_arg(sc, p, e);
}
set_opt3_arglen(cdr(expr), make_permanent_integer(num_args)); /* for op_unknown_np */
set_unsafe_optimize_op(expr, op);
choose_c_function(sc, expr, func, num_args); /* we can use num_args -- mv will redirect to generic call */
return (OPT_F);
}
static s7_function io_function(s7_scheme * sc, s7_function func)
{
if (func == g_with_input_from_string)
return (with_string_in);
if (func == g_with_input_from_file)
return (with_file_in);
if (func == g_with_output_to_file)
return (with_file_out);
if (func == g_call_with_input_string)
return (call_string_in);
if (func == g_call_with_input_file)
return (call_file_in);
return (call_file_out); /* call_with_output_to_file */
}
static void fixup_closure_star_aa(s7_scheme * sc, s7_pointer f,
s7_pointer code, int32_t hop)
{
int32_t arity;
bool safe_case = is_safe_closure(f);
s7_pointer arg1 = cadr(code), par1;
arity = closure_star_arity_to_int(sc, f);
par1 = car(closure_args(f));
if (is_pair(par1))
par1 = car(par1);
set_opt3_arglen(cdr(code), int_two);
set_unsafely_optimized(code);
if ((arity == 1) && (is_keyword(arg1))
&& (keyword_symbol(arg1) == par1))
set_optimize_op(code,
hop +
((safe_case) ? OP_SAFE_CLOSURE_STAR_KA :
OP_CLOSURE_STAR_KA));
else if ((lambda_has_simple_defaults(f)) && (arity == 2))
set_optimize_op(code, hop + ((is_safe_closure(f))
? ((is_null(cdr(closure_body(f)))) ?
OP_SAFE_CLOSURE_STAR_AA_O :
OP_SAFE_CLOSURE_STAR_AA) :
OP_CLOSURE_STAR_NA));
else
set_optimize_op(code,
hop +
((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_2 :
OP_CLOSURE_STAR_NA));
}
static int32_t check_lambda(s7_scheme * sc, s7_pointer form, bool optl);
static opt_t optimize_func_two_args(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop,
int32_t pairs, int32_t symbols,
int32_t quotes, int32_t bad_pairs,
s7_pointer e)
{
s7_pointer arg1, arg2;
if (quotes > 0) {
if (direct_memq(sc->quote_symbol, e))
return (OPT_OOPS);
if ((bad_pairs == quotes) &&
(is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr))))
hop = 1;
}
arg1 = cadr(expr);
arg2 = caddr(expr);
if (((is_symbol(arg1)) &&
(!arg_findable(sc, arg1, e))) ||
((is_symbol(arg2)) && (!arg_findable(sc, arg2, e)))) {
/* wrap bad args */
if ((is_fxable(sc, arg1)) &&
(is_fxable(sc, arg2)) && (s7_is_aritable(sc, func, 2))) {
fx_annotate_args(sc, cdr(expr), e);
return (wrap_bad_args(sc, func, expr, 2, hop, e));
}
return (OPT_F);
}
/* end of bad symbol wrappers */
if (is_c_function(func) &&
(c_function_required_args(func) <= 2) &&
(c_function_all_args(func) >= 2)) {
/* this is a mess */
bool func_is_safe = is_safe_procedure(func);
if ((hop == 0)
&& ((is_immutable(func))
|| ((!sc->in_with_let) && (symbol_id(car(expr)) == 0))))
hop = 1;
if (pairs == 0) {
if ((func_is_safe) ||
((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) {
/* another case here: set-car! and set-cdr! are safe if symbols==1 and arg1 is the symbol (i.e. arg2 is a constant) */
if (symbols == 0)
set_optimize_op(expr, hop + OP_SAFE_C_NC);
else if (symbols == 2) { /* these two symbols are almost never the same, (sqrt (+ (* x x) (* y y))) */
set_optimize_op(expr, hop + OP_SAFE_C_SS);
set_opt2_sym(cdr(expr), arg2);
} else if (is_normal_symbol(arg1)) {
set_opt2_con(cdr(expr), arg2);
set_optimize_op(expr, hop + OP_SAFE_C_SC);
} else {
set_opt1_con(cdr(expr), arg1);
set_opt2_sym(cdr(expr), arg2);
set_optimize_op(expr, hop + OP_SAFE_C_CS);
}
set_optimized(expr);
choose_c_function(sc, expr, func, 2);
return (OPT_T);
}
set_unsafely_optimized(expr);
if (symbols == 2) {
if (c_function_call(func) == g_apply) {
set_optimize_op(expr, OP_APPLY_SS);
set_opt1_cfunc(expr, func); /* not quite set_c_function */
set_opt2_sym(expr, arg2);
} else {
if (is_semisafe(func)) {
set_opt2_sym(cdr(expr), arg2);
set_optimize_op(expr, hop + OP_CL_SS);
} else
set_optimize_op(expr, hop + OP_C_SS);
choose_c_function(sc, expr, func, 2);
}
} else {
set_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_AA :
OP_C_AA));
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_two);
choose_c_function(sc, expr, func, 2);
if (is_safe_procedure(opt1_cfunc(expr))) {
clear_unsafe(expr);
/* symbols can be 0..2 here, no pairs */
set_optimized(expr);
if (symbols == 1) {
if (is_normal_symbol(arg1)) {
set_optimize_op(expr, hop + OP_SAFE_C_SC);
set_opt2_con(cdr(expr), arg2);
} else {
set_opt1_con(cdr(expr), arg1);
set_opt2_sym(cdr(expr), arg2);
set_optimize_op(expr, hop + OP_SAFE_C_CS);
}
}
return (OPT_T);
}
}
return (OPT_F);
}
/* pairs != 0 */
if ((bad_pairs == 0) && (pairs == 2)) {
if ((func_is_safe) ||
((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) {
int32_t op;
op = combine_ops(sc, func, expr, E_C_PP, arg1, arg2);
set_safe_optimize_op(expr, hop + op);
if (op == OP_SAFE_C_PP) {
if (((op_no_hop(cadr(expr))) ==
OP_SAFE_CLOSURE_S_TO_SC)
&& ((op_no_hop(caddr(expr))) ==
OP_SAFE_CLOSURE_S_TO_SC)
&& (is_global(caadr(expr)))
&& (is_global(caaddr(expr)))) {
/* ideally this would be OP not HOP, but safe_closure_s_to_sc is too picky */
/* set_opt3_pair(expr, caddr(expr)); */
set_opt3_arglen(cdr(expr), int_two);
set_safe_optimize_op(expr, HOP_SAFE_C_FF);
}
opt_sp_1(sc, c_function_call(func), expr); /* calls set_opt1_any, sets opt1(cdr(expr)) to OP_SAFE_CONS_SP_1 and friends */
if (is_fxable(sc, arg1)) {
if (is_fxable(sc, arg2))
return (check_c_aa(sc, expr, func, hop, e)); /* AA case */
set_optimize_op(expr, hop + OP_SAFE_C_AP);
fx_annotate_arg(sc, cdr(expr), e);
gx_annotate_arg(sc, cddr(expr), e);
set_opt3_arglen(cdr(expr), int_two);
} else if (is_fxable(sc, arg2)) {
set_optimize_op(expr, hop + OP_SAFE_C_PA);
fx_annotate_arg(sc, cddr(expr), e);
gx_annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_two);
} else
gx_annotate_args(sc, cdr(expr), e);
}
choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */
return (OPT_T);
}
}
if ((bad_pairs == 0) && (pairs == 1)) {
if ((func_is_safe) ||
((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) {
combine_op_t orig_op;
int32_t op;
if (is_pair(arg1)) {
orig_op = (is_normal_symbol(arg2)) ? E_C_PS : E_C_PC;
op = combine_ops(sc, func, expr, orig_op, arg1, arg2);
} else {
orig_op = (is_normal_symbol(arg1)) ? E_C_SP : E_C_CP;
op = combine_ops(sc, func, expr, orig_op, arg1, arg2);
}
if ((((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) &&
(is_fxable(sc, arg2))) ||
(((op == OP_SAFE_C_PS) || (op == OP_SAFE_C_PC)) &&
(is_fxable(sc, arg1)))) {
fx_annotate_args(sc, cdr(expr), e);
if (!safe_c_aa_to_ag_ga(sc, expr, hop)) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_AA);
set_opt3_pair(expr, cddr(expr));
}
} else {
set_safe_optimize_op(expr, hop + op);
if ((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) {
opt_sp_1(sc, c_function_call(func), expr);
set_opt3_any(cdr(expr), arg1);
} else if (op == OP_SAFE_C_PC)
set_opt3_con(cdr(expr), arg2);
}
choose_c_function(sc, expr, func, 2);
return (OPT_T);
}
if ((symbols == 1) &&
(is_normal_symbol(arg1)) && (is_safe_c_s(arg2))) {
set_unsafe_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_S_opSq
: OP_C_S_opSq));
set_opt1_sym(cdr(expr), cadr(arg2));
choose_c_function(sc, expr, func, 2);
return (OPT_F);
}
}
if ((bad_pairs == 1) && (quotes == 1)) {
if ((func_is_safe) ||
((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) {
if (symbols == 1) {
set_optimized(expr);
if (is_normal_symbol(arg1)) {
set_opt2_con(cdr(expr), cadr(arg2));
set_optimize_op(expr, hop + OP_SAFE_C_SC);
} else {
set_opt1_con(cdr(expr), cadr(arg1));
set_opt2_sym(cdr(expr), arg2);
set_optimize_op(expr, hop + OP_SAFE_C_CS);
}
choose_c_function(sc, expr, func, 2);
return (OPT_T);
}
if ((pairs == 1) && (is_pair(arg2))) { /* QC never happens */
set_safe_optimize_op(expr, hop + OP_SAFE_C_CQ);
set_opt2_con(cdr(expr), cadr(arg2));
choose_c_function(sc, expr, func, 2);
return (OPT_T);
}
if (!is_safe_c_s(arg1)) {
if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2)))
return (check_c_aa(sc, expr, func, hop, e));
}
} else if (pairs == 1) {
set_unsafe_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_AA :
OP_C_AA));
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_two);
choose_c_function(sc, expr, func, 2);
return (OPT_F);
}
}
if (quotes == 2) {
if (func_is_safe) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); /* op_safe_c_nc -> fx_c_nc appears to leave quoted pairs quoted? */
set_opt3_pair(expr, cddr(expr));
} else {
set_unsafe_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_AA :
OP_C_AA));
set_opt3_arglen(cdr(expr), int_two);
}
fx_annotate_args(sc, cdr(expr), e);
choose_c_function(sc, expr, func, 2);
return ((func_is_safe) ? OPT_T : OPT_F);
}
if ((pairs == 1) &&
(quotes == 0) &&
((func_is_safe) ||
((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) {
if (symbols == 1) {
set_optimized(expr);
if (is_normal_symbol(arg1)) { /* this is what optimize_expression uses to count symbols */
set_optimize_op(expr, hop + OP_SAFE_C_SP);
opt_sp_1(sc, c_function_call(func), expr);
} else
set_optimize_op(expr, hop + OP_SAFE_C_PS);
choose_c_function(sc, expr, func, 2);
if (bad_pairs == 0)
return (OPT_T);
set_unsafe(expr);
return (OPT_F);
}
if (symbols == 0) {
set_optimized(expr);
if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2)))
return (check_c_aa(sc, expr, func, hop, e));
if (is_pair(arg1)) {
set_optimize_op(expr, hop + OP_SAFE_C_PC);
set_opt3_con(cdr(expr), arg2);
} else {
set_optimize_op(expr, hop + OP_SAFE_C_CP);
opt_sp_1(sc, c_function_call(func), expr);
set_opt3_any(cdr(expr), arg1);
}
choose_c_function(sc, expr, func, 2);
if (bad_pairs == 0)
return (OPT_T);
set_unsafe(expr);
return (OPT_F);
}
}
if ((pairs == 2) &&
((func_is_safe) ||
((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) {
if ((bad_pairs == 1) && (is_safe_c_s(arg1))) {
/* unsafe func here won't work unless we check that later and make the new arg list (for list-values etc)
* (and it has to be the last pair else the unknown_g stuff can mess up)
*/
if ((car(arg2) == sc->quote_symbol) &&
(is_global(sc->quote_symbol))) {
if (!is_proper_list_1(sc, cdr(arg2)))
return (OPT_OOPS);
set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_C);
set_opt1_sym(cdr(expr), cadr(arg1));
set_opt2_con(cdr(expr), cadr(arg2));
choose_c_function(sc, expr, func, 2);
return (OPT_T);
}
set_unsafe_optimize_op(expr, hop + OP_SAFE_C_opSq_P);
opt_sp_1(sc, c_function_call(func), expr);
choose_c_function(sc, expr, func, 2);
return (OPT_F);
}
if (quotes == 0) {
set_unsafely_optimized(expr);
if (is_fxable(sc, arg1)) {
if (is_fxable(sc, arg2))
return (check_c_aa(sc, expr, func, hop, e));
set_optimize_op(expr, hop + OP_SAFE_C_AP);
opt_sp_1(sc, c_function_call(func), expr);
fx_annotate_arg(sc, cdr(expr), e);
gx_annotate_arg(sc, cddr(expr), e);
} else if (is_fxable(sc, arg2)) {
set_optimize_op(expr, hop + OP_SAFE_C_PA);
fx_annotate_arg(sc, cddr(expr), e);
gx_annotate_arg(sc, cdr(expr), e);
} else {
set_optimize_op(expr, hop + OP_SAFE_C_PP);
opt_sp_1(sc, c_function_call(func), expr);
gx_annotate_args(sc, cdr(expr), e);
}
choose_c_function(sc, expr, func, 2);
return (OPT_F);
}
if (quotes == 1) {
if ((car(arg1) == sc->quote_symbol) &&
(is_global(sc->quote_symbol))) {
if (!is_proper_list_1(sc, cdr(arg1)))
return (OPT_OOPS);
set_optimize_op(expr, hop + OP_SAFE_C_CP);
opt_sp_1(sc, c_function_call(func), expr);
set_opt3_any(cdr(expr), cadr(arg1));
} else {
set_optimize_op(expr, hop + OP_SAFE_C_PC);
set_opt3_con(cdr(expr), cadr(arg2));
}
set_unsafely_optimized(expr);
choose_c_function(sc, expr, func, 2);
return (OPT_F);
}
}
if (func_is_safe) {
if (fx_count(sc, expr) == 2)
return (check_c_aa(sc, expr, func, hop, e));
} else {
if (is_fxable(sc, arg1)) {
if (is_fxable(sc, arg2)) {
if ((c_function_call(func) == g_apply) &&
(is_normal_symbol(arg1))) {
set_optimize_op(expr, OP_APPLY_SA);
if ((is_pair(arg2)) && (is_normal_symbol(car(arg2)))) { /* arg2 might be ((if expr op1 op2) ...) */
s7_pointer lister;
lister = lookup(sc, car(arg2));
if ((is_c_function(lister)) &&
(is_pair(c_function_signature(lister))) &&
(car(c_function_signature(lister)) ==
sc->is_proper_list_symbol))
set_optimize_op(expr, OP_APPLY_SL);
}
set_opt1_cfunc(expr, func); /* not quite set_c_function */
} else
set_unsafe_optimize_op(expr,
hop +
((is_semisafe(func)) ?
OP_CL_AA : OP_C_AA));
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_two);
} else {
if (((c_function_call(func) == g_with_input_from_string) || (c_function_call(func) == g_with_input_from_file) || (c_function_call(func) == g_with_output_to_file)) && (is_ok_lambda(sc, arg2)) && (is_null(cadr(arg2))) && (!direct_memq(car(arg2), e))) { /* lambda is redefined?? */
set_unsafe_optimize_op(expr,
(is_string(arg1)) ?
OP_WITH_IO_C : OP_WITH_IO);
set_opt2_pair(expr, cddr(arg2));
set_opt1_any(expr,
(s7_pointer) io_function(sc,
c_function_call
(func)));
return (OPT_F);
}
if (((c_function_call(func) == g_call_with_input_string) || (c_function_call(func) == g_call_with_input_file) || (c_function_call(func) == g_call_with_output_file)) && (is_ok_lambda(sc, arg2)) && (is_proper_list_1(sc, cadr(arg2))) && (is_symbol(caadr(arg2))) && (!is_probably_constant(caadr(arg2))) && (!direct_memq(sc->lambda_symbol, e))) { /* lambda is redefined?? */
set_unsafe_optimize_op(expr,
(is_string(arg1)) ?
OP_WITH_IO_C : OP_WITH_IO);
set_opt2_pair(expr, cddr(arg2));
set_opt3_sym(expr, caadr(arg2));
set_opt1_any(expr,
(s7_pointer) io_function(sc,
c_function_call
(func)));
return (OPT_F);
}
set_unsafe_optimize_op(expr, hop + OP_C_AP);
fx_annotate_arg(sc, cdr(expr), e);
}
choose_c_function(sc, expr, func, 2);
return (OPT_F);
}
if ((is_semisafe(func)) &&
(is_symbol(car(expr))) &&
(car(expr) != sc->values_symbol) &&
(is_fxable(sc, arg2)) &&
(is_pair(arg1)) && (car(arg1) == sc->lambda_symbol)) {
s7_pointer p;
fx_annotate_arg(sc, cddr(expr), e);
set_unsafe_optimize_op(expr, hop + OP_CL_FA);
check_lambda(sc, arg1, true); /* this changes symbol_list */
clear_symbol_list(sc); /* so restore it */
for (p = e; is_pair(p); p = cdr(p))
if (is_normal_symbol(car(p)))
add_symbol_to_list(sc, car(p));
/* two seq args can't happen here (func_2_args = map + lambda + seq, arg1 is the lambda form, arg2 is fxable (see above) */
choose_c_function(sc, expr, func, 2);
if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && ((is_proper_list_1(sc, cadr(arg1))) && /* one parameter */
(!is_possibly_constant(caadr(arg1))))) { /* parameter name not trouble */
/* built-in permanent closure here was not much faster */
set_fn(expr,
(fn_proc(expr) ==
g_for_each) ? g_for_each_closure : NULL);
set_opt3_pair(expr, cdr(arg1));
set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FA);
}
return (OPT_F);
}
}
return (set_any_c_np(sc, func, expr, e, 2, hop + OP_ANY_C_NP)); /* OP_C_PP doesn't exist */
/* TODO: gx_annotate */
}
if (is_closure(func)) {
int32_t arit;
bool one_form, safe_case;
s7_pointer body;
arit = closure_arity_to_int(sc, func);
if (arit != 2) {
if ((arit == -1) && (is_symbol(closure_args(func))))
return (optimize_closure_dotted_args
(sc, expr, func, hop, 2, e));
return (OPT_F);
}
if (is_immutable(func))
hop = 1;
body = closure_body(func);
one_form = is_null(cdr(body));
safe_case = is_safe_closure(func);
if ((pairs == 0) && (symbols >= 1)) {
set_unsafely_optimized(expr);
set_opt1_lambda_add(expr, func);
if (symbols == 2) {
set_opt2_sym(expr, arg2);
if (!one_form)
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_SS :
OP_CLOSURE_SS));
else if (!safe_case)
set_optimize_op(expr, hop + OP_CLOSURE_SS_O);
else if (!is_fxable(sc, car(body)))
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_O);
else {
fx_annotate_arg(sc, body, e);
fx_tree(sc, body, car(closure_args(func)),
cadr(closure_args(func)), NULL, false);
set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A);
/* fx_annotate_args(sc, cdr(expr), e); */
set_closure_one_form_fx_arg(func);
return (OPT_T);
}
return (OPT_F);
}
if (is_normal_symbol(arg1)) {
if (one_form)
set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); /* _A case is very rare */
else
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_SC :
OP_CLOSURE_SC));
set_opt2_con(expr, arg2);
return (OPT_F);
}
}
if ((!arglist_has_rest(sc, closure_args(func))) &&
(fx_count(sc, expr) == 2)) {
if (!one_form)
set_safe_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_AA :
OP_CLOSURE_AA));
else if (!safe_case)
set_optimize_op(expr, hop + OP_CLOSURE_AA_O);
else if (!is_fxable(sc, car(body)))
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_O);
else {
fx_annotate_arg(sc, body, e);
set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_A); /* safe_closure_as|sa_a? */
set_closure_one_form_fx_arg(func);
fx_annotate_args(sc, cdr(expr), e);
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_two);
return (OPT_T);
}
fx_annotate_args(sc, cdr(expr), e);
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_two);
return (OPT_F);
}
if (is_fxable(sc, arg1)) {
set_unsafely_optimized(expr);
fx_annotate_arg(sc, cdr(expr), e);
set_safe_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_AP :
OP_CLOSURE_AP));
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_two); /* for op_unknown_np */
return (OPT_F);
}
if ((is_pair(arg1)) && (car(arg1) == sc->lambda_symbol) && (is_pair(cdr(arg1))) && /* not (lambda) */
(is_fxable(sc, arg2)) && (is_null(cdr(closure_body(func))))) {
s7_pointer p;
fx_annotate_arg(sc, cddr(expr), e);
set_opt2_pair(expr, cdr(arg1));
set_unsafe_optimize_op(expr, hop + OP_CLOSURE_FA);
check_lambda(sc, arg1, false);
clear_symbol_list(sc);
for (p = e; is_pair(p); p = cdr(p))
if (is_normal_symbol(car(p)))
add_symbol_to_list(sc, car(p));
/* check_lambda calls optimize_lambda if define in progress, else just optimize on the body */
clear_safe_closure_body(cddr(arg1)); /* otherwise we need to fixup the local let for the optimizer -- what is this about? */
set_opt1_lambda_add(expr, func);
return (OPT_F);
}
if (is_fxable(sc, arg2)) {
set_unsafely_optimized(expr);
fx_annotate_arg(sc, cddr(expr), e);
set_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_PA :
OP_CLOSURE_PA));
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_two); /* for op_unknown_np */
return (OPT_F);
}
if (is_safe_closure(func)) /* clo* too */
return (set_any_closure_np
(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_PP));
set_unsafely_optimized(expr);
set_optimize_op(expr, hop + OP_CLOSURE_PP);
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_two); /* for op_unknown_np */
return (OPT_F);
}
if (is_closure_star(func)) {
if (is_immutable(func))
hop = 1;
if (fx_count(sc, expr) == 2) {
fixup_closure_star_aa(sc, func, expr, hop);
fx_annotate_args(sc, cdr(expr), e);
set_opt1_lambda_add(expr, func);
return (OPT_F);
}
}
if ((is_c_function_star(func)) &&
(fx_count(sc, expr) == 2) &&
(c_function_all_args(func) >= 1) && (!is_keyword(arg2))) {
if ((hop == 0)
&& ((is_immutable(func))
|| ((!sc->in_with_let) && (symbol_id(car(expr)) == 0))))
hop = 1;
set_optimized(expr);
set_optimize_op(expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_two);
set_c_function(expr, func);
return (OPT_T);
}
if (((is_any_vector(func)) || (is_pair(func))) &&
(is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) {
set_unsafe_optimize_op(expr,
((is_pair(func)) ? OP_IMPLICIT_PAIR_REF_AA :
OP_IMPLICIT_VECTOR_REF_AA));
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_two);
return (OPT_T);
}
return ((is_optimized(expr)) ? OPT_T : OPT_F);
}
static opt_t optimize_safe_c_func_three_args(s7_scheme * sc,
s7_pointer expr,
s7_pointer func, int32_t hop,
int32_t pairs,
int32_t symbols,
int32_t quotes, s7_pointer e)
{
s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr);
if (pairs == 0) {
set_optimized(expr);
if (symbols == 0)
set_optimize_op(expr, hop + OP_SAFE_C_NC);
else if (symbols == 3) {
set_optimize_op(expr, hop + OP_SAFE_C_SSS);
set_opt1_sym(cdr(expr), arg2);
set_opt2_sym(cdr(expr), arg3);
} else if (symbols == 2)
if (!is_normal_symbol(arg1)) {
set_optimize_op(expr, hop + OP_SAFE_C_CSS);
set_opt1_sym(cdr(expr), arg2);
set_opt2_sym(cdr(expr), arg3);
} else if (!is_normal_symbol(arg3)) {
set_opt2_con(cdr(expr), arg3);
set_opt1_sym(cdr(expr), arg2);
set_optimize_op(expr, hop + OP_SAFE_C_SSC);
} else {
set_opt1_con(cdr(expr), arg2);
set_opt2_sym(cdr(expr), arg3);
set_optimize_op(expr, hop + OP_SAFE_C_SCS);
} else if (is_normal_symbol(arg1)) {
set_opt1_con(cdr(expr), arg2);
set_opt2_con(cdr(expr), arg3);
set_optimize_op(expr, hop + OP_SAFE_C_SCC);
} else if (is_normal_symbol(arg2)) {
set_opt1_sym(cdr(expr), arg2);
set_opt2_con(cdr(expr), arg3);
set_opt3_con(cdr(expr), arg1);
set_optimize_op(expr, hop + OP_SAFE_C_CSC);
} else {
set_opt1_sym(cdr(expr), arg3);
set_opt2_con(cdr(expr), arg2);
set_opt3_con(cdr(expr), arg1);
set_optimize_op(expr, hop + OP_SAFE_C_CCS);
}
choose_c_function(sc, expr, func, 3);
return (OPT_T);
}
/* pairs != 0 */
if (fx_count(sc, expr) == 3) {
set_optimized(expr);
if (quotes == 1) {
if ((symbols == 2) &&
(is_normal_symbol(arg1)) && (is_normal_symbol(arg3))) {
set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */
set_opt2_sym(cdr(expr), arg3);
set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */
choose_c_function(sc, expr, func, 3);
return (OPT_T);
}
if (symbols == 1) {
if ((is_normal_symbol(arg3)) &&
(is_proper_quote(sc, arg2)) && (is_safe_c_s(arg1))) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS); /* lg */
set_opt1_con(cdr(expr), cadr(arg2)); /* opt1_con is T_Pos (unchecked) */
set_opt2_sym(cdr(expr), arg3);
set_opt3_sym(cdr(expr), cadr(arg1));
choose_c_function(sc, expr, func, 3);
return (OPT_T);
}
if ((is_normal_symbol(arg2)) &&
(is_proper_quote(sc, arg1)) && (!is_pair(arg3))) {
set_optimize_op(expr, hop + OP_SAFE_C_CSC);
set_opt1_sym(cdr(expr), arg2);
set_opt2_con(cdr(expr), arg3);
set_opt3_con(cdr(expr), cadr(arg1));
choose_c_function(sc, expr, func, 3);
return (OPT_T);
}
}
}
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_three);
set_opt3_pair(expr, cddr(expr));
set_optimize_op(expr, hop + OP_SAFE_C_AAA);
if (pairs == 1) {
if (is_pair(arg1))
set_optimize_op(expr, hop + OP_SAFE_C_AGG);
if ((symbols == 0) && (is_pair(arg2)))
set_optimize_op(expr, hop + OP_SAFE_C_CAC);
else {
if ((symbols == 1) && (is_pair(arg3)))
set_optimize_op(expr,
hop +
((is_normal_symbol(arg2)) ?
OP_SAFE_C_CSA : OP_SAFE_C_SCA));
else {
if (symbols == 2) {
if (is_normal_symbol(arg1)) {
if (is_normal_symbol(arg2)) {
if ((hop == 1)
&& (s7_p_ppp_function(func))) {
set_optimize_op(expr, HOP_SSA_DIRECT);
clear_has_fx(cdr(expr));
set_opt2_direct(cdr(expr), (s7_pointer)
(s7_p_ppp_function
(func)));
} else
set_optimize_op(expr,
hop + OP_SAFE_C_SSA);
} else
set_optimize_op(expr, hop + OP_SAFE_C_SAS);
} else if (is_pair(arg1))
set_optimize_op(expr, hop + OP_SAFE_C_ASS);
}
}
}
} else if ((is_normal_symbol(arg1)) && (pairs == 2))
set_optimize_op(expr, hop + OP_SAFE_C_SAA);
choose_c_function(sc, expr, func, 3);
return (OPT_T);
}
return (OPT_F); /* tell caller to try something else */
}
static opt_t optimize_func_three_args(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop,
int32_t pairs, int32_t symbols,
int32_t quotes, int32_t bad_pairs,
s7_pointer e)
{
s7_pointer arg1, arg2, arg3;
if ((quotes > 0) && (direct_memq(sc->quote_symbol, e)))
return (OPT_OOPS);
arg1 = cadr(expr);
arg2 = caddr(expr);
arg3 = cadddr(expr);
if (((is_symbol(arg1)) &&
(!arg_findable(sc, arg1, e))) ||
((is_symbol(arg2)) &&
(!arg_findable(sc, arg2, e))) ||
((is_symbol(arg3)) && (!arg_findable(sc, arg3, e)))) {
/* wrap bad args */
if ((is_fxable(sc, arg1)) &&
(is_fxable(sc, arg2)) &&
(is_fxable(sc, arg3)) && (s7_is_aritable(sc, func, 3))) {
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_three);
if (is_c_function(func)) {
if (is_safe_procedure(func)) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_AAA);
set_opt3_pair(cdr(expr), cdddr(expr));
set_opt3_pair(expr, cddr(expr));
} else
set_safe_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_NA :
OP_C_NA));
set_c_function(expr, func);
return (OPT_T);
}
if ((is_closure(func)) &&
(closure_arity_to_int(sc, func) == 3) &&
(!arglist_has_rest(sc, closure_args(func)))) {
set_unsafely_optimized(expr);
set_optimize_op(expr,
hop +
((is_safe_closure(func)) ?
OP_SAFE_CLOSURE_3A : OP_CLOSURE_3A));
set_opt1_lambda_add(expr, func);
return (OPT_F);
}
if ((is_closure_star(func)) &&
(lambda_has_simple_defaults(func)) &&
(closure_star_arity_to_int(sc, func) != 0) &&
(closure_star_arity_to_int(sc, func) != 1)) {
set_unsafely_optimized(expr);
if ((is_safe_closure(func))
&& (closure_star_arity_to_int(sc, func) == 3))
set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A);
else
set_optimize_op(expr,
((is_safe_closure(func)) ?
OP_SAFE_CLOSURE_STAR_NA :
OP_CLOSURE_STAR_NA));
set_opt1_lambda_add(expr, func);
}
}
return (OPT_F);
} /* end of bad symbol wrappers */
if ((bad_pairs == quotes) &&
(is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr))))
hop = 1;
if (is_c_function(func) &&
(c_function_required_args(func) <= 3) &&
(c_function_all_args(func) >= 3)) {
if ((hop == 0)
&& ((is_immutable(func))
|| ((!sc->in_with_let) && (symbol_id(car(expr)) == 0))))
hop = 1;
if ((is_safe_procedure(func)) ||
((is_maybe_safe(func)) && (unsafe_is_safe(sc, arg3, e)))) {
if (optimize_safe_c_func_three_args
(sc, expr, func, hop, pairs, symbols, quotes, e) == OPT_T)
return (OPT_T);
if ((is_normal_symbol(arg1)) && (is_normal_symbol(arg2))) {
set_opt3_pair(expr, arg3);
set_unsafe_optimize_op(expr, hop + OP_SAFE_C_SSP);
choose_c_function(sc, expr, func, 3);
return (OPT_F);
}
return (set_any_c_np
(sc, func, expr, e, 3, hop + OP_SAFE_C_3P));
}
/* func is not safe */
if (fx_count(sc, expr) == 3) {
set_optimized(expr);
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_three);
if (is_semisafe(func))
set_optimize_op(expr, hop + (((is_normal_symbol(arg1))
&& (is_normal_symbol(arg3)))
? OP_CL_SAS : OP_CL_NA));
else
set_optimize_op(expr, hop + OP_C_NA);
choose_c_function(sc, expr, func, 3);
set_unsafe(expr);
return (OPT_F);
}
/* (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 = arg2, error_lambda = arg3;
if ((is_ok_lambda(sc, body_lambda)) && (is_ok_lambda(sc, error_lambda)) && (is_null(cadr(body_lambda))) && (((is_symbol(cadr(error_lambda))) && /* (lambda args ... */
(!is_probably_constant(cadr(error_lambda)))) || ((is_pair(cadr(error_lambda))) && /* (lambda (type info) ... */
(is_pair(cdadr(error_lambda))) && (is_null(cddadr(error_lambda))) && (!is_probably_constant(caadr(error_lambda))) && /* (lambda (pi ...) ...) */
(!is_probably_constant(cadadr(error_lambda)))))) {
s7_pointer error_result = caddr(error_lambda);
set_unsafely_optimized(expr);
if ((arg1 == sc->T) && /* tag is #t */
(is_null(cdddr(error_lambda))) && /* error lambda body is one expr */
((!is_symbol(error_result)) || /* (lambda args #f) */
((is_pair(cadr(error_lambda))) && (error_result == caadr(error_lambda)))) && /* (lambda (type info) type) */
((!is_pair(error_result)) || (car(error_result) == sc->quote_symbol) || /* (lambda args 'a) */
((car(error_result) == sc->car_symbol) && (cadr(error_result) == cadr(error_lambda))))) { /* (lambda args (car args) -> error-type */
set_optimize_op(expr, hop + OP_C_CATCH_ALL); /* catch_all* = #t tag, error handling can skip to the simple lambda body */
set_c_function(expr, func);
set_opt2_con(expr, error_result);
set_opt1_pair(cdr(expr), cddr(body_lambda));
if (is_null(cdddr(body_lambda))) {
if (is_fxable(sc, caddr(body_lambda))) {
set_optimize_op(expr,
hop + OP_C_CATCH_ALL_A);
set_fx_direct(cddr(body_lambda),
fx_choose(sc,
cddr(body_lambda),
sc->curlet,
let_symbol_is_safe));
} else {
set_opt1_pair(cdr(expr),
caddr(body_lambda));
set_optimize_op(expr,
hop + OP_C_CATCH_ALL_O);
/* fn got no hits */
}
}
} else {
set_optimize_op(expr, hop + OP_C_CATCH); /* mainly c_catch_p, but this is not a common case */
choose_c_function(sc, expr, func, 3);
}
return (OPT_F);
}
}
}
if ((is_semisafe(func)) &&
(is_symbol(car(expr))) &&
(car(expr) != sc->values_symbol) &&
(is_fxable(sc, arg2)) &&
(is_fxable(sc, arg3)) &&
(is_pair(arg1)) && (car(arg1) == sc->lambda_symbol)) {
choose_c_function(sc, expr, func, 3);
if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && (is_proper_list_2(sc, cadr(arg1))) && /* two parameters */
(!is_possibly_constant(caadr(arg1))) && /* parameter name not trouble */
(!is_possibly_constant(cadadr(arg1)))) {
s7_pointer p;
fx_annotate_args(sc, cddr(expr), e);
check_lambda(sc, arg1, true); /* this changes symbol_list */
clear_symbol_list(sc); /* so restore it */
for (p = e; is_pair(p); p = cdr(p))
if (is_normal_symbol(car(p)))
add_symbol_to_list(sc, car(p));
set_fn(expr,
(fn_proc(expr) ==
g_for_each) ? g_for_each_closure_2 : NULL);
set_opt3_pair(expr, cdr(arg1));
set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FAA);
return (OPT_F);
}
}
if ((is_safe_procedure(func)) ||
((is_semisafe(func)) && (((car(expr) != sc->assoc_symbol)
&& (car(expr) != sc->member_symbol))
|| (unsafe_is_safe(sc, arg3, e)))))
return (set_any_c_np
(sc, func, expr, e, 3, hop + OP_SAFE_C_3P));
return (set_any_c_np(sc, func, expr, e, 3, hop + OP_ANY_C_NP));
}
/* not c func */
if (is_closure(func)) {
int32_t arit;
arit = closure_arity_to_int(sc, func);
if (arit != 3) {
if ((arit == -1) && (is_symbol(closure_args(func))))
return (optimize_closure_dotted_args
(sc, expr, func, hop, 3, e));
return (OPT_F);
}
if (is_immutable(func))
hop = 1;
if (symbols == 3) {
s7_pointer body = closure_body(func);
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_three);
if (is_safe_closure(func)) {
if ((is_null(cdr(body))) && (is_fxable(sc, car(body)))) {
set_opt2_sym(expr, arg2);
set_opt3_sym(expr, arg3);
fx_annotate_arg(sc, body, e);
fx_tree(sc, body, car(closure_args(func)),
cadr(closure_args(func)),
caddr(closure_args(func)), false);
set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S_A);
set_closure_one_form_fx_arg(func);
} else
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S);
return (OPT_T);
}
set_unsafe_optimize_op(expr, hop + OP_CLOSURE_3S);
return (OPT_F);
}
if (fx_count(sc, expr) == 3) {
if (is_safe_closure(func)) {
if ((!is_pair(arg2)) && (!is_pair(arg3)))
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AGG);
else if (is_normal_symbol(arg1))
set_optimize_op(expr,
hop +
((is_normal_symbol(arg2)) ?
OP_SAFE_CLOSURE_SSA :
OP_SAFE_CLOSURE_SAA));
else
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3A);
} else
if ((is_normal_symbol(arg2)) && (is_normal_symbol(arg3)))
set_optimize_op(expr, hop + OP_CLOSURE_ASS);
else if (is_normal_symbol(arg1))
set_optimize_op(expr,
hop +
((is_normal_symbol(arg3)) ? OP_CLOSURE_SAS
: OP_CLOSURE_SAA));
else if (is_normal_symbol(arg3))
set_optimize_op(expr, hop + OP_CLOSURE_AAS);
else if (is_normal_symbol(arg2))
set_optimize_op(expr, hop + OP_CLOSURE_ASA);
else
set_optimize_op(expr, hop + OP_CLOSURE_3A);
set_unsafely_optimized(expr);
fx_annotate_args(sc, cdr(expr), e);
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_three);
return (OPT_F);
}
return (set_any_closure_np
(sc, func, expr, e, 3, hop + OP_ANY_CLOSURE_3P));
}
if (is_closure_star(func)) {
if ((!lambda_has_simple_defaults(func)) ||
(closure_star_arity_to_int(sc, func) == 0) ||
(closure_star_arity_to_int(sc, func) == 1))
return (OPT_F);
if (fx_count(sc, expr) == 3) {
if (is_immutable(func))
hop = 1;
if ((is_safe_closure(func))
&& (closure_star_arity_to_int(sc, func) == 3))
set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A);
else
set_unsafe_optimize_op(expr,
hop +
((is_safe_closure(func) ?
OP_SAFE_CLOSURE_STAR_NA :
OP_CLOSURE_STAR_NA)));
fx_annotate_args(sc, cdr(expr), e);
set_opt1_lambda_add(expr, func);
set_opt3_arglen(cdr(expr), int_three);
return (OPT_F);
}
}
if ((is_c_function_star(func)) &&
(fx_count(sc, expr) == 3) && (c_function_all_args(func) >= 2)) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA);
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), int_three);
set_c_function(expr, func);
return (OPT_T);
}
/* implicit_vector_3a doesn't happen */
if (bad_pairs > quotes)
return (OPT_F);
return ((is_optimized(expr)) ? OPT_T : OPT_F);
}
static bool symbols_are_safe(s7_scheme * sc, s7_pointer args, s7_pointer e)
{
s7_pointer p;
for (p = args; is_pair(p); p = cdr(p)) {
s7_pointer arg;
arg = car(p);
if ((is_normal_symbol(arg)) && (!arg_findable(sc, arg, e)))
return (false);
}
return (true);
}
static opt_t optimize_func_many_args(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop,
int32_t args, int32_t pairs,
int32_t symbols, int32_t quotes,
int32_t bad_pairs, s7_pointer e)
{
bool func_is_closure;
if (quotes > 0) {
if (direct_memq(sc->quote_symbol, e))
return (OPT_OOPS);
if ((bad_pairs == quotes) &&
(is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr))))
hop = 1;
}
if ((is_c_function(func)) &&
(c_function_required_args(func) <= args) &&
(c_function_all_args(func) >= args)) {
if ((hop == 0)
&& ((is_immutable(func))
|| ((!sc->in_with_let) && (symbol_id(car(expr)) == 0))))
hop = 1;
if (is_safe_procedure(func)) {
if (pairs == 0) {
if (symbols == 0) {
set_safe_optimize_op(expr, hop + OP_SAFE_C_NC);
choose_c_function(sc, expr, func, args);
return (OPT_T);
}
if (symbols == args) {
if (symbols_are_safe(sc, cdr(expr), e))
set_safe_optimize_op(expr, hop + OP_SAFE_C_NS);
else {
set_safe_optimize_op(expr,
hop +
((args ==
4) ? OP_SAFE_C_4A :
OP_SAFE_C_NA));
fx_annotate_args(sc, cdr(expr), e);
}
set_opt3_arglen(cdr(expr),
make_permanent_integer(args));
choose_c_function(sc, expr, func, args);
return (OPT_T);
}
}
if (fx_count(sc, expr) == args) {
s7_pointer p;
set_optimized(expr);
set_optimize_op(expr,
hop +
((args ==
4) ? OP_SAFE_C_4A : OP_SAFE_C_NA));
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), make_permanent_integer(args));
choose_c_function(sc, expr, func, args);
for (p = cdr(expr); (is_pair(p)) && (is_pair(cdr(p)));
p = cddr(p)) {
if (is_normal_symbol(car(p)))
break;
if ((is_pair(car(p))) && ((!is_pair(cdar(p)))
|| (caar(p) !=
sc->quote_symbol)))
break;
}
if (is_null(p)) {
set_optimize_op(expr, hop + OP_SAFE_C_ALL_CA);
for (p = cdr(expr); is_pair(p); p = cddr(p)) {
clear_has_fx(p);
set_opt2_con(p,
(is_pair(car(p))) ? cadar(p) :
car(p));
}
}
return (OPT_T);
}
return (set_any_c_np
(sc, func, expr, e, args, hop + OP_ANY_C_NP));
} else { /* c_func is not safe */
if (fx_count(sc, expr) == args) { /* trigger_size doesn't matter for unsafe funcs */
set_unsafe_optimize_op(expr,
hop +
((is_semisafe(func)) ? OP_CL_NA :
OP_C_NA));
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), make_permanent_integer(args));
choose_c_function(sc, expr, func, args);
return (OPT_F);
}
return (set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */
}
return ((is_optimized(expr)) ? OPT_T : OPT_F);
}
func_is_closure = is_closure(func);
if (func_is_closure) {
int32_t arit;
arit = closure_arity_to_int(sc, func);
if (arit != args) {
if ((arit == -1) && (is_symbol(closure_args(func))))
return (optimize_closure_dotted_args
(sc, expr, func, hop, args, e));
return (OPT_F);
}
if (is_immutable(func))
hop = 1;
if (fx_count(sc, expr) == args) {
bool safe_case = is_safe_closure(func);
set_unsafely_optimized(expr);
set_unsafe_optimize_op(expr,
hop +
((safe_case) ? OP_SAFE_CLOSURE_NA
: ((args ==
4) ? OP_CLOSURE_4A :
OP_CLOSURE_NA)));
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), make_permanent_integer(args));
set_opt1_lambda_add(expr, func);
if ((symbols == args) && (symbols_are_safe(sc, cdr(expr), e))) {
if (safe_case)
set_optimize_op(expr, hop + OP_SAFE_CLOSURE_NS);
else
set_optimize_op(expr,
hop +
((args ==
4) ? OP_CLOSURE_4S : OP_CLOSURE_NS));
}
return (OPT_F);
}
if (args == 4)
return (set_any_closure_np
(sc, func, expr, e, 4, hop + OP_ANY_CLOSURE_4P));
return (set_any_closure_np
(sc, func, expr, e, args, hop + OP_ANY_CLOSURE_NP));
}
if ((is_closure_star(func)) &&
((!lambda_has_simple_defaults(func)) ||
(closure_star_arity_to_int(sc, func) == 0) ||
(closure_star_arity_to_int(sc, func) == 1)))
return (OPT_F);
if ((is_c_function_star(func)) &&
(fx_count(sc, expr) == args) &&
(c_function_all_args(func) >= (args / 2))) {
if (is_immutable(func))
hop = 1;
set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA);
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), make_permanent_integer(args));
set_c_function(expr, func);
return (OPT_T);
}
if (((func_is_closure) ||
(is_closure_star(func))) && (fx_count(sc, expr) == args)) {
set_unsafely_optimized(expr);
if (func_is_closure)
set_optimize_op(expr,
hop +
((is_safe_closure(func)) ? OP_SAFE_CLOSURE_NA
: ((args ==
4) ? OP_CLOSURE_4A : OP_CLOSURE_NA)));
else
set_optimize_op(expr,
hop +
((is_safe_closure(func)) ?
OP_SAFE_CLOSURE_STAR_NA :
OP_CLOSURE_STAR_NA));
fx_annotate_args(sc, cdr(expr), e);
set_opt3_arglen(cdr(expr), make_permanent_integer(args));
set_opt1_lambda_add(expr, func);
return (OPT_F);
}
return ((is_optimized(expr)) ? OPT_T : OPT_F);
}
static bool vars_syntax_ok(s7_pointer vars)
{
s7_pointer p;
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var;
var = car(p);
if ((!is_pair(var)) ||
(!is_symbol(car(var))) || (!is_pair(cdr(var))))
return (false);
}
return (true);
}
static opt_t optimize_expression(s7_scheme * sc, s7_pointer expr,
int32_t hop, s7_pointer e,
bool export_ok);
static bool vars_opt_ok(s7_scheme * sc, s7_pointer vars, int32_t hop,
s7_pointer e)
{
s7_pointer p;
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer init;
init = cadar(p);
if ((is_pair(init)) &&
(!is_checked(init)) &&
(optimize_expression(sc, init, hop, e, false) == OPT_OOPS))
return (false);
}
return (true);
}
static opt_t optimize_syntax(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop, s7_pointer e,
bool export_ok)
{
opcode_t op = (opcode_t) syntax_opcode(func);
s7_pointer p, body = cdr(expr), vars;
bool body_export_ok = true;
sc->w = e;
switch (op) {
case OP_QUOTE:
case OP_MACROEXPAND:
return ((is_proper_list_1(sc, body)) ? OPT_F : OPT_OOPS);
case OP_LET:
case OP_LETREC:
case OP_LET_STAR:
case OP_LETREC_STAR:
if (is_symbol(cadr(expr))) {
if (!is_pair(cddr(expr))) /* (let name . x) */
return (OPT_F);
vars = caddr(expr);
if (!is_list(vars))
return (OPT_OOPS);
body = cdddr(expr);
} else {
vars = cadr(expr);
body = cddr(expr);
if (is_null(vars))
e = cons(sc, sc->nil, e); /* () in e = empty let */
else if (!is_pair(vars))
return (OPT_OOPS);
}
if (!is_pair(body))
return (OPT_OOPS);
if (!vars_syntax_ok(vars))
return (OPT_OOPS);
if ((op == OP_LETREC) || (op == OP_LETREC_STAR)) {
e = collect_variables(sc, vars, e);
if (!vars_opt_ok(sc, vars, hop, e))
return (OPT_OOPS);
} else if (op == OP_LET) {
if (!vars_opt_ok(sc, vars, hop, e))
return (OPT_OOPS);
e = collect_variables(sc, vars, e);
} else
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
if ((is_pair(cadr(var))) &&
(!is_checked(cadr(var))) &&
(optimize_expression(sc, cadr(var), hop, e, false) ==
OPT_OOPS))
return (OPT_OOPS);
e = cons(sc, add_symbol_to_list(sc, car(var)), e);
sc->w = e;
}
if (is_symbol(cadr(expr))) {
e = cons(sc, add_symbol_to_list(sc, cadr(expr)), e);
sc->w = e;
}
break;
case OP_LET_TEMPORARILY:
vars = cadr(expr);
if (!is_list(vars))
return (OPT_OOPS);
body = cddr(expr);
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var = car(vars);
if ((is_pair(var)) &&
(is_pair(cdr(var))) &&
(is_pair(cadr(var))) &&
(!is_checked(cadr(var))) &&
(optimize_expression(sc, cadr(var), hop, e, false) ==
OPT_OOPS))
return (OPT_OOPS);
}
/* e = cons(sc, sc->nil, e); *//* !? currently let-temporarily does not make a new let, so it is like begin? */
body_export_ok = export_ok; /* (list x (let-temporarily () (define x 0))) just as in begin */
break;
case OP_DO:
vars = cadr(expr);
if (is_null(vars))
e = cons(sc, sc->nil, e);
else if (!is_pair(vars))
return (OPT_OOPS);
body = cddr(expr);
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
if ((!is_pair(var)) ||
(!is_symbol(car(var))) || (!is_pair(cdr(var))))
return (OPT_OOPS);
if ((is_pair(cadr(var))) && (!is_checked(cadr(var))) && (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) /* the init field -- locals are not defined yet */
return (OPT_OOPS);
}
e = collect_variables(sc, vars, e);
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var = cddar(p);
if ((is_pair(var)) && (is_pair(car(var))) && (!is_checked(car(var))) && (optimize_expression(sc, car(var), hop, e, false) == OPT_OOPS)) /* the step field -- locals are defined */
return (OPT_OOPS);
}
break;
case OP_BEGIN:
body_export_ok = export_ok; /* (list x (begin (define x 0))) */
break;
case OP_WITH_BAFFLE:
e = cons(sc, sc->nil, e);
break;
case OP_DEFINE_BACRO:
case OP_DEFINE_BACRO_STAR:
case OP_BACRO:
case OP_BACRO_STAR:
return (OPT_F);
case OP_DEFINE_MACRO:
case OP_DEFINE_MACRO_STAR:
case OP_DEFINE_CONSTANT:
case OP_DEFINE_EXPANSION:
case OP_DEFINE_EXPANSION_STAR:
case OP_DEFINE:
case OP_DEFINE_STAR:
/* define adds a name to the incoming let (e), the added name is inserted into e after the first, so the caller
* can flush added symbols by maintaining its own pointer into the list if blockers set the car.
* the list is used both to see local symbols and to catch "complicated" functions (find_uncomplicated_symbol).
* In cases like (if expr (define...)) we can't tell at this level whether the define takes place, so
* its name should not be in "e", but it needs to be marked for find_uncomplicated_symbol in a way
* that can be distinguished from members of "e". So in that (rare) case, we use the associated keyword.
* Then find_uncomplicated_symbol can use has_keyword to tell if the keyword search is needed.
* export_ok is trying to protect against optimizing (list x (define x 0)) as op_safe_c_sp and all related cases
*/
vars = cadr(expr);
body = cddr(expr);
if (is_pair(vars)) {
if ((export_ok) && (is_symbol(car(vars)))) {
add_symbol_to_list(sc, car(vars));
if (is_pair(e)) {
if (car(e) != sc->key_if_symbol)
set_cdr(e, cons(sc, car(vars), cdr(e))); /* export it */
else
add_symbol_to_list(sc,
symbol_to_keyword(sc,
car(vars)));
} else
e = cons(sc, car(vars), e);
}
e = collect_parameters(sc, cdr(vars), e);
body_export_ok = export_ok;
} else {
if ((export_ok) && (is_symbol(vars))) {
/* actually if this is defining a function, the name should probably be included in the local let
* but that's next-to-impossible to guarantee unless it's (define x (lambda...)) of course.
*/
sc->temp9 = e;
for (p = body; is_pair(p); p = cdr(p))
if ((is_pair(car(p))) && (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */
(optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS)) /* "body" here is not body in terms of export_ok */
return (OPT_OOPS);
sc->temp9 = sc->nil;
add_symbol_to_list(sc, vars);
if (is_pair(e)) {
if (car(e) != sc->key_if_symbol)
set_cdr(e, cons(sc, vars, cdr(e))); /* export it */
else
add_symbol_to_list(sc,
symbol_to_keyword(sc, vars));
}
/* else e = cons(sc, vars, e); *//* ?? should this be set-cdr etc? */
return (OPT_F);
}
body_export_ok = false;
}
break;
case OP_LAMBDA:
case OP_LAMBDA_STAR:
case OP_MACRO:
case OP_MACRO_STAR:
vars = cadr(expr);
if (is_null(vars))
e = cons(sc, sc->nil, e);
else if ((!is_pair(vars)) && (!is_symbol(vars)))
return (OPT_OOPS);
e = collect_parameters(sc, vars, e);
body = cddr(expr);
break;
case OP_SET:
if ((is_pair(cadr(expr))) && (caadr(expr) == sc->outlet_symbol))
return (OPT_OOPS);
if (!is_pair(cddr(expr)))
return (OPT_OOPS);
if ((is_pair(cadr(expr))) && (!is_checked(cadr(expr)))) {
s7_pointer lp;
set_checked(cadr(expr));
for (lp = cdadr(expr); is_pair(lp); lp = cdr(lp))
if ((is_pair(car(lp))) &&
(!is_checked(car(lp))) &&
(optimize_expression
(sc, car(lp), hop, e, body_export_ok) == OPT_OOPS))
return (OPT_OOPS);
}
if ((is_pair(caddr(expr))) &&
(!is_checked(caddr(expr))) &&
(optimize_expression(sc, caddr(expr), hop, e, body_export_ok)
== OPT_OOPS))
return (OPT_OOPS);
return (OPT_F);
case OP_WITH_LET:
/* we usually can't trust anything here, so hop ought to be off. For example,
* (define (hi) (let ((e (sublet (curlet) :abs (lambda (a) (- a 1))))) (with-let e (abs -1))))
* returns 1 if hop is 1, but -2 otherwise. (with-let (unlet)...) is safe however.
*/
{
bool old_with_let = sc->in_with_let;
sc->in_with_let = (old_with_let) || (!is_pair(body))
|| (!is_pair(car(body)))
|| ((caar(body) != sc->unlet_symbol)
&& (caar(body) != sc->rootlet_symbol)
&& (caar(body) != sc->curlet_symbol));
for (p = body; is_pair(p); p = cdr(p))
if ((is_pair(car(p))) &&
(!is_checked(car(p))) &&
(optimize_expression
(sc, car(p), 0, sc->nil,
body_export_ok) == OPT_OOPS)) {
sc->in_with_let = old_with_let;
return (OPT_OOPS);
}
sc->in_with_let = old_with_let;
return (OPT_F);
}
case OP_CASE:
if ((is_pair(cadr(expr))) &&
(!is_checked(cadr(expr))) &&
(optimize_expression(sc, cadr(expr), hop, e, false) ==
OPT_OOPS))
return (OPT_OOPS);
for (p = cddr(expr); is_pair(p); p = cdr(p))
if ((is_pair(car(p))) && (is_pair(cdar(p)))) {
s7_pointer rst;
for (rst = cdar(p); is_pair(rst); rst = cdr(rst))
if ((is_pair(car(rst))) &&
(!is_checked(car(rst))) &&
(optimize_expression(sc, car(rst), hop, e, false)
== OPT_OOPS))
return (OPT_OOPS);
}
return (OPT_F);
case OP_COND: /* split opt is necessary: (cond (lambda (x) ...)) */
for (p = cdr(expr); is_pair(p); p = cdr(p))
if (is_pair(car(p))) {
s7_pointer test = caar(p), rst;
e = cons(sc, sc->key_if_symbol, e); /* I think this is a marker in case define is encountered? (see above) */
if ((is_pair(test)) &&
(!is_checked(test)) &&
(optimize_expression(sc, test, hop, e, false) ==
OPT_OOPS))
return (OPT_OOPS);
for (rst = cdar(p); is_pair(rst); rst = cdr(rst))
if ((is_pair(car(rst))) &&
(!is_checked(car(rst))) &&
(optimize_expression(sc, car(rst), hop, e, false)
== OPT_OOPS))
return (OPT_OOPS);
}
for (p = cdr(expr); is_pair(p); p = cdr(p)) {
s7_pointer q;
if ((!is_pair(car(p))) || (!is_fxable(sc, caar(p))))
break;
if (!is_pair(cdar(p)))
break;
for (q = cdar(p); is_pair(q); q = cdr(q))
if ((car(q) == sc->feed_to_symbol)
|| (!is_fxable(sc, car(q))))
break;
if (!is_null(q))
break;
}
if (!is_null(p))
return (OPT_F);
set_safe_optimize_op(expr, OP_COND_FX_FX);
for (p = cdr(expr); is_pair(p); p = cdr(p)) {
s7_pointer q;
set_fx_direct(car(p),
fx_choose(sc, car(p), e, pair_symbol_is_safe));
for (q = cdar(p); is_pair(q); q = cdr(q))
set_fx_direct(q, fx_choose(sc, q, e, pair_symbol_is_safe));
}
return (OPT_T);
case OP_IF:
case OP_WHEN:
case OP_UNLESS:
if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr))))
return (OPT_OOPS);
case OP_OR:
case OP_AND:
e = cons(sc, sc->key_if_symbol, e);
break;
default:
break;
}
sc->temp9 = e;
for (p = body; is_pair(p); p = cdr(p))
if ((is_pair(car(p))) && (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */
(optimize_expression(sc, car(p), hop, e, body_export_ok) ==
OPT_OOPS)) {
sc->temp9 = sc->nil;
return (OPT_OOPS);
}
sc->temp9 = sc->nil;
if ((hop == 1) &&
((is_syntax(car(expr))) || (symbol_id(car(expr)) == 0))) {
if (op == OP_IF) {
for (p = cdr(expr); is_pair(p); p = cdr(p))
if (!is_fxable(sc, car(p)))
break;
if (is_null(p)) {
s7_pointer test = cdr(expr), b1, b2;
if ((is_pair(cdr(test))) && (is_pair(cddr(test)))
&& (!is_null(cdddr(test))))
return (OPT_OOPS);
for (p = cdr(expr); is_pair(p); p = cdr(p))
set_fx_direct(p,
fx_choose(sc, p, e,
pair_symbol_is_safe));
b1 = cdr(test);
b2 = cdr(b1);
if ((fx_proc(b1) == fx_q) && (is_pair(b2))) {
set_opt3_con(test, cadar(b1));
if (fx_proc(b2) == fx_q) {
set_safe_optimize_op(expr, OP_IF_A_C_C);
set_opt1_con(expr, cadar(b1));
set_opt2_con(expr, cadar(b2));
return (OPT_T);
}
set_opt1_pair(expr, b1);
set_opt2_pair(expr, b2);
set_safe_optimize_op(expr, OP_IF_A_A_A);
} else {
if ((is_pair(car(test))) &&
(caar(test) == sc->not_symbol) &&
(is_fxable(sc, cadar(test)))) {
set_fx_direct(cdar(test),
fx_choose(sc, cdar(test), e,
pair_symbol_is_safe));
set_opt1_pair(expr, cdar(test));
set_opt2_pair(expr, b1);
if (is_pair(b2))
set_opt3_pair(expr, b2);
set_safe_optimize_op(expr,
(is_null(b2)) ? OP_IF_NOT_A_A
: OP_IF_NOT_A_A_A);
} else {
if ((is_pair(b2)) && (fx_proc(b1) == fx_c)
&& (fx_proc(b2) == fx_c)) {
set_safe_optimize_op(expr, OP_IF_A_C_C);
set_opt1_con(expr, car(b1));
set_opt2_con(expr, car(b2));
return (OPT_T);
}
if ((fx_proc(test) == fx_and_2a)
&& (fx_proc(b1) == fx_s)) {
set_opt1_pair(expr, cdadr(expr));
set_opt2_pair(expr, cddadr(expr));
set_opt3_sym(expr, car(b1));
set_safe_optimize_op(expr, OP_IF_AND2_S_A);
return (OPT_T);
}
set_opt1_pair(expr, b1);
if (is_pair(b2))
set_opt2_pair(expr, b2);
set_safe_optimize_op(expr,
(is_null(b2)) ? OP_IF_A_A
: ((fx_proc(test) ==
fx_s) ? OP_IF_S_A_A :
OP_IF_A_A_A));
}
}
return (OPT_T);
}
} else {
if ((op == OP_OR) || (op == OP_AND)) {
for (p = cdr(expr); is_pair(p); p = cdr(p))
if (!is_fxable(sc, car(p)))
break;
if (is_null(p)) { /* catch the syntax error later: (or #f . 2) etc */
int32_t args, pairs = 0;
s7_pointer sym = NULL;
bool c_s_is_ok = true;
for (args = 0, p = cdr(expr); is_pair(p); p = cdr(p), args++) /* this only applies to or/and */
if (is_pair(car(p))) {
pairs++;
if ((c_s_is_ok) &&
((!is_h_safe_c_s(car(p))) ||
((sym) && (sym != cadar(p)))))
c_s_is_ok = false;
else
sym =
(is_pair(cdar(p))) ? cadar(p) :
sc->unspecified;
}
if ((c_s_is_ok) && (args == 2) && (pairs == 2)) {
if (op == OP_OR) {
set_opt3_sym(cdr(expr), cadadr(expr));
if ((is_symbol(caadr(expr)))
&& (symbol_type(caadr(expr)) > 0)
&& (is_global(caadr(expr)))
&& ((is_symbol(caaddr(expr)))
&& (symbol_type(caaddr(expr)) > 0)
&& (is_global(caaddr(expr))))) {
set_opt3_int(expr,
small_int(symbol_type
(caadr(expr))));
set_opt2_int(cdr(expr),
small_int(symbol_type
(caaddr(expr))));
set_safe_optimize_op(expr, OP_OR_S_TYPE_2);
} else
set_safe_optimize_op(expr, OP_OR_S_2);
} else {
set_opt3_sym(cdr(expr), cadadr(expr));
set_safe_optimize_op(expr, OP_AND_S_2);
}
return (OPT_T);
}
for (p = cdr(expr); is_pair(p); p = cdr(p))
set_fx_direct(p,
fx_choose(sc, p, e,
pair_symbol_is_safe));
if (op == OP_OR) {
if (args == 2)
set_safe_optimize_op(expr, OP_OR_2A);
else {
if (args == 3)
set_safe_optimize_op(expr, OP_OR_3A);
else
set_safe_optimize_op(expr, OP_OR_N);
}
return (OPT_T);
}
if (args == 2)
set_safe_optimize_op(expr, OP_AND_2A);
else if (args == 3)
set_safe_optimize_op(expr, OP_AND_3A);
else
set_safe_optimize_op(expr, OP_AND_N);
return (OPT_T);
}
} else if (op == OP_BEGIN) {
if (!is_pair(cdr(expr)))
return (OPT_F);
for (p = cdr(expr); is_pair(p); p = cdr(p))
if (!is_fxable(sc, car(p)))
break;
if (is_null(p)) {
for (p = cdr(expr); is_pair(p); p = cdr(p))
set_fx_direct(p,
fx_choose(sc, p, e,
pair_symbol_is_safe));
if ((is_pair(cddr(expr))) && (is_null(cdddr(expr))))
set_safe_optimize_op(expr, OP_BEGIN_AA);
else
set_safe_optimize_op(expr, OP_BEGIN_NA);
return (OPT_T);
}
}
}
} /* fully fxable lets don't happen much: even op_let_2a_a is scarcely used */
return (OPT_F);
}
static opt_t optimize_funcs(s7_scheme * sc, s7_pointer expr,
s7_pointer func, int32_t hop, int32_t orig_hop,
s7_pointer e)
{
int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0;
s7_pointer p;
for (p = cdr(expr); is_pair(p); p = cdr(p), args++) { /* check the args (the calling expression) */
s7_pointer car_p = car(p);
if (is_normal_symbol(car_p)) /* for opt func */
symbols++;
else if (is_pair(car_p)) {
pairs++;
if (!is_checked(car_p)) {
opt_t res;
res = optimize_expression(sc, car_p, orig_hop, e, false);
if (res == OPT_F) {
bad_pairs++;
if (is_proper_quote(sc, car_p))
quotes++;
} else if (res == OPT_OOPS)
return (OPT_OOPS);
} else if ((!is_optimized(car_p)) || (is_unsafe(car_p))) {
bad_pairs++;
if (is_proper_quote(sc, 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, e));
case 1:
return (optimize_func_one_arg
(sc, expr, func, hop, pairs, symbols, quotes,
bad_pairs, e));
case 2:
return (optimize_func_two_args
(sc, expr, func, hop, pairs, symbols, quotes,
bad_pairs, e));
case 3:
return (optimize_func_three_args
(sc, expr, func, hop, pairs, symbols, quotes,
bad_pairs, e));
default:
return (optimize_func_many_args
(sc, expr, func, hop, args, pairs, symbols, quotes,
bad_pairs, e));
}
}
return (OPT_F);
}
static opt_t optimize_expression(s7_scheme * sc, s7_pointer expr,
int32_t hop, s7_pointer e, bool export_ok)
{
s7_pointer car_expr = car(expr);
int32_t orig_hop = hop;
set_checked(expr);
if (is_symbol(car_expr)) {
s7_pointer slot;
if (is_syntactic_symbol(car_expr)) {
if (!is_pair(cdr(expr)))
return (OPT_OOPS);
return (optimize_syntax
(sc, expr, T_Syn(global_value(car_expr)), hop, e,
export_ok));
}
slot = find_uncomplicated_symbol(sc, car_expr, e); /* local vars (recursive calls too??) are considered "complicated" */
if (is_slot(slot)) {
s7_pointer func = slot_value(slot);
if (is_syntax(func)) /* 12-8-16 was is_syntactic, but that is only appropriate above -- here we have the value */
return ((is_pair(cdr(expr))) ? optimize_syntax(sc, expr, func, hop, e, export_ok) : OPT_OOPS); /* e can be extended via set-cdr! here */
if (is_any_macro(func))
return (OPT_F);
/* we miss implicit indexing here because at this time, the data are not set */
if ((is_t_procedure(func)) || /* t_procedure_p: c_funcs, closures, etc */
/* (is_any_closure(func)) || *//* added 11-Mar-20, but it's redundant!? */
((is_applicable(func)) && (is_safe_procedure(func)))) { /* built-in applicable objects like vectors */
if ((hop != 0) && ((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */
((!is_global(car_expr)) && ((!is_slot(global_slot(car_expr))) || (global_value(car_expr) != func)))) && (!is_immutable(car_expr)) && /* list|apply-values -- can't depend on opt1 here because it might not be global, or might be redefined locally */
(!is_immutable(slot))) { /* (define-constant...) */
/* (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a)) (f1 12))
* (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a 1)) (f1 12))
* and similar define* cases
*/
hop = 0;
/* this is very tricky! See s7test for some cases. Basically, we need to protect a recursive call
* of the current function being optimized from being confused with some previous definition
* of the same name. But method lists have global names so the global bit is off even though the
* thing is actually a safe global. But no closure can be considered safe in the hop sense --
* even a global function might be redefined at any time, and previous uses of it in other functions
* need to reflect its new value.
* So, closures are always checked, but built-in functions are used as if never redefined until that redefinition.
* Syntax handling is already impure in s7, so the special handling of built-in functions doesn't
* offend me much. Consider each a sort of reader macro until someone redefines it -- previous
* uses might not be affected because they might have been optimized away -- the result depends on the
* current optimizer.
* Another case (from K Matheussen):
* (define (call-func func arg1 arg2) (define (call) (func arg1 arg2)) (call)) (call-func + 1 2.5) (call-func - 5 2)
* when we get here originally "func" is +, hop=1, but just checking for !is_global(car_expr) is
* not good enough -- if we load mockery.scm, nothing is global!
* Yet another case (define (test-abs) (define (abs x) (+ x 1)) (format *stderr* "abs ~A~%" (abs -1)))
* when optimize_syntax sees the (define abs ...), it inserts abs into e so that the caller's e is extended (set-cdr!)
* so that find_uncomplicated_symbol above will be unhappy when we reach (abs -1) as the format arg.
* This can be confused if lambda is redefined at some point, but...
*/
}
return (optimize_funcs(sc, expr, func, hop, orig_hop, e));
}
} else if ((sc->undefined_identifier_warnings) && (slot == sc->undefined) && /* car_expr is not in e or global */
(symbol_tag(car_expr) == 0)) { /* and we haven't looked it up earlier */
s7_pointer p = current_input_port(sc);
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 */
}
/* car_expr is a symbol but it's not a built-in procedure or a "safe" case = vector etc */
{
/* else maybe it's something like a let variable binding: (sqrtfreq (sqrt frequency)) */
s7_pointer p;
int32_t len = 0, pairs = 0, symbols = 0;
for (p = cdr(expr); is_pair(p); p = cdr(p), len++) {
s7_pointer car_p;
car_p = car(p);
if (is_pair(car_p)) {
pairs++;
if ((!is_checked(car_p)) &&
(optimize_expression(sc, car_p, hop, e, false) ==
OPT_OOPS))
return (OPT_OOPS);
} else if (is_symbol(car_p))
symbols++;
}
if ((is_null(p)) && /* (+ 1 . 2) */
(!is_optimized(expr))) {
/* len=0 case is almost entirely arglists */
set_opt1_con(expr, sc->unused);
if (pairs == 0) {
if (len == 0) {
/* hoping to catch object application here, as in readers in Snd */
set_unsafe_optimize_op(expr, OP_UNKNOWN);
return (OPT_F);
}
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,
(symbols ==
1) ? OP_UNKNOWN_G :
OP_UNKNOWN_A);
fx_annotate_arg(sc, cdr(expr), e); /* g->a later if closure */
return (OPT_F);
}
if (len == 2) {
set_unsafely_optimized(expr);
set_optimize_op(expr, OP_UNKNOWN_GG);
return (OPT_F);
}
if (len >= 3) {
if (len == symbols) {
set_unsafe_optimize_op(expr, OP_UNKNOWN_NS);
set_opt3_arglen(cdr(expr),
make_permanent_integer(len));
return (OPT_F);
}
if (fx_count(sc, expr) == len) {
set_unsafe_optimize_op(expr, OP_UNKNOWN_NA);
set_opt3_arglen(cdr(expr),
make_permanent_integer(len));
return (OPT_F);
}
}
} else { /* pairs != 0 */
s7_pointer arg1 = cadr(expr);
if ((pairs == 1) && (len == 1)) {
if ((car_expr == sc->quote_symbol) &&
(direct_memq(sc->quote_symbol, e)))
return (OPT_OOPS);
if (is_fxable(sc, arg1)) {
set_opt3_arglen(cdr(expr), int_one);
fx_annotate_arg(sc, cdr(expr), e);
set_unsafe_optimize_op(expr, OP_UNKNOWN_A);
return (OPT_F);
}
}
if (fx_count(sc, expr) == len) {
set_unsafe_optimize_op(expr,
(len ==
1) ? OP_UNKNOWN_A : ((len
==
2) ?
OP_UNKNOWN_AA
:
OP_UNKNOWN_NA));
set_opt3_arglen(cdr(expr),
make_permanent_integer(len));
if (len <= 2)
fx_annotate_args(sc, cdr(expr), e);
return (OPT_F);
}
set_unsafe_optimize_op(expr, OP_UNKNOWN_NP);
set_opt3_arglen(cdr(expr),
make_permanent_integer(len));
return (OPT_F);
}
}
}
} 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;
if (is_c_function(car_expr)) /* (#_abs x) etc */
return (optimize_funcs(sc, expr, car_expr, 1, orig_hop, e));
if (is_syntax(car_expr)) { /* (#_cond ...) */
if (!is_pair(cdr(expr)))
return (OPT_OOPS);
return (optimize_syntax
(sc, expr, car_expr, orig_hop, e, export_ok));
}
if (is_any_macro(car_expr))
return (OPT_F);
/* if car is a pair, we can't easily tell whether its value is (say) + or cond, so we need to catch this case and fixup fx settings */
for (p = expr; is_pair(p); p = cdr(p))
if ((is_pair(car(p))) &&
(!is_checked(car(p))) &&
(optimize_expression(sc, car(p), hop, e, false) ==
OPT_OOPS))
return (OPT_OOPS);
/* here we get for example:
* ((if (not (let? p)) write write-to-vector) obj p) ; not uncomplicated/c-function [((if 3d fourth third) p) in index]
* ((if (symbol? (cadr f)) cadr (if (pair? (cadr f)) caadr not)) f) ; fx not symbol -- opif_a_aaq_a
* ((if (input-port? port) call-with-input-file call-with-output-file) port proc) ; not safe I guess
*/
}
return (OPT_F);
}
static opt_t optimize(s7_scheme * sc, s7_pointer code, int32_t hop,
s7_pointer e)
{
s7_pointer x;
for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x)) {
s7_pointer obj = car(x);
set_checked(x);
if (is_pair(obj)) {
if ((!is_checked(obj)) &&
(optimize_expression(sc, obj, hop, e, true) == OPT_OOPS)) {
s7_pointer p;
for (p = cdr(x); is_pair(p); p = cdr(p));
if (!is_null(p))
eval_error(sc, "stray dot in function body: ~S", 30,
code);
return (OPT_OOPS);
}
} else
/* new 22-Sep-19, but I don't think this saves anything over falling into trailers */
if (is_symbol(obj))
set_optimize_op(obj,
(is_keyword(obj)) ? OP_CON : ((is_global(obj))
? OP_GLOBAL_SYM :
OP_SYM));
else
set_optimize_op(obj, OP_CON);
}
if (!is_list(x))
eval_error(sc, "stray dot in function body: ~S", 30, code);
return (OPT_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);
}
static void check_lambda_args(s7_scheme * sc, s7_pointer args,
int32_t * arity)
{
s7_pointer x;
int32_t i;
if (!is_list(args)) {
if (is_constant(sc, args)) /* (lambda :a ...) */
eval_error(sc, "lambda parameter '~S is a constant", 34, 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;
}
for (i = 0, x = args; is_pair(x); i++, x = cdr(x)) {
s7_pointer car_x = car(x);
if (is_constant(sc, 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*?)",
69, car_x);
eval_error(sc, "lambda parameter '~S is a constant", 34,
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",
56, car_x);
set_local(car_x);
}
if (is_not_null(x)) {
if (is_constant(sc, x)) /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */
eval_error(sc, "lambda :rest parameter '~S is a constant", 40,
x);
i = -i - 1;
}
if (arity)
(*arity) = i;
}
static s7_pointer check_lambda_star_args(s7_scheme * sc, s7_pointer args,
s7_pointer body)
{ /* checks closure*, macro*, and bacro* */
s7_pointer top, v, w;
int32_t i;
bool has_defaults;
if (!is_list(args)) {
if (is_constant(sc, args)) /* (lambda* :a ...) */
eval_error(sc, "lambda* parameter '~S is a constant", 35,
args);
if (is_symbol(args))
set_local(args);
return (args);
}
has_defaults = false;
top = args;
for (i = 0, v = args, w = args; is_pair(w); i++, v = w, w = cdr(w)) {
s7_pointer car_w = car(w);
if (is_pair(car_w)) {
has_defaults = true;
if (is_constant(sc, car(car_w))) /* (lambda* ((:a 1)) ...) */
eval_error(sc, "lambda* parameter '~A is a constant", 35,
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",
56, 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",
44, car_w);
eval_error(sc, "lambda* parameter is a dotted pair? '~A",
39, car_w);
}
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",
47, 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",
50, car_w);
set_local(car(car_w));
} else {
if (car_w != sc->key_rest_symbol) {
if (is_constant(sc, 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",
50, args);
if (w == top)
eval_error(sc,
":allow-other-keys can't be the only parameter: ~A",
49, args);
set_allow_other_keys(top);
set_cdr(v, sc->nil);
} else /* (lambda* (pi) ...) */
eval_error(sc,
"lambda* parameter '~A is a constant",
35, 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",
56, car_w);
if (!is_keyword(car_w))
set_local(car_w);
} else {
has_defaults = true;
if (!is_pair(cdr(w))) /* (lambda* (:rest) ...) */
eval_error(sc, "lambda* :rest parameter missing? ~A",
35, 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",
43, w);
eval_error(sc,
"lambda* :rest parameter can't have a default value. ~A",
54, w);
}
if (is_constant(sc, cadr(w))) /* (lambda* (a :rest x)...) where x is locally a constant */
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc, cant_bind_immutable_string,
w)));
set_local(cadr(w));
}
}
}
if (is_not_null(w)) {
if (is_constant(sc, w)) /* (lambda* (a . 0.0) a) or (lambda* (a . :b) a) */
eval_error(sc, "lambda* :rest parameter '~A is a constant", 41,
w);
if (is_symbol(w))
set_local(w);
} else if ((body) && (!has_defaults) && (is_pair(args)))
set_has_no_defaults(body);
return (top);
}
static void set_rec_tc_args(s7_scheme * sc, s7_int args)
{
if (sc->rec_tc_args == -1)
sc->rec_tc_args = args;
else if (sc->rec_tc_args != args)
sc->rec_tc_args = -2;
}
typedef enum { UNSAFE_BODY = 0, RECUR_BODY, SAFE_BODY, VERY_SAFE_BODY
} body_t;
static body_t min_body(body_t b1, body_t b2)
{
return ((b1 < b2) ? b1 : b2);
}
static body_t body_is_safe(s7_scheme * sc, s7_pointer func,
s7_pointer body, bool at_end);
static body_t form_is_safe(s7_scheme * sc, s7_pointer func, s7_pointer x,
bool at_end)
{ /* called only from body_is_safe */
s7_pointer expr = car(x);
body_t result = VERY_SAFE_BODY;
if (is_symbol_and_syntactic(expr)) {
if (!is_pair(cdr(x)))
return (UNSAFE_BODY);
/* lambda_unchecked, if_d_p_p define_funchecked */
switch (symbol_syntax_op_checked(x)) {
case OP_OR:
case OP_AND:
case OP_BEGIN:
case OP_WITH_BAFFLE:
return (body_is_safe(sc, func, cdr(x), at_end));
case OP_MACROEXPAND:
return (UNSAFE_BODY);
case OP_QUOTE:
return (((!is_pair(cdr(x))) || (!is_null(cddr(x)))) ? UNSAFE_BODY : VERY_SAFE_BODY); /* (quote . 1) or (quote 1 2) etc */
case OP_IF:
if (!is_pair(cddr(x)))
return (UNSAFE_BODY);
if (is_pair(cadr(x))) {
result = form_is_safe(sc, func, cadr(x), false);
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
if (is_pair(caddr(x))) {
result =
min_body(result,
form_is_safe(sc, func, caddr(x), at_end));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
if ((is_pair(cdddr(x))) && (is_pair(cadddr(x))))
return (min_body
(result,
form_is_safe(sc, func, cadddr(x), at_end)));
return (result);
case OP_WHEN:
case OP_UNLESS:
if (!is_pair(cddr(x)))
return (UNSAFE_BODY);
if (is_pair(cadr(x))) {
result = form_is_safe(sc, func, cadr(x), false);
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
return (min_body
(result, body_is_safe(sc, func, cddr(x), at_end)));
case OP_COND:
{
bool follow = false;
s7_pointer sp, p;
for (p = cdr(x), sp = x; is_pair(p); p = cdr(p)) {
s7_pointer ex;
ex = car(p);
if (!is_pair(ex))
return (UNSAFE_BODY);
if (is_pair(car(ex))) {
result =
min_body(result,
form_is_safe(sc, func, car(ex),
false));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
if (is_pair(cdr(ex))) {
result =
min_body(result,
body_is_safe(sc, func, cdr(ex),
at_end));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
if (follow) {
sp = cdr(sp);
if (p == sp)
return (UNSAFE_BODY);
}
follow = (!follow);
}
return ((is_null(p)) ? result : UNSAFE_BODY);
}
case OP_CASE:
{
bool follow = false;
s7_pointer sp, p;
if (!is_pair(cddr(x)))
return (UNSAFE_BODY);
if (is_pair(cadr(x))) {
result = form_is_safe(sc, func, cadr(x), false);
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
sp = cdr(x);
p = cdr(sp);
for (; is_pair(p); p = cdr(p)) {
if (!is_pair(car(p)))
return (UNSAFE_BODY);
if (is_pair(cdar(p))) {
result = min_body(result, body_is_safe(sc, func, cdar(p), at_end)); /* null cdar(p) ok here */
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
if (follow) {
sp = cdr(sp);
if (p == sp)
return (UNSAFE_BODY);
}
follow = (!follow);
}
return (result);
}
case OP_SET:
/* if we set func, we have to abandon the tail call scan: (let () (define (hi a) (let ((v (vector 1 2 3))) (set! hi v) (hi a))) (hi 1)) */
if (!is_pair(cddr(x)))
return (UNSAFE_BODY);
if (cadr(x) == func)
return (UNSAFE_BODY);
/* car(x) is set!, cadr(x) is settee or obj, caddr(x) is val */
if (is_pair(caddr(x))) {
result = form_is_safe(sc, func, caddr(x), false);
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
return ((is_pair(cadr(x))) ?
min_body(result,
form_is_safe(sc, func, cadr(x),
false)) : result);
/* not OP_DEFINE even in simple cases (safe_closure assumes constant funclet) */
case OP_WITH_LET:
if (!is_pair(cddr(x)))
return (UNSAFE_BODY);
return ((is_pair(cadr(x))) ? UNSAFE_BODY :
min_body(body_is_safe(sc, sc->F, cddr(x), at_end),
SAFE_BODY));
/* shadowing can happen in with-let -- symbols are global so local_slots are shadowable */
case OP_LET_TEMPORARILY:
{
s7_pointer p;
if (!is_pair(cadr(x)))
return (UNSAFE_BODY);
for (p = cadr(x); is_pair(p); p = cdr(p)) {
if ((!is_pair(car(p))) || (!is_pair(cdar(p))))
return (UNSAFE_BODY);
if (is_pair(cadar(p))) {
result =
min_body(result,
form_is_safe(sc, sc->F, cadar(p),
false));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
}
return (min_body
(result,
body_is_safe(sc, sc->F, cddr(x), at_end)));
}
/* in the name binders, we first have to check that "func" actually is the same thing as the caller's func */
case OP_LET:
case OP_LET_STAR:
case OP_LETREC:
case OP_LETREC_STAR:
{
bool follow = false;
s7_pointer let_name, sp, vars = cadr(x), body = cddr(x);
if (is_symbol(vars)) {
if (!is_pair(body))
return (UNSAFE_BODY); /* (let name . res) */
if (vars == func) /* named let shadows caller */
return (UNSAFE_BODY);
let_name = vars;
vars = caddr(x);
body = cdddr(x);
if (is_symbol(func))
add_symbol_to_list(sc, func);
} else
let_name = func;
for (sp = NULL; is_pair(vars); vars = cdr(vars)) {
s7_pointer let_var = car(vars), var_name;
if ((!is_pair(let_var)) || (!is_pair(cdr(let_var))))
return (UNSAFE_BODY);
var_name = car(let_var);
if ((!is_symbol(var_name)) || (var_name == let_name) || /* let var shadows caller */
(var_name == func))
return (UNSAFE_BODY);
add_symbol_to_list(sc, var_name);
if (is_pair(cadr(let_var))) {
result =
min_body(result,
form_is_safe(sc, let_name,
cadr(let_var), false));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
follow = (!follow);
if (follow) {
if (!sp)
sp = vars;
else {
sp = cdr(sp);
if (vars == sp)
return (UNSAFE_BODY);
}
}
}
return (min_body
(result,
body_is_safe(sc, let_name, body,
(let_name != func) || at_end)));
}
case OP_DO: /* (do (...) (...) ...) */
{
if (!is_pair(cddr(x)))
return (UNSAFE_BODY);
if (is_pair(cadr(x))) {
bool follow = false;
s7_pointer vars = cadr(x), sp;
sp = vars;
for (; is_pair(vars); vars = cdr(vars)) {
s7_pointer do_var = car(vars);
if ((!is_pair(do_var)) || (!is_pair(cdr(do_var))) || /* (do ((a . 1) (b . 2)) ...) */
(car(do_var) == func) ||
(!is_symbol(car(do_var))))
return (UNSAFE_BODY);
add_symbol_to_list(sc, car(do_var));
if (is_pair(cadr(do_var)))
result =
min_body(result,
form_is_safe(sc, func,
cadr(do_var),
false));
if ((is_pair(cddr(do_var)))
&& (is_pair(caddr(do_var))))
result =
min_body(result,
form_is_safe(sc, func,
caddr(do_var),
false));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
if (sp != vars) {
if (follow) {
sp = cdr(sp);
if (vars == sp)
return (UNSAFE_BODY);
}
follow = (!follow);
}
}
}
if (is_pair(caddr(x)))
result =
min_body(result,
body_is_safe(sc, func, caddr(x), at_end));
return (min_body
(result, body_is_safe(sc, func, cdddr(x), false)));
}
/* define and friends are not safe: (define (a) (define b 3)...) tries to put b in the current let,
* but in a safe func, that's a constant. See s7test L 1865 for an example.
*/
default:
/* try to catch weird cases like:
* (let () (define (hi1 a) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1))
* (let () (define (hi1 a) (define (ho1 b) b) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1))
*/
return (UNSAFE_BODY);
}
} else { /* car(x) is not syntactic */
if (expr == func) { /* try to catch tail call, expr is car(x) */
bool follow = false;
s7_pointer sp, p;
sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */
set_rec_tc_args(sc, proper_list_length(cdr(x)));
if (!at_end) {
result = RECUR_BODY;
sc->not_tc = true;
}
sp = x;
for (p = cdr(x); is_pair(p); p = cdr(p)) {
if (is_pair(car(p))) {
if (caar(p) == func) { /* func called as arg, so not tail call */
sc->not_tc = true;
result = RECUR_BODY;
}
result =
min_body(result,
form_is_safe(sc, func, car(p), false));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
} else if (car(p) == func) /* func itself as arg */
return (UNSAFE_BODY);
if (follow) {
sp = cdr(sp);
if (p == sp)
return (UNSAFE_BODY);
}
follow = (!follow);
}
if ((at_end) && (!sc->not_tc) && (is_null(p))) { /* tail call, so safe */
sc->got_tc = true;
set_rec_tc_args(sc, proper_list_length(cdr(x)));
return (result);
}
if (result != UNSAFE_BODY)
result = RECUR_BODY;
return (result);
}
if (is_symbol(expr)) { /* expr=car(x) */
s7_pointer f, f_slot;
bool c_safe;
if (symbol_is_in_list(sc, expr))
return (UNSAFE_BODY);
f_slot = lookup_slot_from(expr, sc->curlet);
if (!is_slot(f_slot))
return (UNSAFE_BODY);
f = slot_value(f_slot);
c_safe = (is_c_function(f))
&& (is_safe_or_scope_safe_procedure(f));
result = ((is_sequence(f))
|| ((is_closure(f)) && (is_very_safe_closure(f)))
|| ((c_safe)
&& ((is_immutable(f_slot))
|| (is_global(expr))))) ? VERY_SAFE_BODY :
SAFE_BODY;
if ((c_safe) ||
((is_any_closure(f)) && (is_safe_closure(f))) ||
(is_sequence(f))) {
bool follow = false;
s7_pointer sp = x, p = cdr(x);
for (; is_pair(p); p = cdr(p)) {
if (is_unquoted_pair(car(p))) {
if (caar(p) == func) {
sc->got_rec = true; /* (+ 1 (recur (- x 1))) t123 (and others) */
set_rec_tc_args(sc,
proper_list_length(cdar(p)));
return (RECUR_BODY);
}
if ((is_c_function(f)) && (is_scope_safe(f)) &&
(caar(p) == sc->lambda_symbol)) {
s7_pointer largs, lbody, q;
body_t lresult;
if (!is_pair(cdar(p))) /* (lambda . /) */
return (UNSAFE_BODY);
largs = cadar(p);
lbody = cddar(p);
for (q = largs; is_pair(q); q = cdr(q)) {
if (!is_symbol(car(q)))
return (UNSAFE_BODY);
add_symbol_to_list(sc, car(q));
}
lresult = body_is_safe(sc, func, lbody, false);
result = min_body(result, lresult);
} else
result =
min_body(result,
form_is_safe(sc, func, car(p),
false));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
} else if (car(p) == func) /* the current function passed as an argument to something */
return (UNSAFE_BODY);
if (follow) {
sp = cdr(sp);
if (p == sp)
return (UNSAFE_BODY);
}
follow = (!follow);
}
return ((is_null(p)) ? result : UNSAFE_BODY);
}
if ((expr == sc->quote_symbol) &&
(is_proper_list_1(sc, cdr(x))) &&
(is_global(sc->quote_symbol)))
return (result);
if (expr == sc->values_symbol) { /* (values) is safe, as is (values x) if x is: (values (define...)) */
if (is_null(cdr(x)))
return (result);
if ((is_pair(cdr(x))) && (is_null(cddr(x))))
return ((is_pair(cadr(x))) ?
min_body(result,
form_is_safe(sc, func, cadr(x),
false)) : result);
}
if ((expr == sc->apply_symbol) && /* (apply + ints) */
(is_pair(cdr(x))) &&
(is_pair(cddr(x))) &&
(is_null(cdddr(x))) &&
((!is_pair(caddr(x))) ||
(form_is_safe(sc, func, caddr(x), false)))) {
s7_pointer fn = cadr(x);
if (is_symbol(fn)) {
s7_pointer fn_slot;
if (symbol_is_in_list(sc, fn))
return (UNSAFE_BODY);
fn_slot = lookup_slot_from(fn, sc->curlet);
if (!is_slot(fn_slot))
return (UNSAFE_BODY);
fn = slot_value(fn_slot);
if ((is_c_function(fn)) && (is_safe_procedure(fn)))
return (result);
if ((is_closure(fn)) && (is_very_safe_closure(fn)))
return (result);
}
}
}
return (UNSAFE_BODY); /* not recur_body here if at_end -- possible defines in body etc */
}
return (result);
}
static body_t body_is_safe(s7_scheme * sc, s7_pointer func,
s7_pointer body, bool at_end)
{
bool follow = false;
s7_pointer p, sp;
body_t result = VERY_SAFE_BODY;
for (p = body, sp = body; is_pair(p); p = cdr(p)) {
if (is_pair(car(p))) {
result =
min_body(result, form_is_safe(sc, func, car(p), (at_end)
&& (is_null(cdr(p)))));
if (result == UNSAFE_BODY)
return (UNSAFE_BODY);
}
if (p != body) {
if (follow) {
sp = cdr(sp);
if (p == sp)
return (UNSAFE_BODY);
}
follow = (!follow);
}
}
return ((is_null(p)) ? result : UNSAFE_BODY);
}
static bool tree_has_definers_or_binders(s7_scheme * sc, s7_pointer tree)
{
s7_pointer p;
for (p = tree; is_pair(p); p = cdr(p))
if (tree_has_definers_or_binders(sc, car(p)))
return (true);
return ((is_symbol(tree)) && (is_definer_or_binder(tree)));
}
static void optimize_lambda(s7_scheme * sc, bool unstarred_lambda,
s7_pointer func, s7_pointer args,
s7_pointer body)
{ /* func is either sc->unused or a symbol */
s7_int len;
len = s7_list_length(sc, body);
if (len < 0) /* (define (hi) 1 . 2) */
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"~A: function body messed up, ~A",
31),
(unstarred_lambda) ? sc->
lambda_symbol : sc->lambda_star_symbol,
sc->code));
if (len > 0) { /* i.e. not circular */
body_t result;
s7_pointer p, lst, cleared_args;
clear_symbol_list(sc);
for (p = args; is_pair(p); p = cdr(p))
add_symbol_to_list(sc, (is_symbol(car(p))) ? car(p) : caar(p));
if (!is_null(p))
add_symbol_to_list(sc, p);
sc->got_tc = false;
sc->not_tc = false;
sc->got_rec = false;
sc->rec_tc_args = -1;
result = ((is_symbol(func)) && (symbol_is_in_list(sc, func))) ? UNSAFE_BODY : body_is_safe(sc, func, body, true); /* (define (f f)...) */
clear_symbol_list(sc);
/* if the body is safe, we can optimize the calling sequence */
if (!unstarred_lambda) {
bool happy = true;
/* check default vals -- if none is an expression or symbol, set simple args */
for (p = args; is_pair(p); p = cdr(p)) {
s7_pointer arg;
arg = car(p);
if ((is_pair(arg)) && /* has default value */
(is_pair(cdr(arg))) && /* is not a ridiculous improper list */
((is_symbol(cadr(arg))) || /* if default value might involve eval in any way, it isn't simple */
(is_unquoted_pair(cadr(arg))))) { /* pair as default only ok if it is (quote ...) */
happy = false;
if ((result > UNSAFE_BODY) && (tree_has_definers_or_binders(sc, cadr(arg)))) /* if the default has a definer, body is not safe (funclet is not stable) */
result = UNSAFE_BODY;
break;
}
}
if (happy)
lambda_set_simple_defaults(body);
}
if (result >= SAFE_BODY) { /* not RECUR_BODY here (need new let for cons-r in s7test) */
set_safe_closure_body(body);
if (result == VERY_SAFE_BODY)
set_very_safe_closure_body(body);
}
if (is_symbol(func)) {
lst = list_1(sc, add_symbol_to_list(sc, func));
sc->temp1 = lst;
} else
lst = sc->nil;
if (optimize
(sc, body, 1, cleared_args =
collect_parameters(sc, args, lst)) == OPT_OOPS)
clear_all_optimizations(sc, body);
else {
if (result >= RECUR_BODY) {
int32_t nvars;
for (nvars = 0, p = args;
(is_pair(p)) && (!is_keyword(car(p)));
nvars++, p = cdr(p));
if ((is_null(p)) && (nvars > 0)) {
fx_annotate_args(sc, body, cleared_args); /* almost useless -- we need a recursive traversal here but that collides with check_if et al */
fx_tree(sc, body, /* this usually costs more than it saves! */
(is_pair(car(args))) ? caar(args) : car(args),
(nvars >
1) ? ((is_pair(cadr(args))) ? caadr(args) :
cadr(args)) : NULL,
(nvars >
2) ? ((is_pair(caddr(args))) ? caaddr(args) :
caddr(args)) : NULL, nvars > 3);
}
if (((unstarred_lambda) || ((is_null(p)) && (nvars == sc->rec_tc_args))) && (is_null(cdr(body)))) { /* (if <a> #t|#f...) happens only rarely */
if (sc->got_tc) {
if (check_tc(sc, func, nvars, args, car(body)))
set_safe_closure_body(body); /* (very_)safe_closure set above if > RECUR_BODY */
/* if not check_tc, car(body) is either not a tc op or it is not optimized so that is_fxable will return false */
}
if ((sc->got_rec) &&
(!is_tc_op(optimize_op(car(body)))) &&
(check_recur(sc, func, nvars, args, car(body))))
set_safe_closure_body(body);
}
}
}
if (is_symbol(func)) {
sc->temp1 = sc->nil;
free_cell(sc, lst);
}
sc->got_tc = false;
sc->not_tc = false;
sc->got_rec = false;
}
}
static int32_t check_lambda(s7_scheme * sc, s7_pointer form, bool opt)
{
/* code is a lambda form: (lambda (a b) (+ a b)) */
/* this includes unevaluated symbols (direct symbol table refs) in macro arg list */
s7_pointer code, body;
int32_t arity = 0;
if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, form)))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "lambda: body is cyclic: ~S",
26), form));
code = cdr(form);
if (!is_pair(code)) /* (lambda) or (lambda . 1) */
eval_error(sc, "lambda: no arguments? ~A", 24, form);
body = cdr(code);
if (!is_pair(body)) /* (lambda #f) */
eval_error(sc, "lambda: no body? ~A", 19, form);
/* in many cases, this is a no-op -- we already checked at define */
check_lambda_args(sc, car(code), &arity);
/* clear_symbol_list(sc); *//* not used in check_lambda_args and clobbers optimize_expression find_uncomplicated_symbol check */
/* look for (define f (let (...) (lambda ...))) and treat as equivalent to (define (f ...)...)
* one problem the hop=0 fixes is that safe closures assume the old let exists, so we need to check for define below
* I wonder about apply define...
*/
/* OP_LET1 should work here also, (let ((f (lambda...)))), but subsequent calls assume a saved let if safe
* to mimic define, we need to parallel op_define_with_setter + make_funclet, I think
*/
if ((opt) || (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)
global_value
(sc->dilambda_symbol))))
optimize_lambda(sc, true, sc->unused, car(code), body);
else if (optimize(sc, body, 0,
/* ((sc->op_stack_now > sc->op_stack) && (is_c_function((*(sc->op_stack_now - 1)))) && (is_scope_safe((*(sc->op_stack_now - 1))))) ? 1 : 0, */
/* this works except when someone resets outlet(curlet) after defining a local function! */
collect_parameters(sc, car(code),
sc->nil)) == OPT_OOPS)
clear_all_optimizations(sc, body);
pair_set_syntax_op(form, OP_LAMBDA_UNCHECKED);
if (arity < -1)
arity++; /* confusing! at least 0 = (), but (lambda arg...) has same "arity" here as (lambda (a . b)...)? */
set_opt3_any(code, (s7_pointer) ((intptr_t) arity));
return (arity);
}
static s7_pointer op_lambda(s7_scheme * sc, s7_pointer code)
{
int32_t arity;
arity = check_lambda(sc, code, false);
code = cdr(code);
set_opt3_any(code, (s7_pointer) ((intptr_t) arity));
return (make_closure
(sc, car(code), cdr(code),
T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity));
}
static inline s7_pointer op_lambda_unchecked(s7_scheme * sc,
s7_pointer code)
{
int32_t arity;
arity = (int32_t) ((intptr_t) opt3_any(cdr(code)));
return (inline_make_closure
(sc, cadr(code), cddr(code),
T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity));
}
static void check_lambda_star(s7_scheme * sc)
{
s7_pointer code;
if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, sc->code)))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "lambda*: body is cyclic: ~S",
27), sc->code));
code = cdr(sc->code);
if ((!is_pair(code)) || (!is_pair(cdr(code)))) /* (lambda*) or (lambda* #f) */
eval_error(sc, "lambda*: no arguments or no body? ~A", 36,
sc->code);
set_car(code, check_lambda_star_args(sc, car(code), NULL));
if ((sc->safety > NO_SAFETY) || (main_stack_op(sc) != OP_DEFINE1)) {
if (optimize
(sc, cdr(code), 0,
collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS)
clear_all_optimizations(sc, cdr(code));
} else
optimize_lambda(sc, false, sc->unused, car(code), cdr(code));
pair_set_syntax_op(sc->code, OP_LAMBDA_STAR_UNCHECKED);
sc->code = code;
}
/* -------------------------------- case -------------------------------- */
static inline bool is_undefined_feed_to(s7_scheme * sc, s7_pointer sym)
{
return ((sym == sc->feed_to_symbol) &&
((symbol_ctr(sc->feed_to_symbol) == 0)
|| (s7_symbol_value(sc, sc->feed_to_symbol) ==
sc->undefined)));
}
static s7_pointer check_case(s7_scheme * sc)
{
/* we're not checking repeated or ridiculous (non-eqv?) keys here because they aren't errors */
bool keys_simple = true, has_feed_to = false, keys_single =
true, bodies_simple = true, has_else = false;
int32_t key_type = T_FREE;
s7_pointer x, carc, code = cdr(sc->code);
if (!is_pair(code)) /* (case) or (case . 1) */
eval_error(sc, "case has no selector: ~A", 25, sc->code);
if (!is_pair(cdr(code))) /* (case 1) or (case 1 . 1) */
eval_error(sc, "case has no clauses?: ~A", 25, sc->code);
if (!is_pair(cadr(code))) /* (case 1 1) */
eval_error(sc, "case clause is not a list? ~A", 29, sc->code);
set_opt3_any(code, sc->unspecified);
for (x = cdr(code); is_pair(x); x = cdr(x)) {
s7_pointer y, car_x;
if ((!is_pair(x)) || /* (case 1 ((2) 1) . 1) */
(!is_pair(car(x))))
eval_error(sc, "case clause ~A messed up", 24, x);
car_x = car(x);
if (!is_list(cdr(car_x))) /* (case 1 ((1))) */
eval_error(sc, "case clause result messed up: ~A", 32, car_x);
if ((bodies_simple) &&
((is_null(cdr(car_x))) || (!is_null(cddr(car_x)))))
bodies_simple = false;
y = car(car_x);
if (!is_pair(y)) {
if ((y != sc->else_symbol) && /* (case 1 (2 1)) */
((!is_symbol(y)) || (s7_symbol_value(sc, y) != sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) ... */
eval_error(sc,
"case clause key list ~A is not a proper list or 'else'",
54, y);
else
has_else = true;
if (is_not_null(cdr(x))) /* (case 1 (else 1) ((2) 1)) */
eval_error(sc,
"case 'else' clause, ~A, is not the last clause",
46, x);
if (!is_null(cdr(car_x))) { /* else (else) so return selector */
if (is_pair(cddr(car_x))) {
set_opt3_any(code, cdr(car_x));
bodies_simple = false;
} else {
if ((bodies_simple) && (keys_single))
set_opt3_any(code, cadr(car_x));
else
set_opt3_any(code, cdr(car_x));
set_opt1_clause(x, cadr(car_x));
}
}
} else {
if (!is_simple(car(y)))
keys_simple = false;
if (!is_null(cdr(y)))
keys_single = false;
if (key_type == T_FREE)
key_type = type(car(y));
else if (key_type != type(car(y)))
key_type = NUM_TYPES;
if (key_type == T_SYMBOL)
set_case_key(car(y));
for (y = cdr(y); is_pair(y); y = cdr(y)) {
if (!is_simple(car(y)))
keys_simple = false;
if (key_type != type(car(y)))
key_type = NUM_TYPES;
if (key_type == T_SYMBOL)
set_case_key(car(y));
}
if (!is_null(y)) /* (case () ((1 . 2) . hi) . hi) */
eval_error(sc, "case key list is improper? ~A", 29, x);
}
y = car_x;
if (!s7_is_proper_list(sc, cdr(y)))
eval_error(sc, "case: stray dot? ~A", 19, y);
if ((is_pair(cdr(y))) && (is_undefined_feed_to(sc, cadr(y)))) {
has_feed_to = true;
if (!is_pair(cddr(y))) /* (case 1 (else =>)) */
eval_error(sc, "case: '=>' target missing? ~A", 30, y);
if (is_pair(cdddr(y))) /* (case 1 (else => + - *)) */
eval_error(sc, "case: '=>' has too many targets: ~A", 35,
y);
}
}
if (is_not_null(x)) /* (case x ((1 2)) . 1) */
eval_error(sc, "case: stray dot? ~A", 19, sc->code);
if ((keys_single) && (bodies_simple)) {
for (x = cdr(code); is_not_null(x); x = cdr(x)) {
set_opt2_any(x, caar(x));
if (is_pair(opt2_any(x))) {
set_opt2_any(x, car(opt2_any(x)));
if (is_pair(cdar(x)))
set_opt1_clause(x, cadar(x));
}
}
} else
for (x = cdr(code); is_not_null(x); x = cdr(x)) {
set_opt2_any(x, caar(x));
if ((is_pair(opt2_any(x))) && (is_pair(cdar(x))))
set_opt1_clause(x, cadar(x));
}
if (key_type == T_INTEGER)
set_has_integer_keys(sc->code);
pair_set_syntax_op(sc->code, OP_CASE_P_G_G); /* fallback on this */
if ((has_feed_to) || (!bodies_simple) || /* x_x_g g=general keys or bodies */
(!keys_single)) {
if (!keys_simple) { /* x_g_g (no int32_t case here) */
if (is_symbol(car(code)))
pair_set_syntax_op(sc->code, OP_CASE_S_G_G);
else if (is_fxable(sc, car(code))) {
pair_set_syntax_op(sc->code, OP_CASE_A_G_G);
set_fx_direct(code,
fx_choose(sc, code, sc->curlet,
let_symbol_is_safe));
} else
pair_set_syntax_op(sc->code, OP_CASE_P_G_G);
} else { /* x_e_g */
if (!has_else)
set_opt3_any(code, sc->unused); /* affects all that goto CASE_E_G */
if (is_symbol(car(code)))
pair_set_syntax_op(sc->code,
(key_type ==
T_SYMBOL) ? OP_CASE_S_S_G :
OP_CASE_S_E_G);
else if (is_fxable(sc, car(code))) {
pair_set_syntax_op(sc->code,
(key_type ==
T_SYMBOL) ? OP_CASE_A_S_G :
OP_CASE_A_E_G);
set_fx_direct(code,
fx_choose(sc, code, sc->curlet,
let_symbol_is_safe));
} else
pair_set_syntax_op(sc->code,
(key_type ==
T_SYMBOL) ? OP_CASE_P_S_G :
OP_CASE_P_E_G);
}
} else /* x_x_s */ if (!keys_simple) { /* x_g|i_s */
if (is_symbol(car(code)))
pair_set_syntax_op(sc->code, ((!WITH_GMP)
&& (key_type ==
T_INTEGER)) ? OP_CASE_S_I_S :
OP_CASE_S_G_S);
else if (is_fxable(sc, car(code))) {
pair_set_syntax_op(sc->code, ((!WITH_GMP)
&& (key_type ==
T_INTEGER)) ? OP_CASE_A_I_S :
OP_CASE_A_G_S);
set_fx_direct(code,
fx_choose(sc, code, sc->curlet,
let_symbol_is_safe));
} else
pair_set_syntax_op(sc->code, ((!WITH_GMP)
&& (key_type ==
T_INTEGER)) ? OP_CASE_P_I_S :
OP_CASE_P_G_S);
} else /* x_e_s */ if (is_symbol(car(code)))
pair_set_syntax_op(sc->code,
(key_type ==
T_SYMBOL) ? OP_CASE_S_S_S : OP_CASE_S_E_S);
else if (is_fxable(sc, car(code))) {
pair_set_syntax_op(sc->code,
(key_type ==
T_SYMBOL) ? OP_CASE_A_S_S : OP_CASE_A_E_S);
set_fx_direct(code,
fx_choose(sc, code, sc->curlet, let_symbol_is_safe));
} else
pair_set_syntax_op(sc->code,
(key_type ==
T_SYMBOL) ? OP_CASE_P_S_S : OP_CASE_P_E_S);
carc = cadr(sc->code);
if (!is_pair(carc)) {
sc->value = (is_symbol(carc)) ? lookup_checked(sc, carc) : carc;
return (NULL);
}
push_stack_no_args_direct(sc, OP_CASE_G_G);
sc->code = carc;
return (carc);
}
#if (!WITH_GMP)
static bool op_case_i_s(s7_scheme * sc)
{
s7_pointer x, selector = sc->value, else_clause =
opt3_any(cdr(sc->code));
if (else_clause != sc->unspecified) {
if (is_t_integer(selector)) {
s7_int val = integer(selector);
for (x = cddr(sc->code); is_pair(x); x = cdr(x))
if (is_t_integer(opt2_any(x))) {
if (integer(opt2_any(x)) == val) {
sc->code = opt1_clause(x);
return (false);
}
} else
break;
}
sc->code = else_clause;
return (false);
}
if (is_t_integer(selector)) {
s7_int val = integer(selector);
for (x = cddr(sc->code); is_pair(x); x = cdr(x))
if (integer(opt2_any(x)) == val) {
sc->code = opt1_clause(x);
return (false);
}
}
sc->value = sc->unspecified;
return (true);
}
#endif
static bool op_case_e_g_1(s7_scheme * sc, s7_pointer selector, bool ok)
{
s7_pointer x, y;
if (ok) {
for (x = cddr(sc->code); is_pair(x); x = cdr(x)) {
y = opt2_any(x);
if (!is_pair(y)) /* i.e. else? */
goto ELSE_CASE_1;
do {
if (car(y) == selector)
goto ELSE_CASE_1;
y = cdr(y);
} while (is_pair(y));
}
sc->value = sc->unspecified;
pop_stack(sc);
return (true);
}
sc->code = opt3_any(cdr(sc->code));
if (sc->code == sc->unused) /* set in check_case if no else clause */
sc->value = sc->unspecified;
else if (is_pair(sc->code))
goto ELSE_CASE_2;
pop_stack(sc);
return (true);
ELSE_CASE_1:
/* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */
sc->code = T_Lst(cdar(x));
if (is_null(sc->code)) { /* sc->value is already the selector */
pop_stack(sc);
return (true);
}
ELSE_CASE_2:
if (is_null(cdr(sc->code))) {
sc->code = car(sc->code);
sc->cur_op = optimize_op(sc->code);
return (true);
}
if (is_undefined_feed_to(sc, car(sc->code)))
return (false);
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
sc->cur_op = optimize_op(sc->code);
return (true);
}
static bool op_case_g_g(s7_scheme * sc)
{
s7_pointer x, y;
if (has_integer_keys(sc->code)) {
s7_int selector;
sc->code = cddr(sc->code);
if (is_t_integer(sc->value))
selector = integer(sc->value);
else {
#if WITH_GMP
if ((is_t_big_integer(sc->value))
&& (mpz_fits_slong_p(big_integer(sc->value))))
selector = mpz_get_si(big_integer(sc->value));
else
#endif
{
for (x = sc->code; is_pair(x); x = cdr(x)) /* maybe preset the else case */
if (!is_pair(caar(x)))
goto ELSE_CASE;
sc->value = sc->unspecified;
pop_stack(sc);
return (true);
}
}
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 (integer(car(y)) == selector)
goto ELSE_CASE;
}
sc->value = sc->unspecified;
pop_stack(sc);
return (true);
}
sc->code = cddr(sc->code);
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));
}
sc->value = sc->unspecified;
pop_stack(sc);
return (true);
}
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(sc, car(y), sc->value))
goto ELSE_CASE;
}
sc->value = sc->unspecified; /* this was sc->nil but the spec says case value is unspecified if no clauses match */
pop_stack(sc);
return (true);
ELSE_CASE:
/* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */
sc->code = T_Lst(cdar(x));
if (is_null(sc->code)) { /* sc->value is already the selector */
pop_stack(sc);
return (true);
}
if (is_null(cdr(sc->code))) {
sc->code = car(sc->code);
sc->cur_op = optimize_op(sc->code);
return (true);
}
if (is_undefined_feed_to(sc, car(sc->code)))
return (false);
if (is_pair(cdr(T_Pair(sc->code))))
push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
sc->code = car(sc->code);
sc->cur_op = optimize_op(sc->code);
return (true);
}
static void op_case_e_s(s7_scheme * sc)
{
s7_pointer selector = sc->value;
if (is_simple(selector)) {
s7_pointer x;
for (x = cddr(sc->code); is_pair(x); x = cdr(x))
if (opt2_any(x) == selector) {
sc->code = opt1_clause(x);
return;
}
}
sc->code = opt3_any(cdr(sc->code));
}
static void op_case_s_s(s7_scheme * sc)
{
s7_pointer selector = sc->value;
if (is_symbol(selector)) {
s7_pointer x;
for (x = cddr(sc->code); is_pair(x); x = cdr(x))
if (opt2_any(x) == selector) {
sc->code = opt1_clause(x);
return;
}
}
sc->code = opt3_any(cdr(sc->code));
}
static void op_case_g_s(s7_scheme * sc)
{
s7_pointer x, selector = sc->value;
for (x = cddr(sc->code); is_pair(x); x = cdr(x))
if (s7_is_eqv(sc, opt2_any(x), selector)) {
sc->code = opt1_clause(x);
return;
}
sc->code = opt3_any(cdr(sc->code));
}
/* -------------------------------- let -------------------------------- */
static void check_let_a_body(s7_scheme * sc, s7_pointer form)
{
s7_pointer code = cdr(form);
if (is_fxable(sc, cadr(code))) {
fx_annotate_arg(sc, cdr(code), set_plist_1(sc, caaar(code))); /* was sc->curlet) ? */
fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false);
pair_set_syntax_op(form, OP_LET_A_A_OLD);
} else if (is_pair(cadr(code)))
pair_set_syntax_op(form, OP_LET_A_P_OLD);
}
static void check_let_one_var(s7_scheme * sc, s7_pointer form,
s7_pointer start)
{
s7_pointer binding = car(start), code = cdr(form);
if (is_pair(cadr(binding))) {
/* this is not a named let */
pair_set_syntax_op(form, ((is_pair(cdr(code)))
&& (is_null(cddr(code)))) ?
OP_LET_ONE_P_OLD : OP_LET_ONE_OLD);
set_opt2_sym(cdr(code), car(binding)); /* these don't collide -- cdr(code) and code */
set_opt2_pair(code, cadr(binding));
if (is_optimized(cadr(binding))) {
if (is_null(cddr(code))) { /* one statement body */
if (optimize_op(cadr(binding)) == HOP_SAFE_C_SS) {
/* no lt fx here, 4 s7test */
if (fn_proc(cadr(binding)) == g_assq) {
set_opt2_sym(code, cadadr(binding));
pair_set_syntax_op(form, OP_LET_opaSSq_E_OLD);
} else
pair_set_syntax_op(form, OP_LET_opSSq_E_OLD);
set_opt3_sym(cdr(code), caddadr(binding));
set_opt1_sym(code, car(binding));
return;
}
if (is_fxable(sc, cadr(binding))) {
set_opt2_pair(code, binding);
pair_set_syntax_op(form, OP_LET_A_OLD);
fx_annotate_arg(sc, cdr(binding), sc->curlet);
check_let_a_body(sc, form);
return;
}
}
if (optimize_op(cadr(binding)) == HOP_SAFE_C_SS) {
if (fn_proc(cadr(binding)) == g_assq) {
set_opt2_sym(code, cadadr(binding));
pair_set_syntax_op(form, OP_LET_opaSSq_OLD);
} else
pair_set_syntax_op(form, OP_LET_opSSq_OLD);
set_opt3_sym(cdr(code), caddadr(binding));
set_opt1_sym(code, car(binding));
} else if (is_fxable(sc, cadr(binding))) {
set_opt2_pair(code, binding);
pair_set_syntax_op(form, OP_LET_A_OLD);
fx_annotate_arg(sc, cdr(binding), sc->curlet);
if (is_null(cddr(code)))
check_let_a_body(sc, form);
else {
s7_pointer p;
for (p = cdr(code); is_pair(p); p = cdr(p))
if (!is_fxable(sc, car(p)))
break;
if (is_null(p)) {
pair_set_syntax_op(form, OP_LET_A_FX_OLD);
fx_annotate_args(sc, cdr(code),
set_plist_1(sc, car(binding)));
fx_tree(sc, cdr(code), car(binding), NULL, NULL,
false);
return;
}
}
}
}
} else {
set_opt2_pair(code, binding);
pair_set_syntax_op(form, OP_LET_A_OLD);
fx_annotate_arg(sc, cdr(binding), sc->curlet);
if (is_null(cddr(code)))
check_let_a_body(sc, form);
}
if ((optimize_op(form) == OP_LET_A_OLD) &&
(is_pair(cddr(code))) && (is_null(cdddr(code))))
pair_set_syntax_op(form, OP_LET_A_OLD_2);
}
static s7_pointer check_named_let(s7_scheme * sc, int32_t vars)
{
s7_pointer code = cdr(sc->code);
set_opt2_int(code, make_permanent_integer(vars));
if (vars == 0) {
pair_set_syntax_op(sc->code, OP_NAMED_LET_NO_VARS);
set_opt1_pair(sc->code, cddr(code));
optimize_lambda(sc, true, car(code), sc->nil, cddr(code));
} else {
s7_pointer ex, exp;
bool fx_ok = true;
pair_set_syntax_op(sc->code, OP_NAMED_LET);
/* this is (let name ...) so the initial values need to be removed from the closure arg list */
sc->args = T_Pair(safe_list_if_possible(sc, vars));
for (ex = cadr(code), exp = sc->args; is_pair(ex);
ex = cdr(ex), exp = cdr(exp)) {
s7_function fx;
s7_pointer val = cdar(ex);
fx = fx_choose(sc, val, sc->curlet, let_symbol_is_safe);
if (fx)
set_fx_direct(val, fx);
else
fx_ok = false;
car(exp) = caar(ex);
}
if (fx_ok) {
set_opt1_pair(code, caadr(code));
if (vars == 2)
set_opt3_pair(code, cadadr(code));
pair_set_syntax_op(sc->code,
(vars ==
1) ? OP_NAMED_LET_A : ((vars ==
2) ?
OP_NAMED_LET_AA :
OP_NAMED_LET_FX));
}
optimize_lambda(sc, true, car(code), sc->args, cddr(code)); /* car(code) is the name */
clear_list_in_use(sc->args);
sc->args = sc->nil;
}
return (code);
}
static s7_pointer check_let(s7_scheme * sc)
{ /* called only from op_let */
s7_pointer x, start, code = cdr(sc->code);
bool named_let;
int32_t vars;
if (!is_pair(code)) { /* (let . 1) */
if (is_null(code)) /* (let) */
eval_error(sc, "let has no variables or body: ~A", 32,
sc->code);
eval_error(sc, "let form is an improper list? ~A", 32, sc->code);
}
if (!is_pair(cdr(code))) /* (let () ) or (let () . 1) */
eval_error(sc, "let has no body: ~A", 19, sc->code);
if ((!is_list(car(code))) && /* (let 1 ...) */
(!is_normal_symbol(car(code))))
eval_error(sc, "let variable list is messed up or missing: ~A", 45,
sc->code);
named_let = (is_symbol(car(code)));
if (named_let) {
if (!is_list(cadr(code))) /* (let hi #t) */
eval_error(sc, "let variable list is messed up: ~A", 34,
sc->code);
if (!is_pair(cddr(code))) { /* (let hi () . =>) or (let hi () ) */
if (is_null(cddr(code)))
eval_error(sc, "named let has no body: ~A", 25, sc->code);
else
eval_error(sc, "named let stray dot? ~A", 23, sc->code);
}
if (is_constant_symbol(sc, car(code)))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc, cant_bind_immutable_string,
sc->code)));
set_local(car(code));
start = cadr(code);
} else
start = car(code);
clear_symbol_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",
43, x);
if (!(is_pair(cdr(carx)))) /* (let ((x . 1))...) */
eval_error(sc,
"let variable declaration is not a proper list?: ~A",
50, x);
if (is_not_null(cddr(carx))) /* (let ((x 1 2 3)) ...) */
eval_error(sc,
"let variable declaration has more than one value?: ~A",
53, x);
y = car(carx);
if (!(is_symbol(y)))
eval_error(sc, "bad variable ~S in let (it is not a symbol)",
43, carx);
if (is_constant_symbol(sc, y))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc, cant_bind_immutable_string, x)));
/* check for name collisions -- not sure this is required by Scheme */
if (symbol_is_in_list(sc, y))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"duplicate identifier in let: ~S in ~S",
37), y, sc->code));
add_symbol_to_list(sc, y);
set_local(y);
}
/* (let ('1) quote) -> 1 */
if (is_not_null(x)) /* (let* ((a 1) . b) a) */
eval_error(sc, "let variable list improper?: ~A", 31, sc->code);
if (!s7_is_proper_list(sc, cdr(code))) /* (let ((a 1)) a . 1) */
eval_error(sc, "stray dot in let body: ~S", 25, cdr(code));
if (named_let)
return (check_named_let(sc, vars));
if (vars == 0) /* !in_heap does not happen much here */
pair_set_syntax_op(sc->code, OP_LET_NO_VARS);
else {
pair_set_syntax_op(sc->code, OP_LET_UNCHECKED);
if (vars == 1)
check_let_one_var(sc, sc->code, start);
else {
s7_pointer p;
/* this used to check that vars < gc_trigger_size, but I can't see why */
opcode_t opt = OP_UNOPT;
for (p = start; is_pair(p); p = cdr(p)) {
x = car(p);
if (is_fxable(sc, cadr(x))) {
set_fx_direct(cdr(x),
fx_choose(sc, cdr(x), sc->curlet,
let_symbol_is_safe));
if (opt == OP_UNOPT)
opt = OP_LET_FX_OLD;
} else
opt = OP_LET_UNCHECKED;
}
pair_set_syntax_op(sc->code, opt);
if ((opt == OP_LET_FX_OLD) && (is_null(cddr(code)))) { /* 1 form in body */
/* if (is_fxable(sc, cadr(code))) fprintf(stderr, "%s\n", display(code)); */
if (vars == 2) {
pair_set_syntax_op(sc->code, OP_LET_2A_OLD);
set_opt1_pair(code, caar(code));
set_opt2_pair(code, cadar(code));
} else if (vars == 3) {
pair_set_syntax_op(sc->code, OP_LET_3A_OLD);
set_opt1_pair(code, cadar(code));
set_opt2_pair(code, caddar(code));
}
}
}
}
/* if safe_c or safe_closure as car(body), null cdr(body), see if only vars as args
* symbol_list is intact??
*/
if (optimize_op(sc->code) >= OP_LET_FX_OLD) {
if ((!in_heap(sc->code)) && (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) /* recur_body is apparently never hit */
set_opt3_let(code, make_permanent_let(sc, car(code)));
else {
set_optimize_op(sc->code, optimize_op(sc->code) + 1); /* *_old -> *_new */
set_opt3_let(code, sc->nil);
}
}
if ((is_pair(car(code))) &&
(is_let(sc->curlet)) && (is_funclet(sc->curlet))
&& (tis_slot(let_slots(sc->curlet)))) {
/* apparently works because a safe closure will have old-let -> funclet?? */
s7_pointer p, s1 = let_slots(sc->curlet), s2 = NULL, s3 = NULL;
if (tis_slot(next_slot(s1)))
s2 = slot_symbol(next_slot(s1));
if ((s2) && (tis_slot(next_slot(next_slot(s1)))))
s3 = slot_symbol(next_slot(next_slot(s1)));
s1 = slot_symbol(s1);
for (p = car(code); is_pair(p); p = cdr(p)) {
s7_pointer init = cdar(p);
fx_tree(sc, init, s1, s2, s3, s3);
}
}
return (code);
}
static bool op_named_let_1(s7_scheme * sc, s7_pointer args)
{ /* args = vals in decl order */
s7_pointer body = cddr(sc->code), x;
s7_int n = integer(opt2_int(sc->code));
sc->w = sc->nil;
for (x = cadr(sc->code); is_pair(x); x = cdr(x)) {
sc->w = cons(sc, caar(x), sc->w);
x = cdr(x);
if (!is_pair(x))
break;
sc->w = cons_unchecked(sc, caar(x), sc->w);
}
sc->w = proper_list_reverse_in_place(sc, sc->w); /* init values (args) are also in "reversed" order */
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, n);
add_slot(sc, sc->curlet, car(sc->code), sc->x);
sc->curlet = make_let_slowly(sc, sc->curlet);
for (x = sc->w; is_not_null(args); x = cdr(x)) { /* reuse the value cells as the new let slots */
s7_pointer sym = car(x), new_args = cdr(args);
reuse_as_slot(sc, args, sym, unchecked_car(args)); /* args=slot, sym=symbol, car(args)=value */
slot_set_next(args, let_slots(sc->curlet));
let_set_slots(sc->curlet, args);
symbol_set_local_slot(sym, let_id(sc->curlet), args);
args = new_args;
}
closure_set_let(sc->x, sc->curlet);
let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet)));
sc->x = sc->nil;
sc->code = T_Pair(body);
sc->w = sc->nil;
return (true);
}
static bool op_let1(s7_scheme * sc)
{
s7_pointer x, y, e;
uint64_t id;
/* building a list, then reusing it below as the let/slots seems stupid, but if we make the let first, and
* add slots, there are other problems. The let/slot ids (and symbol_set_local_slot) need to wait
* until the args are evaluated, if an arg invokes call/cc, the let on the stack needs to be copied
* including let_dox_code if it is used to save sc->code (there are 3 things that need to be protected),
* (we win currently because copy_stack copies the list), and make-circular-iterator if called twice (s7test)
* hangs -- I can't see why! Otherwise, the let/slots approach is slightly faster (less than 1% however).
*/
while (true) {
sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code)) {
x = cdar(sc->code);
if (has_fx(x))
sc->value = fx_call(sc, x);
else {
check_stack_size(sc);
push_stack(sc, OP_LET1, sc->args, cdr(sc->code));
sc->code = car(x);
return (false);
}
sc->code = cdr(sc->code);
} else
break;
}
x = proper_list_reverse_in_place(sc, sc->args);
sc->code = car(x); /* restore the original form */
y = cdr(x); /* use sc->args as the new let */
sc->y = y;
set_curlet(sc, reuse_as_let(sc, x, sc->curlet));
if (is_symbol(car(sc->code)))
return (op_named_let_1(sc, y));
e = sc->curlet;
id = let_id(e);
for (x = car(sc->code); is_not_null(y); x = cdr(x)) {
s7_pointer sym = caar(x), args = cdr(y);
/* reuse the value cells as the new let slots */
reuse_as_slot(sc, y, sym, unchecked_car(y));
symbol_set_local_slot(sym, id, y);
slot_set_next(y, let_slots(e));
let_set_slots(e, y);
y = args;
}
sc->code = T_Pair(cdr(sc->code));
sc->y = sc->nil;
return (true);
}
static bool op_let(s7_scheme * sc)
{
/* sc->code is everything after the let: (let ((a 1)) a) so sc->code is (((a 1)) a) */
/* car can be either a list or a symbol ("named let") */
bool named_let;
sc->code = check_let(sc);
sc->value = sc->code;
named_let = is_symbol(car(sc->code));
sc->code = (named_let) ? cadr(sc->code) : car(sc->code);
if (is_null(sc->code)) { /* (let [name] () ...): no bindings, so skip that step */
sc->code = sc->value;
sc->curlet = make_let(sc, sc->curlet);
if (named_let) { /* see also below -- there are 3 cases */
s7_pointer body = cddr(sc->code);
set_opt2_int(cdr(sc->code), int_zero);
sc->x =
make_closure_unchecked(sc, sc->nil, body, T_CLOSURE, 0);
/* args = () in new closure, see NAMED_LET_NO_VARS above */
/* if this is a safe closure, we can build its let in advance and name it (a thunk in this case) */
set_funclet(closure_let(sc->x));
funclet_set_function(closure_let(sc->x), car(sc->code));
add_slot_checked(sc, sc->curlet, car(sc->code), sc->x);
sc->code = T_Pair(body);
sc->x = sc->nil;
} else
sc->code = T_Pair(cdr(sc->code));
return (true);
}
sc->args = sc->nil;
return (op_let1(sc));
}
static bool op_let_unchecked(s7_scheme * sc)
{ /* not named, but has vars */
s7_pointer x, code = cadr(sc->code);
sc->args = list_1(sc, cdr(sc->code));
x = cdar(code);
if (has_fx(x))
sc->value = fx_call(sc, x);
else {
push_stack(sc, OP_LET1, sc->args, cdr(code));
sc->code = car(x);
return (false); /* goto EVAL */
}
sc->code = cdr(code);
return (op_let1(sc));
}
static bool op_named_let(s7_scheme * sc)
{
sc->args = sc->nil;
sc->value = cdr(sc->code);
sc->code = cadr(sc->value);
return (op_let1(sc));
}
static void op_named_let_no_vars(s7_scheme * sc)
{
s7_pointer arg = cadr(sc->code);
sc->code = opt1_pair(sc->code); /* cdddr(sc->code) */
sc->curlet = make_let(sc, sc->curlet);
sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); /* sc->args is a temp here */
add_slot_checked(sc, sc->curlet, arg, sc->args);
}
static void op_named_let_a(s7_scheme * sc)
{
s7_pointer args;
args = cdr(sc->code);
sc->code = cddr(args);
sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) */
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->w = list_1_unchecked(sc, car(opt1_pair(args))); /* caaadr(args), subsequent calls will need a normal list of pars in closure_args */
sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 1); /* picks up curlet (this is the funclet?) */
add_slot(sc, sc->curlet, car(args), sc->x); /* the function */
sc->curlet = make_let_with_slot(sc, sc->curlet, car(sc->w), sc->args); /* why the second let? */
closure_set_let(sc->x, sc->curlet);
sc->x = sc->nil;
sc->w = sc->nil;
}
static void op_named_let_aa(s7_scheme * sc)
{
s7_pointer args;
args = cdr(sc->code);
sc->code = cddr(args);
sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) == init val of first par */
sc->value = fx_call(sc, cdr(opt3_pair(args))); /* cdadadr = init val of second */
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->w = list_2_unchecked(sc, car(opt1_pair(args)), car(opt3_pair(args))); /* subsequent calls will need a normal list of pars in closure_args */
sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 2); /* picks up curlet (this is the funclet?) */
add_slot(sc, sc->curlet, car(args), sc->x); /* the function */
sc->curlet =
make_let_with_two_slots(sc, sc->curlet, car(sc->w), sc->args,
cadr(sc->w), sc->value);
closure_set_let(sc->x, sc->curlet);
sc->x = sc->nil;
sc->w = sc->nil;
}
static bool op_named_let_fx(s7_scheme * sc)
{
s7_pointer p;
sc->code = cdr(sc->code);
for (p = cadr(sc->code), sc->args = sc->nil; is_pair(p); p = cdr(p)) {
sc->args = cons(sc, sc->value = fx_call(sc, cdar(p)), sc->args);
p = cdr(p);
if (!is_pair(p))
break;
sc->args = cons_unchecked(sc, sc->value =
fx_call(sc, cdar(p)), sc->args);
}
sc->args = proper_list_reverse_in_place(sc, sc->args);
return (op_named_let_1(sc, sc->args)); /* sc->code = (name vars . body), args = vals in decl order */
}
static void op_let_no_vars(s7_scheme * sc)
{
sc->curlet = make_let(sc, sc->curlet);
sc->code = T_Pair(cddr(sc->code)); /* ignore the () */
}
static void op_let_one_new(s7_scheme * sc)
{
sc->code = cdr(sc->code);
push_stack_no_args(sc, OP_LET_ONE_NEW_1, cdr(sc->code));
sc->code = opt2_pair(sc->code);
}
static void op_let_one_p_new(s7_scheme * sc)
{
sc->code = cdr(sc->code);
push_stack_no_args(sc, OP_LET_ONE_P_NEW_1, cdr(sc->code));
sc->code = T_Pair(opt2_pair(sc->code));
}
static void op_let_one_old(s7_scheme * sc)
{
sc->code = cdr(sc->code);
push_stack_no_args_direct(sc, OP_LET_ONE_OLD_1);
sc->code = opt2_pair(sc->code);
}
static void op_let_one_old_1(s7_scheme * sc)
{
s7_pointer let;
let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->code = cdr(sc->code);
}
static void op_let_one_p_old(s7_scheme * sc)
{
sc->code = cdr(sc->code);
push_stack_no_args_direct(sc, OP_LET_ONE_P_OLD_1);
sc->code = T_Pair(opt2_pair(sc->code));
}
static void op_let_one_p_old_1(s7_scheme * sc)
{
s7_pointer let;
let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->code = cadr(sc->code);
}
static Inline void op_let_a_new(s7_scheme * sc)
{
sc->code = cdr(sc->code);
sc->curlet =
make_let_with_slot(sc, sc->curlet, car(opt2_pair(sc->code)),
fx_call(sc, cdr(opt2_pair(sc->code))));
}
static Inline void op_let_a_old(s7_scheme * sc)
{
s7_pointer let;
sc->code = cdr(sc->code);
let =
update_let_with_slot(sc, opt3_let(sc->code),
fx_call(sc, cdr(opt2_pair(sc->code))));
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
}
static void op_let_a_a_new(s7_scheme * sc)
{
s7_pointer binding;
sc->code = cdr(sc->code);
binding = opt2_pair(sc->code);
sc->curlet =
make_let_with_slot(sc, sc->curlet, car(binding),
fx_call(sc, cdr(binding)));
sc->value = fx_call(sc, cdr(sc->code));
free_cell(sc, let_slots(sc->curlet));
free_cell(sc, sc->curlet);
/* upon return, we goto START, so sc->curlet should be ok */
}
static void op_let_a_a_old(s7_scheme * sc)
{ /* these are not called as fx*, and restoring sc->curlet has noticeable cost (e.g. 8 in thash) */
s7_pointer let;
sc->code = cdr(sc->code);
let =
update_let_with_slot(sc, opt3_let(sc->code),
fx_call(sc, cdr(opt2_pair(sc->code))));
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->value = fx_call(sc, cdr(sc->code));
}
static void op_let_a_fx_new(s7_scheme * sc)
{
s7_pointer binding, p;
sc->code = cdr(sc->code);
binding = opt2_pair(sc->code);
sc->curlet =
make_let_with_slot(sc, sc->curlet, car(binding),
fx_call(sc, cdr(binding)));
for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p))
fx_call(sc, p);
sc->value = fx_call(sc, p);
free_cell(sc, let_slots(sc->curlet));
free_cell(sc, sc->curlet);
}
/* this and others like it could easily be fx funcs, but check_let is called too late, so it's never seen as fxable */
static void op_let_a_fx_old(s7_scheme * sc)
{
s7_pointer let, p;
sc->code = cdr(sc->code);
let =
update_let_with_slot(sc, opt3_let(sc->code),
fx_call(sc, cdr(opt2_pair(sc->code))));
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p))
fx_call(sc, p);
sc->value = fx_call(sc, p);
}
static inline void op_let_opssq(s7_scheme * sc)
{
s7_pointer largs, in_val;
sc->code = cdr(sc->code);
largs = T_Pair(opt2_pair(sc->code)); /* cadr(caar(sc->code)); */
in_val = lookup(sc, cadr(largs));
set_car(sc->t2_2, lookup(sc, opt3_sym(cdr(sc->code)))); /* caddr(largs)); */
set_car(sc->t2_1, in_val);
sc->value = fn_proc(largs) (sc, sc->t2_1);
}
static inline void op_let_opassq(s7_scheme * sc)
{
s7_pointer in_val, lst;
sc->code = cdr(sc->code);
in_val = lookup(sc, opt2_sym(sc->code)); /* cadadr(caar(sc->code)); */
lst = lookup(sc, opt3_sym(cdr(sc->code)));
if (is_pair(lst))
sc->value = s7_assq(sc, in_val, lst);
else
sc->value =
(is_null(lst)) ? sc->F : g_assq(sc,
set_plist_2(sc, in_val, lst));
}
static void op_let_opssq_old(s7_scheme * sc)
{
s7_pointer let;
op_let_opssq(sc);
let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->code = T_Pair(cdr(sc->code));
}
static void op_let_opssq_new(s7_scheme * sc)
{
op_let_opssq(sc);
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value);
sc->code = T_Pair(cdr(sc->code));
}
static void op_let_opssq_e_old(s7_scheme * sc)
{
s7_pointer let;
op_let_opssq(sc);
let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->code = cadr(sc->code);
}
static void op_let_opssq_e_new(s7_scheme * sc)
{
op_let_opssq(sc);
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value);
sc->code = cadr(sc->code);
}
static void op_let_opassq_old(s7_scheme * sc)
{
s7_pointer let;
op_let_opassq(sc);
let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->code = T_Pair(cdr(sc->code));
}
static void op_let_opassq_new(s7_scheme * sc)
{
op_let_opassq(sc);
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value);
sc->code = T_Pair(cdr(sc->code));
}
static void op_let_opassq_e_old(s7_scheme * sc)
{
s7_pointer let;
op_let_opassq(sc);
let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->code = cadr(sc->code);
}
static void op_let_opassq_e_new(s7_scheme * sc)
{
op_let_opassq(sc);
sc->curlet = make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value); /* caaar(sc->code) = local variable name */
sc->code = cadr(sc->code);
}
static Inline void op_let_fx_new(s7_scheme * sc)
{
s7_pointer p, let;
let = make_simple_let(sc);
sc->args = let;
for (p = cadr(sc->code); is_pair(p); p = cdr(p)) {
s7_pointer arg = cdar(p);
sc->value = fx_call(sc, arg);
add_slot(sc, let, caar(p), sc->value);
}
sc->let_number++;
set_curlet(sc, let);
sc->code = T_Pair(cddr(sc->code));
}
static void op_let_fx_old(s7_scheme * sc)
{
s7_pointer p, slot, let = opt3_let(cdr(sc->code));
uint64_t id;
sc->args = let;
id = ++sc->let_number;
let_set_id(let, id);
let_set_outlet(let, sc->curlet);
for (p = cadr(sc->code), slot = let_slots(let); is_pair(p);
p = cdr(p), slot = next_slot(slot)) {
/* GC protected because it's a permanent let? or perhaps use sc->args? */
slot_set_value(slot, fx_call(sc, cdar(p)));
symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot);
}
set_curlet(sc, let);
sc->code = T_Pair(cddr(sc->code));
}
static void op_let_2a_new(s7_scheme * sc)
{ /* 2 vars, 1 expr in body */
/* opt1|2 free */
s7_pointer a1, a2, code = cdr(sc->code);
a1 = opt1_pair(code); /* caar(code) */
a2 = opt2_pair(code); /* cadar(code) */
sc->curlet =
make_let_with_two_slots(sc, sc->curlet, car(a1),
fx_call(sc, cdr(a1)), car(a2), fx_call(sc,
cdr
(a2)));
sc->code = cadr(code);
}
static inline void op_let_2a_old(s7_scheme * sc)
{ /* 2 vars, 1 expr in body */
s7_pointer let, code = cdr(sc->code);
let =
update_let_with_two_slots(sc, opt3_let(code),
fx_call(sc, cdr(opt1_pair(code))),
fx_call(sc, cdr(opt2_pair(code))));
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->code = cadr(code);
}
static void op_let_3a_new(s7_scheme * sc)
{ /* 3 vars, 1 expr in body */
s7_pointer a1, a2, a3, code = cdr(sc->code);
a1 = caar(code);
a2 = opt1_pair(code); /* cadar */
a3 = opt2_pair(code); /* caddar */
sc->curlet =
make_let_with_two_slots(sc, sc->curlet, car(a1),
fx_call(sc, cdr(a1)), car(a2), fx_call(sc,
cdr
(a2)));
add_slot(sc, sc->curlet, car(a3), fx_call(sc, cdr(a3)));
sc->code = cadr(code);
}
static void op_let_3a_old(s7_scheme * sc)
{ /* 3 vars, 1 expr in body */
s7_pointer let, code = cdr(sc->code);
let =
update_let_with_three_slots(sc, opt3_let(code),
fx_call(sc, cdr(caar(code))),
fx_call(sc, cdr(opt1_pair(code))),
fx_call(sc, cdr(opt2_pair(code))));
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
sc->code = cadr(code);
}
/* -------------------------------- let* -------------------------------- */
static bool check_let_star(s7_scheme * sc)
{
s7_pointer vars, form = sc->code, code;
bool named_let, fxable = true;
code = cdr(form);
if (!is_pair(code)) /* (let* . 1) */
eval_error(sc, "let* variable list is messed up: ~A", 35, form);
if (!is_pair(cdr(code))) /* (let* ()) */
eval_error(sc, "let* has no body: ~A", 20, form);
named_let = (is_symbol(car(code)));
if (named_let) {
if (!is_list(cadr(code))) /* (let* hi #t) */
eval_error(sc, "let* variable list is messed up: ~A", 35,
form);
if (!is_pair(cddr(code))) { /* (let* hi () . =>) or (let* hi () ) */
if (is_null(cddr(code)))
eval_error(sc, "named let* has no body: ~A", 26, form);
else
eval_error(sc, "named let* stray dot? ~A", 24, form);
}
if (is_constant_symbol(sc, car(code)))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc, cant_bind_immutable_string, form));
set_local(car(code));
} else if (!is_list(car(code))) /* (let* x ... ) */
eval_error(sc, "let* variable declaration value is missing: ~A",
46, form);
for (vars = ((named_let) ? cadr(code) : car(code)); is_pair(vars);
vars = cdr(vars)) {
s7_pointer var_and_val, var;
var_and_val = car(vars);
if (!is_pair(var_and_val)) /* (let* (3) ... */
eval_error(sc, "let* variable list is messed up? ~A", 35,
var_and_val);
/* no check for repeated var (unlike lambda* and named let*) */
if (!(is_pair(cdr(var_and_val)))) { /* (let* ((x . 1))...) */
if (is_null(cdr(var_and_val)))
eval_error(sc,
"let* variable declaration, but no value?: ~A",
44, var_and_val);
else
eval_error(sc,
"let* variable declaration is not a proper list?: ~A",
51, var_and_val);
}
if (!is_null(cddr(var_and_val))) /* (let* ((c 1 2)) ...) */
eval_error(sc,
"let* variable declaration has more than one value?: ~A",
54, var_and_val);
var = car(var_and_val);
if (!(is_symbol(var))) /* (let* ((3 1)) 1) */
eval_error(sc, "bad variable ~S in let* (it is not a symbol)",
44, var);
if (is_constant_symbol(sc, var)) /* (let* ((pi 3)) ...) */
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc, cant_bind_immutable_string,
var_and_val));
if ((named_let) && (symbol_is_in_arg_list(var, cdr(vars)))) /* (let* loop ((a 1) (a 2)) ...) -- added 2-Dec-19 */
eval_error(sc,
"named let* parameter '~A is used twice in the parameter list",
60, var);
/* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error. */
set_local(var);
}
if (!is_null(vars))
eval_error(sc, "let* variable list is not a proper list?: ~A", 44,
vars);
if (!s7_is_proper_list(sc, cdr(code)))
eval_error(sc, "stray dot in let* body: ~S", 26, cdr(code));
for (vars = (named_let) ? cadr(code) : car(code); is_pair(vars);
vars = cdr(vars))
if (is_fxable(sc, cadar(vars)))
set_fx_direct(cdar(vars),
fx_choose(sc, cdar(vars), sc->curlet,
let_star_symbol_is_safe));
else
fxable = false;
if (named_let) {
if (is_null(cadr(code))) {
pair_set_syntax_op(form, OP_NAMED_LET_NO_VARS);
set_opt1_pair(form, cdddr(form));
} else {
pair_set_syntax_op(form, OP_NAMED_LET_STAR);
set_opt2_con(code, cadr(caadr(code)));
}
} else if (is_null(car(code)))
pair_set_syntax_op(form, OP_LET_NO_VARS); /* (let* () ...) */
else if (is_null(cdar(code))) {
check_let_one_var(sc, form, car(code)); /* (let* ((var...))...) -> (let ((var...))...) */
if (optimize_op(form) >= OP_LET_FX_OLD) {
if ((!in_heap(form)) &&
(body_is_safe(sc, sc->unused, cdr(code), true) >=
SAFE_BODY))
set_opt3_let(code, make_permanent_let(sc, car(code)));
else {
set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */
set_opt3_let(code, sc->nil);
}
}
} else { /* multiple variables */
s7_pointer last_var;
if (fxable) {
pair_set_syntax_op(form, OP_LET_STAR_FX);
if ((is_null(cddr(code))) && (is_fxable(sc, cadr(code)))) {
fx_annotate_arg(sc, cdr(code), sc->curlet);
pair_set_syntax_op(form, OP_LET_STAR_FX_A);
}
} else
pair_set_syntax_op(form, OP_LET_STAR2);
set_opt2_con(code, cadaar(code));
for (last_var = caaar(code), vars = cdar(code); is_pair(vars);
last_var = caar(vars), vars = cdr(vars))
if (has_fx(cdar(vars)))
fx_tree(sc, cdar(vars), last_var, NULL, NULL, true); /* actually there's isn't a new let unless it's needed */
}
/* let_star_unchecked... */
if (named_let) { /* (is_symbol(car(code))) */
sc->value = cdr(code);
if (is_null(car(sc->value))) {
s7_pointer cx = car(code);
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->code = T_Pair(cdr(sc->value));
add_slot_checked(sc, sc->curlet, cx,
make_closure_unchecked(sc, sc->nil, sc->code,
T_CLOSURE_STAR, 0));
return (false);
}
} else if (is_null(car(code))) {
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->code = T_Pair(cdr(code));
return (false);
}
if (named_let) { /* is_symbol(car(code))) */
push_stack(sc, OP_LET_STAR1, code, cadr(code));
sc->code = cadr(caadr(code));
} else {
push_stack(sc, OP_LET_STAR1, code, car(code));
/* args is the let body, saved for later, code is the list of vars+initial-values */
sc->code = cadr(caar(code));
/* caar(code) = first var/val pair, we've checked that all these guys are legit, so cadr of that is the value */
}
return (true);
}
static inline bool op_let_star1(s7_scheme * sc)
{
uint64_t let_counter = S7_INT64_MAX;
while (true) {
if (let_counter == sc->capture_let_counter)
add_slot_checked(sc, sc->curlet, caar(sc->code), sc->value);
else {
sc->curlet =
make_let_with_slot(sc, sc->curlet, caar(sc->code),
sc->value);
let_counter = sc->capture_let_counter;
}
sc->code = cdr(sc->code);
if (is_pair(sc->code)) {
s7_pointer x = cdar(sc->code);
if (has_fx(x))
sc->value = fx_call(sc, x);
else {
push_stack_direct(sc, OP_LET_STAR1);
sc->code = car(x);
return (true);
}
} 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 */
s7_pointer body = cddr(sc->code), args = cadr(sc->code);
add_slot_checked(sc, sc->curlet, car(sc->code),
make_closure_unchecked(sc, args, body,
T_CLOSURE_STAR,
(is_null(args)) ? 0 :
CLOSURE_ARITY_NOT_SET));
sc->code = body;
} else
sc->code = T_Pair(cdr(sc->code));
return (false);
}
static void op_let_star_fx(s7_scheme * sc)
{
/* fx safe does not mean we can dispense with the inner lets (curlet is safe for example) */
s7_pointer p;
uint64_t let_counter = S7_INT64_MAX;
sc->code = cdr(sc->code);
for (p = car(sc->code); is_pair(p); p = cdr(p)) {
s7_pointer val;
val = fx_call(sc, cdar(p)); /* eval in outer let */
if (let_counter == sc->capture_let_counter)
add_slot_checked(sc, sc->curlet, caar(p), val);
else {
sc->curlet = make_let_with_slot(sc, sc->curlet, caar(p), val);
let_counter = sc->capture_let_counter;
}
}
sc->code = T_Pair(cdr(sc->code));
}
static void op_let_star_fx_a(s7_scheme * sc)
{
s7_pointer p;
uint64_t let_counter = S7_INT64_MAX;
sc->code = cdr(sc->code);
for (p = car(sc->code); is_pair(p); p = cdr(p)) {
s7_pointer val;
val = fx_call(sc, cdar(p));
if (let_counter == sc->capture_let_counter)
add_slot_checked(sc, sc->curlet, caar(p), val);
else {
sc->curlet = make_let_with_slot(sc, sc->curlet, caar(p), val);
let_counter = sc->capture_let_counter;
}
}
sc->value = fx_call(sc, cdr(sc->code));
}
static void op_named_let_star(s7_scheme * sc)
{
s7_pointer code = cdr(sc->code);
push_stack(sc, OP_LET_STAR1, code, cadr(code));
sc->code = opt2_con(code);
}
static void op_let_star2(s7_scheme * sc)
{
s7_pointer code = cdr(sc->code);
push_stack(sc, OP_LET_STAR1, code, car(code));
sc->code = opt2_con(code);
}
/* -------------------------------- letrec, letrec* -------------------------------- */
static void check_letrec(s7_scheme * sc, bool letrec)
{
s7_pointer x, caller, code = cdr(sc->code);
caller = (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol;
if ((!is_pair(code)) || /* (letrec . 1) */
(!is_list(car(code)))) /* (letrec 1 ...) */
eval_error_with_caller(sc, "~A: variable list is messed up: ~A",
34, caller, sc->code);
if (!is_pair(cdr(code))) /* (letrec ()) */
eval_error_with_caller(sc, "~A has no body: ~A", 18, caller,
sc->code);
clear_symbol_list(sc);
for (x = car(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",
34, caller, sc->code);
carx = car(x);
if (!is_pair(carx)) /* (letrec (1 2) #t) */
eval_error_with_caller(sc,
"~A: bad variable ~S (should be a pair (name value))",
51, caller, carx);
if (!(is_symbol(car(carx))))
eval_error_with_caller(sc,
"~A: bad variable ~S (it is not a symbol)",
40, caller, carx);
y = car(carx);
if (is_constant_symbol(sc, y))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc, cant_bind_immutable_string, 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",
42, caller, carx);
eval_error_with_caller(sc,
"~A: variable declaration is not a proper list?: ~A",
50, 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",
53, 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_is_in_list(sc, y))
eval_error_with_caller(sc, "~A: duplicate identifier: ~A", 28,
caller, y);
add_symbol_to_list(sc, y);
set_local(y);
}
if (!s7_is_proper_list(sc, cdr(code)))
eval_error_with_caller(sc, "stray dot in ~A body: ~S", 24, caller,
cdr(code));
for (x = car(code); is_pair(x); x = cdr(x))
if (is_fxable(sc, cadar(x)))
set_fx_direct(cdar(x),
fx_choose(sc, cdar(x), sc->curlet,
let_symbol_is_safe_or_listed));
pair_set_syntax_op(sc->code,
(letrec) ? OP_LETREC_UNCHECKED :
OP_LETREC_STAR_UNCHECKED);
}
static s7_pointer make_funclet(s7_scheme * sc, s7_pointer new_func,
s7_pointer func_name, s7_pointer outer_let);
static void letrec_setup_closures(s7_scheme * sc)
{
s7_pointer slot;
for (slot = let_slots(sc->curlet); tis_slot(slot);
slot = next_slot(slot))
if (is_closure(slot_value(slot))) {
s7_pointer func = slot_value(slot);
if ((!is_safe_closure(func)) ||
(!is_optimized(car(closure_body(func)))))
optimize_lambda(sc, true, slot_symbol(slot),
closure_args(func), closure_body(func));
if (is_safe_closure_body(closure_body(func))) {
set_safe_closure(func);
if (is_very_safe_closure_body(closure_body(func)))
set_very_safe_closure(func);
}
make_funclet(sc, func, slot_symbol(slot), closure_let(func));
/* else closure_set_let(new_func, sc->curlet); -- maybe funclet not needed here? */
}
}
static void op_letrec2(s7_scheme * sc)
{
s7_pointer slot;
for (slot = let_slots(sc->curlet); tis_slot(slot);
slot = next_slot(slot))
if (is_checked_slot(slot))
slot_set_value(slot, slot_pending_value(slot));
letrec_setup_closures(sc);
}
static bool op_letrec_unchecked(s7_scheme * sc)
{
s7_pointer code = cdr(sc->code);
/* get all local vars and set to #<undefined>
* get parallel list of values
* eval each member of values list with let still full of #<undefined>'s
* assign each value to its variable
* eval body
* which means that (letrec ((x x)) x) is not an error!
* but this assumes the environment is not changed by evaluating the exprs?
* (letrec ((a (define b 1))) b) -- if let, the define takes place in the calling let, not the current let
* (letrec ((f1 (lambda (x) (f2 (* 2 x))))) (define (f2 y) (- y 1)) (f1 3)) -> 5 (Guile says unbound f2)
* I think I need to check here that slot_pending_value is set (using the is_checked bit below):
* (letrec ((i (begin (define xyz 37) 0))) (curlet)): (inlet 'i 0 'xyz 37) -- is this correct?
*/
sc->curlet = make_let_slowly(sc, sc->curlet);
if (is_pair(car(code))) {
s7_pointer x, slot;
for (x = car(code); is_not_null(x); x = cdr(x)) {
slot =
add_slot_checked(sc, sc->curlet, caar(x), sc->undefined);
slot_set_pending_value(slot, sc->undefined);
slot_set_expression(slot, cdar(x));
set_checked_slot(slot);
}
for (slot = let_slots(sc->curlet);
tis_slot(slot) && (has_fx(slot_expression(slot)));
slot = next_slot(slot))
slot_set_pending_value(slot,
fx_call(sc, slot_expression(slot)));
if (tis_slot(slot)) {
push_stack(sc, OP_LETREC1, slot, code);
sc->code = car(slot_expression(slot));
return (true);
}
op_letrec2(sc);
}
sc->code = T_Pair(cdr(code));
return (false);
}
static bool op_letrec1(s7_scheme * sc)
{
s7_pointer slot;
slot_set_pending_value(sc->args, sc->value);
for (slot = next_slot(sc->args);
tis_slot(slot) && (has_fx(slot_expression(slot)));
slot = next_slot(slot))
slot_set_pending_value(slot, fx_call(sc, slot_expression(slot)));
if (tis_slot(slot)) {
push_stack(sc, OP_LETREC1, slot, sc->code);
sc->code = car(slot_expression(slot));
return (true);
}
op_letrec2(sc);
sc->code = T_Pair(cdr(sc->code));
return (false);
}
static bool op_letrec_star_unchecked(s7_scheme * sc)
{
s7_pointer slot, code = cdr(sc->code);
/* get all local vars and set to #<undefined>
* eval each member of values list and assign immediately, as in let*
* eval body
*/
sc->curlet = make_let_slowly(sc, sc->curlet);
if (is_pair(car(code))) {
s7_pointer x;
for (x = car(code); is_not_null(x); x = cdr(x)) {
slot =
add_slot_checked(sc, sc->curlet, caar(x), sc->undefined);
slot_set_expression(slot, cdar(x));
}
let_set_slots(sc->curlet,
reverse_slots(sc, let_slots(sc->curlet)));
for (slot = let_slots(sc->curlet);
tis_slot(slot) && (has_fx(slot_expression(slot)));
slot = next_slot(slot))
slot_set_value(slot, fx_call(sc, slot_expression(slot)));
if (tis_slot(slot)) {
push_stack(sc, OP_LETREC_STAR1, slot, code);
sc->code = car(slot_expression(slot));
return (true);
}
}
sc->code = T_Pair(cdr(code));
return (false);
}
static bool op_letrec_star1(s7_scheme * sc)
{
s7_pointer slot = sc->args;
slot_set_value(slot, sc->value);
for (slot = next_slot(slot);
tis_slot(slot) && (has_fx(slot_expression(slot)));
slot = next_slot(slot))
slot_set_value(slot, fx_call(sc, slot_expression(slot)));
if (tis_slot(slot)) {
push_stack(sc, OP_LETREC_STAR1, slot, sc->code);
sc->code = car(slot_expression(slot));
return (true);
}
letrec_setup_closures(sc);
sc->code = T_Pair(cdr(sc->code));
return (false);
}
/* -------------------------------- let-temporarily -------------------------------- */
static void check_let_temporarily(s7_scheme * sc)
{
s7_pointer x, form = sc->code, code;
bool all_fx, all_s7;
code = cdr(form);
if ((!is_pair(code)) || /* (let-temporarily . 1) */
(!is_list(car(code)))) /* (let-temporarily 1 ...) */
eval_error(sc, "let-temporarily: variable list is messed up: ~A",
47, form);
/* cdr(code) = body can be nil */
all_fx = is_pair(car(code));
all_s7 = all_fx;
for (x = car(code); is_not_null(x); x = cdr(x)) {
s7_pointer carx;
if (!is_pair(x)) /* (let-temporarily ((a 1) . 2) ...) */
eval_error(sc,
"let-temporarily: improper list of variables? ~A",
47, form);
carx = car(x);
if (!is_pair(carx)) /* (let-temporarily (1 2) #t) */
eval_error(sc,
"let-temporarily: bad variable ~S (it should be a pair (name value))",
67, carx);
if (is_symbol(car(carx))) {
if (is_constant_symbol(sc, car(carx))) /* (let-temporarily ((pi 3)) ...) */
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc, cant_bind_immutable_string, x));
if (is_syntactic_symbol(car(carx))) /* (let-temporarily ((if 3)) ...) */
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_2(sc,
wrap_string(sc, "can't set! ~A", 13),
car(carx)));
} else if (!is_pair(car(carx))) /* (let-temporarily ((1 2)) ...) */
eval_error(sc,
"let-temporarily: bad variable ~S (the name should be a symbol or a pair)",
73, carx);
if (!is_pair(cdr(carx))) /* (let-temporarily ((x . 1))...) */
eval_error(sc,
"let-temporarily: variable declaration value is messed up: ~S",
60, carx);
if (is_not_null(cddr(carx))) /* (let-temporarily ((x 1 2 3)) ...) */
eval_error(sc,
"let-temporarily: variable declaration has more than one value?: ~A",
66, carx);
if ((all_fx) &&
((!is_symbol(car(carx))) || (!is_fxable(sc, cadr(carx)))))
all_fx = false;
if ((all_s7) &&
((!is_pair(car(carx))) || (caar(carx) != sc->s7_let_symbol) ||
(!is_quoted_symbol(cadar(carx)))
|| (is_keyword(cadr(cadar(carx))))
|| (!is_fxable(sc, cadr(carx)))))
all_s7 = false;
}
if (!s7_is_proper_list(sc, cdr(code)))
eval_error(sc, "stray dot in let-temporarily body: ~S", 37,
cdr(code));
if ((all_fx) || (all_s7)) {
pair_set_syntax_op(form,
(all_fx) ? ((is_null(cdar(code))) ?
OP_LET_TEMP_FX_1 : OP_LET_TEMP_FX) :
OP_LET_TEMP_S7);
for (x = car(code); is_pair(x); x = cdr(x))
fx_annotate_arg(sc, cdar(x), sc->curlet);
if ((optimize_op(form) == OP_LET_TEMP_FX_1) && (is_pair(cdr(code)))
&& (is_null(cddr(code))) && (is_fxable(sc, cadr(code)))) {
fx_annotate_arg(sc, cdr(code), sc->curlet);
pair_set_syntax_op(form, OP_LET_TEMP_A_A);
}
} else {
pair_set_syntax_op(form, OP_LET_TEMP_UNCHECKED);
if ((is_pair(car(code))) && (is_null(cdar(code)))
&& (is_pair(caar(code)))) {
s7_pointer var = caar(code), val;
val = cadr(var);
var = car(var);
if ((is_pair(var)) && (car(var) == sc->setter_symbol)
&& (is_pair(cdr(var))) && (is_pair(cddr(var)))
&& (val == sc->F)) {
optimize_expression(sc, cadr(var), 0, sc->curlet, false);
optimize_expression(sc, caddr(var), 0, sc->curlet, false);
if ((is_fxable(sc, cadr(var)))
&& (is_fxable(sc, caddr(var)))) {
fx_annotate_args(sc, cdr(var), sc->curlet);
pair_set_syntax_op(form, OP_LET_TEMP_SETTER);
}
}
}
}
}
static void op_let_temp_unchecked(s7_scheme * sc)
{
sc->code = cdr(sc->code); /* step past let-temporarily */
sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil);
push_stack_direct(sc, OP_GC_PROTECT);
/* sc->args: varlist, settees, old_values, new_values */
}
static bool op_let_temp_init1(s7_scheme * sc)
{
while (is_pair(car(sc->args))) {
/* eval car, add result to old-vals list, if any vars undefined, error */
s7_pointer binding = caar(sc->args), settee, new_value;
settee = car(binding);
new_value = cadr(binding);
cadr(sc->args) = cons(sc, settee, cadr(sc->args));
binding = cdddr(sc->args);
set_car(binding, cons_unchecked(sc, new_value, car(binding)));
car(sc->args) = cdar(sc->args);
if (is_symbol(settee)) /* get initial values */
set_caddr(sc->args,
cons_unchecked(sc, lookup_checked(sc, settee),
caddr(sc->args)));
else {
if (is_pair(settee)) {
push_stack_direct(sc, OP_LET_TEMP_INIT1);
sc->code = settee;
return (true);
}
set_caddr(sc->args,
cons_unchecked(sc, new_value, caddr(sc->args)));
}
}
car(sc->args) = cadr(sc->args);
return (false);
}
typedef enum { goto_start, goto_begin, fall_through, goto_do_end_clauses,
goto_safe_do_end_clauses,
goto_eval, goto_apply_lambda, goto_do_end, goto_top_no_pop, goto_apply,
goto_eval_args, goto_eval_args_top, goto_do_unchecked,
goto_pop_read_list,
goto_read_tok, goto_feed_to
} goto_t;
static goto_t op_let_temp_init2(s7_scheme * sc)
{
/* now eval set car new-val, cadr=settees, cadddr=new_values */
while (is_pair(car(sc->args))) {
s7_pointer settee = caar(sc->args), new_value, slot, p =
cdddr(sc->args);
new_value = caar(p);
set_car(p, cdar(p));
car(sc->args) = cdar(sc->args);
if ((!is_symbol(settee)) || (is_pair(new_value))) {
if (is_symbol(settee)) {
push_stack_direct(sc, OP_LET_TEMP_INIT2); /* (let-temporarily (((*s7* 'print-length) 32)) ...) */
push_stack_no_args(sc, OP_SET_FROM_LET_TEMP, settee);
sc->code = new_value;
return (goto_eval);
}
sc->code = set_plist_3(sc, sc->set_symbol, settee, new_value);
push_stack_direct(sc, OP_EVAL_DONE);
eval(sc, OP_SET_UNCHECKED);
continue;
}
slot = lookup_slot_from(settee, sc->curlet);
if (!is_slot(slot))
unbound_variable_error(sc, settee);
if (is_immutable_slot(slot))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->let_temporarily_symbol,
settee));
if (is_symbol(new_value))
new_value = lookup_checked(sc, new_value);
/* if ((symbol_has_setter(settee)) && (!slot_has_setter(slot))) settee is local with no setter, but its global binding does have a setter */
if (slot_has_setter(slot))
slot_set_value(slot, call_setter(sc, slot, new_value));
else
slot_set_value(slot, new_value);
}
car(sc->args) = cadr(sc->args);
pop_stack(sc);
sc->code = cdr(sc->code);
if (is_pair(sc->code)) {
push_stack_direct(sc, OP_LET_TEMP_DONE);
return (goto_begin);
}
sc->value = sc->nil; /* so (let-temporarily (<vars)) -> () like begin I guess */
return (fall_through);
}
static bool op_let_temp_done1(s7_scheme * sc)
{
while (is_pair(car(sc->args))) {
s7_pointer settee = caar(sc->args), p = cddr(sc->args);
sc->value = caar(p);
set_car(p, cdar(p));
car(sc->args) = cdar(sc->args);
if ((is_pair(settee)) && (car(settee) == sc->s7_let_symbol) && /* (let-temporarily (((*s7* (symbol "print-length")) 43))...) */
((is_keyword(cadr(settee))) || ((is_pair(cadr(settee)))
&& (caadr(settee) ==
sc->quote_symbol)
&&
(is_symbol(cadadr(settee))))))
{
s7_pointer sym = cadr(settee);
if (is_pair(sym))
sym = cadr(sym);
g_s7_let_set_fallback(sc,
set_plist_3(sc, sc->s7_let, sym,
sc->value));
} else {
s7_pointer slot;
if (!is_symbol(settee)) {
if ((is_pair(sc->value)) || (is_symbol(sc->value)))
sc->code =
set_plist_3(sc, sc->set_symbol, settee,
set_plist_2(sc, sc->quote_symbol,
sc->value));
else
sc->code =
set_plist_3(sc, sc->set_symbol, settee, sc->value);
push_stack_direct(sc, OP_EVAL_DONE);
eval(sc, OP_SET_UNCHECKED);
continue;
}
slot = lookup_slot_from(settee, sc->curlet);
if (is_immutable_slot(slot))
immutable_object_error(sc,
set_elist_3(sc,
immutable_error_string,
sc->let_temporarily_symbol,
settee));
if (slot_has_setter(slot)) /* maybe setter changed in let-temp body? else setter has already checked the init value */
slot_set_value(slot, call_setter(sc, slot, sc->value));
else
slot_set_value(slot, sc->value);
}
}
pop_stack(sc); /* remove the gc_protect */
sc->value = sc->code;
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
return (true); /* goto start */
}
static bool op_let_temp_s7(s7_scheme * sc)
{ /* all entries are of the form ((*s7* 'field) fx-able-value) */
s7_pointer p;
s7_pointer *end = sc->stack_end;
sc->code = cdr(sc->code);
for (p = car(sc->code); is_pair(p); p = cdr(p)) {
s7_pointer old_value, field = cadadr(caar(p)); /* p: (((*s7* 'expansions?) #f)) -- no keywords here (see check_let_temporarily) */
old_value =
g_s7_let_ref_fallback(sc, set_plist_2(sc, sc->s7_let, field));
push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field);
}
for (p = car(sc->code); is_pair(p); p = cdr(p), end += 4)
g_s7_let_set_fallback(sc,
set_plist_3(sc, sc->s7_let, end[0],
fx_call(sc, cdar(p))));
sc->code = cdr(sc->code);
return (is_pair(sc->code)); /* sc->code can be null if no body */
}
static void let_temp_done(s7_scheme * sc, s7_pointer args, s7_pointer code,
s7_pointer let)
{
/* called in call/cc, call-with-exit and, catch (unwind to catch) */
/* check_stack_size(sc); *//* 4-May-21 t101 36/38, but this is an infinite loop if stack resize raises an error (hit if eval is passed a circular list!) */
push_stack_direct(sc, OP_EVAL_DONE);
sc->args = T_Pos(args);
sc->code = code;
set_curlet(sc, let);
eval(sc, OP_LET_TEMP_DONE);
}
static void let_temp_unwind(s7_scheme * sc, s7_pointer slot,
s7_pointer new_value)
{
if (slot_has_setter(slot)) { /* setter has to be called because it might affect other vars (*clm-srate* -> mus-srate etc), but it should not change sc->value */
s7_pointer old_value = sc->value;
slot_set_value(slot, call_setter(sc, slot, new_value)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); */
sc->value = old_value;
} else
slot_set_value(slot, new_value);
}
static bool op_let_temp_fx(s7_scheme * sc)
{ /* all entries are of the form (symbol fx-able-value) */
s7_pointer p, var, settee, new_val, slot;
s7_pointer *end = sc->stack_end;
sc->code = cdr(sc->code);
for (p = car(sc->code); is_pair(p); p = cdr(p)) {
var = car(p);
settee = car(var);
slot = lookup_slot_from(settee, sc->curlet);
if (!is_slot(slot))
unbound_variable_error(sc, settee);
if (is_immutable_slot(slot))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->let_temporarily_symbol,
settee));
push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot);
}
for (p = car(sc->code); is_pair(p); p = cdr(p), end += 4) {
var = car(p);
settee = car(var);
new_val = fx_call(sc, cdr(var));
slot = end[0];
if (slot_has_setter(slot))
slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */
else
slot_set_value(slot, new_val);
}
sc->code = cdr(sc->code);
return (is_pair(sc->code)); /* sc->code can be null if no body */
}
static bool op_let_temp_fx_1(s7_scheme * sc)
{ /* one entry */
s7_pointer var, settee, new_val, slot;
sc->code = cdr(sc->code);
var = caar(sc->code);
settee = car(var);
slot = lookup_slot_from(settee, sc->curlet);
if (!is_slot(slot))
unbound_variable_error(sc, settee);
if (is_immutable_slot(slot))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->let_temporarily_symbol,
settee));
push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot);
new_val = fx_call(sc, cdr(var));
if (slot_has_setter(slot))
slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */
else
slot_set_value(slot, new_val);
sc->code = cdr(sc->code);
return (is_pair(sc->code)); /* sc->code can be null if no body */
}
static s7_pointer fx_let_temp_a_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer result;
op_let_temp_fx_1(sc);
result = fx_call(sc, sc->code);
pop_stack(sc);
let_temp_unwind(sc, sc->code, sc->args);
return (result);
}
static bool op_let_temp_setter(s7_scheme * sc)
{
s7_pointer var, slot, sym, e;
sc->code = cdr(sc->code);
var = caaar(sc->code);
sym = fx_call(sc, cdr(var));
e = sc->curlet;
set_curlet(sc, fx_call(sc, cddr(var)));
slot = lookup_slot_from(sym, sc->curlet);
set_curlet(sc, e);
push_stack(sc, OP_LET_TEMP_SETTER_UNWIND, slot_setter(slot), slot);
slot_set_setter(slot, sc->F);
sc->code = cdr(sc->code);
return (is_pair(sc->code)); /* sc->code can be null if no body */
}
static void op_let_temp_unwind(s7_scheme * sc)
{
let_temp_unwind(sc, sc->code, sc->args);
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
}
static void op_let_temp_s7_unwind(s7_scheme * sc)
{
g_s7_let_set_fallback(sc,
set_plist_3(sc, sc->s7_let, sc->code, sc->args));
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
}
static void op_let_temp_setter_unwind(s7_scheme * sc)
{
slot_set_setter(sc->code, sc->args);
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
}
/* -------------------------------- quote -------------------------------- */
static inline s7_pointer check_quote(s7_scheme * sc, s7_pointer code)
{
if (!is_pair(cdr(code))) { /* (quote . -1) */
if (is_null(cdr(code)))
eval_error(sc, "quote: not enough arguments: ~A", 31, code);
eval_error(sc, "quote: stray dot?: ~A", 21, code);
}
if (is_not_null(cddr(code))) /* (quote . (1 2)) or (quote 1 1) */
eval_error(sc, "quote: too many arguments ~A", 28, code);
pair_set_syntax_op(code, OP_QUOTE_UNCHECKED);
return (cadr(code));
}
/* -------------------------------- and -------------------------------- */
static bool check_and(s7_scheme * sc, s7_pointer expr)
{
/* this and check_or and check_if might not be called -- optimize_syntax can short-circuit it to return fx* choices */
s7_pointer p, code = cdr(expr);
int32_t any_nils = 0, len;
if (is_null(code)) {
sc->value = sc->T;
return (true);
}
for (len = 0, p = code; is_pair(p); p = cdr(p), len++) {
s7_function callee;
callee = (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, let_symbol_is_safe); /* fx_proc can be nil! */
if (!callee)
any_nils++;
set_fx(p, callee);
}
if (is_not_null(p)) /* (and . 1) (and #t . 1) */
eval_error(sc, "and: stray dot?: ~A", 19, expr);
if ((fx_proc(code)) && (is_proper_list_1(sc, cdr(code)))) {
if ((fx_proc(code) == fx_is_pair_s)
|| (fx_proc(code) == fx_is_pair_t)) {
pair_set_syntax_op(expr, OP_AND_PAIR_P);
set_opt3_sym(expr, cadar(code));
set_opt2_con(expr, cadr(code));
} else
pair_set_syntax_op(expr,
(any_nils > 0) ? OP_AND_AP : OP_AND_2A);
} else {
pair_set_syntax_op(expr, (any_nils > 0) ? OP_AND_P : OP_AND_N);
if ((any_nils == 1) && (len > 2)) {
if (!has_fx(code))
pair_set_syntax_op(expr, OP_AND_SAFE_P1);
else if (!has_fx(cdr(code)))
pair_set_syntax_op(expr, OP_AND_SAFE_P2);
else if ((!has_fx(cddr(code))) && (len == 3))
pair_set_syntax_op(expr, OP_AND_SAFE_P3);
}
}
return (false);
}
static bool op_and_pair_p(s7_scheme * sc)
{
if (!is_pair(lookup(sc, opt3_sym(sc->code)))) { /* cadadr(sc->code) */
sc->value = sc->F;
return (true);
}
sc->code = opt2_con(sc->code); /* caddr(sc->code); */
return (false);
}
static bool op_and_ap(s7_scheme * sc)
{
/* we know fx_proc is set on sc->code, and there are only two branches */
if (is_false(sc, fx_call(sc, cdr(sc->code)))) {
sc->value = sc->F;
return (true);
}
sc->code = caddr(sc->code);
return (false);
}
static void op_and_safe_p1(s7_scheme * sc)
{ /* sc->code: (and (func...) (fx...)...) */
sc->code = cdr(sc->code); /* new value will be pushed below */
push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST);
sc->code = car(sc->code);
}
static bool op_and_safe_p2(s7_scheme * sc)
{
sc->value = fx_call(sc, cdr(sc->code));
if (is_false(sc, sc->value))
return (true);
sc->code = cddr(sc->code);
push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST);
sc->code = car(sc->code);
return (false);
}
static bool op_and_safe_p3(s7_scheme * sc)
{
sc->value = fx_call(sc, cdr(sc->code));
if (is_false(sc, sc->value))
return (true);
sc->code = cddr(sc->code);
sc->value = fx_call(sc, sc->code);
if (is_false(sc, sc->value))
return (true);
sc->code = cadr(sc->code);
return (false);
}
/* -------------------------------- or -------------------------------- */
static bool check_or(s7_scheme * sc, s7_pointer expr)
{
s7_pointer p, code = cdr(expr);
bool any_nils = false;
if (is_null(code)) {
sc->value = sc->F;
return (true);
}
for (p = code; is_pair(p); p = cdr(p)) {
s7_function callee;
callee =
(has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet,
let_symbol_is_safe);
if (!callee)
any_nils = true;
set_fx(p, callee);
}
if (is_not_null(p))
eval_error(sc, "or: stray dot?: ~A", 18, expr);
if ((fx_proc(code)) && (is_proper_list_1(sc, cdr(code)))) /* list_1 of cdr so there are 2 exprs */
pair_set_syntax_op(expr, (any_nils) ? OP_OR_AP : OP_OR_2A);
else
pair_set_syntax_op(expr, (any_nils) ? OP_OR_P : OP_OR_N);
return (false);
}
static bool op_or_ap(s7_scheme * sc)
{
/* we know fx_proc is set on sc->code, and there are only two branches */
sc->value = fx_call(sc, cdr(sc->code));
if (is_true(sc, sc->value))
return (true);
sc->code = caddr(sc->code);
return (false);
}
/* -------------------------------- if -------------------------------- */
static void fx_safe_closure_tree(s7_scheme * sc)
{
s7_pointer e = sc->curlet;
if ((is_let(e)) && /* e might be sc->nil */
(is_funclet(e)) && (tis_slot(let_slots(e)))) { /* let_slots might be NULL */
s7_pointer f;
f = lookup(sc, funclet_function(e));
if (is_safe_closure(f)) {
s7_pointer slot1 = let_slots(e), slot2;
slot2 = next_slot(slot1);
fx_tree(sc, closure_body(f),
slot_symbol(slot1),
(tis_slot(slot2)) ? slot_symbol(slot2) : NULL,
((tis_slot(slot2))
&& (tis_slot(next_slot(slot2)))) ?
slot_symbol(next_slot(slot2)) : NULL,
((tis_slot(slot2)) && (tis_slot(next_slot(slot2)))));
}
}
}
static void fb_annotate(s7_scheme * sc, s7_pointer form, s7_function fx,
opcode_t op)
{
s7_pointer bfunc;
bfunc = fx_to_fb(sc, fx);
if (bfunc) {
set_opt3_any(cdr(form), bfunc);
pair_set_syntax_op(form, op);
}
#if 0
else
fprintf(stderr, "%s %s: %s\n", op_names[op],
op_names[optimize_op
((op ==
OP_IF_B_N_N) ? cadadr(form) : cadr(form))],
display_80(form));
#endif
}
#define choose_if_optc(Opc, One, Reversed, Not) ((One) ? ((Reversed) ? OP_ ## Opc ## _R : ((Not) ? OP_ ## Opc ## _N : OP_ ## Opc ## _P)) : ((Not) ? OP_ ## Opc ## _N_N : OP_ ## Opc ## _P_P))
static void set_if_opts(s7_scheme * sc, s7_pointer form, bool one_branch,
bool reversed)
{ /* cdr(form) == sc->code */
s7_pointer test, code = cdr(form);
bool not_case = false;
test = car(code);
if ((!reversed) && (is_pair(test)) && (car(test) == sc->not_symbol)) {
if (!is_proper_list_1(sc, cdr(test)))
return; /* (not) or (not a b) */
not_case = true;
test = cadr(test);
}
set_opt1_any(form, cadr(code));
if (!one_branch)
set_opt2_any(form, caddr(code));
if (is_pair(test)) {
if (is_optimized(test)) {
if (is_h_safe_c_d(test)) { /* replace these with fx_and* */
pair_set_syntax_op(form,
choose_if_optc(IF_A, one_branch,
reversed, not_case));
if (not_case) {
set_fx(cdar(code),
fx_choose(sc, cdar(code), sc->curlet,
let_symbol_is_safe));
if (!reversed)
set_opt3_pair(form, cdadr(form));
} else
set_fx(code,
fx_choose(sc, code, sc->curlet,
let_symbol_is_safe));
return;
}
if ((is_h_safe_c_s(test)) && (is_symbol(car(test)))) {
uint8_t typ;
typ = symbol_type(car(test));
if (typ > 0) {
pair_set_syntax_op(form,
choose_if_optc(IF_IS_TYPE_S,
one_branch, reversed,
not_case));
set_opt3_byte(code, typ);
if ((optimize_op(form) == OP_IF_IS_TYPE_S_P_P) &&
(is_fxable(sc, caddr(code)))) {
set_opt2_pair(form, cddr(code));
if (is_fxable(sc, cadr(code))) {
fx_annotate_arg(sc, cdr(code), sc->curlet);
pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_A);
} else
pair_set_syntax_op(form, OP_IF_IS_TYPE_S_P_A);
fx_annotate_arg(sc, cddr(code), sc->curlet);
fx_safe_closure_tree(sc);
}
} else {
pair_set_syntax_op(form,
choose_if_optc(IF_opSq, one_branch,
reversed, not_case));
if (not_case)
set_opt1_pair(code, cadar(code)); /* code is cdr(if...): ((not (f sym)) ...) */
}
clear_has_fx(code);
set_opt2_sym(code, cadr(test));
return;
}
if (is_fxable(sc, test)) {
if (optimize_op(test) == OP_OR_2A) {
pair_set_syntax_op(form,
choose_if_optc(IF_OR2, one_branch,
reversed, not_case));
clear_has_fx(code);
set_opt2_pair(code, cdr(test));
set_opt3_pair(code, cddr(test));
return;
}
if (optimize_op(test) == OP_AND_2A) {
pair_set_syntax_op(form,
choose_if_optc(IF_AND2, one_branch,
reversed, not_case));
clear_has_fx(code);
set_opt2_pair(code, cdr(test));
set_opt3_pair(code, cddr(test));
return;
}
if (optimize_op(test) == OP_AND_3A) {
pair_set_syntax_op(form,
choose_if_optc(IF_AND3, one_branch,
reversed, not_case));
clear_has_fx(code);
set_opt2_pair(code, cdr(test));
set_opt3_pair(code, cddr(test));
set_opt1_pair(code, cdddr(test));
return;
}
pair_set_syntax_op(form,
choose_if_optc(IF_A, one_branch,
reversed, not_case));
if (not_case) {
set_fx_direct(cdar(code),
fx_choose(sc, cdar(code), sc->curlet,
let_symbol_is_safe));
if (!reversed)
set_opt3_pair(form, cdadr(form));
} else
set_fx_direct(code,
fx_choose(sc, code, sc->curlet,
let_symbol_is_safe));
if (optimize_op(form) == OP_IF_A_P) {
if (is_fxable(sc, cadr(code))) {
pair_set_syntax_op(form, OP_IF_A_A);
fx_annotate_arg(sc, cdr(code), sc->curlet);
set_opt1_pair(form, cdr(code));
fx_safe_closure_tree(sc);
fb_annotate(sc, form, fx_proc(code), OP_IF_B_A);
} else
fb_annotate(sc, form, fx_proc(code), OP_IF_B_P);
}
if (optimize_op(form) == OP_IF_A_R)
fb_annotate(sc, form, fx_proc(code), OP_IF_B_R);
if (optimize_op(form) == OP_IF_A_N_N)
fb_annotate(sc, form, fx_proc(cdar(code)),
OP_IF_B_N_N);
if (optimize_op(form) == OP_IF_A_P_P) {
if (is_fxable(sc, cadr(code))) {
set_opt1_pair(form, cdr(code));
if (is_fxable(sc, caddr(code))) {
pair_set_syntax_op(form, OP_IF_A_A_A); /* b_a_a never happens? */
set_opt2_pair(form, cddr(code));
} else {
pair_set_syntax_op(form, OP_IF_A_A_P);
fb_annotate(sc, form, fx_proc(code),
OP_IF_B_A_P);
}
fx_annotate_args(sc, cdr(code), sc->curlet);
fx_safe_closure_tree(sc);
} else if (is_fxable(sc, caddr(code))) {
pair_set_syntax_op(form, OP_IF_A_P_A);
fx_annotate_args(sc, cdr(code), sc->curlet);
set_opt2_pair(form, cddr(code));
fx_safe_closure_tree(sc);
fb_annotate(sc, form, fx_proc(code), OP_IF_B_P_A);
} else
fb_annotate(sc, form, fx_proc(code), OP_IF_B_P_P);
}
} else {
pair_set_syntax_op(form,
choose_if_optc(IF_P, one_branch,
reversed, not_case));
set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code));
set_opt3_any(code, (not_case) ? cadar(code) : car(code));
}
} else {
pair_set_syntax_op(form,
choose_if_optc(IF_P, one_branch, reversed,
not_case));
clear_has_fx(code);
set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code));
set_opt3_any(code, (not_case) ? cadar(code) : car(code));
if (is_symbol_and_syntactic(car(test))) {
pair_set_syntax_op(test, symbol_syntax_op_checked(test));
if ((symbol_syntax_op(car(test)) == OP_AND) ||
(symbol_syntax_op(car(test)) == OP_OR)) {
opcode_t new_op;
if (symbol_syntax_op(car(test)) == OP_AND)
check_and(sc, test);
else
check_or(sc, test);
new_op = symbol_syntax_op_checked(test);
if ((new_op == OP_AND_P) || (new_op == OP_AND_AP)
|| (new_op == OP_AND_PAIR_P)
|| (new_op == OP_AND_N)
|| (new_op == OP_AND_SAFE_P1)
|| (new_op == OP_AND_SAFE_P2)
|| (new_op == OP_AND_SAFE_P3)) {
pair_set_syntax_op(form,
choose_if_optc(IF_ANDP,
one_branch,
reversed,
not_case));
set_opt2_any(code,
(one_branch) ? cadr(code) :
cdr(code));
set_opt3_pair(code,
(not_case) ? cdadar(code) :
cdar(code));
} else if ((new_op == OP_OR_P) || (new_op == OP_OR_AP)) {
pair_set_syntax_op(form,
choose_if_optc(IF_ORP,
one_branch,
reversed,
not_case));
set_opt2_any(code,
(one_branch) ? cadr(code) :
cdr(code));
set_opt3_pair(code,
(not_case) ? cdadar(code) :
cdar(code));
}
}
}
}
} else /* test is symbol or constant, but constant here is nutty */
if (is_safe_symbol(test)) {
pair_set_syntax_op(form,
choose_if_optc(IF_S, one_branch, reversed,
not_case));
if (not_case)
set_opt1_sym(code, cadar(code)); /* code is cdr(if...): ((not sym) ...) */
if ((optimize_op(form) == OP_IF_S_P_P) &&
(is_fxable(sc, caddr(code)))) {
pair_set_syntax_op(form, OP_IF_S_P_A);
fx_annotate_arg(sc, cddr(code), sc->curlet);
set_opt2_pair(form, cddr(code));
fx_safe_closure_tree(sc);
}
}
}
/* (cond <> (else <>)) only happens in old-fashioned code, so set_if_opts covers if/when/unless but not cond */
static s7_pointer check_if(s7_scheme * sc, s7_pointer form)
{
s7_pointer cdr_code, code = cdr(form);
if (!is_pair(code)) /* (if) or (if . 1) */
eval_error(sc, "(if): if needs at least 2 expressions: ~A", 41,
form);
cdr_code = cdr(code);
if (!is_pair(cdr_code)) /* (if 1) */
eval_error(sc, "~S: if needs another clause", 27, form);
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", 27, form);
} else if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */
eval_error(sc, "if: ~A has improper list?", 25, form);
pair_set_syntax_op(form, OP_IF_UNCHECKED);
set_if_opts(sc, form, is_null(cdr(cdr_code)), false);
return (code);
}
static void op_if(s7_scheme * sc)
{
sc->code = check_if(sc, sc->code);
push_stack_no_args(sc, OP_IF1, cdr(sc->code));
sc->code = car(sc->code);
}
static void op_if_unchecked(s7_scheme * sc)
{
push_stack_no_args(sc, OP_IF1, cddr(sc->code));
sc->code = cadr(sc->code);
}
static bool op_if1(s7_scheme * sc)
{
sc->code =
(is_true(sc, sc->value)) ? car(sc->code) :
unchecked_car(cdr(sc->code));
/* even pre-optimization, (if #f #f) ==> #<unspecified> because unique_car(sc->nil) = sc->unspecified */
if (is_pair(sc->code))
return (true);
sc->value =
(is_symbol(sc->code)) ? lookup_checked(sc, sc->code) : sc->code;
return (false);
}
/* -------------------------------- when -------------------------------- */
static void check_when(s7_scheme * sc)
{
s7_pointer form = sc->code, code = cdr(sc->code);
if (!is_pair(code)) /* (when) or (when . 1) */
eval_error(sc, "when has no expression or body: ~A", 35, form);
if (!is_pair(cdr(code))) /* (when 1) or (when 1 . 1) */
eval_error(sc, "when has no body?: ~A", 22, form);
else if (!s7_is_proper_list(sc, cddr(code)))
eval_error(sc, "when: stray dot?", 16, form);
pair_set_syntax_op(form, OP_WHEN_P);
if (is_null(cddr(code)))
set_if_opts(sc, form, true, false); /* use if where possible */
else {
s7_pointer test = car(code);
if (is_safe_symbol(test)) {
pair_set_syntax_op(form, OP_WHEN_S);
set_opt2_con(form, cadr(code));
set_opt3_pair(form, cddr(code));
} else
/* fxable body doesn't happen very often -- a dozen or so hits in the standard tests */
if (is_fxable(sc, test)) {
pair_set_syntax_op(form, OP_WHEN_A);
if (is_pair(car(code)))
set_opt2_pair(form, cdar(code));
set_opt3_pair(form, cdr(code));
set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); /* "A" in when_a */
if (fx_proc(code) == fx_and_2a)
pair_set_syntax_op(form, OP_WHEN_AND_2A);
else if (fx_proc(code) == fx_and_3a)
pair_set_syntax_op(form, OP_WHEN_AND_3A);
} else if ((is_pair(test)) && (car(test) == sc->and_symbol)) {
opcode_t new_op;
pair_set_syntax_op(test, symbol_syntax_op_checked(test));
check_and(sc, test);
new_op = symbol_syntax_op_checked(test);
if (new_op == OP_AND_AP)
pair_set_syntax_op(form, OP_WHEN_AND_AP);
}
}
push_stack_no_args(sc, OP_WHEN_PP, cdr(code));
sc->code = car(code);
}
static bool op_when_s(s7_scheme * sc)
{
if (is_true(sc, lookup(sc, cadr(sc->code)))) {
push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */
sc->code = opt2_con(sc->code); /* caddr(sc->code) */
return (false);
}
sc->value = sc->unspecified;
return (true);
}
static bool op_when_a(s7_scheme * sc)
{
if (is_true(sc, fx_call(sc, cdr(sc->code)))) {
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */
sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */
return (false);
}
sc->value = sc->unspecified;
return (true);
}
static bool op_when_and_2a(s7_scheme * sc)
{
if ((is_true(sc, fx_call(sc, opt2_pair(sc->code))))
&& (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code)))))) {
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */
sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */
return (false);
}
sc->value = sc->unspecified;
return (true);
}
static bool op_when_and_3a(s7_scheme * sc)
{
if ((is_true(sc, fx_call(sc, opt2_pair(sc->code))))
&& (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code)))))
&& (is_true(sc, fx_call(sc, cddr(opt2_pair(sc->code)))))) {
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */
sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */
return (false);
}
sc->value = sc->unspecified;
return (true);
}
static void op_when_p(s7_scheme * sc)
{
push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code));
sc->code = cadr(sc->code);
}
static bool op_when_and_ap(s7_scheme * sc)
{
s7_pointer andp = cdadr(sc->code);
if (is_true(sc, fx_call(sc, andp))) {
push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code));
sc->code = cadr(andp);
return (false);
}
sc->value = sc->unspecified;
return (true);
}
static bool op_when_pp(s7_scheme * sc)
{
if (is_true(sc, sc->value)) {
if (is_pair(cdr(sc->code)))
push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
sc->code = car(sc->code);
return (false);
}
sc->value = sc->unspecified;
return (true);
}
/* -------------------------------- unless -------------------------------- */
static void check_unless(s7_scheme * sc)
{
s7_pointer form = sc->code, code = cdr(sc->code);
if (!is_pair(code)) /* (unless) or (unless . 1) */
eval_error(sc, "unless has no expression or body: ~A", 37, form);
if (!is_pair(cdr(code))) /* (unless 1) or (unless 1 . 1) */
eval_error(sc, "unless has no body?: ~A", 24, form);
else if (!s7_is_proper_list(sc, cddr(code)))
eval_error(sc, "unless: stray dot?", 18, form);
pair_set_syntax_op(form, OP_UNLESS_P);
if (is_null(cddr(code)))
set_if_opts(sc, form, true, true);
else if (is_safe_symbol(car(code))) {
pair_set_syntax_op(form, OP_UNLESS_S);
set_opt2_con(form, cadr(code));
set_opt3_pair(form, cddr(code));
} else if (is_fxable(sc, car(code))) {
pair_set_syntax_op(form, OP_UNLESS_A);
set_opt2_con(form, cadr(code));
set_opt3_pair(form, cddr(code));
set_fx_direct(code,
fx_choose(sc, code, sc->curlet, let_symbol_is_safe));
}
push_stack_no_args(sc, OP_UNLESS_PP, cdr(code));
sc->code = car(code);
}
static bool op_unless_s(s7_scheme * sc)
{
if (is_false(sc, lookup(sc, cadr(sc->code)))) {
push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */
sc->code = opt2_con(sc->code); /* caddr(sc->code) */
return (false);
}
sc->value = sc->unspecified;
return (true);
}
static bool op_unless_a(s7_scheme * sc)
{
if (is_false(sc, fx_call(sc, cdr(sc->code)))) {
push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */
sc->code = opt2_con(sc->code); /* caddr(sc->code) */
return (false);
}
sc->value = sc->unspecified;
return (true);
}
static void op_unless_p(s7_scheme * sc)
{
push_stack_no_args(sc, OP_UNLESS_PP, cddr(sc->code));
sc->code = cadr(sc->code);
}
static bool op_unless_pp(s7_scheme * sc)
{
if (is_false(sc, sc->value)) {
if (is_pair(cdr(sc->code)))
push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
sc->code = car(sc->code);
return (false);
}
sc->value = sc->unspecified;
return (true);
}
/* -------------------------------- begin -------------------------------- */
static bool op_begin(s7_scheme * sc, s7_pointer code)
{
s7_pointer form = cdr(code);
if (!s7_is_proper_list(sc, form)) /* proper list includes () */
eval_error(sc, "unexpected dot? ~A", 18, code);
if (is_null(form)) { /* (begin) -> () */
sc->value = sc->nil;
return (true);
}
if ((is_pair(cdr(form))) && (is_null(cddr(form)))) /* begin_1 doesn't happen much */
pair_set_syntax_op(code, OP_BEGIN_2_UNCHECKED);
else
pair_set_syntax_op(code, OP_BEGIN_UNCHECKED);
return (false);
}
/* -------------------------------- define -------------------------------- */
static s7_pointer print_truncate(s7_scheme * sc, s7_pointer code)
{
if (tree_len(sc, code) > sc->print_length)
return (object_to_truncated_string
(sc, code, sc->print_length * 10));
return (code);
}
static void check_define(s7_scheme * sc)
{
s7_pointer func, caller, code = cdr(sc->code);
bool starred = (sc->cur_op == OP_DEFINE_STAR);
if (starred) {
caller = sc->define_star_symbol;
sc->cur_op = OP_DEFINE_STAR_UNCHECKED;
} else
caller =
(sc->cur_op ==
OP_DEFINE) ? sc->define_symbol : sc->define_constant_symbol;
if (!is_pair(code))
eval_error_with_caller(sc, "~A: nothing to define? ~A", 25, caller, sc->code); /* (define) */
if (!is_pair(cdr(code))) {
if (is_null(cdr(code)))
eval_error_with_caller(sc, "~A: no value? ~A", 16, caller, sc->code); /* (define var) */
eval_error_with_caller(sc, "~A: stray dot? ~A", 17, caller, sc->code); /* (define var . 1) */
}
if (!is_pair(car(code))) {
if (is_not_null(cddr(code))) /* (define var 1 . 2) */
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"~A: more than one value? ~A",
27), caller,
print_truncate(sc, sc->code)));
if (starred)
eval_error(sc,
"define* is restricted to functions: (define* ~{~S~^ ~})",
55, sc->code);
func = car(code);
if (!is_symbol(func)) /* (define 3 a) */
eval_error_with_caller2(sc,
"~A: can't define ~S, ~A (should be a symbol)",
44, caller, func,
prepackaged_type_name(sc, func));
if (is_keyword(func)) /* (define :hi 1) */
eval_error_with_caller(sc, "~A ~A: keywords are constants", 29,
caller, func);
if (is_syntactic_symbol(func)) { /* (define and a) */
if (sc->safety > NO_SAFETY)
s7_warn(sc, 128,
"%s: syntactic keywords tend to behave badly if redefined\n",
display(func));
set_local(func);
}
if ((is_pair(cadr(code))) && /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */
((caadr(code) == sc->lambda_symbol) ||
(caadr(code) == sc->lambda_star_symbol)) &&
(symbol_id(caadr(code)) == 0)) {
/* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */
if (!is_pair(cdadr(code))) /* (define x (lambda . 1)) */
eval_error_with_caller(sc, "~A: stray dot? ~A", 17, caller,
sc->code);
if (!is_pair(cddr(cadr(code)))) /* (define f (lambda (arg))) */
eval_error_with_caller(sc, "~A: no body: ~A", 15, caller,
sc->code);
if (caadr(code) == sc->lambda_star_symbol)
check_lambda_star_args(sc, cadadr(code), cddr(cadr(code)));
else
check_lambda_args(sc, cadadr(code), NULL);
optimize_lambda(sc, caadr(code) == sc->lambda_symbol, func,
cadadr(code), cddr(cadr(code)));
}
} else {
func = caar(code);
if (!is_symbol(func)) /* (define (3 a) a) */
eval_error_with_caller2(sc,
"~A: can't define ~S, ~A (should be a symbol)",
44, caller, func,
prepackaged_type_name(sc, func));
if (is_syntactic_symbol(func)) { /* (define (and a) a) */
if (sc->safety > NO_SAFETY)
s7_warn(sc, 128,
"%s: syntactic keywords tend to behave badly if redefined\n",
display(func));
set_local(func);
}
if (starred)
set_cdar(code,
check_lambda_star_args(sc, cdar(code), cdr(code)));
else
check_lambda_args(sc, cdar(code), NULL);
optimize_lambda(sc, !starred, func, cdar(code), cdr(code));
}
if ((sc->cur_op == OP_DEFINE) || (sc->cur_op == OP_DEFINE_CONSTANT)) { /* ?? 10-May-18 */
if ((is_pair(car(code))) &&
(!symbol_has_setter(func)) && (!is_possibly_constant(func)))
pair_set_syntax_op(sc->code, OP_DEFINE_FUNCHECKED);
else
pair_set_syntax_op(sc->code, OP_DEFINE_UNCHECKED);
} else if (starred)
pair_set_syntax_op(sc->code, OP_DEFINE_STAR_UNCHECKED);
else
pair_set_syntax_op(sc->code, OP_DEFINE_CONSTANT_UNCHECKED);
}
static bool op_define_unchecked(s7_scheme * sc)
{
s7_pointer code = cdr(sc->code), locp;
if ((is_pair(car(code))) && (has_location(car(code))))
locp = car(code);
else if ((is_pair(cadr(code))) && (has_location(cadr(code))))
locp = cadr(code);
else
locp = sc->nil;
if ((sc->cur_op == OP_DEFINE_STAR_UNCHECKED) && /* sc->cur_op changed above if define* */
(is_pair(cdar(code)))) {
sc->value =
make_closure(sc, cdar(code), cdr(code), T_CLOSURE_STAR,
CLOSURE_ARITY_NOT_SET);
/* closure_body might not be cdr(code) after make_closure (add_trace) */
if ((is_pair(locp)) && (has_location(locp))) {
pair_set_location(closure_body(sc->value),
pair_location(locp));
set_has_location(closure_body(sc->value));
}
sc->code = caar(code);
return (false);
}
if (!is_pair(car(code))) {
s7_pointer x = car(code);
sc->code = cadr(code);
if (is_pair(sc->code)) {
push_stack_no_args(sc, OP_DEFINE1, x);
sc->cur_op = optimize_op(sc->code);
return (true);
}
sc->value =
(is_symbol(sc->code)) ? lookup_global(sc, sc->code) : sc->code;
sc->code = x;
} else {
s7_pointer x, args = cdar(code);
/* a closure. If we called this same code earlier (a local define), the only thing
* that is new here is the environment -- we can't blithely save the closure object
* in opt2 somewhere, and pick it up the next time around (since call/cc might take
* us back to the previous case). We also can't re-use opt2(sc->code) because opt2
* is not cleared in the gc.
*/
x = make_closure(sc, args, cdr(code),
T_CLOSURE | ((!s7_is_proper_list(sc, args)) ?
T_COPY_ARGS : 0),
(is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET);
if ((is_pair(locp)) && (has_location(locp))) {
pair_set_location(closure_body(x), pair_location(locp));
set_has_location(closure_body(x));
}
sc->value = T_Pos(x);
sc->code = caar(code);
}
return (false);
}
static s7_pointer make_funclet(s7_scheme * sc, s7_pointer new_func,
s7_pointer func_name, s7_pointer outer_let)
{
s7_pointer new_let, arg;
new_cell_no_check(sc, new_let, T_LET | T_FUNCLET);
let_set_id(new_let, ++sc->let_number);
let_set_outlet(new_let, outer_let);
closure_set_let(new_func, new_let);
funclet_set_function(new_let, func_name); /* *function* returns at least funclet_function */
let_set_slots(new_let, slot_end(sc));
arg = closure_args(new_func);
if (is_null(arg)) {
let_set_slots(new_let, slot_end(sc));
return (new_let);
}
if (is_safe_closure(new_func)) {
s7_pointer last_slot = NULL;
if (is_closure(new_func)) {
if (is_pair(arg)) {
last_slot = make_slot(sc, car(arg), sc->nil);
slot_set_next(last_slot, slot_end(sc));
let_set_slots(new_let, last_slot);
symbol_set_local_slot(car(arg), let_id(new_let),
last_slot);
for (arg = cdr(arg); is_pair(arg); arg = cdr(arg))
last_slot =
add_slot_at_end(sc, let_id(new_let), last_slot,
car(arg), sc->nil);
}
if (is_symbol(arg)) {
if (last_slot)
last_slot =
add_slot_at_end(sc, let_id(new_let), last_slot,
arg, sc->nil);
else {
last_slot = make_slot(sc, arg, sc->nil);
slot_set_next(last_slot, slot_end(sc));
let_set_slots(new_let, last_slot);
symbol_set_local_slot(arg, let_id(new_let), last_slot);
}
set_is_rest_slot(last_slot);
}
} else { /* closure_star */
s7_pointer slot, first_default = sc->nil;
let_set_slots(new_let, slot_end(sc));
for (; is_pair(arg); arg = cdr(arg)) {
s7_pointer par = car(arg);
if (is_pair(par)) {
s7_pointer val = cadr(par);
slot =
add_slot_checked(sc, new_let, car(par), sc->nil);
slot_set_expression(slot, val);
if ((is_symbol(val)) || (is_pair(val))) {
if (is_null(first_default))
first_default = slot;
set_slot_defaults(slot);
}
} else if (is_keyword(par)) {
if (par == sc->key_rest_symbol) {
arg = cdr(arg);
slot =
add_slot_checked(sc, new_let, car(arg),
sc->nil);
slot_set_expression(slot, sc->nil);
}
} else {
slot = add_slot_checked(sc, new_let, par, sc->nil);
slot_set_expression(slot, sc->F);
}
}
if (is_symbol(arg)) {
slot = add_slot_checked(sc, new_let, arg, sc->nil); /* set up rest arg */
set_is_rest_slot(slot);
slot_set_expression(slot, sc->nil);
}
if (tis_slot(let_slots(new_let))) {
let_set_slots(new_let,
reverse_slots(sc, let_slots(new_let)));
slot_set_pending_value(let_slots(new_let), first_default);
}
}
set_immutable_let(new_let);
} else
let_set_slots(new_let, slot_end(sc)); /* if unsafe closure, arg-holding-let will be created on each call */
return (new_let);
}
static bool op_define_constant(s7_scheme * sc)
{
s7_pointer code = cdr(sc->code);
if ((!is_pair(code)) || (!is_pair(cdr(code)))) /* (define-constant) */
eval_error(sc, "define-constant: not enough arguments: ~S", 41,
sc->code);
if (is_keyword(car(code))) { /* (define-constant :rest :allow-other-keys) */
if (car(code) == cadr(code)) { /* (define-constant pi pi) returns pi */
sc->value = car(code);
return (true);
}
eval_error_with_caller(sc, "~A ~A: keywords are constants", 29,
sc->define_constant_symbol, car(code));
}
if ((is_symbol(car(code))) && /* (define-constant abs abs): "abs will not be touched" */
(car(code) == cadr(code)) && (symbol_id(car(code)) == 0) && /* else (let iter ... (define-constant iter iter) ...) -> segfault on later calls */
(is_null(cddr(code)))) {
s7_pointer sym = car(code);
set_immutable(global_slot(sym)); /* id == 0 so its global */
set_possibly_constant(sym);
sc->value = lookup_checked(sc, car(code));
return (true);
}
push_stack_no_args(sc, OP_DEFINE_CONSTANT1, car(code));
return (false);
}
static void op_define_constant1(s7_scheme * sc)
{
if (is_pair(sc->code))
sc->code = car(sc->code); /* (define-constant (ex3 a)...) */
if (is_symbol(sc->code)) {
s7_pointer slot;
slot = lookup_slot_from(sc->code, sc->curlet);
set_possibly_constant(sc->code);
set_immutable(slot);
if (is_any_closure(slot_value(slot)))
set_immutable(slot_value(slot)); /* for the optimizer mainly */
}
}
static inline void define_funchecked(s7_scheme * sc)
{
s7_pointer new_func, code = cdr(sc->code);
sc->value = caar(code); /* func name */
new_cell(sc, new_func,
T_CLOSURE | ((!s7_is_proper_list(sc, cdar(code))) ?
T_COPY_ARGS : 0));
closure_set_args(new_func, cdar(code));
closure_set_body(new_func, cdr(code));
if (is_pair(cddr(code)))
set_closure_has_multiform(new_func);
else
set_closure_has_one_form(new_func);
closure_set_setter(new_func, sc->F);
closure_set_arity(new_func, CLOSURE_ARITY_NOT_SET);
sc->capture_let_counter++;
if (is_safe_closure_body(cdr(code))) {
set_safe_closure(new_func);
if (is_very_safe_closure_body(cdr(code)))
set_very_safe_closure(new_func);
make_funclet(sc, new_func, sc->value, sc->curlet);
} else
closure_set_let(new_func, sc->curlet); /* unsafe closures created by other functions do not support *function* */
if (let_id(sc->curlet) < symbol_id(sc->value))
sc->let_number++; /* dummy let, force symbol lookup */
add_slot_unchecked(sc, sc->curlet, sc->value, new_func,
sc->let_number);
sc->value = new_func;
}
static s7_pointer cur_op_to_caller(s7_scheme * sc, opcode_t op)
{
switch (op) {
case OP_DEFINE_MACRO:
return (sc->define_macro_symbol);
case OP_DEFINE_MACRO_STAR:
return (sc->define_macro_star_symbol);
case OP_DEFINE_BACRO:
return (sc->define_bacro_symbol);
case OP_DEFINE_BACRO_STAR:
return (sc->define_bacro_star_symbol);
case OP_DEFINE_EXPANSION:
return (sc->define_expansion_symbol);
case OP_DEFINE_EXPANSION_STAR:
return (sc->define_expansion_star_symbol);
case OP_MACRO:
return (sc->macro_symbol);
case OP_MACRO_STAR:
return (sc->macro_star_symbol);
case OP_BACRO:
return (sc->bacro_symbol);
case OP_BACRO_STAR:
return (sc->bacro_star_symbol);
}
return (sc->define_macro_symbol);
}
static s7_pointer check_define_macro(s7_scheme * sc, opcode_t op)
{
s7_pointer mac_name, args, caller;
caller = cur_op_to_caller(sc, op);
if (!is_pair(sc->code)) /* (define-macro . 1) */
eval_error_with_caller(sc, "~A name missing (stray dot?): ~A", 32,
caller, sc->code);
if (!is_pair(car(sc->code))) /* (define-macro a ...) */
return (wrong_type_argument_with_type
(sc, caller, 1, car(sc->code),
wrap_string(sc, "a list: (name ...)", 18)));
mac_name = caar(sc->code);
if (!is_symbol(mac_name))
eval_error_with_caller(sc, "~A: ~S is not a symbol?", 23, caller,
mac_name);
if (is_syntactic_symbol(mac_name)) {
if (sc->safety > NO_SAFETY)
s7_warn(sc, 128,
"%s: syntactic keywords tend to behave badly if redefined\n",
display(mac_name));
set_local(mac_name);
}
if (is_constant_symbol(sc, mac_name))
eval_error_with_caller(sc, "~A: ~S is constant", 18, caller,
mac_name);
if (!is_pair(cdr(sc->code))) /* (define-macro (...)) */
eval_error_with_caller(sc, "~A ~A, but no body?", 19, caller,
mac_name);
args = cdar(sc->code);
if ((!is_list(args)) && (!is_symbol(args)))
return (s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac . 1) ...) */
set_elist_3(sc,
wrap_string(sc,
"macro ~A argument list is ~S?",
29), mac_name, args)));
if ((op == OP_DEFINE_MACRO) || (op == OP_DEFINE_BACRO)
|| (op == OP_DEFINE_EXPANSION)) {
for (; is_pair(args); args = cdr(args))
if (!is_symbol(car(args)))
return (s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */
set_elist_3(sc,
wrap_string(sc,
"~A parameter name, ~A, is not a symbol",
38), caller,
car(args))));
check_lambda_args(sc, cdar(sc->code), NULL);
} else
set_cdar(sc->code,
check_lambda_star_args(sc, cdar(sc->code), NULL));
return (sc->code);
}
static s7_pointer check_macro(s7_scheme * sc, opcode_t op)
{
s7_pointer args, caller;
caller = cur_op_to_caller(sc, op);
if (!is_pair(sc->code)) /* (define-macro . 1) */
eval_error_with_caller(sc, "~A name missing (stray dot?): ~A", 32,
caller, sc->code);
if (!is_pair(cdr(sc->code))) /* (define-macro (...)) */
eval_error_with_caller(sc, "(~A ~A) has no body?", 20, caller,
car(sc->code));
args = car(sc->code);
if ((!is_list(args)) && (!is_symbol(args)))
return (s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac . 1) ...) */
set_elist_2(sc,
wrap_string(sc,
"macro argument list is ~S?",
26), args)));
if ((op == OP_MACRO) || (op == OP_BACRO)) {
for (; is_pair(args); args = cdr(args))
if (!is_symbol(car(args)))
return (s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */
set_elist_3(sc,
wrap_string(sc,
"~A parameter name, ~A, is not a symbol",
38), caller,
car(args))));
check_lambda_args(sc, car(sc->code), NULL);
} else
set_car(sc->code, check_lambda_star_args(sc, car(sc->code), NULL));
return (sc->code);
}
static void op_define_macro(s7_scheme * sc)
{
sc->code = cdr(sc->code);
check_define_macro(sc, sc->cur_op);
if ((is_immutable(sc->curlet)) && (is_let(sc->curlet))) /* not () */
eval_error(sc, "define-macro ~S: let is immutable", 33, caar(sc->code)); /* need eval_error_any_with_caller? */
sc->value = make_macro(sc, sc->cur_op, true);
}
static void op_macro(s7_scheme * sc)
{ /* (macro (x) `(+ ,x 1)) */
sc->code = cdr(sc->code);
if ((!is_pair(sc->code)) || (!mac_is_ok(sc->code))) { /* (macro)? or (macro . #\a)? */
check_macro(sc, sc->cur_op);
if (is_pair(sc->code))
set_mac_is_ok(sc->code);
}
sc->value = make_macro(sc, sc->cur_op, false);
}
static bool unknown_any(s7_scheme * sc, s7_pointer f, s7_pointer code);
static void apply_macro_star_1(s7_scheme * sc);
static inline bool op_macro_d(s7_scheme * sc)
{
sc->value = lookup(sc, car(sc->code));
if (!is_macro(sc->value)) /* for-each (etc) called a macro before, now it's something else -- a very rare case */
return (unknown_any(sc, sc->value, sc->code));
sc->args = cdr(sc->code); /* sc->args = copy_proper_list(sc, cdr(sc->code)); */
sc->code = sc->value; /* the macro */
check_stack_size(sc); /* (define-macro (f) (f)) (f) */
push_stack_op_let(sc, OP_EVAL_MACRO);
sc->curlet = make_let(sc, closure_let(sc->code));
return (false); /* fall into apply_lambda */
}
static bool op_macro_star_d(s7_scheme * sc)
{
sc->value = lookup(sc, car(sc->code));
if (!is_macro_star(sc->value))
return (unknown_any(sc, sc->value, sc->code));
sc->args = cdr(sc->code); /* sc->args = copy_proper_list(sc, cdr(sc->code)); */
sc->code = sc->value;
check_stack_size(sc);
push_stack_op_let(sc, OP_EVAL_MACRO);
sc->curlet = make_let(sc, closure_let(sc->code));
apply_macro_star_1(sc);
return (false);
}
static void transfer_macro_info(s7_scheme * sc, s7_pointer mac)
{
s7_pointer body = closure_body(mac);
if (has_pair_macro(mac)) {
set_maclet(sc->curlet);
funclet_set_function(sc->curlet, pair_macro(body));
}
if (has_location(body)) {
let_set_file(sc->curlet, pair_file_number(body));
let_set_line(sc->curlet, pair_line_number(body));
set_has_let_file(sc->curlet);
}
}
static goto_t op_expansion(s7_scheme * sc)
{
int64_t loc = current_stack_top(sc) - 1;
s7_pointer caller;
caller = (is_pair(stack_args(sc->stack, loc))) ? car(stack_args(sc->stack, loc)) : sc->F; /* this can be garbage */
if ((loc >= 3) && (stack_op(sc->stack, loc) != OP_READ_QUOTE) && /* '(expansion ...) */
(stack_op(sc->stack, loc) != OP_READ_VECTOR) && /* #(expansion ...) */
(caller != sc->quote_symbol) && /* (quote (expansion ...)) */
(caller != sc->macroexpand_symbol) && /* (macroexpand (expansion ...)) */
(caller != sc->define_expansion_symbol) && /* (define-expansion ...) being reloaded/redefined */
(caller != sc->define_expansion_star_symbol)) { /* (define-expansion* ...) being reloaded/redefined */
s7_pointer symbol = car(sc->value), slot;
/* we're playing fast and loose with sc->curlet in the reader, so here we need a disaster check */
if (!is_let(sc->curlet))
sc->curlet = sc->nil;
if ((symbol_id(symbol) == 0) || (sc->curlet == sc->nil))
slot = global_slot(symbol);
else
slot = lookup_slot_from(symbol, sc->curlet);
sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined;
if ((!is_either_macro(sc->code)) || (!is_expansion(sc->code)))
clear_expansion(symbol);
else {
/* call the reader macro */
sc->args = cdr(sc->value);
push_stack_no_code(sc, OP_EXPANSION, sc->nil);
sc->curlet = make_let(sc, closure_let(sc->code));
transfer_macro_info(sc, sc->code);
if (!is_macro_star(sc->code))
return (goto_apply_lambda);
apply_macro_star_1(sc);
return (goto_begin);
/* bacros don't seem to make sense here -- they are tied to the run-time environment,
* procedures would need to evaluate their arguments in rootlet
*/
}
}
return (fall_through);
}
static void macroexpand_c_macro(s7_scheme * sc)
{ /* callgrind shows this when it's actually calling apply_c_function (code is identical) */
s7_int len;
len = proper_list_length(sc->args);
if (len < c_macro_required_args(sc->code))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, not_enough_arguments_string, sc->code,
sc->args));
if (c_macro_all_args(sc->code) < len)
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, sc->code,
sc->args));
sc->value = c_macro_call(sc->code) (sc, sc->args);
}
static goto_t macroexpand(s7_scheme * sc)
{
switch (type(sc->code)) {
case T_MACRO:
sc->curlet = make_let(sc, closure_let(sc->code));
return (goto_apply_lambda);
case T_BACRO:
sc->curlet = make_let(sc, sc->curlet);
return (goto_apply_lambda);
case T_MACRO_STAR:
sc->curlet = make_let(sc, closure_let(sc->code));
apply_macro_star_1(sc);
return (goto_begin);
case T_BACRO_STAR:
sc->curlet = make_let(sc, sc->curlet);
apply_macro_star_1(sc);
return (goto_begin);
case T_C_MACRO:
macroexpand_c_macro(sc);
return (goto_start);
default:
eval_error(sc, "macroexpand argument is not a macro call: ~A", 44,
sc->args);
}
return (fall_through); /* for the compiler */
}
static goto_t op_macroexpand(s7_scheme * sc)
{
s7_pointer form = sc->code;
sc->code = cdr(sc->code);
/* mimic APPLY, but don't push OP_EVAL_MACRO or OP_EXPANSION
* (define-macro (mac a) `(+ ,a 1)) (macroexpand (mac 3)), sc->code: ((mac 3))
*/
if ((!is_pair(sc->code)) || (!is_pair(car(sc->code))))
eval_error(sc, "macroexpand argument is not a macro call: ~A", 44,
form);
if (!is_null(cdr(sc->code)))
eval_error(sc, "macroexpand: too many arguments: ~A", 35, form);
if (is_pair(caar(sc->code))) { /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */
push_stack_no_args_direct(sc, OP_MACROEXPAND_1);
sc->code = caar(sc->code);
return (goto_eval);
}
sc->args = cdar(sc->code);
if (!is_list(sc->args)) /* (macroexpand (mac . 7)) */
eval_error(sc,
"can't macroexpand ~S: the macro's argument list is not a list",
61, car(sc->code));
if (!is_symbol(caar(sc->code))) {
if (!is_any_macro(caar(sc->code)))
eval_error(sc, "macroexpand argument is not a macro call: ~A",
44, sc->code);
sc->code = caar(sc->code);
return (macroexpand(sc));
}
sc->code = lookup_checked(sc, caar(sc->code));
return (macroexpand(sc));
}
static goto_t op_macroexpand_1(s7_scheme * sc)
{
sc->args = cdar(sc->code);
sc->code = sc->value;
return (macroexpand(sc));
}
static void op_eval_macro(s7_scheme * sc)
{ /* after (scheme-side) macroexpansion, evaluate the resulting expression */
/* (define-macro (hi a) `(+ ,a 1)), (hi 2), here with value: (+ 2 1) */
if (is_multiple_value(sc->value)) {
/* a normal macro's result is evaluated (below) and its value replaces the macro invocation,
* so if a macro returns multiple values, evaluate each one, then replace the macro
* invocation with (apply values evaluated-results-in-a-list). We need to save the
* new list of results, and where we are in the macro's output list, so code=macro output,
* args=new list. If it returns (values), should we use #<unspecified>? I think that
* happens now without generating a multiple_value object:
* (define-macro (hi) (values)) (hi) -> #<unspecified>
* (define-macro (ho) (values '(+ 1 2) '(* 3 4))) (+ 1 (ho) 3) -> 19
* (define-macro (ha) (values '(define a 1) '(define b 2))) (let () (ha) (+ a b)) -> 3
*/
push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->value));
sc->code = car(sc->value);
} else
sc->code = sc->value;
}
static bool op_eval_macro_mv(s7_scheme * sc)
{
if (is_null(sc->code)) { /* end of values list */
sc->value =
splice_in_values(sc,
multiple_value(proper_list_reverse_in_place
(sc,
cons(sc, sc->value,
sc->args))));
return (true);
}
push_stack(sc, OP_EVAL_MACRO_MV, cons(sc, sc->value, sc->args),
cdr(sc->code));
sc->code = car(sc->code);
return (false);
}
static void op_finish_expansion(s7_scheme * sc)
{
/* after the expander has finished, if a list was returned, we need to add some annotations.
* if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*).
*/
if (sc->value == sc->no_value)
sc->stack_end[-1] = (s7_pointer) OP_READ_NEXT;
else if (is_pair(sc->value))
sc->value = copy_body(sc, sc->value);
}
/* -------------------------------- with-let -------------------------------- */
static void check_with_let(s7_scheme * sc)
{
s7_pointer form = cdr(sc->code);
if (!is_pair(form)) /* (with-let . "hi") */
eval_error(sc, "with-let takes an environment argument: ~A", 42,
sc->code);
if (!is_pair(cdr(form))) /* (with-let e) -> an error? */
eval_error(sc, "with-let body is messed up: ~A", 30, sc->code);
if (!s7_is_proper_list(sc, cdr(form))) /* (with-let e . 3) */
eval_error(sc, "stray dot in with-let body: ~S", 30, sc->code);
if ((is_pair(car(form))) && (caar(form) == sc->unlet_symbol) && /* a constant, (with-let (unlet) ...) */
(is_null(cdar(form))) && (is_symbol(cadr(form))) && (is_null(cddr(form)))) /* (with-let (unlet) symbol) */
pair_set_syntax_op(sc->code, OP_WITH_UNLET_S);
else if (is_symbol(car(form)))
pair_set_syntax_op(sc->code, OP_WITH_LET_S);
else
pair_set_syntax_op(sc->code, OP_WITH_LET_UNCHECKED);
}
static bool op_with_let_unchecked(s7_scheme * sc)
{
sc->code = cdr(sc->code);
sc->value = car(sc->code);
if (!is_pair(sc->value)) {
if (is_symbol(sc->value))
sc->value = lookup_checked(sc, sc->value);
sc->code = cdr(sc->code);
return (false);
}
push_stack_no_args(sc, OP_WITH_LET1, cdr(sc->code));
sc->code = sc->value; /* eval let arg */
return (true);
}
static inline bool op_with_let_s(s7_scheme * sc)
{
s7_pointer e;
sc->code = cdr(sc->code);
e = lookup_checked(sc, car(sc->code));
if ((!is_let(e)) && (e != sc->rootlet))
eval_error_any(sc, sc->wrong_type_arg_symbol,
"with-let takes an environment argument: ~A", 42,
e);
if ((is_null(cddr(sc->code))) && (is_symbol(cadr(sc->code)))) {
sc->value = s7_let_ref(sc, e, cadr(sc->code)); /* (with-let e s) -> (let-ref e s) */
return (false);
}
if (e == sc->rootlet)
sc->curlet = sc->nil;
else {
set_with_let_let(e);
let_set_id(e, ++sc->let_number);
set_curlet(sc, e);
update_symbol_ids(sc, e);
}
sc->code = T_Pair(cdr(sc->code));
return (true);
}
static s7_pointer with_unlet_s(s7_scheme * sc)
{
s7_pointer sym = caddr(sc->code);
if (is_slot(initial_slot(sym)))
return (initial_value(sym));
return (lookup(sc, sym));
}
static void activate_with_let(s7_scheme * sc, s7_pointer e)
{
if (!is_let(e)) /* (with-let . "hi") */
eval_error_any(sc, sc->wrong_type_arg_symbol,
"with-let takes an environment argument: ~A", 42,
e);
if (e == sc->rootlet)
sc->curlet = sc->nil; /* (with-let (rootlet) ...) */
else {
set_with_let_let(e);
let_set_id(e, ++sc->let_number);
set_curlet(sc, e);
update_symbol_ids(sc, e);
}
}
/* -------------------------------- cond -------------------------------- */
static void check_cond(s7_scheme * sc)
{
bool has_feed_to = false, result_fx = true, result_single = true;
s7_pointer x, code = cdr(sc->code), form = sc->code;
if (!is_pair(code)) /* (cond) or (cond . 1) */
eval_error(sc, "cond, but no body: ~A", 21, form);
for (x = 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", 39,
car(x));
else {
s7_pointer y = car(x);
if (!s7_is_proper_list(sc, cdr(y)))
eval_error(sc, "stray dot? ~A", 13, y);
if (is_pair(cdr(y))) {
if (is_pair(cddr(y)))
result_single = false;
if (is_undefined_feed_to(sc, cadr(y))) {
has_feed_to = true;
if (!is_pair(cddr(y))) /* (cond (#t =>)) or (cond (#t => . 1)) */
eval_error(sc, "cond: '=>' target missing? ~A",
30, x);
if (is_pair(cdddr(y))) /* (cond (1 => + abs)) */
eval_error(sc,
"cond: '=>' has too many targets: ~A",
35, x);
}
} else
result_single = false;
}
if (is_not_null(x)) /* (cond ((1 2)) . 1) */
eval_error(sc, "cond: stray dot? ~A", 19, form);
for (x = code; is_pair(x); x = cdr(x)) {
s7_pointer p = car(x);
if (is_fxable(sc, car(p)))
fx_annotate_arg(sc, p, sc->curlet);
for (p = cdr(p); is_pair(p); p = cdr(p))
if (!has_fx(p)) {
s7_function f;
f = fx_choose(sc, p, sc->curlet, let_symbol_is_safe);
if (f)
set_fx_direct(p, f);
else
result_fx = false;
}
}
if (has_feed_to) {
pair_set_syntax_op(form, OP_COND_UNCHECKED);
if (is_null(cdr(code))) {
s7_pointer expr = car(code), f;
f = caddr(expr);
if ((is_proper_list_3(sc, f)) && (car(f) == sc->lambda_symbol)) {
s7_pointer arg = cadr(f);
if ((is_pair(arg)) && (is_null(cdr(arg))) && (is_symbol(car(arg)))) { /* (define (hi) (cond (#t => (lambda (s) s)))) */
set_opt2_lambda(code, caddar(code)); /* (lambda ...) above */
pair_set_syntax_op(form, OP_COND_FEED);
}
}
}
} else {
s7_pointer p;
bool xopt = true;
int32_t i;
pair_set_syntax_op(form, OP_COND_SIMPLE);
for (i = 0, p = code; xopt && (is_pair(p)); i++, p = cdr(p))
xopt = ((has_fx(car(p))) && (is_pair(cdar(p))));
if (xopt) {
pair_set_syntax_op(form,
(result_fx) ? OP_COND_FX_FX
: ((result_single) ? OP_COND_FX_NP_O :
OP_COND_FX_NP));
if (result_single) {
if (i == 2) {
p = caadr(code);
if ((p == sc->else_symbol) || (p == sc->T))
pair_set_syntax_op(form, OP_COND_FX_2E);
} else if (i == 3) {
p = caaddr(code);
if ((p == sc->else_symbol) || (p == sc->T))
pair_set_syntax_op(form, OP_COND_FX_3E);
}
}
} else if (result_single)
pair_set_syntax_op(form, OP_COND_SIMPLE_O);
}
set_opt3_any(code, caar(code));
}
static bool op_cond_unchecked(s7_scheme * sc)
{
sc->code = cdr(sc->code);
if (has_fx(car(sc->code))) {
sc->value = fx_call(sc, car(sc->code)); /* false -> fall through into cond1 */
return (false);
}
push_stack_no_args_direct(sc, OP_COND1); /* true -> push cond1, goto eval */
sc->code = opt3_any(sc->code); /* caar */
return (true);
}
static bool op_cond_simple(s7_scheme * sc)
{ /* no => */
sc->code = cdr(sc->code);
if (has_fx(car(sc->code))) {
sc->value = fx_call(sc, car(sc->code));
return (false);
}
push_stack_no_args_direct(sc, OP_COND1_SIMPLE);
sc->code = opt3_any(sc->code); /* caar */
return (true);
}
static bool op_cond_simple_o(s7_scheme * sc)
{ /* no =>, no null or multiform consequent */
sc->code = cdr(sc->code);
if (has_fx(car(sc->code))) {
sc->value = fx_call(sc, car(sc->code));
return (false);
}
push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O);
sc->code = opt3_any(sc->code); /* caar */
return (true);
}
static bool op_cond1(s7_scheme * sc)
{
while (true) {
if (is_true(sc, sc->value)) { /* test is true, so evaluate result */
sc->code = cdar(sc->code);
if (is_pair(sc->code)) {
if (is_null(cdr(sc->code))) {
if (has_fx(sc->code)) {
sc->value = fx_call(sc, sc->code);
pop_stack(sc);
return (true); /* goto top_no_pop */
}
sc->code = car(sc->code);
sc->cur_op = optimize_op(sc->code);
return (true);
}
/* check_cond catches stray dots */
if (is_undefined_feed_to(sc, car(sc->code)))
return (false);
if (has_fx(sc->code)) {
sc->value = fx_call(sc, sc->code);
sc->code = cdr(sc->code);
if (is_pair(cdr(sc->code)))
push_stack_no_args(sc, sc->begin_op,
cdr(sc->code));
} else
push_stack_no_args(sc, sc->begin_op,
T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
sc->cur_op = optimize_op(sc->code);
return (true);
}
/* sc->code is () */
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 */
pop_stack(sc);
return (true);
}
sc->code = cdr(sc->code); /* go to next clause */
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.
*/
pop_stack(sc);
return (true);
}
if (has_fx(car(sc->code)))
sc->value = fx_call(sc, car(sc->code));
else {
push_stack_no_args_direct(sc, OP_COND1);
sc->code = caar(sc->code);
sc->cur_op = optimize_op(sc->code);
return (true);
}
}
return (true); /* make the compiler happy */
}
static bool op_cond1_simple(s7_scheme * sc)
{
while (true) {
if (is_true(sc, sc->value)) {
sc->code = T_Lst(cdar(sc->code));
if (is_null(sc->code)) {
if (is_multiple_value(sc->value))
sc->value =
splice_in_values(sc, multiple_value(sc->value));
pop_stack(sc);
return (true);
}
if (!has_fx(sc->code))
return (false);
sc->value = fx_call(sc, sc->code);
sc->code = cdr(sc->code);
if (is_pair(sc->code))
return (false); /* goto begin */
pop_stack(sc);
return (true); /* goto top_no_pop */
}
sc->code = cdr(sc->code);
if (is_null(sc->code)) {
sc->value = sc->unspecified;
pop_stack(sc);
return (true);
}
if (has_fx(car(sc->code)))
sc->value = fx_call(sc, car(sc->code));
else {
push_stack_no_args_direct(sc, OP_COND1_SIMPLE);
sc->code = caar(sc->code);
sc->cur_op = optimize_op(sc->code);
return (true);
}
}
}
static bool op_cond1_simple_o(s7_scheme * sc)
{
while (true) {
if (is_true(sc, sc->value)) {
sc->code = cdar(sc->code);
if (has_fx(sc->code)) {
sc->value = fx_call(sc, sc->code);
return (true); /* goto start */
}
sc->code = car(sc->code);
return (false);
}
sc->code = cdr(sc->code);
if (is_null(sc->code)) {
sc->value = sc->unspecified;
return (true);
}
if (has_fx(car(sc->code)))
sc->value = fx_call(sc, car(sc->code));
else {
check_stack_size(sc); /* 4-May-21 snd-test */
push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O);
sc->code = caar(sc->code);
return (false);
}
}
}
static bool op_cond_fx_np(s7_scheme * sc)
{ /* all tests are fxable, results may be a mixture, no =>, no missing results */
s7_pointer p;
for (p = cdr(sc->code); is_pair(p); p = cdr(p))
if (is_true(sc, fx_call(sc, car(p)))) {
for (p = T_Lst(cdar(p)); is_pair(p); p = cdr(p))
if (has_fx(T_Pair(p)))
sc->value = fx_call(sc, p);
else {
if (is_pair(cdr(p)))
push_stack_no_args(sc, OP_COND_FX_NP_1, cdr(p));
sc->code = car(p);
return (false);
}
return (true);
}
sc->value = sc->unspecified;
return (true);
}
static bool op_cond_fx_np_1(s7_scheme * sc)
{ /* continuing to handle a multi-statement result from cond_fx_np */
s7_pointer p;
for (p = sc->code; is_pair(p); p = cdr(p))
if (has_fx(T_Pair(p)))
sc->value = fx_call(sc, p);
else {
if (is_pair(cdr(p)))
push_stack_no_args(sc, OP_COND_FX_NP_1, cdr(p));
sc->code = car(p);
return (false);
}
return (true);
}
static Inline bool op_cond_fx_np_o(s7_scheme * sc)
{ /* all tests are fxable, results may be a mixture, no =>, no missing results, all result one expr */
s7_pointer p;
for (p = cdr(sc->code); is_pair(p); p = cdr(p))
if (is_true(sc, fx_call(sc, car(p)))) {
p = cdar(p);
if (has_fx(T_Pair(p))) {
sc->value = fx_call(sc, p);
return (true);
}
sc->code = car(p);
return (false);
}
sc->value = sc->unspecified;
return (true);
}
static inline bool fx_cond_value(s7_scheme * sc, s7_pointer p)
{
if (has_fx(p)) {
sc->value = fx_call(sc, p);
return (true);
}
sc->code = car(p);
return (false);
}
static bool op_cond_fx_2e(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code);
return (fx_cond_value
(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p)));
}
static bool op_cond_fx_3e(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code);
if (is_true(sc, fx_call(sc, car(p))))
return (fx_cond_value(sc, cdar(p)));
p = cdr(p);
return (fx_cond_value
(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p)));
}
static bool op_cond_feed(s7_scheme * sc)
{
/* (cond (expr => p)) where p is (lambda (s) ...) -- see check_cond */
sc->code = cdr(sc->code);
if (has_fx(car(sc->code)))
sc->value = fx_call(sc, car(sc->code));
else {
push_stack_no_args_direct(sc, OP_COND_FEED_1);
sc->code = caar(sc->code);
return (true);
}
return (false);
}
static bool op_cond_feed_1(s7_scheme * sc)
{
if (is_true(sc, sc->value)) {
if (is_multiple_value(sc->value))
sc->code =
cons(sc, opt2_lambda(sc->code), multiple_value(sc->value));
else {
sc->curlet =
make_let_with_slot(sc, sc->curlet,
caadr(opt2_lambda(sc->code)),
sc->value);
sc->code = caddr(opt2_lambda(sc->code));
}
return (true);
}
sc->value = sc->unspecified; /* it's cond -- perhaps push as sc->args above; this was nil until 21-Feb-17! */
return (false);
}
static bool feed_to(s7_scheme * sc)
{
if (is_multiple_value(sc->value)) {
sc->args = multiple_value(sc->value);
clear_multiple_value(sc->args);
if (is_symbol(cadr(sc->code))) {
sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */
return (true);
}
} else {
if (is_symbol(cadr(sc->code))) {
sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */
sc->args =
(needs_copied_args(sc->code)) ? list_1(sc,
sc->value) :
set_plist_1(sc, sc->value);
return (true);
}
sc->args = list_1(sc, sc->value); /* not plist here */
}
push_stack_direct(sc, OP_FEED_TO_1);
sc->code = cadr(sc->code); /* need to evaluate the target function */
return (false);
}
/* -------------------------------- set! -------------------------------- */
static void set_dilambda_opt(s7_scheme * sc, s7_pointer form, opcode_t opt,
s7_pointer expr)
{
s7_pointer func;
func = lookup_checked(sc, car(expr));
if ((is_closure(func)) &&
(is_closure(closure_setter(func))) &&
(is_safe_closure(closure_setter(func)))) {
s7_pointer setter = closure_setter(func);
pair_set_syntax_op(form, opt);
if ((!(is_let(closure_let(setter)))) ||
(!(is_funclet(closure_let(setter)))))
make_funclet(sc, setter, car(expr), closure_let(setter));
}
}
static void check_set(s7_scheme * sc)
{
s7_pointer form = sc->code, code = cdr(sc->code);
if (!is_pair(code)) {
if (is_null(code)) /* (set!) */
eval_error(sc, "set!: not enough arguments: ~A", 30, form);
eval_error(sc, "set!: stray dot? ~A", 19, form); /* (set! . 1) */
}
if (!is_pair(cdr(code))) {
if (is_null(cdr(code))) /* (set! var) */
eval_error(sc, "set!: not enough arguments: ~A", 30, form);
eval_error(sc, "set!: stray dot? ~A", 19, form); /* (set! var . 1) */
}
if (is_not_null(cddr(code))) /* (set! var 1 2) */
eval_error(sc, "~A: too many arguments to set!", 30, form);
/* cadr (the value) has not yet been evaluated */
if (is_pair(car(code))) {
if ((is_pair(caar(code))) && (!is_list(cdar(code)))) /* (set! ('(1 2) . 0) 1) */
eval_error(sc, "improper list of arguments to set!: ~A", 38,
form);
if (!s7_is_proper_list(sc, car(code))) /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */
eval_error(sc,
"set! target is an improper list: (set! ~A ...)",
46, car(code));
} else if (!is_symbol(car(code))) /* (set! 12345 1) */
eval_error(sc, "set! can't change ~S", 20, car(code));
else if (is_constant_symbol(sc, car(code))) /* (set! pi 3) */
eval_error(sc,
(is_keyword(car(code))) ?
"set!: can't change keyword's value: ~S" :
"set!: can't alter constant's value: ~S", 38,
car(code));
if (is_pair(car(code))) {
/* here we have (set! (...) ...) */
s7_pointer inner = car(code), value = cadr(code);
pair_set_syntax_op(form, OP_SET_UNCHECKED); /* if not pair car, op_set_normal below */
if (is_symbol(car(inner))) {
if ((is_null(cdr(inner))) &&
(!is_pair(value)) &&
(is_global(car(inner))) &&
(is_c_function(global_value(car(inner)))) &&
(c_function_required_args(global_value(car(inner))) == 0))
pair_set_syntax_op(form, OP_SET_PWS);
else {
if ((is_pair(cdr(inner))) && (!is_pair(cddr(inner)))) { /* we check cddr(code) above */
/* this leaves (set! (vect i j) 1) unhandled so we go to OP_SET_UNCHECKED */
if (!is_pair(cadr(inner))) {
/* (set! (f s) ...) */
if (!is_pair(value)) {
pair_set_syntax_op(form, OP_SET_PAIR);
if (is_symbol(car(inner)))
set_dilambda_opt(sc, form, OP_SET_DILAMBDA,
inner);
} else
pair_set_syntax_op(form, OP_SET_PAIR_P); /* splice_in_values protects us here from values */
if (!is_fxable(sc, value)) {
if (is_symbol(car(inner)))
set_dilambda_opt(sc, form,
OP_SET_DILAMBDA_P, inner);
} else {
s7_pointer obj;
if ((car(inner) == sc->s7_let_symbol) &&
(is_keyword(cadr(inner)))) {
pair_set_syntax_op(form,
OP_IMPLICIT_S7_LET_SET_SA);
fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */
set_opt3_sym(cdr(form),
keyword_symbol(cadr(inner)));
return;
}
obj = lookup_checked(sc, car(inner)); /* might be (set! (undefined-var ...)...) */
if (((is_c_function(obj))
&& (car(inner) !=
make_symbol(sc,
c_function_name(obj))))
|| ((is_closure(obj))
&& (car(inner) !=
closure_name(sc, obj)))
|| ((!is_c_function(obj))
&& (!is_closure(obj))))
return;
fx_annotate_arg(sc, cdr(code), sc->curlet);
pair_set_syntax_op(form, OP_SET_PAIR_ZA);
if ((is_c_function(obj)) &&
(is_c_function(c_function_setter(obj))))
pair_set_syntax_op(form, OP_SET_PAIR_A);
else if (is_symbol(cadr(inner))) {
if (!has_fx(cdr(code)))
fx_annotate_arg(sc, cdr(code),
sc->curlet);
if ((is_closure(obj)) &&
(is_closure(closure_setter(obj))) &&
(is_safe_closure(closure_setter(obj))))
{
s7_pointer setter =
closure_setter(obj), body;
body = closure_body(setter);
if ((is_proper_list_1(sc, body)) &&
((has_fx(body))
|| (is_fxable(sc, car(body))))) {
s7_pointer setter_args;
if (!has_fx(body)) {
fx_annotate_arg(sc, body,
sc->curlet);
set_closure_one_form_fx_arg
(setter);
}
setter_args = closure_args(setter);
if ((is_pair(setter_args))
&& (is_pair(cdr(setter_args)))
&&
(is_null(cddr(setter_args))))
fx_tree(sc, body,
car(setter_args),
cadr(setter_args),
NULL, false);
pair_set_syntax_op(form,
OP_SET_DILAMBDA_SA_A);
if ((!(is_let(closure_let(setter)))) || /* ?? not sure this can happen */
(!(is_funclet
(closure_let(setter)))))
make_funclet(sc, setter,
car(inner),
closure_let
(setter));
}
}
}
}
} else /* is_pair(cadr(inner)) */
if ((caadr(inner) == sc->quote_symbol) &&
(is_global(sc->quote_symbol)) && /* (call/cc (lambda* 'x) ... (set! (setter 'y) ...)...) should return y */
(is_symbol(car(inner))) &&
((is_normal_symbol(value)) ||
(is_fxable(sc, value)))) {
if ((car(inner) == sc->s7_let_symbol) &&
(is_symbol(cadadr(inner)))) {
pair_set_syntax_op(form,
OP_IMPLICIT_S7_LET_SET_SA);
fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */
set_opt3_sym(cdr(form), cadadr(inner));
return;
}
if (is_safe_symbol(value))
pair_set_syntax_op(form, OP_SET_LET_S);
else {
pair_set_syntax_op(form, OP_SET_LET_FX);
set_fx(cdr(code),
fx_choose(sc, cdr(code), sc->curlet,
let_symbol_is_safe));
}
}
}
}
}
return;
}
pair_set_syntax_op(form, OP_SET_NORMAL);
if (is_symbol(car(code))) {
s7_pointer settee = car(code), value = cadr(code);
if ((!symbol_has_setter(settee)) && (!is_syntactic_symbol(settee))) {
if (is_normal_symbol(value)) {
if (is_slot(lookup_slot_from(value, sc->curlet))) {
pair_set_syntax_op(form, OP_SET_SYMBOL_S);
set_opt2_sym(code, value);
}
} else {
if ((!is_pair(value)) || ((car(value) == sc->quote_symbol) && (is_pair(cdr(value))))) { /* (quote . 1) ? */
pair_set_syntax_op(form, OP_SET_SYMBOL_C);
set_opt2_con(code,
(is_pair(value)) ? cadr(value) : value);
} 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)
*
* (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_op(form, OP_SET_SYMBOL_P);
if (is_optimized(value)) {
if (optimize_op(value) == HOP_SAFE_C_NC) {
pair_set_syntax_op(form, OP_SET_SYMBOL_A);
fx_annotate_arg(sc, cdr(code), sc->curlet);
} else {
if (optimize_op(value) == HOP_SAFE_C_SS) {
if (settee == cadr(value)) {
pair_set_syntax_op(form,
OP_INCREMENT_SS);
set_opt2_sym(code, caddr(value));
} else {
pair_set_syntax_op(form,
OP_SET_SYMBOL_A);
fx_annotate_arg(sc, cdr(code),
sc->curlet);
}
} else {
if (is_fxable(sc, value)) { /* value = cadr(code) */
pair_set_syntax_op(form,
OP_SET_SYMBOL_A);
fx_annotate_arg(sc, cdr(code),
sc->curlet);
}
if ((is_safe_c_op(optimize_op(value))) &&
(is_pair(cdr(value))) &&
(settee == cadr(value)) &&
(!is_null(cddr(value)))) {
if (is_null(cdddr(value))) {
if (is_fxable(sc, caddr(value))) {
pair_set_syntax_op(form,
OP_INCREMENT_SA);
fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */
set_opt2_pair(code,
cddr(value));
} else {
pair_set_syntax_op(form,
OP_INCREMENT_SP);
set_opt2_pair(code,
caddr(value));
}
} else
if ((is_null(cddddr(value))) &&
(is_fxable(sc, caddr(value)))
&&
(is_fxable(sc, cadddr(value))))
{
pair_set_syntax_op(form,
OP_INCREMENT_SAA);
fx_annotate_arg(sc, cddr(value),
sc->curlet);
fx_annotate_arg(sc, cdddr(value),
sc->curlet);
set_opt2_pair(code, cddr(value));
}
}
}
}
}
if ((is_h_optimized(value)) && (!is_unsafe(value)) && /* is_unsafe(value) can happen! */
(is_not_null(cdr(value)))) { /* (set! x (y)) */
if (is_not_null(cddr(value))) {
if ((caddr(value) == int_one) &&
(cadr(value) == settee)) {
if (opt1_cfunc(value) == sc->add_x1)
pair_set_syntax_op(form,
OP_INCREMENT_BY_1);
else if (opt1_cfunc(value) ==
sc->subtract_x1)
pair_set_syntax_op(form,
OP_DECREMENT_BY_1);
} else if ((cadr(value) == int_one)
&& (caddr(value) == settee)
&& (opt1_cfunc(value) ==
sc->add_1x))
pair_set_syntax_op(form,
OP_INCREMENT_BY_1);
else if ((settee == caddr(value))
&& (is_safe_symbol(cadr(value)))
&& (caadr(code) == sc->cons_symbol)) {
pair_set_syntax_op(form, OP_SET_CONS);
set_opt2_sym(code, cadr(value));
}
}
}
}
}
}
}
}
static void op_set_symbol_c(s7_scheme * sc)
{
s7_pointer slot;
slot = lookup_slot_from(cadr(sc->code), sc->curlet);
slot_set_value(slot, sc->value = opt2_con(cdr(sc->code)));
}
static void op_set_symbol_s(s7_scheme * sc)
{
s7_pointer slot;
slot = lookup_slot_from(cadr(sc->code), sc->curlet);
slot_set_value(slot, sc->value = lookup(sc, opt2_sym(cdr(sc->code))));
}
static void op_set_symbol_a(s7_scheme * sc)
{
s7_pointer slot;
slot = lookup_slot_from(cadr(sc->code), sc->curlet);
slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code)));
}
static void op_set_from_let_temp(s7_scheme * sc)
{
s7_pointer settee = sc->code, slot;
slot = lookup_slot_from(settee, sc->curlet);
if (!is_slot(slot))
unbound_variable_error(sc, settee);
if (is_immutable_slot(slot))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->let_temporarily_symbol,
settee));
if (slot_has_setter(slot))
slot_set_value(slot, call_setter(sc, slot, sc->value));
else
slot_set_value(slot, sc->value);
}
static inline void op_set_cons(s7_scheme * sc)
{
s7_pointer slot;
slot = lookup_slot_from(cadr(sc->code), sc->curlet);
slot_set_value(slot, sc->value = cons(sc, lookup(sc, opt2_sym(cdr(sc->code))), slot_value(slot))); /* ([set!] bindings (cons v bindings)) */
}
static void op_increment_ss(s7_scheme * sc)
{
s7_pointer slot;
sc->code = cdr(sc->code);
slot = lookup_slot_from(car(sc->code), sc->curlet);
set_car(sc->t2_1, slot_value(slot));
set_car(sc->t2_2, lookup(sc, opt2_sym(sc->code)));
slot_set_value(slot, sc->value =
fn_proc(cadr(sc->code)) (sc, sc->t2_1));
}
static void op_increment_saa(s7_scheme * sc)
{
s7_pointer slot, arg, val;
sc->code = cdr(sc->code);
slot = lookup_slot_from(car(sc->code), sc->curlet);
arg = opt2_pair(sc->code); /* cddr(value) */
val = fx_call(sc, cdr(arg));
set_car(sc->t3_2, fx_call(sc, arg));
set_car(sc->t3_3, val);
set_car(sc->t3_1, slot_value(slot));
slot_set_value(slot, sc->value =
fn_proc(cadr(sc->code)) (sc, sc->t3_1));
}
static void op_increment_sa(s7_scheme * sc)
{
s7_pointer slot, arg;
sc->code = cdr(sc->code);
slot = lookup_slot_from(car(sc->code), sc->curlet);
arg = opt2_pair(sc->code);
set_car(sc->t2_2, fx_call(sc, arg));
set_car(sc->t2_1, slot_value(slot));
slot_set_value(slot, sc->value =
fn_proc(cadr(sc->code)) (sc, sc->t2_1));
}
static inline void op_set_pair_a(s7_scheme * sc)
{
s7_pointer obj, setter, code = cdr(sc->code);
obj = lookup_checked(sc, caar(code));
setter = c_function_setter(obj);
obj = fx_call(sc, cdr(code));
set_car(sc->t2_1, cadar(code)); /* might be a constant: (set! (mus-sound-srate "oboe.snd") 12345) */
if (is_symbol(car(sc->t2_1)))
set_car(sc->t2_1, lookup_checked(sc, cadar(code)));
set_car(sc->t2_2, obj);
sc->value = c_function_call(setter) (sc, sc->t2_1);
}
static void op_set_pair_p(s7_scheme * sc)
{
/* ([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, cdr(sc->code));
sc->code = caddr(sc->code);
}
static bool set_pair_p_3(s7_scheme * sc, s7_pointer obj, s7_pointer arg,
s7_pointer value)
{
if (is_slot(obj))
obj = slot_value(obj);
else
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(obj)]));
switch (type(obj)) {
case T_C_OBJECT:
set_car(sc->t3_1, obj);
set_car(sc->t3_2, arg);
set_car(sc->t3_3, value);
sc->value = (*(c_object_set(sc, obj))) (sc, sc->t3_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:
case T_BYTE_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_t_integer(arg))
eval_error_any(sc, sc->wrong_type_arg_symbol,
"vector-set!: index must be an integer: ~S",
41, sc->code);
index = integer(arg);
if (index < 0)
eval_error_any(sc, sc->out_of_range_symbol,
"vector-set!: index must not be negative: ~S",
43, sc->code);
if (index >= vector_length(obj))
eval_error_any(sc, sc->out_of_range_symbol,
"vector-set!: index must be less than vector length: ~S",
54, sc->code);
if (is_immutable(obj))
immutable_object_error(sc,
set_elist_3(sc,
immutable_error_string,
sc->vector_set_symbol,
obj));
if (is_typed_vector(obj)) {
if ((sc->safety < NO_SAFETY) || /* or == NO_SAFETY?? */
(typed_vector_typer_call
(sc, obj, set_plist_1(sc, value)) != sc->F))
vector_element(obj, index) = value;
else
return (s7_wrong_type_arg_error
(sc, "vector-set!", 3, value,
make_type_name(sc,
typed_vector_typer_name(sc,
obj),
INDEFINITE_ARTICLE)));
} else
vector_setter(obj) (sc, obj, index, value);
sc->value = T_Pos(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_t_integer(arg))
eval_error_any(sc, sc->wrong_type_arg_symbol,
"index must be an integer: ~S", 28,
sc->code);
index = integer(arg);
if (index < 0)
eval_error_any(sc, sc->out_of_range_symbol,
"index must not be negative: ~S", 30,
sc->code);
if (index >= string_length(obj))
eval_error_any(sc, sc->out_of_range_symbol,
"index must be less than sequence length: ~S",
43, sc->code);
if (is_immutable(obj))
immutable_object_error(sc,
set_elist_3(sc,
immutable_error_string,
sc->string_set_symbol,
obj));
if (!is_character(value))
eval_error_any(sc, sc->wrong_type_arg_symbol,
"(string-)set!: value must be a character: ~S",
44, sc->code);
string_value(obj)[index] = (char) s7_character(value);
sc->value = value;
}
#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:
if (is_immutable(obj))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->hash_table_set_symbol,
obj));
sc->value = s7_hash_table_set(sc, obj, arg, value);
break;
case T_LET:
sc->value = s7_let_set(sc, obj, arg, value); /* this checks immutable */
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_any_procedure(c_function_setter(obj)))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(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);
sc->args =
(needs_copied_args(sc->code)) ? list_2(sc, arg,
value) :
set_plist_2(sc, arg, value);
return (true); /* goto APPLY; */
}
break;
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
case T_CLOSURE:
case T_CLOSURE_STAR:
if (!is_any_procedure(closure_setter(obj)))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(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);
sc->args =
(needs_copied_args(sc->code)) ? list_2(sc, arg,
value) :
set_plist_2(sc, arg, value);
return (true); /* goto APPLY; */
}
break;
default: /* (set! (1 2) 3) */
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(obj)]));
}
return (false);
}
static Inline bool op_set_pair_p_1(s7_scheme * sc)
{
/* 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 value = sc->value, arg = cadar(sc->code);
if (is_symbol(arg))
arg = lookup_checked(sc, arg);
else if (is_pair(arg))
arg = cadr(arg); /* can only be (quote ...) in this case */
return (set_pair_p_3
(sc, lookup_slot_from(caar(sc->code), sc->curlet), arg,
value));
}
static bool op_set_pair(s7_scheme * sc)
{
/* ([set!] (setter g) s) or ([set!] (str 0) #\a) */
s7_pointer obj, arg, value;
sc->code = cdr(sc->code);
value = cadr(sc->code);
if (is_symbol(value))
value = lookup_checked(sc, value);
arg = cadar(sc->code);
if (is_symbol(arg))
arg = lookup_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 = lookup_slot_from(obj, sc->curlet);
return (set_pair_p_3(sc, obj, arg, value));
}
static void op_set_safe(s7_scheme * sc)
{
s7_pointer lx;
lx = lookup_slot_from(sc->code, sc->curlet); /* SET_CASE above looks for car(sc->code) */
if (is_slot(lx))
slot_set_value(lx, sc->value);
else
unbound_variable_error(sc, sc->code);
}
static s7_pointer op_set1(s7_scheme * sc)
{
s7_pointer lx;
/* if unbound variable hook here, we need the binding, not the current value */
lx = lookup_slot_from(sc->code, sc->curlet);
if (is_slot(lx)) {
if (is_immutable(lx))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->set_symbol,
slot_symbol(lx)));
if (slot_has_setter(lx)) {
s7_pointer func = slot_setter(lx);
if (is_c_function(func))
sc->value =
call_c_function_setter(sc, func, sc->code, sc->value);
else if (is_any_procedure(func)) {
/* don't push OP_EVAL_DONE here and call eval(sc, OP_APPLY) below -- setter might hit an error */
push_stack_no_args(sc, OP_SET_FROM_SETTER, lx);
if (has_let_arg(func))
sc->args = list_3(sc, sc->code, sc->value, sc->curlet);
else
sc->args = list_2(sc, sc->code, sc->value); /* these lists are reused as the closure_let slots in apply_lambda via apply_closure */
sc->code = func;
return (NULL); /* goto APPLY */
}
} else if ((is_syntactic_symbol(sc->code)) || /* (set! case 3) */
((global_slot(sc->code) == lx) && /* (begin (let ((case 2)) case) (set! case 3)) */
(is_syntax(slot_value(lx))) &&
(sc->code == syntax_symbol(slot_value(lx)))))
eval_error(sc, "can't set! ~A", 13, sc->code);
slot_set_value(lx, sc->value);
symbol_increment_ctr(sc->code); /* see define setfib example in s7test.scm -- I'm having second thoughts about this... */
return (sc->value); /* goto START */
}
if (has_let_set_fallback(sc->curlet)) /* (with-let (mock-hash-table 'b 2) (set! b 3)) */
return (call_let_set_fallback
(sc, sc->curlet, sc->code, sc->value));
return (s7_error
(sc, sc->unbound_variable_symbol,
set_elist_4(sc,
wrap_string(sc, "~S is unbound in (set! ~S ~S)",
29), sc->code, sc->code, sc->value)));
}
static goto_t set_implicit(s7_scheme * sc);
static goto_t op_set2(s7_scheme * sc)
{
if (is_pair(sc->value)) {
/* (let ((L '((1 2 3)))) (set! ((L 0) 1) 32) L)
* (let ((L '(((1 2 3))))) (set! ((L 0) 0 1) 32) L)
* any deeper nesting was handled already by the first eval
* set! looks at its first argument, if it's a symbol, it sets the associated value,
* if it's a list, it looks at the car of that list to decide which setter to call,
* if it's a list of lists, it passes the embedded lists to eval, then looks at the
* car of the result. This means that we can do crazy things like:
* (let ((x '(1)) (y '(2))) (set! ((if #t x y) 0) 32) x)
* the other args need to be evaluated (but not the list as if it were code):
* (let ((L '((1 2 3))) (index 1)) (set! ((L 0) index) 32) L)
*/
if (!s7_is_proper_list(sc, sc->args)) /* (set! ('(1 2) 1 . 2) 1) */
eval_error(sc,
"set! target arguments are an improper list: ~A",
46, sc->args);
if (is_multiple_value(sc->value)) /* this has to be at least 2 args, sc->args and sc->code make 2 more, so... */
eval_error(sc, "set!: too many arguments: ~S", 28,
set_ulist_1(sc, sc->set_symbol,
pair_append(sc,
multiple_value(sc->value),
pair_append(sc, sc->args,
sc->code))));
if (sc->args == sc->nil)
eval_error(sc, "list set!: not enough arguments: ~S", 35,
sc->code);
push_op_stack(sc, sc->list_set_function);
if (!is_null(cdr(sc->args)))
sc->code = pair_append(sc, cdr(sc->args), sc->code);
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value),
T_Pair(sc->code));
sc->code = car(sc->args);
return (goto_eval);
}
if (is_any_vector(sc->value)) {
/* (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)
eval_error(sc, "vector set!: not enough arguments: ~S", 37,
sc->code);
push_op_stack(sc, sc->vector_set_function);
if (!is_null(cdr(sc->args)))
sc->code = pair_append(sc, cdr(sc->args), sc->code);
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value),
T_Pair(sc->code));
sc->code = car(sc->args);
return (goto_eval);
}
#if 0
sc->code = cons_unchecked(sc, sc->set_symbol, cons_unchecked(sc, cons(sc, sc->value, sc->args), sc->code)); /* (let ((x 32)) (set! ((curlet) 'x) 3) x) */
#else
sc->code =
set_ulist_2(sc, sc->set_symbol,
set_ulist_1(sc, sc->value, sc->args), sc->code);
#endif
return (set_implicit(sc));
}
static bool op_set_with_let_1(s7_scheme * sc)
{
s7_pointer e, b, x;
/* from the T_SYNTAX branch of op_set_pair: (set! (with-let e b) x) as in let-temporarily
* here sc->value is the new value for the settee = x, args has the (as yet unevaluated) let and settee-expression.
* 'b above can be a pair = generalized set in the 'e environment.
*/
if (!is_pair(sc->args)) /* (set! (with-let) ...) */
eval_error(sc, "set! (with-let)? ~A", 19, current_code(sc));
if (!is_pair(cdr(sc->args))) /* (set! (with-let e) ...) */
eval_error(sc, "set! (with-let ...) has no symbol to set? ~A", 44,
current_code(sc));
e = car(sc->args);
b = cadr(sc->args);
x = sc->value;
if (is_symbol(e)) {
if (is_symbol(b)) {
e = lookup_checked(sc, e); /* the let */
if (!is_let(e))
wrong_type_argument_with_type(sc, sc->let_set_symbol, 1, e,
a_let_string);
sc->value = let_set_1(sc, e, b, x);
pop_stack(sc);
return (true);
}
sc->value = lookup_checked(sc, e);
sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x))
|| (is_pair(x))) ?
set_plist_2(sc, sc->quote_symbol, x) : x);
/* (let* ((x (vector 1 2)) (lt (curlet))) (set! (with-let lt (x 0)) 32) x) here: (set! (x 0) 32) */
return (false); /* goto SET_WITH_LET */
}
sc->code = e; /* 'e above, an expression we need to evaluate */
sc->args = set_plist_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */
push_stack_direct(sc, OP_SET_WITH_LET_2);
sc->cur_op = optimize_op(sc->code);
return (true); /* goto top_no_pop */
}
static bool op_set_with_let_2(s7_scheme * sc)
{
s7_pointer b, x;
/* here sc->value = let = 'e, args = '(b x) where 'b might be a pair */
if (!is_let(sc->value))
wrong_type_argument_with_type(sc, sc->let_set_symbol, 1, sc->value,
a_let_string);
b = car(sc->args);
x = cadr(sc->args);
if (is_symbol(b)) { /* b is a symbol -- everything else is ready so call let-set! */
sc->value = let_set_1(sc, sc->value, b, x);
return (true); /* goto START */
}
if ((is_symbol(x)) || (is_pair(x))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */
sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x))
|| (is_pair(x))) ?
set_plist_2(sc, sc->quote_symbol, x) : x);
else
sc->code = set_ulist_1(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), x=16 b=(*s7* 'print-length) */
return (false); /* fall into SET_WITH_LET */
}
static bool op_set_normal(s7_scheme * sc)
{
s7_pointer x;
sc->code = cdr(sc->code);
x = cadr(sc->code);
if (is_pair(x)) {
push_stack_no_args(sc, OP_SET1, car(sc->code));
sc->code = x;
return (true);
}
sc->value = (is_symbol(x)) ? lookup_checked(sc, x) : T_Pos(x);
sc->code = car(sc->code);
return (false);
}
static void op_set_symbol_p(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_no_args(sc, OP_SET_SAFE, cadr(sc->code));
sc->code = caddr(sc->code);
}
static void op_increment_sp(s7_scheme * sc)
{
s7_pointer sym;
sc->code = cdr(sc->code);
sym = lookup_slot_from(car(sc->code), sc->curlet);
push_stack(sc, OP_INCREMENT_SP_1, sym, sc->code);
sc->code = T_Pair(opt2_pair(sc->code)); /* caddadr(sc->code); */
}
static void op_increment_sp_1(s7_scheme * sc)
{
set_car(sc->t2_1, slot_value(sc->args));
set_car(sc->t2_2, sc->value);
sc->value = fn_proc(cadr(sc->code)) (sc, sc->t2_1);
slot_set_value(sc->args, sc->value);
}
static void op_increment_sp_mv(s7_scheme * sc)
{
sc->value =
fn_proc(cadr(sc->code)) (sc,
set_ulist_1(sc, slot_value(sc->args),
sc->value));
set_car(sc->u1_1, sc->F);
slot_set_value(sc->args, sc->value);
}
static goto_t op_set_dilambda_p_1(s7_scheme * sc)
{
s7_pointer obj, func, arg = cadar(sc->code);
if (is_symbol(arg))
arg = lookup_checked(sc, arg);
else if (is_pair(arg))
arg = cadr(arg); /* can only be (quote ...) in this case */
obj = lookup_slot_from(caar(sc->code), sc->curlet);
func = slot_value(obj);
if ((is_closure(func)) && (is_safe_closure(closure_setter(func)))) {
s7_pointer setter = closure_setter(func);
if (is_pair(closure_args(setter))) {
sc->curlet =
update_let_with_two_slots(sc, closure_let(setter), arg,
sc->value);
sc->code = T_Pair(closure_body(setter));
return (goto_begin);
}
}
return ((set_pair_p_3(sc, obj, arg, sc->value)) ? goto_apply :
goto_start);
}
/* ---------------- implicit ref/set ---------------- */
static Inline goto_t op_implicit_vector_ref_a(s7_scheme * sc)
{
s7_pointer v, x;
v = lookup_checked(sc, car(sc->code));
if (!is_any_vector(v)) {
sc->last_function = v;
return (fall_through);
}
x = fx_call(sc, cdr(sc->code));
if ((s7_is_integer(x)) && (vector_rank(v) == 1)) {
s7_int index = s7_integer_checked(sc, x);
if ((index < vector_length(v)) && (index >= 0)) {
sc->value =
(is_float_vector(v)) ? make_real(sc,
float_vector(v,
index)) :
vector_getter(v) (sc, v, index);
return (goto_start);
}
}
sc->value = vector_ref_1(sc, v, set_plist_1(sc, x));
return (goto_start);
}
static goto_t op_implicit_vector_ref_aa(s7_scheme * sc)
{
s7_pointer v, x, y, code;
v = lookup_checked(sc, car(sc->code));
if (!is_any_vector(v)) {
sc->last_function = v;
return (fall_through);
}
code = cdr(sc->code);
x = fx_call(sc, code);
y = fx_call(sc, cdr(code));
if ((s7_is_integer(x)) && (s7_is_integer(y)) && (vector_rank(v) == 2)) {
s7_int ix = s7_integer_checked(sc, x), iy =
s7_integer_checked(sc, y);
if ((ix >= 0) && (iy >= 0) && (ix < vector_dimension(v, 0))
&& (iy < vector_dimension(v, 1))) {
s7_int index;
index = (ix * vector_offset(v, 0)) + iy;
sc->value = vector_getter(v) (sc, v, index); /* check for normal vector saves in some cases, costs in others */
return (goto_start);
}
}
sc->value = vector_ref_1(sc, v, set_plist_2(sc, x, y));
return (goto_start);
}
static inline bool op_implicit_vector_set_3(s7_scheme * sc)
{
s7_pointer v, i1, code = cdr(sc->code);
v = lookup(sc, caar(code));
if (!is_any_vector(v)) {
/* this could be improved -- set_pair_p_3 perhaps: pair_p_3 set opt3? but this calls g_vector_set_3 */
pair_set_syntax_op(sc->code, OP_SET_UNCHECKED);
return (true);
}
i1 = fx_call(sc, cdar(code)); /* gc protect? */
set_car(sc->t3_3, fx_call(sc, cdr(code)));
set_car(sc->t3_1, v);
set_car(sc->t3_2, i1);
sc->value = g_vector_set_3(sc, sc->t3_1); /* calls vector_setter handling any vector type whereas vector_set_p_ppp wants a normal vector */
/* sc->value = vector_set_p_ppp(sc, v, i1, fx_call(sc, cdr(code))); */
return (false);
}
static bool op_implicit_vector_set_4(s7_scheme * sc)
{
s7_pointer v, i1, i2, code = cdr(sc->code);
v = lookup(sc, caar(code));
if (!is_any_vector(v)) {
pair_set_syntax_op(sc->code, OP_SET_UNCHECKED);
return (true);
}
i1 = fx_call(sc, cdar(code));
i2 = fx_call(sc, opt3_pair(sc->code)); /* cddar(code) */
set_car(sc->t3_3, fx_call(sc, cdr(code)));
set_car(sc->t4_1, v);
set_car(sc->t3_1, i1);
set_car(sc->t3_2, i2);
sc->value = g_vector_set_4(sc, sc->t4_1);
set_car(sc->t4_1, sc->F);
return (false);
}
static goto_t set_implicit_vector(s7_scheme * sc, s7_pointer cx,
s7_pointer form)
{
/* cx is the vector, sc->code is expr without the set!, form is the full expr, args have not been evaluated! */
s7_pointer settee = car(sc->code), index;
s7_int argnum;
if (!implicit_set_ok(sc->code)) {
if (!is_pair(cdr(sc->code))) /* (set! (v 0)) */
s7_wrong_number_of_args_error(sc,
"no value for vector-set!: ~S",
form);
if (!is_null(cddr(sc->code))) /* (set! (v 0) 1 2) */
s7_wrong_number_of_args_error(sc,
"too many values for vector-set!: ~S",
form);
if (!is_pair(cdr(settee)))
s7_wrong_number_of_args_error(sc,
"no index for vector-set!: ~S",
form);
set_implicit_set_ok(sc->code);
}
if (is_immutable(cx))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->vector_set_symbol, cx));
argnum = proper_list_length(cdr(settee));
if ((argnum > 1) &&
(is_normal_vector(cx)) && (argnum != vector_rank(cx))) {
/* this block needs to be first to handle (eg):
* (let ((v (vector (inlet 'a 0)))) (set! (v 0 'a) 32) v): #((inlet 'a 32))
*/
push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code));
sc->code = list_2(sc, car(settee), cadr(settee));
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
if ((argnum > 1) || (vector_rank(cx) > 1)) {
if ((argnum == 2) && (is_fxable(sc, cadr(settee))) && (is_fxable(sc, caddr(settee))) && (is_fxable(sc, cadr(sc->code)))) { /* (set! (v fx fx) fx) */
fx_annotate_args(sc, cdr(settee), sc->curlet);
fx_annotate_arg(sc, cdr(sc->code), sc->curlet);
set_opt3_pair(form, cddr(settee));
pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_4);
}
if ((argnum == vector_rank(cx)) && (!is_pair(cadr(sc->code)))) {
s7_pointer p;
for (p = cdr(settee); is_pair(p); p = cdr(p))
if (is_pair(car(p)))
break;
if (is_null(p)) {
s7_pointer args, pa;
args = safe_list_if_possible(sc, argnum + 2);
if (in_heap(args))
gc_protect_via_stack(sc, args);
car(args) = cx;
for (p = cdr(settee), pa = cdr(args); is_pair(p);
p = cdr(p), pa = cdr(pa)) {
index = car(p);
if (is_symbol(index))
index = lookup_checked(sc, index);
if (!s7_is_integer(index))
eval_error_any(sc, sc->wrong_type_arg_symbol,
"vector-set!: index must be an integer: ~S",
41, form);
car(pa) = index;
}
car(pa) = cadr(sc->code);
if (is_symbol(car(pa)))
car(pa) = lookup_checked(sc, car(pa));
sc->value = g_vector_set(sc, args);
if (in_heap(args))
unstack(sc);
else
clear_list_in_use(args);
return (goto_start);
}
}
push_op_stack(sc, sc->vector_set_function); /* vector_setter(cx) has wrong args */
sc->code = (is_null(cddr(settee))) ? cdr(sc->code) : pair_append(sc, cddr(settee), cdr(sc->code)); /* i.e. rest(args) + val */
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), sc->code);
sc->code = cadr(settee);
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
/* one index, rank == 1 */
index = cadr(settee);
if ((is_fxable(sc, index)) && (is_fxable(sc, cadr(sc->code)))) {
fx_annotate_arg(sc, cdr(settee), sc->curlet);
fx_annotate_arg(sc, cdr(sc->code), sc->curlet);
pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_3);
}
if (!is_pair(index)) {
s7_int ind;
s7_pointer val;
if (is_symbol(index))
index = lookup_checked(sc, index);
if (!s7_is_integer(index))
eval_error_any(sc, sc->wrong_type_arg_symbol,
"vector-set!: index must be an integer: ~S", 41,
sc->code);
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= vector_length(cx)))
out_of_range(sc, sc->vector_set_symbol, int_two, index,
(ind <
0) ? its_negative_string : its_too_large_string);
val = cadr(sc->code);
if (!is_pair(val)) {
if (is_symbol(val))
val = lookup_checked(sc, val);
if (is_typed_vector(cx))
typed_vector_setter(sc, cx, ind, val);
else
vector_setter(cx) (sc, cx, ind, val);
sc->value = T_Pos(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);
}
/* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens */
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code));
push_op_stack(sc, sc->vector_set_function);
sc->code = cadr(settee);
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t set_implicit_c_object(s7_scheme * sc, s7_pointer cx,
s7_pointer form)
{
s7_pointer settee, index, val;
if (!implicit_set_ok(sc->code)) {
if (!is_pair(cdr(sc->code)))
s7_wrong_number_of_args_error(sc,
"no value for object-set!: ~S",
form);
if (!is_null(cddr(sc->code)))
s7_wrong_number_of_args_error(sc,
"too many values for object-set!: ~S",
form);
set_implicit_set_ok(sc->code);
}
settee = car(sc->code);
if ((!is_pair(cdr(settee))) || (!is_null(cddr(settee)))) {
push_op_stack(sc, sc->c_object_set_function);
if (is_null(cdr(settee))) {
push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), sc->nil);
sc->code = cadr(sc->code);
} else {
sc->code = pair_append(sc, cddr(settee), cdr(sc->code));
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), sc->code);
sc->code = cadr(settee);
}
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
index = cadr(settee);
if (!is_pair(index)) {
if (is_symbol(index))
index = lookup_checked(sc, index);
val = cadr(sc->code);
if (!is_pair(val)) {
if (is_symbol(val))
val = lookup_checked(sc, val);
set_car(sc->t3_1, cx);
set_car(sc->t3_2, index);
set_car(sc->t3_3, val);
sc->value = (*(c_object_set(sc, cx))) (sc, sc->t3_1);
return (goto_start);
}
push_op_stack(sc, sc->c_object_set_function);
sc->args = list_2(sc, index, cx);
sc->code = cdr(sc->code);
return (goto_eval_args);
}
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code));
push_op_stack(sc, sc->c_object_set_function);
sc->code = cadr(settee);
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t op_implicit_string_ref_a(s7_scheme * sc)
{
s7_int index;
s7_pointer s, x;
s = lookup_checked(sc, car(sc->code));
x = fx_call(sc, cdr(sc->code));
if (!is_string(s)) {
sc->last_function = s;
return (fall_through);
}
if (!s7_is_integer(x)) {
sc->value = string_ref_1(sc, s, set_plist_1(sc, x));
return (goto_start);
}
index = s7_integer_checked(sc, x);
if ((index < string_length(s)) && (index >= 0)) {
sc->value = chars[((uint8_t *) string_value(s))[index]];
return (goto_start);
}
sc->value = string_ref_1(sc, s, x);
return (goto_start);
}
static goto_t set_implicit_string(s7_scheme * sc, s7_pointer cx,
s7_pointer form)
{
/* here only one index makes sense, and it is required, so (set! ("str") #\a), (set! ("str" . 1) #\a) and (set! ("str" 1 2) #\a) are all errors (but see below!) */
s7_pointer settee = car(sc->code), index, val;
if (!implicit_set_ok(sc->code)) {
if (!is_pair(cdr(sc->code)))
s7_wrong_number_of_args_error(sc,
"no value for string-set!: ~S",
form);
if (!is_null(cddr(sc->code)))
s7_wrong_number_of_args_error(sc,
"too many values for string-set!: ~S",
form);
if (!is_pair(cdr(settee)))
s7_wrong_number_of_args_error(sc,
"no index for string-set!: ~S",
form);
if (!is_null(cddr(settee)))
s7_wrong_number_of_args_error(sc,
"too many indices for string-set!: ~S",
form);
set_implicit_set_ok(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 = lookup_checked(sc, index);
if (!s7_is_integer(index))
eval_error_any(sc, sc->wrong_type_arg_symbol,
"index must be an integer: ~S", 28, form);
ind = s7_integer_checked(sc, index);
if ((ind < 0) || (ind >= string_length(cx)))
out_of_range(sc, sc->string_set_symbol, int_two, index,
(ind <
0) ? its_negative_string : its_too_large_string);
if (is_immutable(cx))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->string_set_symbol, cx));
val = cadr(sc->code);
if (!is_pair(val)) {
if (is_symbol(val))
val = lookup_checked(sc, val);
if (is_character(val)) {
string_value(cx)[ind] = character(val);
sc->value = val;
return (goto_start);
}
eval_error_any(sc, sc->wrong_type_arg_symbol,
"value must be a character: ~S", 29, form);
}
push_op_stack(sc, sc->string_set_function);
sc->args = list_2(sc, index, cx);
sc->code = cdr(sc->code);
return (goto_eval_args);
}
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code)); /* args4 not 1 because we know cdr(sc->code) is a pair */
push_op_stack(sc, sc->string_set_function);
sc->code = cadar(sc->code);
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t set_implicit_pair(s7_scheme * sc, s7_pointer cx,
s7_pointer form)
{ /* code: ((lst 1) 32) from (let ((lst (list 1 2 3))) (set! (lst 1) 32)) */
s7_pointer settee = car(sc->code), index, val;
if (!implicit_set_ok(sc->code)) {
if (!is_pair(cdr(sc->code)))
s7_wrong_number_of_args_error(sc, "no value for list-set!: ~S",
form);
if (!is_null(cddr(sc->code)))
s7_wrong_number_of_args_error(sc,
"too many values for list-set!: ~S",
form);
if (!is_pair(cdr(settee)))
s7_wrong_number_of_args_error(sc, "no index for list-set!: ~S",
form);
set_implicit_set_ok(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));
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
index = cadr(settee);
val = cadr(sc->code);
if ((is_pair(index)) || (is_pair(val))) {
push_op_stack(sc, sc->list_set_function);
sc->code =
(is_null(cddr(settee))) ? cdr(sc->code) : pair_append(sc,
cddr
(settee),
cdr
(sc->code));
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), sc->code);
sc->code = index;
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
if (is_symbol(index))
index = lookup_checked(sc, index);
if (is_symbol(val))
val = lookup_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);
}
static goto_t set_implicit_hash_table(s7_scheme * sc, s7_pointer cx,
s7_pointer form)
{
s7_pointer settee = car(sc->code), key;
if (!implicit_set_ok(sc->code)) {
if (!is_pair(cdr(sc->code)))
s7_wrong_number_of_args_error(sc,
"no value for hash-table-set!: ~S",
form);
if (!is_null(cddr(sc->code)))
s7_wrong_number_of_args_error(sc,
"too many values for hash-table-set!: ~S",
form);
if (!is_pair(cdr(settee)))
s7_wrong_number_of_args_error(sc,
"no key for hash-table-set!: ~S",
form);
set_implicit_set_ok(sc->code);
}
if (is_immutable(cx))
immutable_object_error(sc,
set_elist_3(sc, immutable_error_string,
sc->hash_table_set_symbol, cx));
if (!is_null(cddr(settee))) {
push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code));
sc->code = list_2(sc, car(settee), cadr(settee));
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
key = cadr(settee);
if (!is_pair(key)) {
s7_pointer val;
if (is_symbol(key))
key = lookup_checked(sc, key);
val = cadr(sc->code);
if (!is_pair(val)) {
if (is_symbol(val))
val = lookup_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);
}
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code));
push_op_stack(sc, sc->hash_table_set_function);
sc->code = cadar(sc->code);
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t set_implicit_let(s7_scheme * sc, s7_pointer cx,
s7_pointer form)
{
s7_pointer settee = car(sc->code), key;
/* code: ((gen 'input) input) from (set! (gen 'input) input) */
if (!implicit_set_ok(sc->code)) {
if (!is_pair(cdr(sc->code)))
s7_wrong_number_of_args_error(sc, "no value for let-set!: ~S",
form);
if (!is_null(cddr(sc->code)))
s7_wrong_number_of_args_error(sc,
"too many values for let-set!: ~S",
form);
if (!is_pair(cdr(settee)))
s7_wrong_number_of_args_error(sc,
"no symbol (variable name) for let-set!: ~S",
form);
set_implicit_set_ok(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));
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
key = cadr(settee);
if (is_proper_quote(sc, key)) {
s7_pointer val = cadr(sc->code);
key = cadr(key);
if (!is_pair(val)) {
if (is_symbol(val))
val = lookup_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);
}
push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code));
push_op_stack(sc, sc->let_set_function);
sc->code = cadar(sc->code);
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t set_implicit_function(s7_scheme * sc, s7_pointer cx)
{ /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */
if (!is_t_procedure(c_function_setter(cx))) {
if (!is_any_macro(c_function_setter(cx)))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(cx)]));
if (is_null(cdar(sc->code)))
sc->args = cdr(sc->code);
else
sc->args = pair_append(sc, cdar(sc->code), cdr(sc->code));
sc->code = c_function_setter(cx);
return (goto_apply);
}
/* here the setter can be anything, so we need to check the needs_copied_args bit. (set! ((dilambda / (let ((x 3)) (lambda (y) (+ x y))))) 3)! */
if (is_pair(cdar(sc->code))) {
if ((is_symbol(cadr(sc->code))) && (is_symbol(cadar(sc->code)))) {
if (is_null(cddar(sc->code))) {
if (needs_copied_args(c_function_setter(cx)))
sc->args =
list_2(sc, lookup_checked(sc, cadar(sc->code)),
lookup_checked(sc, cadr(sc->code)));
else {
s7_pointer val1, val2;
val1 = lookup_checked(sc, cadar(sc->code));
val2 = lookup_checked(sc, cadr(sc->code));
set_car(sc->t2_1, val1);
set_car(sc->t2_2, val2);
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)))) {
if (needs_copied_args(c_function_setter(cx)))
sc->args = list_3(sc,
lookup_checked(sc, cadar(sc->code)),
lookup_checked(sc, caddar(sc->code)),
lookup_checked(sc, cadr(sc->code)));
else {
s7_pointer val1, val2, val3;
val1 = lookup_checked(sc, cadar(sc->code));
val2 = lookup_checked(sc, caddar(sc->code));
val3 = lookup_checked(sc, cadr(sc->code));
set_car(sc->t3_1, val1);
set_car(sc->t3_2, val2);
set_car(sc->t3_3, val3);
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));
sc->value =
(is_null(cddar(sc->code))) ? cdr(sc->code) : pair_append(sc,
cddar
(sc->code),
cdr
(sc->code));
push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->value);
sc->code = cadar(sc->code);
} else {
if ((is_null(cddr(sc->code))) && (!is_pair(cadr(sc->code)))) {
if (needs_copied_args(c_function_setter(cx)))
sc->args =
list_1(sc,
(is_symbol(cadr(sc->code))) ? lookup_checked(sc,
cadr
(sc->code))
: cadr(sc->code));
else {
if (is_symbol(cadr(sc->code)))
set_car(sc->t1_1, lookup_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);
}
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t set_implicit_closure(s7_scheme * sc, s7_pointer cx)
{
s7_pointer setter = closure_setter(cx);
if ((setter == sc->F) && (!closure_no_setter(cx)))
setter = g_setter(sc, set_plist_1(sc, cx));
if (is_t_procedure(setter)) {
/* (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 {
sc->value =
pair_append(sc, cddar(sc->code), cdr(sc->code));
push_stack(sc, OP_EVAL_ARGS4, sc->nil, sc->value);
}
sc->code = cadar(sc->code);
}
} else {
if (!is_any_macro(setter))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(cx)]));
if (is_null(cdar(sc->code)))
sc->args = cdr(sc->code);
else
sc->args = pair_append(sc, cdar(sc->code), cdr(sc->code));
sc->code = setter;
return (goto_apply);
}
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t set_implicit_iterator(s7_scheme * sc, s7_pointer cx)
{
s7_pointer 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))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(cx)]));
sc->args = cdr(sc->code);
sc->code = setter;
return (goto_apply);
}
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t set_implicit_syntax(s7_scheme * sc, s7_pointer cx)
{
if (cx != global_value(sc->with_let_symbol))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(cx)]));
/* (set! (with-let a b) x), cx = with-let, sc->code = ((with-let a b) x)
* a and x are in the current let, b is in a, we need to evaluate a and x, then
* call (with-let a-value (set! b x-value))
*/
sc->args = cdar(sc->code);
sc->code = cadr(sc->code);
push_stack_direct(sc, OP_SET_WITH_LET_1);
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
}
static goto_t set_implicit(s7_scheme * sc)
{ /* sc->code incoming is (set! (...) ...) */
s7_pointer caar_code, cx, form = sc->code;
sc->code = cdr(sc->code);
caar_code = caar(sc->code);
if (is_symbol(caar_code)) {
/* this was cx = s7_symbol_value(sc, caar_code) but the function call overhead is noticeable */
cx = lookup_slot_from(caar_code, sc->curlet);
if (is_slot(cx))
cx = slot_value(cx);
else
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar_code,
sc->prepackaged_type_names[type(cx)]));
} else if (is_pair(caar_code)) {
push_stack(sc, OP_SET2, cdar(sc->code), T_Pair(cdr(sc->code)));
sc->code = caar_code;
sc->cur_op = optimize_op(sc->code);
return (goto_top_no_pop);
} else
cx = caar_code;
/* code here is the setter and the value without the "set!": ((window-width) 800) */
/* (set! (hi 0) (* 2 3)) -> ((hi 0) (* 2 3)) */
/* for gmp case, indices need to be decoded via s7_integer, not just integer */
switch (type(cx)) {
case T_STRING:
return (set_implicit_string(sc, cx, form));
case T_PAIR:
return (set_implicit_pair(sc, cx, form));
case T_HASH_TABLE:
return (set_implicit_hash_table(sc, cx, form));
case T_LET:
return (set_implicit_let(sc, cx, form));
case T_C_OBJECT:
return (set_implicit_c_object(sc, cx, form));
case T_ITERATOR:
return (set_implicit_iterator(sc, cx)); /* not sure this makes sense */
case T_SYNTAX:
return (set_implicit_syntax(sc, cx));
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
case T_BYTE_VECTOR:
return (set_implicit_vector(sc, cx, form));
case T_C_MACRO:
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:
return (set_implicit_function(sc, cx));
case T_MACRO:
case T_MACRO_STAR:
case T_BACRO:
case T_BACRO_STAR:
case T_CLOSURE:
case T_CLOSURE_STAR:
return (set_implicit_closure(sc, cx));
default: /* (set! (1 2) 3) */
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar_code,
sc->prepackaged_type_names[type(cx)]));
}
return (goto_top_no_pop);
}
/* -------------------------------- do -------------------------------- */
static bool safe_stepper_expr(s7_pointer expr, s7_pointer var)
{
/* for now, just look for stepper as last element of any list
* any embedded set is handled by do_is_safe, so we don't need to descend into the depths
*/
s7_pointer p;
if (cadr(expr) == var)
return (false);
for (p = cdr(expr); is_pair(cdr(p)); p = cdr(p));
if (is_pair(p)) {
if ((is_optimized(p)) &&
(op_has_hop(p)) && (is_safe_c_op(optimize_op(p))))
return (true);
if (car(p) == var)
return (false);
} else if (p == var)
return (false);
return (true);
}
static bool tree_match(s7_pointer tree)
{
if (is_symbol(tree))
return (is_matched_symbol(tree));
return ((is_pair(tree)) &&
((tree_match(car(tree))) || (tree_match(cdr(tree)))));
}
static bool do_is_safe(s7_scheme * sc, s7_pointer body, s7_pointer stepper,
s7_pointer var_list, bool *has_set)
{
/* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble
* we can free var_list if return(false) not after (!do_is_safe...), but it seems to make no difference, or be slightly slower
*/
s7_pointer p;
/* sc->code is the complete do form (do ...) */
for (p = body; is_pair(p); p = cdr(p)) {
s7_pointer expr = car(p);
if (is_pair(expr)) {
s7_pointer x = car(expr);
if ((is_symbol(x))
|| ((is_c_function(x)) && (is_safe_procedure(x)))) {
if (is_symbol_and_syntactic(x)) {
opcode_t op;
s7_pointer func = global_value(x), vars, cp;
op = (opcode_t) syntax_opcode(func);
switch (op) {
case OP_MACROEXPAND:
return (false);
case OP_QUOTE:
if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (quote . 1) or (quote 1 2) etc */
return (false);
break;
case OP_LET:
case OP_LET_STAR:
case OP_LETREC:
case OP_LETREC_STAR:
if ((!is_pair(cdr(expr))) ||
(!is_list(cadr(expr))) ||
(!is_pair(cddr(expr))))
return (false);
cp = var_list;
for (vars = cadr(expr); is_pair(vars);
vars = cdr(vars)) {
s7_pointer var;
if (!is_pair(car(vars)))
return (false);
var = caar(vars);
if (direct_memq(var, ((op == OP_LET)
|| (op ==
OP_LETREC)) ? cp :
var_list))
return (false);
if ((!is_symbol(var)) || (is_keyword(var)))
return (false);
cp = cons(sc, var, cp);
sc->x = cp;
}
sc->x = sc->nil;
if (!do_is_safe
(sc, cddr(expr), stepper, cp, has_set))
return (false);
break;
case OP_DO:
if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */
return (false);
cp = var_list;
for (vars = cadr(expr); is_pair(vars);
vars = cdr(vars)) {
s7_pointer var;
if (!is_pair(car(vars)))
return (false);
var = caar(vars);
if ((direct_memq(var, cp)) || (var == stepper))
return (false);
cp = cons(sc, var, cp);
sc->x = cp;
if ((is_pair(cdar(vars))) &&
(!do_is_safe
(sc, cdar(vars), stepper, cp, has_set))) {
sc->x = sc->nil;
return (false);
}
}
sc->x = sc->nil;
if (!do_is_safe
(sc, caddr(expr), stepper, cp, has_set))
return (false);
if ((is_pair(cdddr(expr))) &&
(!do_is_safe
(sc, cdddr(expr), stepper, cp, has_set)))
return (false);
break;
case OP_SET:
{
s7_pointer settee;
if (!is_pair(cdr(expr))) /* (set!) */
return (false);
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 = lookup_unexamined(sc, car(settee));
if (!((setv) &&
((is_sequence(setv)) ||
((is_c_function(setv)) &&
(is_safe_procedure
(c_function_setter(setv)))))))
return (false);
if (has_set)
(*has_set) = true;
} else {
if ((is_pair(caddr(sc->code))) && /* sc->code = do-form (formerly (cdr(do-form)) causing a bug here) */
(is_pair(caaddr(sc->code)))) {
bool res;
set_match_symbol(settee);
res = tree_match(caaddr(sc->code)); /* (set! end ...) in some fashion */
clear_match_symbol(settee);
if (res)
return (false);
}
if ((has_set) && (!direct_memq(cadr(expr), var_list))) /* is some non-local variable being set? */
(*has_set) = true;
}
if (!do_is_safe
(sc, cddr(expr), stepper, var_list,
has_set))
return (false);
if (!safe_stepper_expr(expr, stepper)) /* is step var's value used as the stored value by set!? */
return (false);
}
break;
case OP_LET_TEMPORARILY:
if ((!is_pair(cdr(expr))) ||
(!is_pair(cadr(expr))) ||
(!is_pair(cddr(expr))))
return (false);
for (cp = cadr(expr); is_pair(cp); cp = cdr(cp))
if ((!is_pair(car(cp))) ||
(!is_pair(cdar(cp))) ||
(!do_is_safe
(sc, cdar(cp), stepper, var_list,
has_set)))
return (false);
if (!do_is_safe
(sc, cddr(expr), stepper, var_list, has_set))
return (false);
break;
case OP_COND:
for (cp = cdr(expr); is_pair(cp); cp = cdr(cp))
if (!do_is_safe
(sc, car(cp), stepper, var_list, has_set))
return (false);
break;
case OP_CASE:
if ((!is_pair(cdr(expr))) ||
(!do_is_safe
(sc, cadr(expr), stepper, var_list, has_set)))
return (false);
for (cp = cddr(expr); is_pair(cp); cp = cdr(cp))
if ((!is_pair(car(cp))) || /* (case x #(123)...) */
(!do_is_safe
(sc, cdar(cp), stepper, var_list,
has_set)))
return (false);
break;
case OP_IF:
case OP_WHEN:
case OP_UNLESS:
case OP_AND:
case OP_OR:
case OP_BEGIN:
case OP_WITH_BAFFLE:
if (!do_is_safe
(sc, cdr(expr), stepper, var_list, has_set))
return (false);
break;
case OP_WITH_LET:
return (true); /* ?? did I mean false here?? */
default:
return (false);
}
} /* is_syntax(x=car(expr)) */
else {
/* if a macro, we'll eventually expand it (if *_optimize), but that requires a symbol lookup here and macroexpand */
if ((!is_optimized(expr)) ||
(optimize_op(expr) == OP_UNKNOWN_NP) ||
(!do_is_safe
(sc, cdr(expr), stepper, var_list, has_set)))
return (false);
if ((is_symbol(x)) && (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 (is_null(cdr(expr))) /* (vector) for example */
return ((x == sc->vector_symbol) ||
(x == sc->list_symbol) ||
(x == sc->string_symbol));
if ((has_set) && (!direct_memq(cadr(expr), var_list)) && /* non-local is being changed */
((cadr(expr) == stepper) || /* stepper is being set? */
(!is_pair(cddr(expr))) ||
(!is_pair(cdddr(expr))) ||
(is_pair(cddddr(expr))) ||
((x == sc->hash_table_set_symbol) &&
(is_symbol(caddr(expr))) &&
(caddr(expr) == stepper)) ||
((is_symbol(cadddr(expr))) &&
(cadddr(expr) == stepper)) ||
((is_pair(cadddr(expr))) &&
(s7_tree_memq(sc, stepper, cadddr(expr))))))
(*has_set) = true;
if (!do_is_safe
(sc, cddr(expr), stepper, var_list, has_set))
return (false);
if (!safe_stepper_expr(expr, stepper))
return (false);
}
}
} /* is_symbol(x=car(expr)) */
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, uint32_t x)
{
return ((x == sc->add_class) ||
(x == sc->subtract_class) || (x == sc->multiply_class));
}
static s7_pointer simple_stepper(s7_scheme * sc, s7_pointer v)
{
if ((is_proper_list_3(sc, v)) && (is_fxable(sc, cadr(v)))) {
s7_pointer step_expr = caddr(v);
if ((is_optimized(step_expr)) && (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(v) == cadr(step_expr))) || ((is_h_safe_c_d(step_expr)) && /* replace with is_fxable? */
(is_pair(cdr(step_expr))) && /* ((v 0 (+))) */
(car(v) == cadr(step_expr)) && ((opt1_cfunc(step_expr) == sc->add_x1) || (opt1_cfunc(step_expr) == sc->subtract_x1))) || ((optimize_op(step_expr) == HOP_SAFE_C_CS) && (car(v) == caddr(step_expr)))))
return (step_expr);
}
return (NULL);
}
static bool is_simple_end(s7_scheme * sc, s7_pointer end)
{
return ((is_optimized(end)) && (is_safe_c_op(optimize_op(end))) && (is_pair(cddr(end))) && /* end: (zero? n) */
(cadr(end) != caddr(end)) &&
((opt1_cfunc(end) == sc->num_eq_xi) ||
(optimize_op(end) == HOP_SAFE_C_SS)
|| (optimize_op(end) == HOP_SAFE_C_SC)));
}
static s7_pointer fxify_step_exprs(s7_scheme * sc, s7_pointer code)
{
s7_pointer p, e, vars = car(code);
e = collect_variables(sc, vars, sc->nil); /* only valid in step exprs, not in inits */
for (p = vars; is_pair(p); p = cdr(p)) {
s7_function callee = NULL;
s7_pointer expr = cdar(p); /* init */
if (is_pair(expr)) {
callee = fx_choose(sc, expr, sc->nil, do_symbol_is_safe); /* not vars -- they aren't defined yet */
if (callee)
set_fx(expr, callee);
}
expr = cddar(p); /* step */
if (is_pair(expr)) {
if ((is_pair(car(expr))) && (!is_checked(car(expr))))
optimize_expression(sc, car(expr), 0, e, false);
callee = fx_choose(sc, expr, vars, do_symbol_is_safe); /* fx_proc can be nil! */
if (callee)
set_fx(expr, callee);
}
}
if ((is_pair(cdr(code))) && (is_pair(cadr(code)))) {
s7_pointer result;
result = cdadr(code);
if ((is_pair(result)) && (is_fxable(sc, car(result))))
set_fx_direct(result,
fx_choose(sc, result, vars, do_symbol_is_safe));
}
return (code);
}
static bool do_vector_has_definers(s7_scheme * sc, s7_pointer v)
{
s7_int i, len = vector_length(v);
s7_pointer *els = vector_elements(v);
for (i = 0; i < len; i++)
if ((is_pair(els[i])) && (is_symbol(car(els[i]))) && (is_definer(car(els[i])))) /* this is a desperate kludge */
return (true);
return (false);
}
static inline bool do_tree_has_definers(s7_scheme * sc, s7_pointer tree)
{
/* we can't be very fancy here because quote gloms up everything: (cond '(define x 0) ...) etc, and the tree here can
* be arbitrarily messed up, and we need to be reasonably fast. So we accept some false positives: (case ((define)...)...) or '(define...)
* but what about ((f...)...) where (f...) returns a macro that defines something? Or (for-each or ...) where for-each and or might be
* obfuscated and the args might contain a definer?
*/
s7_pointer p;
for (p = tree; is_pair(p); p = cdr(p)) {
s7_pointer pp = car(p);
if (is_symbol(pp)) {
if ((is_definer(pp)) && ((pp != sc->varlet_symbol) || ((is_pair(cdr(p))) && /* if varlet, is target let local? */
(is_symbol(cadr(p))) && (!symbol_is_in_list(sc, cadr(p))))))
return (true);
} else if (is_pair(pp)) {
if (do_tree_has_definers(sc, pp))
return (true);
} else if ((is_applicable(pp)) && (((is_normal_vector(pp))
&&
(do_vector_has_definers
(sc, pp)))
|| ((is_c_function(pp))
&& (is_func_definer(pp)))
|| ((is_syntax(pp))
&&
(is_syntax_definer(pp)))))
return (true);
}
return (false);
}
static void check_do_for_obvious_errors(s7_scheme * sc, s7_pointer form)
{
s7_pointer x, code = cdr(form);
if ((!is_pair(code)) || /* (do . 1) */
((!is_pair(car(code))) && /* (do 123) */
(is_not_null(car(code))))) /* (do () ...) is ok */
eval_error(sc, "do: variable list is not a list: ~S", 35, form);
if (!is_pair(cdr(code))) /* (do () . 1) */
eval_error(sc, "do body is messed up: ~A", 24, form);
if ((!is_pair(cadr(code))) && /* (do ((i 0)) 123) */
(is_not_null(cadr(code)))) /* no end-test? */
eval_error(sc, "do: end-test and end-value list is not a list: ~A",
49, form);
if (is_pair(car(code))) {
clear_symbol_list(sc);
for (x = car(code); is_pair(x); x = cdr(x)) {
s7_pointer y;
y = car(x);
if (!(is_pair(y))) /* (do (4) (= 3)) */
eval_error(sc, "do: variable name missing? ~A", 29, form);
if (!is_symbol(car(y))) /* (do ((3 2)) ()) */
eval_error(sc, "do step variable: ~S is not a symbol?", 37,
y);
if (is_constant_symbol(sc, car(y))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */
eval_error(sc, "do step variable: ~S is immutable", 33, y);
if (!is_pair(cdr(y)))
eval_error(sc,
"do: step variable has no initial value: ~A",
42, x);
if (!is_pair(cddr(y))) {
if (is_not_null(cddr(y))) /* (do ((i 0 . 1)) ...) */
eval_error(sc,
"do: step variable info is an improper list?: ~A",
47, x);
} else if (is_not_null(cdddr(y))) /* (do ((i 0 1 (+ i 1))) ...) */
eval_error(sc,
"do: step variable info has extra stuff after the increment: ~A",
62, x);
set_local(car(y));
if (symbol_is_in_list(sc, car(y))) /* (do ((i 0 (+ i 1)) (i 2))...) */
eval_error(sc, "duplicate identifier in do: ~A", 30, x);
add_symbol_to_list(sc, car(y));
}
if (is_not_null(x)) /* (do ((i 0 i) . 1) ((= i 1))) */
eval_error(sc, "do: list of variables is improper: ~A", 37,
form);
}
if (is_pair(cadr(code))) {
for (x = cadr(code); is_pair(x); x = cdr(x));
if (is_not_null(x))
eval_error(sc, "stray dot in do end section? ~A", 31, form);
}
for (x = cddr(code); is_pair(x); x = cdr(x));
if (is_not_null(x))
eval_error(sc, "stray dot in do body? ~A", 24, form);
}
static s7_pointer do_end_bad(s7_scheme * sc, s7_pointer form)
{
s7_pointer code = cdr(form);
if (is_null(cddr(code))) {
s7_pointer p;
/* no body, end not fxable (if eval car(end) might be unopt) */
for (p = car(code); is_pair(p); p = cdr(p)) { /* gather var names */
s7_pointer var = car(p);
if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */
set_match_symbol(car(var));
}
for (p = car(code); is_pair(p); p = cdr(p)) { /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)) */
s7_pointer var = car(p), val;
val = cddr(var);
if (is_pair(val)) {
clear_match_symbol(car(var)); /* ignore current var */
if (tree_match(car(val))) {
s7_pointer q;
for (q = car(code); is_pair(q); q = cdr(q))
clear_match_symbol(caar(q));
return (code);
}
}
set_match_symbol(car(var));
}
for (p = car(code); is_pair(p); p = cdr(p)) /* clear var names */
clear_match_symbol(caar(p));
if (is_null(p)) {
if ((is_null(cadr(code))) && /* (do () ()) or (do (fxable vars) ()) */
(is_null(cddr(code)))) {
if (sc->safety > 0)
s7_warn(sc, 256, "%s: infinite do loop: %s\n",
__func__, display(form));
return (code);
}
fxify_step_exprs(sc, code);
for (p = car(code); is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
if ((!has_fx(cdr(var))) ||
((is_pair(cddr(var))) && (!has_fx(cddr(var)))))
return (code);
}
pair_set_syntax_op(form, OP_DO_NO_BODY_FX_VARS);
return (sc->nil);
}
}
return (fxify_step_exprs(sc, code));
}
static bool do_expr_tree(s7_scheme * sc, s7_pointer expr)
{
if ((!expr) || (!is_pair(expr)))
return (false);
if ((is_funclet(sc->curlet)) && (tis_slot(let_slots(sc->curlet)))) {
s7_pointer s1 = let_slots(sc->curlet), s2;
s2 = next_slot(s1);
fx_tree_in(sc, expr,
slot_symbol(s1),
(tis_slot(s2)) ? slot_symbol(s2) : NULL, ((tis_slot(s2))
&&
(tis_slot
(next_slot
(s2)))) ?
slot_symbol(next_slot(s2)) : NULL, ((tis_slot(s2))
&&
(tis_slot
(next_slot(s2)))));
}
return (true);
}
static s7_pointer check_do(s7_scheme * sc)
{
/* returns nil if optimizable */
s7_pointer form = sc->code, code, vars, end, body, p, e;
check_do_for_obvious_errors(sc, form);
pair_set_syntax_op(form, OP_DO_UNCHECKED);
code = cdr(form);
end = cadr(code);
if ((!is_pair(end)) || (!is_fxable(sc, car(end))))
return (do_end_bad(sc, form));
set_fx_direct(end,
fx_choose(sc, end, sc->curlet,
let_symbol_is_safe_or_listed));
if ((is_pair(cdr(end))) && (is_fxable(sc, cadr(end))))
set_fx_direct(cdr(end),
fx_choose(sc, cdr(end), sc->curlet,
let_symbol_is_safe_or_listed));
vars = car(code);
if (is_null(vars)) {
pair_set_syntax_op(form, OP_DO_NO_VARS);
return (sc->nil);
}
if (do_tree_has_definers(sc, form)) /* we don't want definers in body, vars, or end test */
return (fxify_step_exprs(sc, code));
if ((is_pair(vars)) && (is_null(cdr(vars))))
fx_tree(sc, end, caar(vars), NULL, NULL, false);
for (e = sc->curlet; (is_let(e)) && (e != sc->rootlet);
e = let_outlet(e))
if ((is_funclet(e)) || (is_maclet(e))) {
s7_pointer fname, fval;
fname = funclet_function(e);
fval = s7_symbol_local_value(sc, fname, e);
if ((is_closure(fval)) && (is_safe_closure(fval))) {
if ((is_pair(vars)) && (is_null(cdr(vars))) && /* so do var is always == t (see mk2 in s7test) */
(tis_slot(let_slots(sc->curlet))) && /* let + 1 var, or funclet (so var order is guaranteed */
((!tis_slot(next_slot(let_slots(sc->curlet)))) ||
(is_funclet(sc->curlet)))) {
s7_pointer var1, var2 = NULL, var3 = NULL;
p = let_slots(sc->curlet);
var1 = slot_symbol(p);
if (tis_slot(next_slot(p)))
var2 = slot_symbol(next_slot(p));
if ((var2) && (tis_slot(next_slot(next_slot(p)))))
var3 = slot_symbol(next_slot(next_slot(p)));
fx_tree_outer(sc, end, var1, var2, var3, var3);
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
if (is_pair(cdr(var))) {
fx_tree(sc, cadr(var), var1, var2, var3, var3);
if (is_pair(cddr(var)))
fx_tree_outer(sc, caddr(var), var1, var2,
var3, var3);
}
}
}
}
break;
}
body = cddr(code);
if ((is_pair(end)) && (is_pair(car(end))) &&
(is_pair(vars)) && (is_null(cdr(vars))) &&
(is_pair(body)) && (is_pair(car(body))) && ((is_symbol(caar(body)))
||
((is_c_function
(caar(body)))
&&
(is_safe_procedure
(caar(body)))))) {
/* loop has one step variable, and normal-looking end test */
s7_pointer v = car(vars), step_expr;
step_expr = simple_stepper(sc, v);
if (step_expr) {
s7_pointer orig_end = end;
set_fx(cdr(v), fx_choose(sc, cdr(v), vars, do_symbol_is_safe)); /* v is (i 0 (+ i 1)) or the like */
/* step var is (var const|symbol (op var const)|(op const var)) */
end = car(end);
if ((is_simple_end(sc, end)) && (car(v) == cadr(end))) {
/* end var is (op var const|symbol) using same var as step so at least we can use SIMPLE_DO */
bool has_set = false, one_line;
one_line = ((is_null(cdr(body))) && (is_pair(car(body))));
if ((car(end) == sc->num_eq_symbol)
&& (is_symbol(cadr(end)))
&& (is_t_integer(caddr(end)))) {
set_c_function(end, sc->num_eq_2);
set_opt2_con(cdr(end), caddr(end));
set_fx_direct(orig_end,
(integer(caddr(end)) ==
0) ? fx_num_eq_s0 : fx_num_eq_si);
}
set_opt1_any(code, caddr(end)); /* symbol or int(?) */
set_opt2_pair(code, step_expr); /* caddr(caar(code)) */
pair_set_syntax_op(form, OP_SIMPLE_DO); /* simple_do: 1 var easy step/end */
if ((c_function_class(opt1_cfunc(step_expr)) == sc->add_class) && /* we check above that (car(v) == cadr(step_expr)) and (car(v) == cadr(end)) */
((c_function_class(opt1_cfunc(end)) ==
sc->num_eq_class)
|| (opt1_cfunc(end) == sc->geq_2))) {
if ((one_line) && ((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_NC)) && /* this does happen: (if (= i 3) (vector-set! j 0 i)) */
(is_symbol_and_syntactic(caar(body))) && (s7_is_integer(caddr(step_expr))) && /* this currently blocks s7_optimize of float steppers */
(s7_integer_checked(sc, caddr(step_expr)) == 1)) {
pair_set_syntax_op(car(body),
symbol_syntax_op_checked(car
(body)));
pair_set_syntax_op(form, OP_DOTIMES_P); /* dotimes_p: simple + syntax body + 1 expr */
}
if (((caddr(step_expr) == int_one)
|| (cadr(step_expr) == int_one))
&&
(do_is_safe(sc, body, car(v), sc->nil, &has_set)))
{
pair_set_syntax_op(form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */
/* no permanent let here because apparently do_is_safe accepts recursive calls? */
if ((!has_set) &&
(c_function_class(opt1_cfunc(end)) ==
sc->num_eq_class)) {
pair_set_syntax_op(form, OP_SAFE_DOTIMES); /* safe_dotimes: end is = */
if (is_fxable(sc, car(body)))
fx_annotate_arg(sc, body,
collect_variables(sc, vars,
sc->nil));
}
fx_tree(sc, body, car(v), NULL, NULL, false);
/* an experiment (this never works...) */
if (stack_op(sc->stack, current_stack_top(sc) - 1)
== OP_SAFE_DO_STEP)
fx_tree_outer(sc, body,
caaar(stack_code
(sc->stack,
(current_stack_top(sc) -
1))), NULL, NULL, true);
}
}
return (sc->nil);
}
}
}
/* we get here if there is more than one local var or anything "non-simple" about the rest */
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
if ((!is_fxable(sc, cadr(var))) ||
((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var)))) ||
((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var)))))
{
s7_pointer q;
for (q = vars; q != p; q = cdr(q))
clear_match_symbol(caar(q));
return (fxify_step_exprs(sc, code));
}
if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */
set_match_symbol(car(var));
}
{
s7_pointer stepper0 = NULL, stepper1 = NULL, stepper2 =
NULL, stepper3 = NULL, last_expr = NULL, previous_expr = NULL;
bool got_pending = false;
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var = car(p), val;
stepper3 = stepper2;
stepper2 = stepper1;
stepper1 = stepper0;
previous_expr = last_expr;
stepper0 = car(var);
last_expr = cdr(var); /* inits refer to the outer let */
val = cdr(last_expr);
if (is_pair(val)) {
var = car(var);
clear_match_symbol(var); /* ignore current var */
if (tree_match(car(val))) {
s7_pointer q;
for (q = vars; is_pair(q); q = cdr(q))
clear_match_symbol(caar(q));
if (is_null(body))
got_pending = true;
else
return (fxify_step_exprs(sc, code));
}
set_match_symbol(var);
}
}
for (p = vars; is_pair(p); p = cdr(p))
clear_match_symbol(caar(p));
/* end and steps look ok! */
for (p = vars; is_pair(p); p = cdr(p)) {
s7_pointer var = car(p);
set_fx_direct(cdr(var), fx_choose(sc, cdr(var), sc->curlet, let_symbol_is_safe)); /* init val */
if (is_pair(cddr(var))) {
s7_pointer step_expr = caddr(var);
set_fx_direct(cddr(var), fx_choose(sc, cddr(var), vars, do_symbol_is_safe)); /* sets opt2(cddr(var)), not opt1 */
if (!is_pair(step_expr)) { /* (i 0 0) */
if (cadr(var) == caddr(var)) /* not types match: (i x y) etc */
set_safe_stepper_expr(cddr(var));
} else {
s7_pointer endp, var1;
if ((car(step_expr) != sc->quote_symbol) && /* opt1_cfunc(==opt1) might not be set in this case (sigh) */
(is_safe_c_op(optimize_op(step_expr))) && ((preserves_type(sc, c_function_class(opt1_cfunc(step_expr)))) || /* add etc */
(car(step_expr) == sc->cdr_symbol) || (car(step_expr) == sc->cddr_symbol) || ((is_pair(cadr(var))) && (is_pair(c_function_signature(c_function_base(opt1_cfunc(step_expr))))) && (car(c_function_signature(c_function_base(opt1_cfunc(step_expr)))) != sc->T) && (caadr(var) == car(step_expr))))) /* i.e. accept char-position as init/step, but not iterate */
set_safe_stepper_expr(cddr(var));
endp = car(end);
var1 = car(var);
if ((is_proper_list_3(sc, endp))
&& (is_proper_list_3(sc, step_expr))
&& ((car(endp) == sc->num_eq_symbol)
|| (car(endp) == sc->geq_symbol))
&& (is_symbol(cadr(endp)))
&& ((is_t_integer(caddr(endp)))
|| (is_symbol(caddr(endp))))
&& (car(step_expr) == sc->add_symbol)
&& (var1 == cadr(endp))
&& (var1 == cadr(step_expr))
&& ((car(endp) != sc->num_eq_symbol)
|| ((caddr(step_expr) == int_one))))
set_step_end_ok(end);
}
}
}
pair_set_syntax_op(form,
(got_pending) ? OP_DOX_PENDING_NO_BODY :
OP_DOX);
/* there are only a couple of cases in snd-test where a multi-statement do body is completely fx-able */
if ((is_null(body)) &&
(is_null(cdr(vars))) &&
(is_pair(cdr(end))) &&
(is_null(cddr(end))) &&
(has_fx(cdr(end))) &&
(is_pair(cdar(vars))) && (is_pair(cddar(vars)))) {
s7_pointer var, step;
if (!in_heap(cdr(form)))
set_opt3_any(cdr(form), make_permanent_let(sc, vars));
else
set_opt3_any(cdr(form), sc->F);
if (!got_pending)
pair_set_syntax_op(form, OP_DOX_NO_BODY);
var = caar(vars);
step = cddar(vars);
if (is_safe_stepper_expr(step)) {
step = car(step);
if ((is_pair(step)) && (is_proper_list_3(sc, step))) {
if ((car(step) == sc->add_symbol) &&
(((cadr(step) == var) && (caddr(step) == int_one))
|| (caddr(step) == var))
&& (cadr(step) == int_one))
set_opt2_con(cdr(form), int_one);
else if ((car(step) == sc->subtract_symbol) &&
(cadr(step) == var) &&
(caddr(step) == int_one))
set_opt2_con(cdr(form), minus_one);
else
set_opt2_con(cdr(form), int_zero);
} else
set_opt2_con(cdr(form), int_zero);
} else
set_opt2_con(cdr(form), int_zero);
}
if (do_passes_safety_check(sc, body, sc->nil, NULL)) {
if (stepper0) {
if ((is_pair(car(end))) && (has_fx(end)) && (!(is_syntax(caar(end)))) && (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end))))) && (!fx_tree_in(sc, end, stepper0, stepper1, stepper2, stepper3))) /* just the end-test, not the results */
fx_tree(sc, car(end), stepper0, stepper1, stepper2, stepper3); /* car(end) might be (or ...) */
if ((is_pair(cdr(end))) &&
(is_pair(cadr(end))) &&
(is_null(cddr(end))) &&
(has_fx(cdr(end))) &&
(!fx_tree_in
(sc, cdr(end), stepper0, stepper1, stepper2,
stepper3)))
fx_tree(sc, cadr(end), stepper0, stepper1, stepper2,
stepper3);
/* the bad case for results: (let ((vals3t with-baffle)) func+do+ (vals3t (* 2 i 3 4))) -> fx_t|u trouble */
if (do_expr_tree(sc, last_expr)) {
last_expr = cdr(last_expr);
if (is_pair(last_expr))
fx_tree(sc, last_expr, stepper0, stepper1,
stepper2, stepper3);
if (do_expr_tree(sc, previous_expr)) {
previous_expr = cdr(previous_expr);
if (is_pair(previous_expr))
fx_tree(sc, previous_expr, stepper0, stepper1,
stepper2, stepper3);
}
}
}
if ((is_pair(body)) && (is_null(cdr(body))) &&
(is_fxable(sc, car(body)))) {
fx_annotate_arg(sc, body,
collect_variables(sc, vars, sc->nil));
fx_tree(sc, body, stepper0, stepper1, stepper2, stepper3);
}
}
}
return (sc->nil);
}
static bool has_safe_steppers(s7_scheme * sc, s7_pointer let)
{
s7_pointer slot;
for (slot = let_slots(let); tis_slot(slot); slot = next_slot(slot)) {
s7_pointer val = slot_value(slot);
if (slot_has_expression(slot)) {
s7_pointer step_expr = slot_expression(slot);
if (!is_pair(step_expr)) {
if ((is_null(step_expr)) || (type(step_expr) == type(val)))
set_safe_stepper(slot);
else
clear_safe_stepper(slot);
} else {
if (is_safe_stepper_expr(step_expr)) {
if (is_t_integer(val)) {
if (is_int_optable(step_expr))
set_safe_stepper(slot);
else if (no_int_opt(step_expr))
clear_safe_stepper(slot);
else {
sc->pc = 0;
if (int_optimize(sc, step_expr)) {
set_safe_stepper(slot);
set_is_int_optable(step_expr);
} else {
clear_safe_stepper(slot);
set_no_int_opt(step_expr);
}
}
} else if (is_small_real(val)) {
if (is_float_optable(step_expr))
set_safe_stepper(slot);
else if (no_float_opt(step_expr))
clear_safe_stepper(slot);
else {
sc->pc = 0;
if (float_optimize(sc, step_expr)) {
set_safe_stepper(slot);
set_is_float_optable(step_expr);
} else {
clear_safe_stepper(slot);
set_no_float_opt(step_expr);
}
}
} else
set_safe_stepper(slot); /* ?? shouldn't this check types ?? */
}
}
} else {
if (is_t_real(val))
slot_set_value(slot, s7_make_mutable_real(sc, real(val)));
if (is_t_integer(val))
slot_set_value(slot,
make_mutable_integer(sc, integer(val)));
set_safe_stepper(slot);
}
if (!is_safe_stepper(slot))
return (false);
}
return (true);
}
static bool copy_if_end_ok(s7_scheme * sc, s7_pointer dest,
s7_pointer source, s7_int i, s7_pointer endp,
s7_pointer stepper, opt_info * o)
{
if ((fn_proc(endp) == g_num_eq_2) && (is_symbol(cadr(endp)))
&& (is_symbol(caddr(endp)))) {
s7_pointer end_slot;
end_slot =
lookup_slot_from((cadr(endp) ==
slot_symbol(stepper)) ? caddr(endp) :
cadr(endp), sc->curlet);
if ((is_slot(end_slot)) && (is_t_integer(slot_value(end_slot)))) {
copy_to_same_type(sc, dest, source, i,
integer(slot_value(end_slot)), i);
return (true);
}
}
return (false);
}
static bool op_dox_init(s7_scheme * sc)
{
s7_pointer let, vars, test, code = cdr(sc->code);
let = make_let(sc, sc->curlet);
sc->temp1 = let;
for (vars = car(code); is_pair(vars); vars = cdr(vars)) {
add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars)));
if (is_pair(cddar(vars)))
slot_set_expression(let_slots(let), cddar(vars));
else
slot_just_set_expression(let_slots(let), sc->nil);
}
set_curlet(sc, let);
sc->temp1 = sc->nil;
test = cadr(code);
if (is_true(sc, sc->value = fx_call(sc, test))) {
sc->code = cdr(test);
return (true); /* goto DO_END_CLAUSES */
}
sc->code = T_Pair(cddr(code));
push_stack_no_args(sc,
(intptr_t) ((is_null(cdr(sc->code))) ? OP_DOX_STEP_O
: OP_DOX_STEP), code);
return (false); /* goto BEGIN */
}
static goto_t op_dox_no_body_1(s7_scheme * sc, s7_pointer slots,
s7_pointer end, int32_t steppers,
s7_pointer stepper)
{
s7_function endf;
s7_pointer endp = car(end);
endf = fx_proc(end);
if (endf == fx_c_nc) {
endf = fn_proc(endp);
endp = cdr(endp);
}
if (steppers == 1) {
s7_function f;
s7_pointer a;
f = fx_proc(slot_expression(stepper)); /* e.g. fx_add_s1 */
a = car(slot_expression(stepper));
if (f == fx_c_nc) {
f = fn_proc(a);
a = cdr(a);
}
if (((f == fx_cdr_s) || (f == fx_cdr_t)) &&
(cadr(a) == slot_symbol(stepper))) {
do {
slot_set_value(stepper, cdr(slot_value(stepper)));
} while (endf(sc, endp) == sc->F);
sc->value = sc->T;
} else {
/* (- n 1) tpeak dup */
if (((f == fx_add_t1) || (f == fx_add_u1))
&& (is_t_integer(slot_value(stepper)))) {
s7_pointer p;
p = make_mutable_integer(sc, integer(slot_value(stepper)));
slot_set_value(stepper, p);
if (!no_bool_opt(end)) {
sc->pc = 0;
if (bool_optimize(sc, end)) { /* in dup.scm this costs more than the fb(o) below saves (search is short) */
/* but tc is much slower (and bool|int_optimize dominates) */
opt_info *o = sc->opts[0];
bool (*fb)(opt_info * o);
fb = o->v[0].fb;
do {
integer(p)++;
} while (!fb(o)); /* do {integer(p)++;} while ((sc->value = optf(sc, endp)) == sc->F); */
clear_mutable_integer(p);
sc->value = sc->T;
sc->code = cdr(end);
return (goto_do_end_clauses);
} else
set_no_bool_opt(end);
}
do {
integer(p)++;
} while ((sc->value = endf(sc, endp)) == sc->F);
clear_mutable_integer(p);
} else
do {
slot_set_value(stepper, f(sc, a));
} while ((sc->value = endf(sc, endp)) == sc->F);
}
sc->code = cdr(end);
return (goto_do_end_clauses);
}
if ((steppers == 2) && (!tis_slot(next_slot(next_slot(slots))))) {
s7_pointer step1 = slots, step2, expr1, expr2;
expr1 = slot_expression(step1);
step2 = next_slot(step1);
expr2 = slot_expression(step2); /* presetting fx_proc/car(expr) is not faster */
if ((fx_proc(expr2) == fx_subtract_u1) &&
(is_t_integer(slot_value(step2))) && (endf == fx_num_eq_ui)) {
s7_int i, lim = integer(caddr(endp));
for (i = integer(slot_value(step2)) - 1; i >= lim; i--)
slot_set_value(step1, fx_call(sc, expr1));
} else
do {
slot_set_value(step1, fx_call(sc, expr1));
slot_set_value(step2, fx_call(sc, expr2));
} while ((sc->value = endf(sc, endp)) == sc->F);
sc->code = cdr(end);
if (!is_symbol(car(sc->code)))
return (goto_do_end_clauses);
step1 = lookup_slot_from(car(sc->code), sc->curlet);
sc->value = slot_value(step1);
if (is_t_real(sc->value))
clear_mutable_number(sc->value);
return (goto_start);
}
do {
s7_pointer slt = slots;
do {
if (slot_has_expression(slt))
slot_set_value(slt, fx_call(sc, slot_expression(slt)));
slt = next_slot(slt);
} while (tis_slot(slt));
} while ((sc->value = endf(sc, endp)) == sc->F);
sc->code = cdr(end);
return (goto_do_end_clauses);
}
static goto_t op_dox(s7_scheme * sc)
{
/* any number of steppers using dox exprs, end also dox, body and end result arbitrary.
* since all these exprs are local, we don't need to jump until the body
*/
int64_t id, steppers = 0;
s7_pointer let, vars, code, end, endp, stepper = NULL, form =
sc->code, slots;
s7_function endf;
#if WITH_GMP
bool got_bignum = false;
#endif
sc->code = cdr(sc->code);
let = make_let(sc, sc->curlet); /* new let is not tied into the symbol lookup process yet */
sc->temp1 = let;
for (vars = car(sc->code); is_pair(vars); vars = cdr(vars)) {
s7_pointer expr = cdar(vars), val, stp, slot;
val = fx_call(sc, expr);
#if WITH_GMP
if (!got_bignum)
got_bignum = is_big_number(val);
#endif
new_cell_no_check(sc, slot, T_SLOT);
slot_set_symbol_and_value(slot, caar(vars), val);
stp = cdr(expr); /* cddar(vars) */
if (is_pair(stp)) {
steppers++;
stepper = slot;
slot_set_expression(slot, stp);
} else
slot_just_set_expression(slot, sc->nil);
slot_set_next(slot, let_slots(let));
let_set_slots(let, slot);
}
set_curlet(sc, let);
slots = let_slots(sc->curlet);
sc->temp1 = sc->nil;
id = let_id(let);
/* the fn_calls above could have redefined a previous stepper, so that its symbol_id is > let let_id when we get here,
* so we use symbol_set_local_slot_unchecked below to sidestep the debugger (see zauto.scm: i is a stepper, but then mock-vector-ref uses i as its index)
*/
{
s7_pointer slot;
for (slot = slots; tis_slot(slot); slot = next_slot(slot))
symbol_set_local_slot_unchecked_and_unincremented(slot_symbol
(slot), id,
slot);
}
end = cadr(sc->code);
endp = car(end);
endf = fx_proc(end);
/* an experiment */
if ((step_end_ok(end)) && (steppers == 1) &&
(is_t_integer(slot_value(stepper)))) {
s7_pointer stop_slot;
stop_slot =
(is_symbol(caddr(endp))) ? opt_integer_symbol(sc,
caddr(endp)) :
sc->nil;
if (stop_slot) { /* sc->nil -> it's an integer */
set_step_end(stepper);
set_do_loop_end(slot_value(stepper),
(is_slot(stop_slot)) ?
integer(slot_value(stop_slot)) :
integer(caddr(endp)));
}
}
if (is_true(sc, sc->value = endf(sc, endp))) {
sc->code = cdr(end);
return (goto_do_end_clauses);
}
code = cddr(sc->code);
if (is_null(code)) /* no body -- how does this happen? */
return (op_dox_no_body_1(sc, slots, end, steppers, stepper));
if ((is_null(cdr(code))) && /* 1 expr, code is cdddr(form) here */
(is_pair(car(code)))) {
s7_pointer body = car(code);
s7_pfunc bodyf = NULL;
if ((!no_cell_opt(code)) &&
#if WITH_GMP
(!got_bignum) &&
#endif
(has_safe_steppers(sc, sc->curlet)))
bodyf = s7_optimize_nr(sc, code);
if ((!bodyf) && (is_fxable(sc, body)) && /* happens very rarely, #_* as car etc */
(is_c_function(car(body))))
bodyf =
s7_optimize_nr(sc,
set_dlist_1(sc,
set_ulist_1(sc,
make_symbol(sc,
c_function_name
(car
(body))),
cdr(body))));
if (bodyf) {
if (steppers == 1) { /* one expr body, 1 stepper */
s7_pointer stepa = car(slot_expression(stepper));
s7_function stepf;
stepf = fx_proc(slot_expression(stepper));
if (((stepf == fx_add_t1) || (stepf == fx_add_u1))
&& (is_t_integer(slot_value(stepper)))) {
s7_int i = integer(slot_value(stepper));
opt_info *o = sc->opts[0];
if (bodyf == opt_cell_any_nr) {
s7_pointer(*fp) (opt_info * o);
fp = o->v[0].fp;
/* a laborious experiment... */
if (!((fp == opt_p_pip_sso)
&& (o->v[2].p == o->v[4].p)
&&
(((o->v[5].p_pip_f ==
string_set_p_pip_unchecked)
&& (o->v[6].p_pi_f ==
string_ref_p_pi_unchecked))
||
((o->v[5].p_pip_f == string_set_unchecked)
&& (o->v[6].p_pi_f ==
string_ref_unchecked))
||
((o->v[5].p_pip_f ==
vector_set_p_pip_unchecked)
&& (o->v[6].p_pi_f ==
normal_vector_ref_p_pi_unchecked))
||
((o->v[5].p_pip_f == vector_set_unchecked)
&& (o->v[6].p_pi_f ==
vector_ref_unchecked))
||
((o->v[5].p_pip_f ==
list_set_p_pip_unchecked)
&& (o->v[6].p_pi_f ==
list_ref_p_pi_unchecked)))
&&
(copy_if_end_ok
(sc, slot_value(o->v[1].p),
slot_value(o->v[3].p), i, endp, stepper,
o)))) {
if (is_step_end(stepper)) {
s7_int lim;
lim = do_loop_end(slot_value(stepper));
do {
fp(o);
slot_set_value(stepper,
make_integer(sc, ++i));
} while (i < lim);
sc->value = sc->T;
} else
do {
fp(o);
slot_set_value(stepper,
make_integer(sc, ++i));
} while ((sc->value =
endf(sc, endp)) == sc->F);
}
} else if (!(((bodyf == opt_float_any_nr)
&& (o->v[0].fd == opt_d_7pid_ss_ss)
&& (o->v[2].p == o->v[6].p)
&&
((o->v[4].d_7pid_f ==
float_vector_set_d_7pid)
|| (o->v[4].d_7pid_f ==
float_vector_set_unchecked))
&& (o->v[3].d_7pi_f ==
float_vector_ref_d_7pi)
&&
(copy_if_end_ok
(sc, slot_value(o->v[1].p),
slot_value(o->v[5].p), i, endp,
stepper, o)))
|| ((bodyf == opt_int_any_nr)
&& ((o->v[0].fi == opt_i_7pii_ssf)
|| (o->v[0].fi ==
opt_i_7pii_ssf_vset))
&& (o->v[2].p == o->v[4].o1->v[2].p)
&&
(((o->v[3].i_7pii_f ==
int_vector_set_i_7pii)
&& (o->v[4].o1->v[3].i_7pi_f ==
int_vector_ref_i_7pi))
||
((o->v[3].i_7pii_f ==
int_vector_set_unchecked)
&& (o->v[4].o1->v[3].i_7pi_f ==
int_vector_ref_unchecked)))
&&
(copy_if_end_ok
(sc, slot_value(o->v[1].p),
slot_value(o->v[4].o1->v[1].p),
i, endp, stepper, o)))))
/* here the is_step_end business doesn't happen much */
do {
bodyf(sc);
slot_set_value(stepper, make_integer(sc, ++i));
} while ((sc->value = endf(sc, endp)) == sc->F);
sc->code = cdr(end);
return (goto_do_end_clauses);
}
do {
bodyf(sc);
slot_set_value(stepper, stepf(sc, stepa));
} while ((sc->value = endf(sc, endp)) == sc->F);
sc->code = cdr(end);
return (goto_do_end_clauses);
}
if ((steppers == 2) &&
(!tis_slot(next_slot(next_slot(slots))))) {
s7_pointer s1 = slots, s2, p1, p2;
s7_function f1, f2;
s2 = next_slot(s1);
f1 = fx_proc(slot_expression(s1));
f2 = fx_proc(slot_expression(s2));
p1 = car(slot_expression(s1));
p2 = car(slot_expression(s2));
/* split out opt_float_any_nr gained nothing (see tmp), same for opt_cell_any_nr */
if (bodyf == opt_cell_any_nr) {
s7_pointer(*fp) (opt_info * o);
opt_info *o = sc->opts[0];
fp = o->v[0].fp;
/* maybe this can be generalized (thash:79) -- explicit integer stepper, but there must be a simpler way */
if ((f2 == fx_add_u1) && (is_t_integer(slot_value(s2)))
&& (endf == fx_num_eq_ui)
&& (is_symbol(cadr(endp)))
&& (cadr(endp) == slot_symbol(s2))
&& (is_t_integer(caddr(endp)))
&& (!s7_tree_memq(sc, cadr(endp), body))) {
s7_int i = integer(slot_value(s2)), endi =
integer(caddr(endp));
do {
fp(o);
slot_set_value(s1, f1(sc, p1));
i++;
} while (i < endi);
} else
do {
fp(o);
slot_set_value(s1, f1(sc, p1));
slot_set_value(s2, f2(sc, p2));
} while ((sc->value = endf(sc, endp)) == sc->F);
} else
do {
bodyf(sc);
slot_set_value(s1, f1(sc, p1));
slot_set_value(s2, f2(sc, p2));
} while ((sc->value = endf(sc, endp)) == sc->F);
sc->code = cdr(end);
return (goto_do_end_clauses);
}
if (bodyf == opt_cell_any_nr) {
s7_pointer(*fp) (opt_info * o);
opt_info *o = sc->opts[0];
fp = o->v[0].fp;
do {
s7_pointer slot1;
fp(o);
slot1 = slots;
do {
if (slot_has_expression(slot1))
slot_set_value(slot1,
fx_call(sc,
slot_expression
(slot1)));
slot1 = next_slot(slot1);
} while (tis_slot(slot1));
} while ((sc->value = endf(sc, endp)) == sc->F);
} else
do {
s7_pointer slot1;
bodyf(sc);
slot1 = slots;
do {
if (slot_has_expression(slot1))
slot_set_value(slot1,
fx_call(sc,
slot_expression
(slot1)));
slot1 = next_slot(slot1);
} while (tis_slot(slot1));
} while ((sc->value = endf(sc, endp)) == sc->F);
sc->code = cdr(end);
return (goto_do_end_clauses);
}
if ((steppers == 1) &&
(car(body) == sc->set_symbol) &&
(is_pair(cdr(body))) &&
(is_symbol(cadr(body))) &&
(is_pair(cddr(body))) &&
((has_fx(cddr(body))) || (is_fxable(sc, caddr(body)))) &&
(is_null(cdddr(body)))) {
s7_pointer val = cddr(body), slot, stepa;
s7_function stepf, valf;
if (!has_fx(val))
set_fx(val,
fx_choose(sc, val, sc->curlet, let_symbol_is_safe));
valf = fx_proc(val);
val = car(val);
slot = lookup_slot_from(cadr(body), sc->curlet);
if (slot == sc->undefined)
unbound_variable_error(sc, cadr(body));
stepf = fx_proc(slot_expression(stepper));
stepa = car(slot_expression(stepper));
do {
slot_set_value(slot, valf(sc, val));
slot_set_value(stepper, stepf(sc, stepa));
} while ((sc->value = endf(sc, endp)) == sc->F);
sc->code = cdr(end);
return (goto_do_end_clauses);
}
/* not fxable body (bodyf nil) but body might be gxable here: is_gxable(body) */
if ((has_gx(body)) || (gx_annotate_arg(sc, code, sc->curlet))) {
s7_function f;
f = fx_proc_unchecked(code);
do {
s7_pointer slot1;
f(sc, body);
slot1 = slots;
do {
if (slot_has_expression(slot1))
slot_set_value(slot1,
fx_call(sc,
slot_expression(slot1)));
slot1 = next_slot(slot1);
} while (tis_slot(slot1));
} while ((sc->value = endf(sc, endp)) == sc->F);
sc->code = cdr(end);
return (goto_do_end_clauses);
}
} else { /* more than one expr */
s7_pointer p = code;
bool use_opts = false;
int32_t body_len = 0;
opt_info *body[32];
#define MAX_OPT_BODY_SIZE 32
if ((!no_cell_opt(code)) &&
#if WITH_GMP
(!got_bignum) &&
#endif
(has_safe_steppers(sc, sc->curlet))) {
int32_t k;
sc->pc = 0;
for (k = 0; (is_pair(p)) && (k < MAX_OPT_BODY_SIZE);
k++, p = cdr(p), body_len++) {
opt_info *start = sc->opts[sc->pc];
if (!cell_optimize(sc, p)) {
set_no_cell_opt(code);
p = code;
break;
}
oo_idp_nr_fixup(start);
body[k] = start;
}
use_opts = is_null(p);
}
if (p == code)
for (; is_pair(p); p = cdr(p))
if (!is_fxable(sc, car(p)))
break;
if (is_null(p)) {
int32_t i;
s7_pointer stepa = NULL;
s7_function stepf = NULL;
if (!use_opts)
fx_annotate_args(sc, code, sc->curlet);
if (stepper) {
stepf = fx_proc(slot_expression(stepper));
stepa = car(slot_expression(stepper));
}
while (true) {
if (use_opts)
for (i = 0; i < body_len; i++)
body[i]->v[0].fp(body[i]);
else
for (p = code; is_pair(p); p = cdr(p))
fx_call(sc, p);
if (steppers == 1)
slot_set_value(stepper, stepf(sc, stepa));
else {
s7_pointer slot = slots;
do {
if (slot_has_expression(slot))
slot_set_value(slot,
fx_call(sc,
slot_expression(slot)));
slot = next_slot(slot);
} while (tis_slot(slot));
}
if (is_true(sc, sc->value = endf(sc, endp))) {
sc->code = cdr(end);
return (goto_do_end_clauses);
}
}
}
}
if ((is_null(cdr(code))) && /* one expr */
(is_pair(car(code)))) {
code = car(code);
if ((is_syntactic_pair(code)) ||
(is_symbol_and_syntactic(car(code)))) {
push_stack_no_args_direct(sc, OP_DOX_STEP_O);
if (is_syntactic_pair(code))
sc->cur_op = (opcode_t) optimize_op(code);
else {
sc->cur_op = (opcode_t) symbol_syntax_op_checked(code);
pair_set_syntax_op(code, sc->cur_op);
}
sc->code = code;
return (goto_top_no_pop);
}
}
pair_set_syntax_op(form, OP_DOX_INIT);
sc->code = T_Pair(cddr(sc->code));
push_stack_no_args(sc,
(intptr_t) ((is_null(cdr(sc->code))) ? OP_DOX_STEP_O
: OP_DOX_STEP), cdr(form));
return (goto_begin);
}
static bool op_dox_step(s7_scheme * sc)
{
s7_pointer slot = let_slots(sc->curlet);
do {
if (slot_has_expression(slot))
slot_set_value(slot, fx_call(sc, slot_expression(slot)));
slot = next_slot(slot);
} while (tis_slot(slot));
sc->value = fx_call(sc, cadr(sc->code));
if (is_true(sc, sc->value)) {
sc->code = cdadr(sc->code);
return (true);
}
push_stack_no_args_direct(sc, OP_DOX_STEP);
sc->code = T_Pair(cddr(sc->code));
return (false);
}
static bool op_dox_step_o(s7_scheme * sc)
{ /* every dox case has vars (else op_do_no_vars) */
s7_pointer slot = let_slots(sc->curlet);
do {
if (slot_has_expression(slot))
slot_set_value(slot, fx_call(sc, slot_expression(slot)));
slot = next_slot(slot);
} while (tis_slot(slot));
sc->value = fx_call(sc, cadr(sc->code));
if (is_true(sc, sc->value)) {
sc->code = cdadr(sc->code);
return (true);
}
push_stack_no_args_direct(sc, OP_DOX_STEP_O);
sc->code = caddr(sc->code);
return (false);
}
static void op_dox_no_body(s7_scheme * sc)
{
s7_pointer slot, var, test, result;
s7_function testf;
sc->code = cdr(sc->code);
var = caar(sc->code);
testf = fx_proc(cadr(sc->code));
test = caadr(sc->code);
result = cdadr(sc->code);
if ((!in_heap(sc->code)) && (is_let(opt3_any(sc->code)))) { /* (*repl* 'keymap) anything -> segfault because opt3_any here is #f. (see line 80517) */
s7_pointer let;
let =
update_let_with_slot(sc, opt3_any(sc->code),
fx_call(sc, cdr(var)));
let_set_outlet(let, sc->curlet);
set_curlet(sc, let);
} else
sc->curlet =
make_let_with_slot(sc, sc->curlet, car(var),
fx_call(sc, cdr(var)));
slot = let_slots(sc->curlet);
if ((is_t_integer(slot_value(slot))) &&
((integer(opt2_con(sc->code))) != 0)) {
s7_int incr = integer(opt2_con(sc->code));
s7_pointer istep;
istep = make_mutable_integer(sc, integer(slot_value(slot)));
/* this can cause unexpected, but correct behavior: (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (memq x '(0)))) -> #f
* because (eq? 0 x) here is false -- memv will return '(0). tree-count is similar.
*/
slot_set_value(slot, istep);
if (testf == fx_or_2a) {
s7_pointer t1 = cadr(test), t2 = caddr(test);
s7_function f1, f2;
f1 = fx_proc(cdr(test));
f2 = fx_proc(cddr(test));
while ((f1(sc, t1) == sc->F) && (f2(sc, t2) == sc->F))
integer(istep) += incr;
} else
while (testf(sc, test) == sc->F) {
integer(istep) += incr;
}
if (is_small_int(integer(istep)))
slot_set_value(slot, small_int(integer(istep)));
else
clear_mutable_integer(istep);
sc->value = fx_call(sc, result);
} else {
s7_function stepf = fx_proc(cddr(var));
s7_pointer step = caddr(var);
if (testf == fx_or_and_2a) {
s7_pointer f1_arg = cadr(test), p =
opt3_pair(test) /* cdadr(p) */ , f2_arg = car(p), f3_arg =
cadr(p);
s7_function f1, f2, f3;
f1 = fx_proc(cdr(test));
f2 = fx_proc(p);
f3 = fx_proc(cdr(p));
if (((stepf == fx_add_t1) || (stepf == fx_add_u1))
&& (is_t_integer(slot_value(slot)))) {
s7_pointer ip;
ip = make_mutable_integer(sc, integer(slot_value(slot)));
slot_set_value(slot, ip);
while ((f1(sc, f1_arg) == sc->F) &&
((f2(sc, f2_arg) == sc->F)
|| (f3(sc, f3_arg) == sc->F)))
integer(ip)++;
clear_mutable_integer(ip);
} else
while ((f1(sc, f1_arg) == sc->F) &&
((f2(sc, f2_arg) == sc->F)
|| (f3(sc, f3_arg) == sc->F)))
slot_set_value(slot, stepf(sc, step));
} else
while (testf(sc, test) == sc->F) {
slot_set_value(slot, stepf(sc, step));
}
sc->value = fx_call(sc, result);
}
}
static void op_dox_pending_no_body(s7_scheme * sc)
{
s7_pointer let, vars, test, slots;
bool all_steps = true;
sc->code = cdr(sc->code);
let = make_let(sc, sc->curlet);
sc->temp1 = let;
for (vars = car(sc->code); is_pair(vars); vars = cdr(vars)) {
add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars)));
if (is_pair(cddar(vars)))
slot_set_expression(let_slots(let), cddar(vars));
else {
all_steps = false;
slot_just_set_expression(let_slots(let), sc->nil);
}
}
slots = let_slots(let);
set_curlet(sc, let);
sc->temp1 = sc->nil;
test = cadr(sc->code);
let_set_has_pending_value(sc->curlet);
if ((all_steps) &&
(!tis_slot(next_slot(next_slot(slots)))) && (is_pair(cdr(test)))) {
s7_pointer slot1 = slots, slot2, expr1, expr2;
expr1 = slot_expression(slot1);
slot2 = next_slot(slot1);
expr2 = slot_expression(slot2);
while (fx_call(sc, test) == sc->F) {
slot_simply_set_pending_value(slot1, fx_call(sc, expr1)); /* use pending_value for GC protection */
slot_set_value(slot2, fx_call(sc, expr2));
slot_set_value(slot1, slot_pending_value(slot1));
}
sc->code = cdr(test);
let_clear_has_pending_value(sc->curlet);
return;
}
while ((sc->value = fx_call(sc, test)) == sc->F) {
s7_pointer slt = slots;
do {
if (slot_has_expression(slt))
slot_simply_set_pending_value(slt,
fx_call(sc,
slot_expression
(slt)));
slt = next_slot(slt);
} while (tis_slot(slt));
slt = slots;
do {
if (slot_has_expression(slt))
slot_set_value(slt, slot_pending_value(slt));
slt = next_slot(slt);
} while (tis_slot(slt));
}
sc->code = cdr(test);
let_clear_has_pending_value(sc->curlet);
}
static bool op_do_no_vars(s7_scheme * sc)
{
s7_pointer p, form = sc->code;
int32_t i;
opt_info *body[32];
sc->code = cdr(sc->code);
sc->pc = 0;
for (i = 0, p = cddr(sc->code); (is_pair(p)) && (i < 32);
i++, p = cdr(p)) {
body[i] = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
break;
}
if (is_null(p)) {
s7_pointer end = cadr(sc->code);
sc->curlet = make_let(sc, sc->curlet);
if (i == 1) {
while ((sc->value = fx_call(sc, end)) == sc->F)
body[0]->v[0].fp(body[0]);
sc->code = cdr(end);
return (true);
}
if (i == 0) { /* null body! */
s7_function endf;
s7_pointer endp = car(end);
endf = fx_proc(end);
while (!is_true(sc, sc->value = endf(sc, endp))); /* the assignment is (normally) in the noise */
sc->code = cdr(end);
return (true);
}
while ((sc->value = fx_call(sc, end)) == sc->F) {
int32_t k;
for (k = 0; k < i; k++)
body[k]->v[0].fp(body[k]);
}
sc->code = cdr(end);
return (true);
}
/* back out */
pair_set_syntax_op(form, OP_DO_NO_VARS_NO_OPT);
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->value = fx_call(sc, cadr(sc->code));
if (is_true(sc, sc->value)) {
sc->code = cdadr(sc->code);
return (true);
}
push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1);
sc->code = T_Pair(cddr(sc->code));
return (false);
}
static void op_do_no_vars_no_opt(s7_scheme * sc)
{
sc->code = cdr(sc->code);
sc->curlet = make_let(sc, sc->curlet);
}
static bool op_do_no_vars_no_opt_1(s7_scheme * sc)
{
sc->value = fx_call(sc, cadr(sc->code));
if (is_true(sc, sc->value)) {
sc->code = cdadr(sc->code);
return (true);
}
push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1);
sc->code = T_Pair(cddr(sc->code));
return (false);
}
static void op_do_no_body_fx_vars(s7_scheme * sc)
{
s7_pointer let, vars, stepper = NULL;
s7_int steppers = 0;
sc->code = cdr(sc->code);
let = make_let(sc, sc->curlet);
sc->temp1 = let;
for (vars = car(sc->code); is_pair(vars); vars = cdr(vars)) {
add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars)));
if (is_pair(cddar(vars))) {
slot_set_expression(let_slots(let), cddar(vars));
steppers++;
stepper = let_slots(let);
} else
slot_just_set_expression(let_slots(let), sc->nil);
}
if (steppers == 1)
let_set_dox_slot1(let, stepper);
set_curlet(sc, let);
sc->temp1 = sc->nil;
push_stack_no_args_direct(sc,
(intptr_t) ((steppers ==
1) ?
OP_DO_NO_BODY_FX_VARS_STEP_1 :
OP_DO_NO_BODY_FX_VARS_STEP));
sc->code = caadr(sc->code);
}
static bool op_do_no_body_fx_vars_step(s7_scheme * sc)
{
s7_pointer slot;
if (sc->value != sc->F) {
sc->code = cdadr(sc->code);
return (true);
}
for (slot = let_slots(sc->curlet); tis_slot(slot);
slot = next_slot(slot))
if (slot_has_expression(slot))
slot_set_value(slot, fx_call(sc, slot_expression(slot)));
push_stack_no_args_direct(sc, OP_DO_NO_BODY_FX_VARS_STEP);
sc->code = caadr(sc->code);
return (false);
}
static bool op_do_no_body_fx_vars_step_1(s7_scheme * sc)
{
if (sc->value != sc->F) {
sc->code = cdadr(sc->code);
return (true);
}
slot_set_value(let_dox_slot1(sc->curlet),
fx_call(sc,
slot_expression(let_dox_slot1(sc->curlet))));
push_stack_no_args_direct(sc, OP_DO_NO_BODY_FX_VARS_STEP_1);
sc->code = caadr(sc->code);
return (false);
}
static bool do_step1(s7_scheme * sc)
{
while (true) {
s7_pointer code;
if (is_null(sc->args)) { /* after getting the new values, transfer them into the slot_values */
s7_pointer x;
for (x = sc->code; is_pair(x); x = cdr(x)) { /* sc->code here is the original sc->args list */
slot_set_value(car(x), slot_pending_value(car(x)));
slot_clear_has_pending_value(car(x));
}
pop_stack_no_op(sc);
return (true);
}
code = slot_expression(car(sc->args)); /* get the next stepper new value */
if (has_fx(code)) {
sc->value = fx_call(sc, code);
slot_set_pending_value(car(sc->args), sc->value); /* consistently slower if slot_simply_set... here? */
sc->args = cdr(sc->args); /* go to next step var */
} else {
push_stack_direct(sc, OP_DO_STEP2);
sc->code = car(code);
return (false);
}
}
}
static bool op_do_step2(s7_scheme * sc)
{
if (is_multiple_value(sc->value))
eval_error(sc, "do: variable step value can't be ~S", 35,
set_ulist_1(sc, sc->values_symbol, sc->value));
slot_set_pending_value(car(sc->args), sc->value); /* save current value */
sc->args = cdr(sc->args); /* go to next step var */
return (do_step1(sc));
}
static bool op_do_step(s7_scheme * sc)
{
/* increment all vars, return to endtest
* these are also updated in parallel at the end, so we gather all the incremented values first
*
* here we know car(sc->args) is not null, args is the list of steppable vars,
* any unstepped vars in the do var section are not in this list, so
* (do ((i 0 (+ i 1)) (j 2)) ...) arrives here with sc->args: '(slot<((+ i 1)=expr, 0=pending_value>))
*/
push_stack_direct(sc, OP_DO_END);
sc->args = car(sc->args); /* the var data lists */
sc->code = sc->args; /* save the top of the list */
return (do_step1(sc));
}
static goto_t do_end_code(s7_scheme * sc)
{
if (is_pair(cdr(sc->code))) {
if (is_undefined_feed_to(sc, car(sc->code)))
return (goto_feed_to);
/* never has_fx(sc->code) here (first of a body) */
push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
sc->code = car(sc->code);
return (goto_eval);
}
if (has_fx(sc->code)) {
sc->value = fx_call(sc, sc->code);
return (goto_start);
}
sc->code = T_Pair(car(sc->code));
return (goto_eval);
}
static bool do_end_clauses(s7_scheme * sc)
{
if (!is_null(sc->code))
return (false);
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
return (true);
}
static bool opt_do_copy(s7_scheme * sc, opt_info * o, s7_int start,
s7_int stop)
{
s7_pointer(*fp) (opt_info * o);
if (start >= stop)
return (true);
fp = o->v[0].fp; /* o->v[6].p_pi_f is getter, o->v[5].p_pip_f is setter */
if ((fp == opt_p_pip_sso) &&
(type(slot_value(o->v[1].p)) == type(slot_value(o->v[3].p))) &&
(o->v[2].p == o->v[4].p)) {
s7_pointer dest, source, caller = NULL;
dest = slot_value(o->v[1].p);
source = slot_value(o->v[3].p);
if ((is_normal_vector(dest)) &&
(((o->v[5].p_pip_f == vector_set_p_pip_unchecked)
|| (o->v[5].p_pip_f == vector_set_unchecked))
&& ((o->v[6].p_pi_f == normal_vector_ref_p_pi_unchecked)
|| (o->v[6].p_pi_f == vector_ref_p_pi_unchecked)
|| (o->v[6].p_pi_f == vector_ref_unchecked))))
caller = sc->vector_set_symbol;
else if ((is_string(dest)) &&
(((o->v[5].p_pip_f == string_set_p_pip_unchecked)
|| (o->v[5].p_pip_f == string_set_unchecked))
&& ((o->v[6].p_pi_f == string_ref_p_pi_unchecked)
|| (o->v[6].p_pi_f == string_ref_unchecked))))
caller = sc->string_set_symbol;
else if ((is_pair(dest)) &&
((o->v[5].p_pip_f == list_set_p_pip_unchecked)
&& (o->v[6].p_pi_f == list_ref_p_pi_unchecked)))
caller = sc->list_set_symbol;
else
return (false);
if (start < 0)
return (out_of_range
(sc, caller, wrap_integer1(sc, 2),
wrap_integer2(sc, start), its_negative_string));
if ((stop > integer(s7_length(sc, source)))
|| (stop > integer(s7_length(sc, dest))))
return (out_of_range
(sc, caller, wrap_integer1(sc, 2),
wrap_integer2(sc, stop), its_too_large_string));
if ((caller)
&& (copy_to_same_type(sc, dest, source, start, stop, start)))
return (true);
}
return (false);
}
static bool op_simple_do_1(s7_scheme * sc, s7_pointer code)
{
s7_pointer step_expr, step_var, ctr_slot, end_slot;
s7_function stepf, endf;
s7_pfunc func;
code = cdr(code);
if (no_cell_opt(cddr(code)))
return (false);
func = s7_optimize_nr(sc, cddr(code));
if (!func) {
set_no_cell_opt(cddr(code));
return (false);
}
/* func must be set */
step_expr = opt2_pair(code); /* caddr(caar(code)) */
stepf = fn_proc(step_expr);
endf = fn_proc(caadr(code));
ctr_slot = let_dox_slot1(sc->curlet);
end_slot = let_dox_slot2(sc->curlet);
step_var = caddr(step_expr);
/* use g* funcs (not fx) because we're passing the actual values, not the expressions */
if ((stepf == g_add_x1) &&
(is_t_integer(slot_value(ctr_slot))) &&
((endf == g_num_eq_2) || (endf == g_num_eq_xi)
|| (endf == g_geq_2)) && (is_t_integer(slot_value(end_slot)))) {
s7_int i, start, stop;
start = integer(slot_value(ctr_slot));
stop = integer(slot_value(end_slot));
if (func == opt_cell_any_nr) {
opt_info *o = sc->opts[0];
s7_pointer(*fp) (opt_info * o);
fp = o->v[0].fp;
if ((fp == opt_p_ppp_sss) || (fp == opt_p_ppp_sss_mul)
|| (fp == opt_p_ppp_sss_hset)) {
s7_p_ppp_t fpt;
fpt = o->v[4].p_ppp_f;
for (i = start; i < stop; i++) {
slot_set_value(ctr_slot, make_integer(sc, i));
fpt(sc, slot_value(o->v[1].p), slot_value(o->v[2].p),
slot_value(o->v[3].p));
}
} else if (fp == opt_p_ppp_sfs) {
s7_p_ppp_t fpt;
fpt = o->v[3].p_ppp_f;
for (i = start; i < stop; i++) {
slot_set_value(ctr_slot, make_integer(sc, i));
fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1),
slot_value(o->v[2].p));
}
} else if ((fp == opt_p_pip_sss_vset) && (start >= 0)
&& (stop <= vector_length(slot_value(o->v[1].p)))) {
s7_pointer v;
v = slot_value(o->v[1].p);
for (i = start; i < stop; i++) {
slot_set_value(ctr_slot, make_integer(sc, i));
vector_element(v, integer(slot_value(o->v[2].p))) =
slot_value(o->v[3].p);
}
} else
for (i = start; i < stop; i++) {
slot_set_value(ctr_slot, make_integer(sc, i));
fp(o);
}
} else
/* splitting out opt_float_any_nr here saves almost nothing */
for (i = start; i < stop; i++) {
slot_set_value(ctr_slot, make_integer(sc, i));
func(sc);
}
sc->value = sc->T;
sc->code = cdadr(code);
return (true);
}
if ((stepf == g_subtract_x1) &&
(is_t_integer(slot_value(ctr_slot))) &&
((endf == g_less_x0) || (endf == g_less_2) || (endf == g_less_xi))
&& (is_t_integer(slot_value(end_slot)))) {
s7_int i, start = integer(slot_value(ctr_slot)), stop =
integer(slot_value(end_slot));
if (func == opt_cell_any_nr) {
opt_info *o = sc->opts[0];
if (!opt_do_copy(sc, o, stop, start + 1)) {
s7_pointer(*fp) (opt_info * o);
fp = o->v[0].fp;
for (i = start; i >= stop; i--) {
slot_set_value(ctr_slot, make_integer(sc, i));
fp(o);
}
}
} else
for (i = start; i >= stop; i--) {
slot_set_value(ctr_slot, make_integer(sc, i));
func(sc);
}
sc->value = sc->T;
sc->code = cdadr(code);
return (true);
}
if ((stepf == g_add_2_xi) &&
(is_t_integer(slot_value(ctr_slot))) &&
((endf == g_num_eq_2) || (endf == g_num_eq_xi)
|| (endf == g_geq_2)) && (is_t_integer(slot_value(end_slot)))) {
s7_int i, start = integer(slot_value(ctr_slot)), stop =
integer(slot_value(end_slot)), incr =
integer(caddr(step_expr));
if (func == opt_cell_any_nr) {
s7_pointer(*fp) (opt_info * o);
opt_info *o = sc->opts[0];
fp = o->v[0].fp;
for (i = start; i < stop; i += incr) {
slot_set_value(ctr_slot, make_integer(sc, i));
fp(o);
}
} else
for (i = start; i < stop; i += incr) {
slot_set_value(ctr_slot, make_integer(sc, i));
func(sc);
}
sc->value = sc->T;
sc->code = cdadr(code);
return (true);
}
if (func == opt_cell_any_nr) {
opt_info *o = sc->opts[0];
s7_pointer(*fp) (opt_info * o);
fp = o->v[0].fp;
if ((stepf == g_add_x1) && (is_t_integer(slot_value(ctr_slot))) &&
(endf == g_greater_2) && (is_t_integer(slot_value(end_slot))))
{
s7_int i, start = integer(slot_value(ctr_slot)), stop =
integer(slot_value(end_slot));
for (i = start; i <= stop; i++) {
slot_set_value(ctr_slot, make_integer(sc, i));
fp(o);
}
} else
do {
fp(o);
set_car(sc->t2_1, slot_value(ctr_slot));
set_car(sc->t2_2, step_var);
slot_set_value(ctr_slot, stepf(sc, sc->t2_1));
set_car(sc->t2_1, slot_value(ctr_slot));
set_car(sc->t2_2, slot_value(end_slot));
} while ((sc->value = endf(sc, sc->t2_1)) == sc->F);
} else
do {
func(sc);
set_car(sc->t2_1, slot_value(ctr_slot));
set_car(sc->t2_2, step_var);
slot_set_value(ctr_slot, stepf(sc, sc->t2_1));
set_car(sc->t2_1, slot_value(ctr_slot));
set_car(sc->t2_2, slot_value(end_slot));
} while ((sc->value = endf(sc, sc->t2_1)) == sc->F);
sc->code = cdadr(code);
return (true);
}
static bool op_simple_do(s7_scheme * sc)
{
/* body might not be safe in this case, but the step and end exprs are easy
* simple_do: set up local let, check end (c_c?), goto op_simple_do_1
* if latter gets s7_optimize, run locally, else goto simple_do_step.
*/
s7_pointer end, body, code = cdr(sc->code);
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->value = fx_call(sc, cdaar(code));
let_set_dox_slot1(sc->curlet,
add_slot_checked(sc, sc->curlet, caaar(code),
sc->value));
end = opt1_any(code); /* caddr(caadr(code)) */
if (is_symbol(end))
let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet));
else
let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end));
set_car(sc->t2_1, let_dox1_value(sc->curlet));
set_car(sc->t2_2, let_dox2_value(sc->curlet));
sc->value = fn_proc(caadr(code)) (sc, sc->t2_1);
if (is_true(sc, sc->value)) {
sc->code = cdadr(code);
return (true); /* goto DO_END_CLAUSES */
}
body = cddr(code);
if ((is_null(cdr(body))) && /* one expr in body */
(is_pair(car(body))) && /* and it is a pair */
(is_symbol(cadr(opt2_pair(code)))) && /* caddr(caar(code)), caar=(i 0 (+ i 1)), caddr=(+ i 1), so this is apparently checking that the stepf is reasonable? */
(is_t_integer(caddr(opt2_pair(code)))) &&
(op_simple_do_1(sc, sc->code)))
return (true); /* goto DO_END_CLAUSES */
push_stack_no_args(sc, OP_SIMPLE_DO_STEP, code);
sc->code = body;
return (false); /* goto BEGIN */
}
static bool op_simple_do_step(s7_scheme * sc)
{
s7_pointer step, ctr = let_dox_slot1(sc->curlet), end =
let_dox_slot2(sc->curlet), code = sc->code;
step = opt2_pair(code); /* caddr(caar(code)) */
if (is_symbol(cadr(step))) {
set_car(sc->t2_1, slot_value(ctr));
set_car(sc->t2_2, caddr(step));
} else {
set_car(sc->t2_2, slot_value(ctr));
set_car(sc->t2_1, cadr(step));
}
slot_set_value(ctr, fn_proc(step) (sc, sc->t2_1));
set_car(sc->t2_1, slot_value(ctr));
set_car(sc->t2_2, slot_value(end));
end = cadr(code);
sc->value = fn_proc(car(end)) (sc, sc->t2_1);
if (is_true(sc, sc->value)) {
sc->code = cdr(end);
return (true);
}
push_stack_direct(sc, OP_SIMPLE_DO_STEP);
sc->code = T_Pair(cddr(code));
return (false);
}
static bool op_safe_do_step(s7_scheme * sc)
{
s7_int step, end = integer(let_dox2_value(sc->curlet));
s7_pointer slot = let_dox_slot1(sc->curlet);
step = integer(slot_value(slot)) + 1;
slot_set_value(slot, make_integer(sc, step));
if ((step == end) ||
((step > end) && (opt1_cfunc(caadr(sc->code)) == sc->geq_2))) {
sc->value = sc->T;
sc->code = cdadr(sc->code);
return (true);
}
push_stack_direct(sc, OP_SAFE_DO_STEP);
sc->code = T_Pair(opt2_pair(sc->code));
return (false);
}
static bool op_safe_dotimes_step(s7_scheme * sc)
{
s7_pointer arg = slot_value(sc->args);
numerator(arg)++;
if (numerator(arg) == do_loop_end(arg)) {
sc->value = sc->T;
sc->code = cdadr(sc->code);
return (true);
}
push_stack_direct(sc, OP_SAFE_DOTIMES_STEP);
sc->code = opt2_pair(sc->code); /* here we know the body has more than one form */
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
return (false);
}
static bool op_safe_dotimes_step_o(s7_scheme * sc)
{
s7_pointer arg = slot_value(sc->args);
numerator(arg)++;
if (numerator(arg) == do_loop_end(arg)) {
sc->value = sc->T;
sc->code = cdadr(sc->code);
return (true);
}
push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_O);
sc->code = opt2_pair(sc->code);
return (false);
}
static Inline bool op_dotimes_step_o(s7_scheme * sc)
{
s7_pointer now, end, end_test, code = sc->code, ctr =
let_dox_slot1(sc->curlet);
now = slot_value(ctr);
end = let_dox2_value(sc->curlet);
end_test = opt2_pair(code);
if (is_t_integer(now)) {
slot_set_value(ctr, make_integer(sc, integer(now) + 1));
now = slot_value(ctr);
if (is_t_integer(end)) {
if ((integer(now) == integer(end)) ||
((integer(now) > integer(end))
&& (opt1_cfunc(end_test) == sc->geq_2))) {
sc->value = sc->T;
sc->code = cdadr(code);
return (true);
}
} else {
set_car(sc->t2_1, now);
set_car(sc->t2_2, end);
end = cadr(code);
sc->value = fn_proc(car(end)) (sc, sc->t2_1);
if (is_true(sc, sc->value)) {
sc->code = cdr(end);
return (true);
}
}
} else {
set_car(sc->t1_1, now);
slot_set_value(ctr, g_add_x1(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);
end = cadr(code);
sc->value = fn_proc(car(end)) (sc, sc->t2_1);
if (is_true(sc, sc->value)) {
sc->code = cdr(end);
return (true);
}
}
push_stack_direct(sc, OP_DOTIMES_STEP_O);
sc->code = caddr(code);
return (false);
}
static bool opt_dotimes(s7_scheme * sc, s7_pointer code, s7_pointer scc,
bool safe_step)
{
s7_int end;
end = do_loop_end(slot_value(sc->args)); /* s7_optimize below can step on this value! */
if (safe_step)
set_safe_stepper(sc->args);
else
set_safe_stepper(let_dox_slot1(sc->curlet));
/* I think safe_step means the stepper is completely unproblematic */
if (is_null(cdr(code))) {
s7_pfunc func;
if (no_cell_opt(code))
return (false);
func = s7_optimize_nr(sc, code);
if (!func) {
set_no_cell_opt(code);
return (false);
}
if (safe_step) {
s7_pointer stepper;
slot_set_value(sc->args, stepper =
make_mutable_integer(sc,
integer(slot_value
(sc->args))));
if ((func == opt_float_any_nr) || (func == opt_cell_any_nr)) {
opt_info *o = sc->opts[0];
if (func == opt_float_any_nr) {
s7_double(*fd) (opt_info * o);
fd = o->v[0].fd;
if ((fd == opt_d_id_sf) && /* by far the most common case in clm: (outa i ...) etc */
(is_slot(o->v[1].p)) &&
(stepper == slot_value(o->v[1].p))) {
opt_info *o1;
s7_int end8 = end - 8;
s7_d_id_t f0;
f0 = o->v[3].d_id_f;
o1 = sc->opts[1];
fd = o1->v[0].fd;
while (integer(stepper) < end8)
LOOP_8(f0(integer(stepper), fd(o1));
integer(stepper)++);
while (integer(stepper) < end) {
f0(integer(stepper), fd(o1));
integer(stepper)++;
}
} else if ((o->v[0].fd == opt_d_7pid_ss_ss)
&& (o->v[4].d_7pid_f ==
float_vector_set_unchecked)
&& (o->v[3].d_7pi_f ==
float_vector_ref_d_7pi)
&& (o->v[2].p == o->v[6].p))
copy_to_same_type(sc, slot_value(o->v[1].p),
slot_value(o->v[5].p),
integer(stepper), end,
integer(stepper));
else if ((o->v[0].fd == opt_d_7pid_ssc)
&& (o->v[4].d_7pid_f ==
float_vector_set_unchecked)
&& (stepper == slot_value(o->v[2].p)))
s7_fill(sc,
set_elist_4(sc, slot_value(o->v[1].p),
make_real(sc, o->v[3].x),
stepper, make_integer(sc,
end)));
else
for (; integer(stepper) < end; integer(stepper)++)
fd(o);
} else {
s7_pointer(*fp) (opt_info * o);
fp = o->v[0].fp;
if ((fp == opt_p_pip_ssc) && (stepper == slot_value(o->v[2].p)) && /* i.e. index by do counter */
((o->v[3].p_pip_f == string_set_unchecked)
|| (o->v[3].p_pip_f == vector_set_unchecked)
|| (o->v[3].p_pip_f == list_set_p_pip_unchecked)))
s7_fill(sc,
set_elist_4(sc, slot_value(o->v[1].p),
o->v[4].p, stepper,
make_integer(sc, end)));
else {
if (fp == opt_if_bp) {
for (; integer(stepper) < end;
integer(stepper)++)
if (o->v[3].fb(o->v[2].o1))
o->v[5].fp(o->v[4].o1);
} else if (fp == opt_if_nbp_fs) {
for (; integer(stepper) < end;
integer(stepper)++)
if (!
(o->
v[2].b_pi_f(sc,
o->v[5].fp(o->v[4].o1),
integer(slot_value
(o->v[3].p)))))
o->v[11].fp(o->v[10].o1);
} else if (fp == opt_unless_p_1) {
for (; integer(stepper) < end;
integer(stepper)++)
if (!(o->v[4].fb(o->v[3].o1)))
o->v[5].o1->v[0].fp(o->v[5].o1);
} else
for (; integer(stepper) < end;
integer(stepper)++)
fp(o);
}
}
} else {
if (func == opt_int_any_nr) {
s7_int(*fi) (opt_info * o);
opt_info *o = sc->opts[0];
fi = o->v[0].fi;
if ((fi == opt_i_7pii_ssc)
&& (stepper == slot_value(o->v[2].p))
&& (o->v[3].i_7pii_f == int_vector_set_unchecked))
s7_fill(sc,
set_elist_4(sc, slot_value(o->v[1].p),
make_integer(sc, o->v[4].i),
stepper, make_integer(sc,
end)));
else if ((o->v[3].i_7pii_f == int_vector_set_unchecked)
&& (o->v[5].fi == opt_7pi_ss_ivref)
&& (o->v[2].p == o->v[4].o1->v[2].p))
copy_to_same_type(sc, slot_value(o->v[1].p),
slot_value(o->v[4].o1->v[1].p),
integer(stepper), end,
integer(stepper));
else
for (; integer(stepper) < end; integer(stepper)++)
fi(o);
} else /* what cases are here? */
for (; integer(stepper) < end; integer(stepper)++)
func(sc);
}
clear_mutable_integer(stepper);
} else { /* not safe_step */
s7_int step, stop;
s7_pointer step_slot = let_dox_slot1(sc->curlet), end_slot =
let_dox_slot2(sc->curlet);
step = integer(slot_value(step_slot));
stop = integer(slot_value(end_slot));
if (func == opt_cell_any_nr) {
opt_info *o = sc->opts[0];
s7_pointer(*fp) (opt_info * o);
fp = o->v[0].fp;
if (!opt_do_copy(sc, o, step, stop)) {
if ((step >= 0) && (stop < NUM_SMALL_INTS)) {
if (fp == opt_when_p_2) {
while (step < stop) {
slot_set_value(step_slot, small_int(step));
if (o->v[4].fb(o->v[3].o1)) {
o->v[6].fp(o->v[5].o1);
o->v[8].fp(o->v[7].o1);
}
step = integer(slot_value(step_slot)) + 1;
}
} else
while (step < stop) {
slot_set_value(step_slot, small_int(step));
fp(o);
step = integer(slot_value(step_slot)) + 1;
}
} else
while (step < stop) {
slot_set_value(step_slot,
make_integer(sc, step));
fp(o);
step = integer(slot_value(step_slot)) + 1;
}
}
} else if ((step >= 0) && (stop < NUM_SMALL_INTS))
while (step < stop) {
slot_set_value(step_slot, small_int(step));
func(sc);
step = integer(slot_value(step_slot)) + 1;
} else if (func == opt_int_any_nr) {
s7_int(*fi) (opt_info * o);
opt_info *o = sc->opts[0];
fi = o->v[0].fi;
while (step < stop) {
slot_set_value(step_slot, make_integer(sc, step));
fi(o);
step = integer(slot_value(step_slot)) + 1;
}
} else
while (step < stop) {
slot_set_value(step_slot, make_integer(sc, step));
func(sc);
step = integer(slot_value(step_slot)) + 1;
}
if ((S7_DEBUGGING) && (stop != integer(slot_value(end_slot))))
fprintf(stderr, "end: %" ld64 " %" ld64 "\n", stop,
integer(slot_value(end_slot)));
}
sc->value = sc->T;
sc->code = cdadr(scc);
return (true);
}
{
s7_pointer p;
s7_int body_len;
opt_info *body[32];
int32_t k;
body_len = s7_list_length(sc, code);
sc->pc = 0;
if (body_len >= 32)
return (false);
if (!no_float_opt(code)) {
for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) {
body[k] = sc->opts[sc->pc];
if (!float_optimize(sc, p))
break;
}
if (is_pair(p)) {
pc_fallback(sc, 0);
set_no_float_opt(code);
} else {
int32_t i;
end = do_loop_end(slot_value(sc->args));
if (safe_step) {
s7_pointer stepper;
slot_set_value(sc->args, stepper =
make_mutable_integer(sc,
integer(slot_value
(sc->args))));
for (; integer(stepper) < end; integer(stepper)++)
for (i = 0; i < body_len; i++)
body[i]->v[0].fd(body[i]);
clear_mutable_integer(stepper);
} else {
s7_int step, stop;
s7_pointer step_slot =
let_dox_slot1(sc->curlet), end_slot =
let_dox_slot2(sc->curlet);
stop = integer(slot_value(end_slot));
for (step = integer(slot_value(step_slot));
step < stop;
step = integer(slot_value(step_slot)) + 1) {
slot_set_value(step_slot, make_integer(sc, step));
for (i = 0; i < body_len; i++)
body[i]->v[0].fd(body[i]);
}
}
sc->value = sc->T;
sc->code = cdadr(scc);
return (true);
}
}
/* not float opt */
sc->pc = 0;
for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) {
opt_info *start = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
break;
oo_idp_nr_fixup(start);
body[k] = start;
}
if (is_null(p)) {
int32_t i;
end = do_loop_end(slot_value(sc->args));
if (safe_step) {
s7_pointer stepper;
slot_set_value(sc->args, stepper =
make_mutable_integer(sc,
integer(slot_value
(sc->args))));
for (; integer(stepper) < end; integer(stepper)++)
for (i = 0; i < body_len; i++)
body[i]->v[0].fp(body[i]);
clear_mutable_integer(stepper);
} else {
s7_int step, stop;
s7_pointer step_slot =
let_dox_slot1(sc->curlet), end_slot =
let_dox_slot2(sc->curlet);
stop = integer(slot_value(end_slot));
for (step = integer(slot_value(step_slot)); step < stop;
step = integer(slot_value(step_slot)) + 1) {
slot_set_value(step_slot, make_integer(sc, step));
for (i = 0; i < body_len; i++)
body[i]->v[0].fp(body[i]);
}
}
sc->value = sc->T;
sc->code = cdadr(scc);
return (true);
}
}
return (false);
}
static goto_t do_let(s7_scheme * sc, s7_pointer step_slot, s7_pointer scc)
{
s7_pointer let_body, p = NULL, let_vars, let_code, ip;
bool let_star;
s7_pointer old_e, stepper;
s7_int body_len, var_len, k, end;
#define O_SIZE 32
opt_info *body[O_SIZE], *vars[O_SIZE];
memset((void *) body, 0, O_SIZE * sizeof(opt_info *)); /* placate the damned compiler */
memset((void *) vars, 0, O_SIZE * sizeof(opt_info *));
/* do_let with non-float vars doesn't get many fixable hits */
let_code = caddr(scc);
if ((!is_pair(cdr(let_code))) || (!is_list(cadr(let_code)))) /* (do ((j 0 (+ j 1))) ((= j 1)) (let name 123)) */
return (fall_through);
let_body = cddr(let_code);
body_len = s7_list_length(sc, let_body);
if ((body_len <= 0) || (body_len >= 32))
return (fall_through);
let_star = (symbol_syntax_op_checked(let_code) == OP_LET_STAR);
let_vars = cadr(let_code);
set_safe_stepper(step_slot);
stepper = slot_value(step_slot);
old_e = sc->curlet;
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->pc = 0;
for (var_len = 0, p = let_vars; (is_pair(p)) && (var_len < 32);
var_len++, p = cdr(p)) {
if ((!is_pair(car(p))) || (!is_normal_symbol(caar(p)))
|| (!is_pair(cdar(p))))
return (fall_through);
vars[var_len] = sc->opts[sc->pc];
if (!float_optimize(sc, cdar(p))) { /* each of these needs to set the associated variable */
set_curlet(sc, old_e);
return (fall_through);
}
if (let_star)
add_slot_checked(sc, sc->curlet, caar(p),
s7_make_mutable_real(sc, 1.5));
}
if (!let_star)
for (p = let_vars; is_pair(p); p = cdr(p))
add_slot_checked(sc, sc->curlet, caar(p),
s7_make_mutable_real(sc, 1.5));
for (k = 0, p = let_body; is_pair(p); k++, p = cdr(p)) {
body[k] = sc->opts[sc->pc];
if (!float_optimize(sc, p)) {
set_curlet(sc, old_e);
return (fall_through);
}
}
if (!is_null(p)) { /* no hits in s7test or snd-test */
set_curlet(sc, old_e);
return (fall_through);
}
end = do_loop_end(stepper);
let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet)));
ip = slot_value(step_slot);
if (body_len == 1) {
if (var_len == 1) {
s7_pointer xp;
opt_info *first, *o;
s7_double(*f1) (opt_info * o);
s7_double(*f2) (opt_info * o);
xp = t_lookup(sc, caar(let_vars), let_vars);
first = sc->opts[0];
f1 = first->v[0].fd;
integer(ip) = numerator(stepper);
set_real(xp, f1(first));
o = body[0];
f2 = o->v[0].fd;
f2(o);
if ((f2 == opt_fmv) &&
(f1 == opt_d_dd_ff_o2) &&
(first->v[3].d_dd_f == add_d_dd) &&
(slot_symbol(step_slot) == slot_symbol(o->v[2].p))) {
opt_info *o1, *o2, *o3;
s7_d_v_t vf1, vf2, vf3, vf4;
s7_d_vd_t vf5, vf6;
s7_d_vid_t vf7;
void *obj1, *obj2, *obj3, *obj4, *obj5, *obj6, *obj7;
o1 = o->v[12].o1;
o2 = o->v[13].o1;
o3 = o->v[14].o1;
vf1 = first->v[4].d_v_f;
vf2 = first->v[5].d_v_f;
vf3 = o1->v[2].d_v_f;
vf4 = o3->v[5].d_v_f;
vf5 = o2->v[3].d_vd_f;
vf6 = o3->v[6].d_vd_f;
vf7 = o->v[4].d_vid_f;
obj1 = first->v[1].obj;
obj2 = first->v[2].obj;
obj3 = o1->v[1].obj;
obj4 = o3->v[1].obj;
obj5 = o->v[5].obj;
obj6 = o2->v[5].obj;
obj7 = o3->v[2].obj;
for (k = numerator(stepper) + 1; k < end; k++) {
s7_double amp_env, vib;
vib = vf1(obj1) + vf2(obj2);
amp_env = vf3(obj3);
vf7(obj5, k,
amp_env * vf5(obj6,
vib + (vf4(obj4) * vf6(obj7, vib))));
}
} else
for (k = numerator(stepper) + 1; k < end; k++) {
integer(ip) = k;
set_real(xp, f1(first));
f2(o);
}
} /* body_len == 1 and var_len == 1 */
else {
if (var_len == 2) {
s7_pointer s1 = let_slots(sc->curlet), s2;
s2 = next_slot(s1);
for (k = numerator(stepper); k < end; k++) {
integer(ip) = k;
set_real(slot_value(s1), vars[0]->v[0].fd(vars[0]));
set_real(slot_value(s2), vars[1]->v[0].fd(vars[1]));
body[0]->v[0].fd(body[0]);
}
} /* body_len == 1 and var_len == 2 */
else
for (k = numerator(stepper); k < end; k++) {
int32_t n;
integer(ip) = k;
for (n = 0, p = let_slots(sc->curlet); tis_slot(p);
n++, p = next_slot(p))
set_real(slot_value(p), vars[n]->v[0].fd(vars[n]));
body[0]->v[0].fd(body[0]);
}
}
} /* end body_len == 1 */
else if ((body_len == 2) && (var_len == 1)) {
s7_pointer s1 = let_slots(sc->curlet);
for (k = numerator(stepper); k < end; k++) {
integer(ip) = k;
set_real(slot_value(s1), vars[0]->v[0].fd(vars[0]));
body[0]->v[0].fd(body[0]);
body[1]->v[0].fd(body[1]);
}
} else
for (k = numerator(stepper); k < end; k++) {
int32_t i;
integer(ip) = k;
for (i = 0, p = let_slots(sc->curlet); tis_slot(p);
i++, p = next_slot(p))
set_real(slot_value(p), vars[i]->v[0].fd(vars[i]));
for (i = 0; i < body_len; i++)
body[i]->v[0].fd(body[i]);
}
set_curlet(sc, old_e);
sc->value = sc->T;
sc->code = cdadr(scc);
return (goto_safe_do_end_clauses);
}
static bool dotimes(s7_scheme * sc, s7_pointer code, bool safe_case)
{
s7_pointer body = caddr(code); /* here we assume one expr in body */
if (((is_syntactic_pair(body)) ||
(is_symbol_and_syntactic(car(body)))) &&
((symbol_syntax_op_checked(body) == OP_LET) ||
(symbol_syntax_op(car(body)) == OP_LET_STAR)))
return (do_let(sc, sc->args, code) == goto_safe_do_end_clauses);
return (opt_dotimes(sc, cddr(code), code, safe_case));
}
static goto_t op_safe_dotimes(s7_scheme * sc)
{
s7_pointer init_val, form = sc->code;
sc->code = cdr(sc->code);
init_val = fx_call(sc, cdaar(sc->code));
if (s7_is_integer(init_val)) {
s7_pointer end_expr, end_val, code = sc->code;
end_expr = caadr(code);
end_val = caddr(end_expr);
if (is_symbol(end_val))
end_val = lookup_checked(sc, end_val);
if (s7_is_integer(end_val)) {
sc->code = cddr(code);
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->args =
add_slot_checked(sc, sc->curlet, caaar(code),
make_mutable_integer(sc,
s7_integer_checked
(sc, init_val)));
set_do_loop_end(slot_value(sc->args),
s7_integer_checked(sc, end_val));
set_step_end(sc->args); /* safe_dotimes step is by 1 */
/* (define (hi) (do ((i 1 (+ 1 i))) ((= i 1) i))) -- we need the let even if the loop is not evaluated */
/* safe_dotimes: (car(body) is known to be a pair here)
* if 1-expr body look for syntactic case, if let(*) goto do_let, else opt_dotimes
* if they are unhappy, got safe_dotimes_step_o
* else goto opt_dotimes then safe_dotimes_step_o
* if multi-line body, check opt_dotimes, then safe_dotimes_step
*/
if (s7_integer_checked(sc, init_val) ==
s7_integer_checked(sc, end_val)) {
sc->value = sc->T;
sc->code = cdadr(code);
return (goto_safe_do_end_clauses);
}
if ((is_null(cdr(sc->code))) && (is_pair(car(sc->code)))) {
sc->code = car(sc->code);
set_opt2_pair(code, sc->code); /* is_pair above */
if ((is_syntactic_pair(sc->code)) ||
(is_symbol_and_syntactic(car(sc->code)))) {
if (!is_unsafe_do(code)) {
if (dotimes(sc, code, true))
return (goto_safe_do_end_clauses);
set_unsafe_do(code);
}
push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code);
if (is_syntactic_pair(sc->code))
sc->cur_op = (opcode_t) optimize_op(sc->code);
else {
sc->cur_op =
(opcode_t) symbol_syntax_op_checked(sc->code);
pair_set_syntax_op(sc->code, sc->cur_op);
}
return (goto_top_no_pop);
}
/* car not syntactic? */
if ((!is_unsafe_do(code)) &&
(opt_dotimes(sc, cddr(code), code, true)))
return (goto_safe_do_end_clauses);
set_unsafe_do(code);
if (has_fx(cddr(code))) { /* this almost never happens and the func case below is only in timing tests */
s7_int end = s7_integer_checked(sc, end_val);
s7_pointer body = cddr(code), stepper =
slot_value(sc->args);
for (; integer(stepper) < end; integer(stepper)++)
fx_call(sc, body);
sc->value = sc->T;
sc->code = cdadr(code);
return (goto_safe_do_end_clauses);
}
push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); /* arg is local step var slot, code is do form - do, sc->code is the body */
return (goto_eval);
}
/* multi-line body */
if ((!is_unsafe_do(code)) &&
(opt_dotimes(sc, sc->code, code, true)))
return (goto_safe_do_end_clauses);
set_unsafe_do(code);
set_opt2_pair(code, sc->code);
push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, code);
return (goto_begin);
}
}
pair_set_syntax_op(form, OP_SIMPLE_DO);
sc->code = form;
if (op_simple_do(sc))
return (goto_do_end_clauses);
return (goto_begin);
}
static goto_t op_safe_do(s7_scheme * sc)
{
/* body is safe, step = +1, end is = or >=, but stepper and end might be set (or at least indirectly exported) in the body:
* (let ((lst ())) (do ((i 0 (+ i 1))) ((= i 10)) (let ((j (min i 100))) (set! lst (cons j lst)))) lst)
* however, we're very restrictive about this in check_do and do_is_safe; even this is considered trouble:
* (let ((x 0)) (do ((i i (+ i 1))) ((= i 7)) (set! x (+ x i))) x)
* but end might not be an integer -- need to catch this earlier.
*/
s7_pointer end, init_val, end_val, code, form = sc->code;
/* inits, if not >= opt_dotimes else safe_do_step */
sc->code = cdr(sc->code);
code = sc->code;
init_val = fx_call(sc, cdaar(code));
end = opt1_any(code); /* caddr(caadr(code)) */
end_val = (is_symbol(end)) ? lookup_checked(sc, end) : end;
if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) { /* this almost never happens */
pair_set_syntax_op(form, OP_DO_UNCHECKED);
return (goto_do_unchecked);
}
/* (let ((sum 0)) (define (hi) (do ((i 10 (+ i 1))) ((= i 10) i) (set! sum (+ sum i)))) (hi)) */
sc->curlet = make_let_slowly(sc, sc->curlet);
let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), init_val)); /* define the step var -- might be needed in the end clauses */
if ((s7_integer_checked(sc, init_val) ==
s7_integer_checked(sc, end_val))
||
((s7_integer_checked(sc, init_val) >
s7_integer_checked(sc, end_val))
&& (opt1_cfunc(caadr(code)) == sc->geq_2))) {
sc->value = sc->T;
sc->code = cdadr(code);
return (goto_safe_do_end_clauses);
}
if (is_symbol(end))
let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet));
else
let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end));
sc->args = let_dox_slot2(sc->curlet); /* the various safe steps assume sc->args is the end slot */
{
s7_pointer step_slot = let_dox_slot1(sc->curlet);
set_step_end(step_slot);
slot_set_value(step_slot,
make_mutable_integer(sc,
integer(slot_value
(step_slot))));
set_do_loop_end(slot_value(step_slot),
s7_integer_checked(sc, end_val));
}
if (!is_unsafe_do(sc->code)) {
s7_pointer old_let = sc->curlet;
sc->temp7 = old_let;
if (opt_dotimes(sc, cddr(sc->code), sc->code, false))
return (goto_safe_do_end_clauses);
set_curlet(sc, old_let); /* apparently s7_optimize can step on sc->curlet? */
}
if (is_null(cdddr(sc->code))) {
s7_pointer body = caddr(sc->code);
if ((car(body) == sc->set_symbol) &&
(is_pair(cdr(body))) &&
(is_symbol(cadr(body))) &&
(is_pair(cddr(body))) &&
(has_fx(cddr(body))) && (is_null(cdddr(body)))) {
s7_pointer step_slot = let_dox_slot1(sc->curlet);
if (slot_symbol(step_slot) != cadr(body)) {
s7_int step, endi;
s7_pointer val_slot, fx_p, step_val;
endi = integer(let_dox2_value(sc->curlet));
val_slot = lookup_slot_from(cadr(body), sc->curlet);
fx_p = cddr(body);
step = integer(slot_value(step_slot));
slot_set_value(step_slot, step_val =
make_mutable_integer(sc, step));
do {
slot_set_value(val_slot, fx_call(sc, fx_p));
integer(step_val) = ++step;
} while (step != endi); /* geq not needed here -- we're leq endi and stepping by +1 all ints */
clear_mutable_integer(step_val);
sc->value = sc->T;
sc->code = cdadr(code);
return (goto_safe_do_end_clauses);
}
}
}
sc->code = cddr(code);
set_unsafe_do(sc->code);
set_opt2_pair(code, sc->code);
push_stack_no_args(sc, OP_SAFE_DO_STEP, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */
return (goto_begin);
}
static goto_t op_dotimes_p(s7_scheme * sc)
{
s7_pointer end, code = cdr(sc->code), init_val, end_val, slot, old_e;
/* (do ... (set! args ...)) -- one line, syntactic */
init_val = fx_call(sc, cdaar(code));
sc->value = init_val;
set_opt2_pair(code, caadr(code));
end = opt1_any(code); /* caddr(opt2_pair(code)) */
if (is_symbol(end)) {
slot = lookup_slot_from(end, sc->curlet);
end_val = slot_value(slot);
} else {
slot = make_slot(sc, make_symbol(sc, "___end___"), end); /* name is ignored, but needs to be > 8 chars for gcc's benefit (version 10.2.1)! */
end_val = end;
}
if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) {
pair_set_syntax_op(sc->code, OP_DO_UNCHECKED);
sc->code = cdr(sc->code);
return (goto_do_unchecked);
}
old_e = sc->curlet;
sc->curlet = make_let_slowly(sc, sc->curlet);
let_set_dox_slot1(sc->curlet,
add_slot_checked(sc, sc->curlet, caaar(code),
init_val));
let_set_dox_slot2(sc->curlet, slot);
set_car(sc->t2_1, let_dox1_value(sc->curlet));
set_car(sc->t2_2, let_dox2_value(sc->curlet));
if (is_true(sc, sc->value = fn_proc(caadr(code)) (sc, sc->t2_1))) {
sc->code = cdadr(code);
return (goto_do_end_clauses);
}
if ((!is_unsafe_do(code)) && (opt1_cfunc(caadr(code)) != sc->geq_2)) {
s7_pointer old_args = sc->args, old_init =
let_dox1_value(sc->curlet);
sc->args = T_Slt(let_dox_slot1(sc->curlet)); /* used in opt_dotimes */
slot_set_value(sc->args,
make_mutable_integer(sc,
integer(let_dox1_value
(sc->curlet))));
set_do_loop_end(slot_value(sc->args),
integer(let_dox2_value(sc->curlet)));
set_step_end(sc->args); /* dotimes step is by 1 */
sc->code = cdr(sc->code);
if (dotimes(sc, code, false))
return (goto_do_end_clauses); /* not safe_do here */
slot_set_value(sc->args, old_init);
set_curlet(sc, old_e); /* free_cell(sc, sc->curlet) beforehand is not safe */
sc->args = old_args;
set_unsafe_do(code);
return (goto_do_unchecked);
}
push_stack_no_args(sc, OP_DOTIMES_STEP_O, code);
sc->code = caddr(code);
return (goto_eval);
}
static goto_t op_do_init_1(s7_scheme * sc)
{
s7_pointer x, y, z;
while (true) { /* at start, first value is the loop (for GC protection?), returning sc->value is the next value */
s7_pointer init;
sc->args = cons(sc, sc->value, sc->args); /* code will be last element (first after reverse), these cons's will be used below for the new let/slots */
if (!is_pair(sc->code))
break;
/* here sc->code is a list like: ((i 0 (+ i 1)) ...) so cadar gets the init value. */
init = cdar(sc->code);
if (has_fx(init))
sc->value = fx_call(sc, init);
else {
init = car(init);
if (is_pair(init)) {
push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */
sc->code = init;
return (goto_eval);
}
sc->value =
(is_symbol(init)) ? lookup_checked(sc, init) : init;
}
sc->code = cdr(sc->code);
}
/* all the initial values are now in the args list */
sc->args = proper_list_reverse_in_place(sc, sc->args);
sc->code = car(sc->args); /* saved at the start */
z = sc->args;
sc->args = cdr(sc->args); /* init values */
/* sc->args was cons'd above, so it should be safe to reuse it as the new let */
set_curlet(sc, reuse_as_let(sc, z, sc->curlet)); /* sc->curlet = make_let_slowly(sc, sc->curlet); */
/* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->curlet, also reuse sc->args as the new let slots */
sc->value = sc->nil;
y = sc->args;
for (x = car(sc->code); is_not_null(y); x = cdr(x)) {
s7_pointer sym = caar(x), args = cdr(y);
reuse_as_slot(sc, y, sym, unchecked_car(y));
slot_set_next(y, let_slots(sc->curlet));
let_set_slots(sc->curlet, y);
symbol_set_local_slot(sym, let_id(sc->curlet), y);
if (is_pair(cddar(x))) { /* else no incr expr, so ignore it henceforth */
slot_set_expression(y, cddar(x));
sc->value = cons_unchecked(sc, y, sc->value);
}
y = args;
}
sc->args = cons(sc, sc->value =
proper_list_reverse_in_place(sc, sc->value),
cadr(sc->code));
sc->code = cddr(sc->code);
return (fall_through);
}
static bool op_do_init(s7_scheme * sc)
{
if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */
eval_error_any(sc, sc->wrong_type_arg_symbol,
"do: variable initial value can't be ~S", 38,
set_ulist_1(sc, sc->values_symbol, sc->value));
return (op_do_init_1(sc) != goto_eval);
}
static void op_do_unchecked(s7_scheme * sc)
{
push_stack_no_code(sc, OP_GC_PROTECT, sc->code);
sc->code = cdr(sc->code);
}
static bool do_unchecked(s7_scheme * sc)
{
if (is_null(car(sc->code))) { /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */
sc->curlet = make_let_slowly(sc, sc->curlet);
sc->args = cons_unchecked(sc, sc->nil, cadr(sc->code));
sc->code = cddr(sc->code);
return (false);
}
/* eval each init value, then set up the new let (like let, not let*) */
sc->args = sc->nil; /* the evaluated var-data */
sc->value = sc->code; /* protect it */
sc->code = car(sc->code); /* the vars */
return (op_do_init_1(sc) == goto_eval);
}
static bool op_do_end(s7_scheme * sc)
{
/* car(sc->args) here is the var list used by do_end2 */
if (is_pair(cdr(sc->args))) {
if (!has_fx(cdr(sc->args))) {
push_stack_direct(sc, OP_DO_END1);
sc->code = cadr(sc->args); /* evaluate the end expr */
return (true);
}
sc->value = fx_call(sc, cdr(sc->args));
} else
sc->value = sc->F; /* goto "if (is_pair(sc->code))..." below */
return (false);
}
static goto_t op_do_end1(s7_scheme * sc)
{
if (is_true(sc, sc->value)) { /* sc->value is the result of end-test evaluation */
/* we're done -- deal with result exprs, if there isn't an end test, there also isn't a result (they're in the same list)
* multiple-value end-test result is ok
*/
sc->code = T_Lst(cddr(sc->args)); /* result expr (a list -- implicit begin) */
free_cell(sc, sc->args);
sc->args = sc->nil;
if (is_null(sc->code)) {
if (is_multiple_value(sc->value)) /* (define (f) (+ 1 (do ((i 2 (+ i 1))) ((values i (+ i 1)))))) -> 6 */
sc->value =
splice_in_values(sc, multiple_value(sc->value));
/* similarly, if the result is a multiple value: (define (f) (+ 1 (do ((i 2 (+ i 1))) ((= i 3) (values i (+ i 1)))))) -> 8 */
return (goto_start);
}
/* might be => here as in cond and case */
if (is_null(cdr(sc->code))) {
if (has_fx(sc->code)) {
sc->value = fx_call(sc, sc->code);
return (goto_start);
}
sc->code = car(sc->code);
return (goto_eval);
}
if (is_undefined_feed_to(sc, car(sc->code)))
return (goto_feed_to);
push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
sc->code = car(sc->code);
return (goto_eval);
}
if (!is_pair(sc->code))
return ((is_null(car(sc->args))) ? /* no steppers */ goto_do_end :
fall_through);
if (is_null(car(sc->args)))
push_stack_direct(sc, OP_DO_END);
else
push_stack_direct(sc, OP_DO_STEP);
return (goto_begin);
}
/* -------------------------------------------------------------------------------- */
static void op_unwind_output(s7_scheme * sc)
{
bool is_file = is_file_port(sc->code);
if ((is_output_port(sc->code)) && (!port_is_closed(sc->code)))
s7_close_output_port(sc, sc->code); /* may call fflush */
if (((is_output_port(sc->args)) &&
(!port_is_closed(sc->args))) || (sc->args == sc->F))
set_current_output_port(sc, sc->args);
if ((is_file) && (is_multiple_value(sc->value)))
sc->value = splice_in_values(sc, multiple_value(sc->value));
}
static void op_unwind_input(s7_scheme * sc)
{
/* sc->code is an input port */
if (!port_is_closed(sc->code))
s7_close_input_port(sc, sc->code);
if ((is_input_port(sc->args)) && (!port_is_closed(sc->args)))
set_current_input_port(sc, sc->args);
if (is_multiple_value(sc->value))
sc->value = splice_in_values(sc, multiple_value(sc->value));
}
static goto_t op_dynamic_wind(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);
}
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);
}
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 goto_t op_read_s(s7_scheme * sc)
{
/* another lint opt */
s7_pointer port;
port = lookup(sc, cadr(sc->code));
if (!is_input_port(port)) { /* was also not stdin */
sc->value = g_read(sc, set_plist_1(sc, port));
return (goto_start);
}
if (port_is_closed(port)) /* I guess the port_is_closed check is needed because we're going down a level below */
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);
if (is_multiple_value(sc->value)) {
clear_multiple_value(sc->value);
s7_error(sc, sc->bad_result_symbol,
set_elist_2(sc,
wrap_string(sc,
"input-function-port read returned: ~S",
37), sc->value));
}
} else
if ((is_string_port(port)) &&
(port_data_size(port) <= port_position(port)))
sc->value = eof_object;
else {
push_input_port(sc, port);
push_stack_op(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */
sc->tok = token(sc);
switch (sc->tok) {
case TOKEN_EOF:
return (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(current_input_port(sc)); /* this info is used to track down missing close parens */
sc->current_file = port_filename(current_input_port(sc));
}
}
/* equally read-done and read-list here */
return (goto_start);
}
static Inline void op_increment_by_1(s7_scheme * sc)
{ /* ([set!] ctr (+ ctr 1)) */
s7_pointer val, y;
y = lookup_slot_from(cadr(sc->code), sc->curlet);
if (!is_slot(y))
s7_error(sc, sc->unbound_variable_symbol,
set_elist_3(sc, wrap_string(sc, "~S in ~S", 8),
cadr(sc->code), sc->code));
val = slot_value(y);
if (is_t_integer(val))
sc->value = make_integer(sc, integer(val) + 1);
else
switch (type(val)) {
case T_RATIO:
new_cell(sc, sc->value, T_RATIO);
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 = add_p_pp(sc, val, int_one);
break;
}
slot_set_value(y, sc->value);
}
static void op_decrement_by_1(s7_scheme * sc)
{ /* ([set!] ctr (- ctr 1)) */
s7_pointer val, y;
y = lookup_slot_from(cadr(sc->code), sc->curlet);
if (!is_slot(y))
s7_error(sc, sc->unbound_variable_symbol,
set_elist_3(sc, wrap_string(sc, "~S in ~S", 8),
cadr(sc->code), sc->code));
val = slot_value(y);
if (is_t_integer(val))
sc->value = make_integer(sc, integer(val) - 1); /* increment (set!) returns the new value in sc->value */
else
switch (type(val)) {
case T_RATIO:
new_cell(sc, sc->value, T_RATIO);
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, int_one));
break;
}
slot_set_value(y, sc->value);
}
static void op_set_pws(s7_scheme * sc)
{
/* this is (set! (getter) val) where getter is a global c_function (a built-in pws) and val is not a pair: (set! (mus-clipping) #f) */
s7_pointer obj, code = cdr(sc->code);
obj = caar(code);
if (is_symbol(obj)) {
obj = lookup_slot_from(obj, sc->curlet);
if (is_slot(obj))
obj = slot_value(obj);
else
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(code),
sc->prepackaged_type_names[type(obj)]));
}
if ((is_c_function(obj)) && (is_procedure(c_function_setter(obj)))) {
s7_pointer value = cadr(code);
if (is_symbol(value))
value = lookup_checked(sc, value);
set_car(sc->t1_1, value);
sc->value = c_function_call(c_function_setter(obj)) (sc, sc->t1_1);
} else
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, no_setter_string, caar(sc->code),
sc->prepackaged_type_names[type(obj)]));
}
/* -------------------------------- apply functions -------------------------------- */
static void apply_c_function(s7_scheme * sc)
{ /* -------- C-based function -------- */
s7_int len;
len = proper_list_length(sc->args);
if (len < c_function_required_args(sc->code))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(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, too_many_arguments_string, sc->code,
sc->args));
sc->value = c_function_call(sc->code) (sc, sc->args);
/* just by chance, this code is identical to macroexpand_c_macro's code (after macro expansion)! So,
* gcc -O2 uses the macroexpand code, but then valgrind shows us calling macros all the time, and
* gdb with break apply_c_function breaks at macroexpand -- confusing!
*/
}
static void apply_c_opt_args_function(s7_scheme * sc)
{ /* -------- C-based function that has n optional arguments -------- */
s7_int len;
len = proper_list_length(sc->args);
if (c_function_all_args(sc->code) < len)
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(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 -------- */
s7_int len;
len = proper_list_length(sc->args);
if (len < c_function_required_args(sc->code))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(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_macro(s7_scheme * sc)
{ /* -------- C-based macro -------- */
s7_int len;
len = proper_list_length(sc->args);
if (len < c_macro_required_args(sc->code))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, not_enough_arguments_string, sc->code,
sc->args));
if (c_macro_all_args(sc->code) < len)
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, sc->code,
sc->args));
sc->code = c_macro_call(sc->code) (sc, sc->args);
}
static void apply_syntax(s7_scheme * sc)
{ /* -------- syntactic keyword as applicable object -------- */
/* current reader-cond macro uses this via (map quote ...) */
s7_int len; /* ((apply lambda '((x) (+ x 1))) 4) */
if (is_pair(sc->args)) { /* this is ((pars) . body) */
len = s7_list_length(sc, sc->args);
if (len == 0)
eval_error(sc, "attempt to evaluate a circular list: ~S", 39,
sc->args);
if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, sc->args)))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc,
wrap_string(sc,
"apply ~S: body is circular: ~S",
30), sc->code, sc->args));
} else
len = 0;
if (len < syntax_min_args(sc->code))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(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, too_many_arguments_string, sc->code,
sc->args));
sc->cur_op = (opcode_t) syntax_opcode(sc->code); /* (apply begin '((define x 3) (+ x 2))) */
/* I had elaborate checks here for embedded circular lists, but now I think that is the caller's problem */
sc->code = cons(sc, sc->code, sc->args);
pair_set_syntax_op(sc->code, sc->cur_op);
}
static void apply_vector(s7_scheme * sc)
{ /* -------- vector as applicable object -------- */
/* sc->code is the vector, sc->args is the list of indices */
if (is_null(sc->args)) /* (#2d((1 2) (3 4))) */
s7_wrong_number_of_args_error(sc,
"not enough arguments 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 = s7_integer_checked(sc, car(sc->args));
if ((index >= 0) && (index < vector_length(sc->code)))
sc->value = vector_getter(sc->code) (sc, sc->code, index);
else
out_of_range(sc, sc->vector_ref_symbol, int_two, 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_pair(sc->args)) && (is_null(cdr(sc->args)))) {
if (s7_is_integer(car(sc->args))) {
s7_int index = s7_integer_checked(sc, car(sc->args));
if ((index >= 0) && (index < string_length(sc->code))) {
sc->value =
chars[((uint8_t *) string_value(sc->code))[index]];
return;
}
}
sc->value = string_ref_1(sc, sc->code, car(sc->args));
} else
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc,
(is_null(sc->args)) ?
not_enough_arguments_string :
too_many_arguments_string, sc->code,
sc->args));
}
static bool 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 = pair_append(sc, cdr(sc->x), sc->args);
sc->x = sc->nil;
return (false);
}
if (is_null(sc->args))
s7_wrong_number_of_args_error(sc,
"not enough arguments 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 (true);
}
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 arguments 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))
wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, sc->args,
a_symbol_string);
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 arguments for iterator: ~A",
sc->args);
sc->value = s7_iterate(sc, sc->code);
}
static Inline 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] */
s7_pointer x, z, e = sc->curlet, sym, slot, last_slot;
uint64_t id;
id = let_id(e);
last_slot = slot_end(sc);
for (x = closure_args(sc->code), z = T_Lst(sc->args); is_pair(x); x = cdr(x), z = cdr(z)) { /* closure_args can be a symbol, for example */
if (is_null(z))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, not_enough_arguments_string, sc->code,
sc->args));
sym = car(x);
slot = make_slot(sc, sym, T_Pos(unchecked_car(z)));
#if S7_DEBUGGING
slot->debugger_bits = 0;
#endif
symbol_set_local_slot(sym, id, slot);
if (tis_slot(last_slot))
slot_set_next(last_slot, slot);
else
let_set_slots(e, slot);
last_slot = slot;
slot_set_next(slot, slot_end(sc));
}
if (is_null(x)) {
if (is_not_null(z))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, sc->code,
sc->args));
} else {
sym = x;
slot = make_slot(sc, sym, z);
symbol_set_local_slot(sym, id, slot);
if (tis_slot(last_slot))
slot_set_next(last_slot, slot);
else
let_set_slots(e, slot);
slot_set_next(slot, slot_end(sc));
}
sc->code = closure_body(sc->code);
}
/* lambda* */
static void op_lambda_star(s7_scheme * sc)
{
check_lambda_star(sc);
if (!is_pair(car(sc->code)))
sc->value =
make_closure(sc, car(sc->code), cdr(sc->code),
(is_symbol(car(sc->code))) ? (T_CLOSURE |
T_COPY_ARGS) :
T_CLOSURE, CLOSURE_ARITY_NOT_SET);
else
sc->value =
make_closure(sc, car(sc->code), cdr(sc->code),
(!arglist_has_rest(sc, car(sc->code))) ?
T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS),
CLOSURE_ARITY_NOT_SET);
}
static void op_lambda_star_unchecked(s7_scheme * sc)
{
s7_pointer code = cdr(sc->code);
if (!is_pair(car(code)))
sc->value =
make_closure(sc, car(code), cdr(code),
(is_symbol(car(code))) ? (T_CLOSURE | T_COPY_ARGS)
: T_CLOSURE, CLOSURE_ARITY_NOT_SET);
else
sc->value =
make_closure(sc, car(code), cdr(code),
(!arglist_has_rest(sc, car(code))) ?
T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS),
CLOSURE_ARITY_NOT_SET);
}
static s7_pointer star_set(s7_scheme * sc, s7_pointer slot, s7_pointer val,
bool check_rest)
{
if (is_checked_slot(slot))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc, parameter_set_twice_string,
slot_symbol(slot), sc->args)));
if ((check_rest) && (is_rest_slot(slot)))
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
wrap_string(sc,
"can't set rest argument ~S to ~S via keyword",
44), slot_symbol(slot),
val)));
set_checked_slot(slot);
slot_set_value(slot, val);
return (val);
}
static s7_pointer lambda_star_argument_set_value(s7_scheme * sc,
s7_pointer sym,
s7_pointer val,
s7_pointer slot,
bool check_rest)
{
s7_pointer x;
if (val == sc->no_value)
val = sc->unspecified;
if (sym == slot_symbol(slot))
return (star_set(sc, slot, val, check_rest));
for (x = let_slots(sc->curlet) /* presumably the arglist */ ;
tis_slot(x); x = next_slot(x))
if (slot_symbol(x) == sym)
return (star_set(sc, x, val, check_rest));
return (sc->no_value);
}
static s7_pointer lambda_star_set_args(s7_scheme * sc)
{
bool allow_other_keys;
s7_pointer lx = sc->args, cx, zx = sc->nil, code = sc->code, args =
sc->args, slot = let_slots(sc->curlet);
cx = closure_args(code);
allow_other_keys = ((is_pair(cx)) && (allows_other_keys(cx)));
while ((is_pair(cx)) && (is_pair(lx))) {
if (car(cx) == sc->key_rest_symbol) { /* the rest arg: a default is not allowed here (see check_lambda_star_args) */
/* next arg is bound to trailing args from this point as a list */
zx = sc->key_rest_symbol;
cx = cdr(cx);
if ((is_keyword(car(lx))) &&
(is_pair(cdr(lx))) && (keyword_symbol(car(lx)) == car(cx)))
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
wrap_string(sc,
"can't set rest argument ~S to ~S via keyword",
44), car(cx),
cadr(lx))));
lambda_star_argument_set_value(sc, car(cx), lx, slot, false);
lx = cdr(lx);
cx = cdr(cx);
slot = next_slot(slot);
} else {
s7_pointer car_lx = car(lx);
if (is_keyword(car_lx)) {
if (!is_pair(cdr(lx))) {
if (!sc->accept_all_keyword_arguments)
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"~A: keyword argument's value is missing: ~S in ~S",
49),
closure_name(sc,
code),
lx, args)));
slot_set_value(slot, car_lx);
set_checked_slot(slot);
lx = cdr(lx);
} else {
s7_pointer sym = keyword_symbol(car_lx);
if (lambda_star_argument_set_value
(sc, sym, cadr(lx), slot, true) == sc->no_value) {
/* if default value is a key, go ahead and use this value.
* (define* (f (a :b)) a) (f :c)
* this has become much trickier than I anticipated...
*/
if (allow_other_keys) {
/* in CL: (defun hi (&key (a 1) &allow-other-keys) a) (hi :b :a :a 3) -> 3
* in s7: (define* (hi (a 1) :allow-other-keys) a) (hi :b :a :a 3) -> 3
*/
lx = cddr(lx);
} else {
if (!sc->accept_all_keyword_arguments)
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"~A: unknown key: ~S in ~S",
25),
closure_name(sc,
code),
lx, args)));
slot_set_value(slot, car_lx);
set_checked_slot(slot);
lx = cdr(lx);
cx = cdr(cx);
slot = next_slot(slot);
}
continue;
}
lx = cddr(lx);
}
slot = next_slot(slot);
} else { /* not a key/value pair */
if (is_checked_slot(slot))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc, parameter_set_twice_string,
slot_symbol(slot), sc->args)));
set_checked_slot(slot);
slot_set_value(slot, car(lx));
slot = next_slot(slot);
lx = cdr(lx);
}
cx = cdr(cx);
}
}
/* (let () (define* (hi (a 1) :allow-other-keys) a) (hi :a 2 32)) -> 'error */
/* (let () (define* (f (a :b)) a) (list (f) (f 1) (f :c) (f :a :c) (f :a 1) (f))) -> 'error */
/* check for trailing args with no :rest arg */
if (is_not_null(lx)) {
if ((is_not_null(cx)) || (zx == sc->key_rest_symbol)) {
if (is_symbol(cx)) {
if ((is_keyword(car(lx))) &&
(is_pair(cdr(lx))) && (keyword_symbol(car(lx)) == cx))
return (s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc,
wrap_string(sc,
"can't set rest argument ~S to ~S via keyword",
44), cx,
cadr(lx))));
slot_set_value(slot, 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, too_many_arguments_string,
closure_name(sc, code), args)));
/* 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,
wrap_string(sc,
"~A: not a key/value pair: ~S",
28),
closure_name(sc, code),
lx)));
slot =
symbol_to_local_slot(sc, keyword_symbol(car(lx)),
sc->curlet);
if ((is_slot(slot)) && (is_checked_slot(slot)))
return (s7_error
(sc, sc->wrong_type_arg_symbol,
set_elist_3(sc, parameter_set_twice_string,
slot_symbol(slot), sc->args)));
lx = cddr(lx);
}
}
}
return (sc->nil);
}
static inline goto_t lambda_star_default(s7_scheme * sc)
{
while (true) {
s7_pointer z = sc->args;
#if S7_DEBUGGING
if ((z) && (!is_slot(z)))
fprintf(stderr, "%s: z is %s\n", __func__,
s7_type_names[unchecked_type(z)]);
#endif
if (tis_slot(z)) {
if ((slot_value(z) == sc->undefined) && /* trouble: (lambda* ((e #<undefined>))...) */
(slot_has_expression(z)) && /* if default val is not a pair or a symbol, this is false */
(!is_checked_slot(z))) {
s7_pointer val = slot_expression(z);
if (is_symbol(val)) {
slot_set_value(z, lookup_checked(sc, val));
if (slot_value(z) == sc->undefined) {
/* the current environment here contains the function parameters which
* defaulted to #<undefined> (or maybe #<unused>?) earlier in apply_*_closure_star_1,
* so (define (f f) (define* (f (f f)) f) (f)) (f 0) looks for the
* default f, finds itself currently undefined, and raises an error!
* So, before claiming it is unbound, we need to check outlet as well.
* But in the case above, the inner define* shadows the caller's
* parameter before checking the default arg values, so the default f
* refers to the define* -- I'm not sure this is a bug. It means
* that (define* (f (a f)) a) returns f: (equal? f (f)) -> #t, so
* any outer f needs an extra let and endless outlets:
* (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3
* We want the shadowing once the define* is done, so the current mess is simplest.
*/
slot_set_value(z,
s7_symbol_local_value(sc, val,
let_outlet
(sc->curlet)));
if (slot_value(z) == sc->undefined)
eval_error(sc,
"lambda* defaults: ~A is unbound",
31, slot_symbol(z));
}
} else if (!is_pair(val))
slot_set_value(z, val);
else 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(sc, "lambda* default: ~A is messed up",
32, val);
slot_set_value(z, cadr(val));
} else {
push_stack_direct(sc, OP_LAMBDA_STAR_DEFAULT);
sc->code = val;
return (goto_eval);
}
}
sc->args = next_slot(z);
} else
break;
}
sc->args = sc->nil;
return (fall_through);
}
static bool op_lambda_star_default(s7_scheme * sc)
{
/* sc->args is the current let slots position, sc->value is the default expression's value */
if (is_multiple_value(sc->value))
eval_error(sc, "lambda*: argument default value can't be ~S", 43,
set_ulist_1(sc, sc->values_symbol, sc->value));
slot_set_value(sc->args, sc->value);
sc->args = next_slot(sc->args);
if (lambda_star_default(sc) == goto_eval)
return (true);
pop_stack_no_op(sc);
sc->code = T_Pair(closure_body(sc->code));
return (false);
}
static inline bool set_star_args(s7_scheme * sc, s7_pointer top)
{
lambda_star_set_args(sc); /* load up current arg vals */
sc->args = top;
if (is_slot(sc->args)) {
/* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */
push_stack_direct(sc, OP_GC_PROTECT);
if (lambda_star_default(sc) == goto_eval)
return (true); /* else fall_through */
pop_stack_no_op(sc); /* get original args and code back */
}
sc->code = closure_body(sc->code);
return (false);
}
static bool apply_safe_closure_star_1(s7_scheme * sc)
{ /* -------- define* (lambda*) -------- */
s7_pointer z;
/* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */
set_curlet(sc, closure_let(sc->code));
if (has_no_defaults(sc->code)) {
for (z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) {
clear_checked_slot(z);
slot_set_value(z, sc->F);
}
if (!is_null(sc->args))
lambda_star_set_args(sc); /* load up current arg vals */
sc->code = closure_body(sc->code);
return (false); /* goto BEGIN */
}
for (z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) {
clear_checked_slot(z);
slot_set_value(z,
(slot_defaults(z)) ? sc->undefined :
slot_expression(z));
}
return (set_star_args(sc, slot_pending_value(let_slots(sc->curlet))));
}
static bool apply_unsafe_closure_star_1(s7_scheme * sc)
{
s7_pointer z, val, top = sc->nil;
for (z = closure_args(sc->code); is_pair(z); z = cdr(z)) {
s7_pointer car_z = car(z);
if (is_pair(car_z)) { /* arg has a default value */
s7_pointer slot;
val = cadr(car_z);
if ((!is_pair(val)) && (!is_symbol(val)))
slot = add_slot_checked(sc, sc->curlet, car(car_z), val);
else {
add_slot(sc, sc->curlet, car(car_z), sc->undefined);
slot = let_slots(sc->curlet);
slot_set_expression(slot, val);
}
if (is_null(top))
top = slot;
} else if (!is_keyword(car_z))
add_slot(sc, sc->curlet, car_z, sc->F);
else if (car_z == sc->key_rest_symbol) { /* else it's :allow-other-keys? */
set_is_rest_slot(add_slot_checked
(sc, sc->curlet, cadr(z), sc->nil));
z = cdr(z);
}
}
if (is_symbol(z))
set_is_rest_slot(add_slot_checked(sc, sc->curlet, z, sc->nil)); /* set up rest arg */
let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet)));
return (set_star_args(sc, top));
}
static void apply_macro_star_1(s7_scheme * sc)
{
/* here the defaults (if any) are not evalled, and there is not existing let */
s7_pointer p;
for (p = closure_args(sc->code); is_pair(p); p = cdr(p)) {
s7_pointer par = car(p);
if (is_pair(par))
add_slot_checked(sc, sc->curlet, car(par), cadr(par));
else if (!is_keyword(par))
add_slot_checked(sc, sc->curlet, par, sc->F);
else if (par == sc->key_rest_symbol) {
set_is_rest_slot(add_slot_checked
(sc, sc->curlet, cadr(p), sc->nil));
p = cdr(p);
}
}
if (is_symbol(p))
set_is_rest_slot(add_slot_checked(sc, sc->curlet, p, sc->nil));
let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet)));
lambda_star_set_args(sc);
sc->code = T_Pair(closure_body(sc->code));
}
static void apply_macro(s7_scheme * sc)
{
/* this is not from the reader, so treat expansions here as normal macros */
check_stack_size(sc);
push_stack_op_let(sc, OP_EVAL_MACRO);
sc->curlet = make_let(sc, closure_let(sc->code)); /* closure_let -> sc->curlet, sc->code is the macro */
transfer_macro_info(sc, sc->code);
}
static void apply_bacro(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_op_let(sc, OP_EVAL_MACRO);
sc->curlet = make_let(sc, sc->curlet); /* like let* -- we'll be adding macro args, so might as well sequester things here */
transfer_macro_info(sc, sc->code);
}
static void apply_macro_star(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_op_let(sc, OP_EVAL_MACRO);
sc->curlet = make_let(sc, closure_let(sc->code));
transfer_macro_info(sc, sc->code);
apply_macro_star_1(sc);
}
static void apply_bacro_star(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_op_let(sc, OP_EVAL_MACRO);
sc->curlet = make_let(sc, sc->curlet);
transfer_macro_info(sc, sc->code);
apply_macro_star_1(sc);
}
static void apply_closure(s7_scheme * sc)
{
/* we can get safe_closures here, but can't easily determine whether we have the expected saved funclet -- see ~/old/safe-closure-s7.c */
check_stack_size(sc);
sc->curlet = make_let(sc, closure_let(sc->code));
}
static bool apply_closure_star(s7_scheme * sc)
{
if (is_safe_closure(sc->code))
return (apply_safe_closure_star_1(sc));
check_stack_size(sc);
sc->curlet = make_let_slowly(sc, closure_let(sc->code));
return (apply_unsafe_closure_star_1(sc));
}
static Inline s7_pointer op_safe_closure_star_a1(s7_scheme * sc,
s7_pointer code)
{
s7_pointer val, func = opt1_lambda(code);
val = fx_call(sc, cdr(code));
if ((is_keyword(val)) && (!sc->accept_all_keyword_arguments))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"~A: keyword argument's value is missing: ~S in ~S",
49), closure_name(sc, func), val,
sc->args));
sc->curlet = update_let_with_slot(sc, closure_let(func), val);
sc->code = T_Pair(closure_body(func));
return (func);
}
static void op_safe_closure_star_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer p, func;
func = op_safe_closure_star_a1(sc, code);
p = cdr(closure_args(func));
if (is_pair(p)) {
s7_pointer x;
for (x = next_slot(let_slots(closure_let(func))); is_pair(p);
p = cdr(p), x = next_slot(x)) {
if (is_pair(car(p))) {
s7_pointer 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(slot_symbol(x), let_id(sc->curlet), x);
}
}
}
static void op_safe_closure_star_ka(s7_scheme * sc, s7_pointer code)
{
s7_pointer func = opt1_lambda(code);
/* two args, but k=arg key, key has been checked. no trailing pars */
sc->curlet =
update_let_with_slot(sc, closure_let(func),
fx_call(sc, cddr(code)));
sc->code = T_Pair(closure_body(func));
}
static void op_safe_closure_star_aa(s7_scheme * sc, s7_pointer code)
{
/* here closure_arity == 2 and we have 2 args and those args' defaults are simple (no eval or lookup needed) */
s7_pointer arg1, arg2, func = opt1_lambda(code);
arg1 = fx_call(sc, cdr(code));
sc->w = arg1; /* weak GC protection */
arg2 = fx_call(sc, cddr(code));
if (is_keyword(arg1)) {
if (keyword_symbol(arg1) ==
slot_symbol(let_slots(closure_let(func)))) {
arg1 = arg2;
arg2 = cadr(closure_args(func));
if (is_pair(arg2))
arg2 = (is_pair(cadr(arg2))) ? cadadr(arg2) : cadr(arg2);
else
arg2 = sc->F;
} else
if (keyword_symbol(arg1) ==
slot_symbol(next_slot(let_slots(closure_let(func))))) {
arg1 = car(closure_args(func));
if (is_pair(arg1))
arg1 = (is_pair(cadr(arg1))) ? cadadr(arg1) : cadr(arg1);
else
arg1 = sc->F;
} else if (!sc->accept_all_keyword_arguments)
s7_error(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "~A: unknown keyword argument: ~S in ~S", 38), closure_name(sc, func), arg1, code)); /* arg1 is already the value */
} else if ((is_keyword(arg2)) && (!sc->accept_all_keyword_arguments))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"~A: keyword argument's value is missing: ~S in ~S",
49), closure_name(sc, func), arg2,
code));
sc->curlet =
update_let_with_two_slots(sc, closure_let(func), arg1, arg2);
sc->code = T_Pair(closure_body(func));
}
#define call_lambda_star(sc) do {sc->code = opt1_lambda(code); target = apply_safe_closure_star_1(sc); clear_list_in_use(arglist);} while (0)
static bool op_safe_closure_star_aaa(s7_scheme * sc, s7_pointer code)
{
s7_pointer p, arg1, arg2, arg3, func = opt1_lambda(code);
arg1 = fx_call(sc, cdr(code));
sc->w = arg1; /* weak GC protection */
arg2 = fx_call(sc, cddr(code));
sc->v = arg2;
arg3 = fx_call(sc, cdddr(code));
if ((is_keyword(arg1)) || (is_keyword(arg2)) || (is_keyword(arg3))) {
bool target;
s7_pointer arglist;
sc->args = make_safe_list(sc, 3);
arglist = sc->args;
set_car(sc->args, arg1);
set_car(cdr(sc->args), arg2);
set_car(cddr(sc->args), arg3);
call_lambda_star(sc); /* this clears list_in_use, sets target */
return (target);
}
sc->curlet =
update_let_with_three_slots(sc, closure_let(func), arg1, arg2,
arg3);
p = T_Pair(closure_body(func));
if (is_pair(cdr(p)))
push_stack_no_args(sc, sc->begin_op, cdr(p));
sc->code = car(p);
return (true);
}
static bool op_safe_closure_star_na_0(s7_scheme * sc, s7_pointer code)
{
sc->args = sc->nil;
sc->code = opt1_lambda(code);
return (apply_safe_closure_star_1(sc));
}
static bool op_safe_closure_star_na_1(s7_scheme * sc, s7_pointer code)
{
bool target;
s7_pointer arglist;
sc->args = safe_list_1(sc);
arglist = sc->args;
set_car(sc->args, fx_call(sc, cdr(code)));
call_lambda_star(sc); /* this clears list_in_use, sets target */
return (target);
}
static bool op_safe_closure_star_na_2(s7_scheme * sc, s7_pointer code)
{
bool target;
s7_pointer arglist, p;
sc->args = safe_list_2(sc);
arglist = sc->args;
set_car(sc->args, fx_call(sc, cdr(code)));
p = cddr(code);
set_car(cdr(sc->args), fx_call(sc, p));
call_lambda_star(sc); /* this clears list_in_use, sets target */
return (target);
}
static Inline bool op_safe_closure_star_na(s7_scheme * sc, s7_pointer code)
{
s7_pointer old_args, p, arglist;
bool target;
sc->args = safe_list_if_possible(sc, integer(opt3_arglen(cdr(code))));
arglist = sc->args;
for (p = sc->args, old_args = cdr(code); is_pair(p);
p = cdr(p), old_args = cdr(old_args))
set_car(p, fx_call(sc, old_args));
call_lambda_star(sc); /* this clears list_in_use, sets target */
return (target);
}
static void op_closure_star_ka(s7_scheme * sc, s7_pointer code)
{
s7_pointer val, p, func;
val = fx_call(sc, cddr(code));
func = opt1_lambda(code);
p = car(closure_args(func));
sc->curlet =
make_let_with_slot(sc, closure_let(func),
(is_pair(p)) ? car(p) : p, val);
sc->code = T_Pair(closure_body(func));
}
static void op_closure_star_a(s7_scheme * sc, s7_pointer code)
{
s7_pointer val, p, func;
val = fx_call(sc, cdr(code));
if ((is_keyword(val)) && (!sc->accept_all_keyword_arguments))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc,
wrap_string(sc,
"~A: keyword argument's value is missing: ~S in ~S",
49), closure_name(sc,
opt1_lambda
(code)), val,
code));
func = opt1_lambda(code);
p = car(closure_args(func));
sc->curlet =
make_let_with_slot(sc, closure_let(func),
(is_pair(p)) ? car(p) : p, val);
if (closure_star_arity_to_int(sc, func) > 1) {
s7_pointer last_slot = let_slots(sc->curlet);
s7_int id = let_id(sc->curlet);
for (p = cdr(closure_args(func)); is_pair(p); p = cdr(p)) {
s7_pointer par = car(p);
if (is_pair(par))
last_slot = add_slot_at_end(sc, id, last_slot, car(par), (is_pair(cadr(par))) ? cadadr(par) : cadr(par)); /* possible quoted list as default value */
else
last_slot = add_slot_at_end(sc, id, last_slot, par, sc->F);
}
}
sc->code = T_Pair(closure_body(func));
}
static inline bool op_closure_star_na(s7_scheme * sc, s7_pointer code)
{
/* check_stack_size(sc); */
if (is_pair(cdr(code))) {
s7_pointer old_args, p;
sc->w = cdr(code); /* args aren't evaluated yet */
sc->args = make_list(sc, integer(opt3_arglen(cdr(code))), sc->F);
for (p = sc->args, old_args = sc->w; is_pair(p);
p = cdr(p), old_args = cdr(old_args))
set_car(p, fx_call(sc, old_args));
sc->w = sc->nil;
} else
sc->args = sc->nil;
sc->code = opt1_lambda(code);
sc->curlet = make_let(sc, closure_let(sc->code));
return (apply_unsafe_closure_star_1(sc));
}
static goto_t op_define1(s7_scheme * sc)
{
/* sc->code is the symbol being defined, sc->value is its value
* if sc->value is a closure, car is of the form ((args...) body...)
* it's not possible to expand and replace macros at this point without evaluating
* the body. Just as examples, say we have a macro "mac",
* (define (hi) (call/cc (lambda (mac) (mac 1))))
* (define (hi) (quote (mac 1))) or macroexpand etc
* (define (hi mac) (mac 1)) assuming mac here is a function passed as an arg, etc...
* the immutable constant check needs to wait until we have the actual new value because
* we want to ignore the rebinding (not raise an error) if it is the existing value.
* This happens when we reload a file that calls define-constant.
*/
if (is_multiple_value(sc->value)) /* (define x (values 1 2)) */
eval_error(sc, "define: more than one value: ~S", 31, sc->value);
if (is_constant_symbol(sc, sc->code)) { /* (define pi 3) or (define (pi a) a) */
s7_pointer x;
x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) :
lookup_slot_from(sc->code, sc->curlet);
/* local_slot can be free even if sc->code is immutable (local constant now defunct) */
if (!((is_slot(x)) && (type(sc->value) == unchecked_type(slot_value(x))) && (s7_is_equivalent(sc, sc->value, slot_value(x))))) /* if value is unchanged, just ignore this (re)definition */
eval_error(sc, "define: ~S is immutable", 23, sc->code); /* can't use s7_is_equal because value might be NaN, etc */
}
if (symbol_has_setter(sc->code)) {
s7_pointer x;
x = lookup_slot_from(sc->code, sc->curlet);
if ((is_slot(x)) && (slot_has_setter(x))) {
sc->value =
bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER,
sc->code, sc->value);
if (sc->value == sc->no_value)
return (goto_apply);
/* if all goes well, OP_DEFINE_WITH_SETTER will jump to DEFINE2 */
}
}
return (fall_through);
}
static void set_let_file_and_line(s7_scheme * sc, s7_pointer new_let,
s7_pointer new_func)
{
if (port_file(current_input_port(sc)) != stdin) {
/* unbound_variable will be called if *function* is encountered, and will return this info as if *function* had some meaning */
if ((is_pair(closure_args(new_func))) &&
(has_location(closure_args(new_func)))) {
let_set_file(new_let,
pair_file_number(closure_args(new_func)));
let_set_line(new_let,
pair_line_number(closure_args(new_func)));
} else if (has_location(closure_body(new_func))) {
let_set_file(new_let,
pair_file_number(closure_body(new_func)));
let_set_line(new_let,
pair_line_number(closure_body(new_func)));
} else {
s7_pointer p;
for (p = cdr(closure_body(new_func)); is_pair(p); p = cdr(p))
if ((is_pair(car(p))) && (has_location(car(p))))
break;
let_set_file(new_let,
(is_pair(p)) ? pair_file_number(car(p)) :
port_file_number(current_input_port(sc)));
let_set_line(new_let,
(is_pair(p)) ? pair_line_number(car(p)) :
port_line_number(current_input_port(sc)));
}
set_has_let_file(new_let);
} else {
let_set_file(new_let, 0);
let_set_line(new_let, 0);
clear_has_let_file(new_let);
}
}
static void op_define_with_setter(s7_scheme * sc)
{
s7_pointer code = sc->code;
if ((is_immutable(sc->curlet)) && (is_let(sc->curlet))) /* not () */
s7_error(sc, sc->immutable_error_symbol,
set_elist_2(sc,
wrap_string(sc,
"can't define ~S: curlet is immutable",
36), code));
if ((is_any_closure(sc->value)) && ((!(is_let(closure_let(sc->value)))) || (!(is_funclet(closure_let(sc->value)))))) { /* otherwise it's (define f2 f1) or something similar */
s7_pointer new_func = sc->value, new_let;
if (is_safe_closure_body(closure_body(new_func))) {
set_safe_closure(new_func);
if (is_very_safe_closure_body(closure_body(new_func)))
set_very_safe_closure(new_func);
}
new_let = make_funclet(sc, new_func, code, closure_let(new_func));
/* this should happen only if the closure* default values do not refer in any way to
* the enclosing environment (else we can accidentally shadow something that happens
* to share an argument name that is being used as a default value -- kinda dumb!).
* I think I'll check this before setting the safe_closure bit.
*/
set_let_file_and_line(sc, new_let, new_func);
/* add the newly defined thing to the current environment */
if (is_let(sc->curlet)) {
if (let_id(sc->curlet) < symbol_id(code)) { /* we're adding a later-bound symbol to an old let (?) */
s7_pointer slot;
sc->let_number++; /* dummy let, force symbol lookup */
for (slot = let_slots(sc->curlet); tis_slot(slot);
slot = next_slot(slot))
if (slot_symbol(slot) == code) {
if (is_immutable(slot))
eval_error(sc,
"define ~S, but it is immutable",
30, code);
slot_set_value(slot, new_func);
symbol_set_local_slot(code, sc->let_number, slot);
set_local(code);
sc->value = new_func; /* probably not needed? */
return;
}
new_cell_no_check(sc, slot, T_SLOT);
slot_set_symbol_and_value(slot, code, new_func);
symbol_set_local_slot(code, sc->let_number, slot);
slot_set_next(slot, let_slots(sc->curlet));
let_set_slots(sc->curlet, slot);
} else
add_slot(sc, sc->curlet, code, new_func);
set_local(code);
} else {
if ((is_slot(global_slot(code))) &&
(is_immutable(global_slot(code)))) {
s7_pointer old_symbol = code, old_value =
global_value(code);
if ((type(old_value) != type(new_func)) || (!s7_is_equivalent(sc, old_value, new_func))) /* if value is unchanged, just ignore this (re)definition */
eval_error(sc, "define ~S, but it is immutable", 30,
old_symbol);
}
s7_make_slot(sc, sc->curlet, code, new_func);
}
sc->value = new_func; /* 25-Jul-14 so define returns the value not the name */
} else {
s7_pointer lx;
lx = symbol_to_local_slot(sc, code, sc->curlet); /* add the newly defined thing to the current environment */
if (is_slot(lx)) {
if (is_immutable(lx)) {
s7_pointer old_symbol = code, old_value = slot_value(lx);
if ((type(old_value) != type(sc->value)) || (!s7_is_equivalent(sc, old_value, sc->value))) /* if value is unchanged, just ignore this (re)definition */
eval_error(sc, "define ~S, but it is immutable", 30,
old_symbol);
}
slot_set_value_with_hook(lx, sc->value);
symbol_increment_ctr(code);
} else
s7_make_slot(sc, sc->curlet, code, sc->value);
if ((is_any_macro(sc->value)) && (!is_c_macro(sc->value))) {
set_pair_macro(closure_body(sc->value), code);
set_has_pair_macro(sc->value);
}
}
}
/* -------------------------------- eval -------------------------------- */
static void check_for_cyclic_code(s7_scheme * sc, s7_pointer code)
{
if (tree_is_cyclic(sc, code))
eval_error(sc, "attempt to evaluate a circular list: ~A", 39,
code);
resize_stack(sc); /* we've already checked that resize_stack is needed */
}
static void op_thunk(s7_scheme * sc)
{
s7_pointer p = opt1_lambda(sc->code);
check_stack_size(sc); /* full-test (toward end, grows to 524288!) */
/* 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))
*/
sc->curlet = make_let(sc, closure_let(p));
p = T_Pair(closure_body(p));
if (is_pair(cdr(p)))
push_stack_no_args(sc, sc->begin_op, cdr(p));
sc->code = car(p);
}
static void op_thunk_any(s7_scheme * sc)
{
s7_pointer p = opt1_lambda(sc->code);
sc->curlet =
make_let_with_slot(sc, closure_let(p), closure_args(p), sc->nil);
sc->code = closure_body(p);
}
static void op_safe_thunk(s7_scheme * sc)
{ /* no let needed */
s7_pointer p = opt1_lambda(sc->code);
sc->curlet = closure_let(p);
p = T_Pair(closure_body(p));
if (is_pair(cdr(p)))
push_stack_no_args(sc, sc->begin_op, cdr(p));
sc->code = car(p);
}
static void op_closure_s(s7_scheme * sc)
{
s7_pointer p = opt1_lambda(sc->code);
check_stack_size(sc);
sc->curlet =
make_let_with_slot(sc, closure_let(p), car(closure_args(p)),
lookup(sc, opt2_sym(sc->code)));
p = T_Pair(closure_body(p));
if (is_pair(cdr(p)))
push_stack_no_args(sc, sc->begin_op, cdr(p));
sc->code = car(p);
}
static inline void op_closure_s_o(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
make_let_with_slot(sc, closure_let(f), car(closure_args(f)),
lookup(sc, opt2_sym(sc->code)));
sc->code = car(closure_body(f));
}
static void op_safe_closure_s(s7_scheme * sc)
{
s7_pointer p = opt1_lambda(sc->code);
sc->curlet =
update_let_with_slot(sc, closure_let(p),
lookup(sc, opt2_sym(sc->code)));
p = T_Pair(closure_body(p));
if (is_pair(cdr(p)))
push_stack_no_args(sc, sc->begin_op, cdr(p));
sc->code = car(p);
}
static void op_safe_closure_s_o(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_slot(sc, closure_let(f),
lookup(sc, opt2_sym(sc->code)));
sc->code = car(closure_body(f));
}
static void op_safe_closure_p(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_no_args(sc, OP_SAFE_CLOSURE_P_1, opt1_lambda(sc->code));
sc->code = cadr(sc->code);
}
static void op_safe_closure_p_1(s7_scheme * sc)
{
sc->curlet =
update_let_with_slot(sc, closure_let(sc->code), sc->value);
sc->code = T_Pair(closure_body(sc->code));
}
static void op_safe_closure_p_a(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_no_args(sc, OP_SAFE_CLOSURE_P_A_1, opt1_lambda(sc->code));
sc->code = cadr(sc->code);
}
static void op_safe_closure_p_a_1(s7_scheme * sc)
{
sc->curlet =
update_let_with_slot(sc, closure_let(sc->code), sc->value);
sc->value = fx_call(sc, closure_body(sc->code));
}
static Inline void op_closure_a(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->value = fx_call(sc, cdr(sc->code));
sc->curlet =
make_let_with_slot(sc, closure_let(f), car(closure_args(f)),
sc->value);
sc->code = T_Pair(closure_body(f));
}
static void op_safe_closure_3s(s7_scheme * sc)
{
s7_pointer args = cddr(sc->code), f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_three_slots(sc, closure_let(f),
lookup(sc, cadr(sc->code)), lookup(sc,
car
(args)),
lookup(sc, cadr(args)));
sc->code = T_Pair(closure_body(f));
}
static void op_safe_closure_ssa(s7_scheme * sc)
{ /* ssa_a is hit once, but is only about 3/4% faster -- there's the fx overhead, etc */
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_three_slots(sc, closure_let(f),
lookup(sc, car(args)), lookup(sc,
cadr
(args)),
fx_call(sc, cddr(args)));
sc->code = T_Pair(closure_body(f));
}
static void op_safe_closure_saa(s7_scheme * sc)
{
s7_pointer arg2, f = opt1_lambda(sc->code), args = cddr(sc->code);
arg2 = lookup(sc, cadr(sc->code)); /* I don't see fx_t|u here? */
sc->code = fx_call(sc, args);
sc->curlet =
update_let_with_three_slots(sc, closure_let(f), arg2, sc->code,
fx_call(sc, cdr(args)));
sc->code = T_Pair(closure_body(f));
}
static void op_safe_closure_agg(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_three_slots(sc, closure_let(f), fx_call(sc, args),
fx_call(sc, cdr(args)), fx_call(sc,
cddr
(args)));
sc->code = T_Pair(closure_body(f));
}
static void op_closure_p(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_no_args(sc, OP_CLOSURE_P_1, opt1_lambda(sc->code));
sc->code = cadr(sc->code);
}
static void op_closure_p_1(s7_scheme * sc)
{
sc->curlet =
make_let_with_slot(sc, closure_let(sc->code),
car(closure_args(sc->code)), sc->value);
sc->code = T_Pair(closure_body(sc->code));
}
static void op_safe_closure_a(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_slot(sc, closure_let(f),
fx_call(sc, cdr(sc->code)));
sc->code = T_Pair(closure_body(f));
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
}
static void op_safe_closure_a_o(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_slot(sc, closure_let(f),
fx_call(sc, cdr(sc->code)));
sc->code = car(closure_body(f));
}
static void op_closure_ap(s7_scheme * sc)
{
s7_pointer code = sc->code;
sc->args = fx_call(sc, cdr(code));
/* (hook-push (undo-hook ind 0) (lambda (hook) (set! u0 #t))) -> #<unused>
* g_undo_hook calls s7_eval_c_string so it obviously should be declared unsafe!
*/
push_stack(sc, OP_CLOSURE_AP_1, opt1_lambda(sc->code), sc->args);
sc->code = caddr(code);
}
static void op_closure_ap_1(s7_scheme * sc)
{
/* sc->value is presumably the "P" argument value, "A" is sc->args->sc->code above (sc->args here is opt1_lambda(original sc->code)) */
sc->curlet =
make_let_with_two_slots(sc, closure_let(sc->args),
car(closure_args(sc->args)), sc->code,
cadr(closure_args(sc->args)), sc->value);
sc->code = T_Pair(closure_body(sc->args));
}
static void op_closure_pa(s7_scheme * sc)
{
s7_pointer code = sc->code;
sc->args = fx_call(sc, cddr(code));
push_stack(sc, OP_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code)); /* "p" can be self-call changing func locally! so pass opt1_lambda(sc->code), not sc->code */
sc->code = cadr(code);
}
static void op_closure_pa_1(s7_scheme * sc)
{
sc->curlet =
make_let_with_two_slots(sc, closure_let(sc->code),
car(closure_args(sc->code)), sc->value,
cadr(closure_args(sc->code)), sc->args);
sc->code = T_Pair(closure_body(sc->code));
}
static void op_closure_pp(s7_scheme * sc)
{
check_stack_size(sc);
push_stack(sc, OP_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code);
sc->code = cadr(sc->code);
}
static void op_closure_pp_1(s7_scheme * sc)
{
push_stack(sc, OP_CLOSURE_AP_1, sc->args, sc->value);
sc->code = caddr(sc->code);
}
static void op_safe_closure_ap(s7_scheme * sc)
{
check_stack_size(sc);
sc->args = fx_call(sc, cdr(sc->code));
push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->args, opt1_lambda(sc->code));
sc->code = caddr(sc->code);
}
static void op_safe_closure_ap_1(s7_scheme * sc)
{
sc->curlet =
update_let_with_two_slots(sc, closure_let(sc->code), sc->args,
sc->value);
sc->code = T_Pair(closure_body(sc->code));
}
static void op_safe_closure_pa(s7_scheme * sc)
{
check_stack_size(sc);
sc->args = fx_call(sc, cddr(sc->code));
push_stack(sc, OP_SAFE_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code));
sc->code = cadr(sc->code);
}
static void op_safe_closure_pa_1(s7_scheme * sc)
{
sc->curlet =
update_let_with_two_slots(sc, closure_let(sc->code), sc->value,
sc->args);
sc->code = T_Pair(closure_body(sc->code));
}
static void op_safe_closure_pp(s7_scheme * sc)
{
check_stack_size(sc);
push_stack(sc, OP_SAFE_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code);
sc->code = cadr(sc->code);
}
static void op_safe_closure_pp_1(s7_scheme * sc)
{
push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->args);
sc->code = caddr(sc->code);
}
static void op_any_closure_3p(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code);
if (has_fx(p)) {
sc->args = fx_call(sc, p);
p = cdr(p);
if (has_fx(p)) {
sc->stack_end[0] = sc->code; /* push_stack_direct(sc, OP_ANY_CLOSURE_3P_3) here but trying to be too clever? */
sc->stack_end[2] = sc->args; /* stack[args] == arg1 to closure) */
sc->stack_end[3] = (s7_pointer) (OP_ANY_CLOSURE_3P_3);
sc->stack_end += 4;
stack_protected3(sc) = fx_call(sc, p); /* (i.e. stack[curlet] == arg2 of closure), fx_call might push_stack gc_protect etc, so push_stack via +4 before it */
sc->code = cadr(p);
} else {
push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */
sc->code = car(p);
}
} else {
push_stack_no_args(sc, OP_ANY_CLOSURE_3P_1, sc->code);
sc->code = car(p);
}
}
static bool closure_3p_end(s7_scheme * sc, s7_pointer p)
{
/* sc->args == arg1, sc->value == arg2 */
if (has_fx(p)) {
s7_pointer func = opt1_lambda(sc->code), arg2 = sc->value, arg3;
arg3 = fx_call(sc, p);
if (is_safe_closure(func))
sc->curlet =
update_let_with_three_slots(sc, closure_let(func),
sc->args, arg2, arg3);
else {
sc->value = arg2;
sc->code = arg3;
make_let_with_three_slots(sc, func, sc->args, arg2, arg3);
}
sc->code = T_Pair(closure_body(func));
return (true);
}
push_stack_direct(sc, OP_ANY_CLOSURE_3P_3);
stack_protected3(sc) = sc->value; /* arg2 == curlet stack loc */
sc->code = car(p);
return (false);
}
static bool op_any_closure_3p_1(s7_scheme * sc)
{
s7_pointer p;
sc->args = sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */
p = cddr(sc->code);
if (has_fx(p)) {
sc->value = fx_call(sc, p);
return (closure_3p_end(sc, cdr(p)));
}
push_stack_direct(sc, OP_ANY_CLOSURE_3P_2);
sc->code = car(p);
return (false);
}
static bool op_any_closure_3p_2(s7_scheme * sc)
{
return (closure_3p_end(sc, cdddr(sc->code)));
}
static void op_any_closure_3p_3(s7_scheme * sc)
{
/* display(obj) will not work here because sc->curlet is being used as arg2 of the closure3 */
s7_pointer func; /* incoming args (from pop_stack): sc->args, sc->curlet, and sc->value from last evaluation */
func = opt1_lambda(sc->code);
if (is_safe_closure(func))
sc->curlet =
update_let_with_three_slots(sc, closure_let(func), sc->args,
sc->curlet, sc->value);
else
make_let_with_three_slots(sc, func, sc->args, sc->curlet,
sc->value);
sc->code = T_Pair(closure_body(func));
}
static void op_any_closure_4p(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code);
check_stack_size(sc);
if (has_fx(p)) {
gc_protect_via_stack(sc, fx_call(sc, p));
p = cdr(p);
if (has_fx(p)) {
stack_protected2(sc) = fx_call(sc, p);
p = cdr(p);
if (has_fx(p)) {
stack_protected3(sc) = fx_call(sc, p);
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4);
sc->code = cadr(p);
} else {
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3);
sc->code = car(p);
}
} else {
sc->stack_end[2] = sc->unused; /* copy_stack dangling pair */
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2);
sc->code = car(p);
}
} else {
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_1);
sc->code = car(p);
}
}
static bool closure_4p_end(s7_scheme * sc, s7_pointer p)
{
if (has_fx(p)) {
s7_pointer func = opt1_lambda(sc->code);
sc->args = fx_call(sc, p);
if (is_safe_closure(func))
sc->curlet =
update_let_with_four_slots(sc, closure_let(func),
stack_protected1(sc),
stack_protected2(sc),
stack_protected3(sc), sc->args);
else
make_let_with_four_slots(sc, func, stack_protected1(sc),
stack_protected2(sc),
stack_protected3(sc), sc->args);
sc->code = T_Pair(closure_body(func));
unstack(sc);
return (true);
}
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4);
sc->code = car(p);
return (false);
}
static bool op_any_closure_4p_1(s7_scheme * sc)
{
s7_pointer p = cddr(sc->code);
gc_protect_via_stack(sc, sc->value);
if (has_fx(p)) {
stack_protected2(sc) = fx_call(sc, p);
p = cdr(p);
if (has_fx(p)) {
stack_protected3(sc) = fx_call(sc, p);
return (closure_4p_end(sc, cdr(p)));
}
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3);
sc->code = car(p);
} else {
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2);
sc->code = car(p);
}
return (false);
}
static bool op_any_closure_4p_2(s7_scheme * sc)
{
s7_pointer p = cdddr(sc->code);
stack_protected2(sc) = sc->value;
if (has_fx(p)) {
stack_protected3(sc) = fx_call(sc, p);
return (closure_4p_end(sc, cdr(p)));
}
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3);
sc->code = car(p);
return (false);
}
static bool op_any_closure_4p_3(s7_scheme * sc)
{
stack_protected3(sc) = sc->value;
return (closure_4p_end(sc, cddddr(sc->code)));
}
static inline void op_any_closure_4p_4(s7_scheme * sc)
{
s7_pointer func = opt1_lambda(sc->code);
if (is_safe_closure(func))
sc->curlet =
update_let_with_four_slots(sc, closure_let(func),
stack_protected1(sc),
stack_protected2(sc),
stack_protected3(sc), sc->value);
else
make_let_with_four_slots(sc, func, stack_protected1(sc),
stack_protected2(sc),
stack_protected3(sc), sc->value);
sc->code = T_Pair(closure_body(func));
unstack(sc);
}
static void op_safe_closure_ss(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_two_slots(sc, closure_let(f),
lookup(sc, cadr(sc->code)), lookup(sc,
opt2_sym
(sc->code)));
sc->code = T_Pair(closure_body(f));
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
}
static void op_safe_closure_ss_o(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_two_slots(sc, closure_let(f),
lookup(sc, cadr(sc->code)), lookup(sc,
opt2_sym
(sc->code)));
sc->code = car(closure_body(f));
}
static inline void op_closure_ss(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
check_stack_size(sc);
sc->curlet =
make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)),
lookup(sc, cadr(sc->code)),
cadr(closure_args(f)), lookup(sc,
opt2_sym
(sc->code)));
sc->code = T_Pair(closure_body(f));
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
}
static inline void op_closure_ss_o(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)),
lookup(sc, cadr(sc->code)),
cadr(closure_args(f)), lookup(sc,
opt2_sym
(sc->code)));
sc->code = car(closure_body(f));
}
static void op_safe_closure_sc(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_two_slots(sc, closure_let(f),
lookup(sc, cadr(sc->code)),
opt2_con(sc->code));
sc->code = T_Pair(closure_body(f));
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
}
static void op_safe_closure_sc_o(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
sc->curlet =
update_let_with_two_slots(sc, closure_let(f),
lookup(sc, cadr(sc->code)),
opt2_con(sc->code));
sc->code = car(closure_body(f));
}
static void op_closure_sc(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
check_stack_size(sc);
sc->curlet =
make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)),
lookup(sc, cadr(sc->code)),
cadr(closure_args(f)), opt2_con(sc->code));
sc->code = T_Pair(closure_body(f));
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
}
static void op_closure_sc_o(s7_scheme * sc)
{
s7_pointer f = opt1_lambda(sc->code);
check_stack_size(sc);
sc->curlet =
make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)),
lookup(sc, cadr(sc->code)),
cadr(closure_args(f)), opt2_con(sc->code));
sc->code = car(closure_body(f));
}
#define if_pair_set_up_begin(Sc) if (is_pair(cdr(Sc->code))) {check_stack_size(Sc); push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code));} Sc->code = car(Sc->code);
static inline void op_closure_3s(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), v1;
v1 = lookup(sc, car(args));
args = cdr(args);
sc->code = opt1_lambda(sc->code);
make_let_with_three_slots(sc, sc->code, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */
sc->code = T_Pair(closure_body(sc->code));
if_pair_set_up_begin(sc);
}
static void op_closure_4s(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), v1, v2;
v1 = lookup(sc, car(args));
args = cdr(args);
v2 = lookup(sc, car(args));
args = cdr(args);
sc->code = opt1_lambda(sc->code);
make_let_with_four_slots(sc, sc->code, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */
sc->code = T_Pair(closure_body(sc->code));
if_pair_set_up_begin(sc);
}
static void op_safe_closure_aa(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code);
sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */
sc->curlet =
update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p),
sc->code);
p = T_Pair(closure_body(f));
/* check_stack_size(sc); *//* pretty-print if cycles=#f? */
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p)));
sc->code = car(p);
}
static inline void op_safe_closure_aa_o(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code);
sc->code = fx_call(sc, cdr(p));
sc->curlet =
update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p),
sc->code);
sc->code = car(closure_body(f));
}
static void op_closure_aa(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code);
sc->code = fx_call(sc, cdr(p));
sc->value = fx_call(sc, p);
sc->curlet =
make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)),
sc->value, cadr(closure_args(f)),
sc->code);
p = T_Pair(closure_body(f));
check_stack_size(sc);
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p)));
sc->code = car(p);
}
static Inline void op_closure_aa_o(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code);
sc->code = fx_call(sc, cdr(p));
sc->value = fx_call(sc, p);
sc->curlet =
make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)),
sc->value, cadr(closure_args(f)),
sc->code);
sc->code = car(closure_body(f));
}
static inline void op_closure_fa(s7_scheme * sc)
{
s7_pointer farg, new_clo, aarg, func, func_args, code = sc->code;
farg = opt2_pair(code); /* cdadr(code); */
aarg = fx_call(sc, cddr(code));
new_clo =
make_closure(sc, car(farg), cdr(farg),
T_CLOSURE | ((is_symbol(car(farg))) ? T_COPY_ARGS :
0), CLOSURE_ARITY_NOT_SET);
func = opt1_lambda(code); /* outer func */
func_args = closure_args(func);
sc->curlet =
make_let_with_two_slots(sc, closure_let(func), car(func_args),
new_clo, cadr(func_args), aarg);
sc->code = car(closure_body(func));
}
static void op_safe_closure_ns(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), let, x;
uint64_t id;
sc->code = opt1_lambda(sc->code);
id = ++sc->let_number;
let = closure_let(sc->code);
let_set_id(let, id);
for (x = let_slots(let); tis_slot(x);
x = next_slot(x), args = cdr(args)) {
slot_set_value(x, lookup(sc, car(args)));
symbol_set_local_slot(slot_symbol(x), id, x);
}
set_curlet(sc, let);
sc->code = closure_body(sc->code);
if (is_pair(cdr(sc->code)))
push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
sc->code = car(sc->code);
}
static void op_safe_closure_3a(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code);
sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */
sc->args = fx_call(sc, cddr(p)); /* is sc->args safe here? */
sc->curlet =
update_let_with_three_slots(sc, closure_let(f), fx_call(sc, p),
sc->code, sc->args);
p = closure_body(f);
if (is_pair(cdr(p)))
push_stack_no_args(sc, sc->begin_op, cdr(p));
sc->code = car(p);
}
static void op_safe_closure_na(s7_scheme * sc)
{
s7_pointer args, p, let, x, z;
uint64_t id;
sc->args =
safe_list_if_possible(sc, integer(opt3_arglen(cdr(sc->code))));
for (args = cdr(sc->code), p = sc->args; is_pair(args);
args = cdr(args), p = cdr(p))
set_car(p, fx_call(sc, args));
sc->code = opt1_lambda(sc->code);
id = ++sc->let_number;
let = closure_let(sc->code);
let_set_id(let, id);
for (x = let_slots(let), z = sc->args; tis_slot(x);
x = next_slot(x), z = cdr(z)) {
slot_set_value(x, car(z));
symbol_set_local_slot(slot_symbol(x), id, x);
}
clear_list_in_use(sc->args);
set_curlet(sc, let);
sc->code = closure_body(sc->code);
if (is_pair(cdr(sc->code)))
push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
sc->code = car(sc->code);
}
static Inline void op_closure_ns(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), p, e, last_slot;
s7_int id;
/* 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.
*/
sc->code = opt1_lambda(sc->code);
e = make_let(sc, closure_let(sc->code));
sc->z = e;
id = let_id(e);
p = closure_args(sc->code);
add_slot_unchecked(sc, e, car(p), lookup(sc, car(args)), id);
last_slot = let_slots(e);
for (p = cdr(p), args = cdr(args); is_pair(p);
p = cdr(p), args = cdr(args))
last_slot = add_slot_at_end(sc, id, last_slot, car(p), lookup(sc, car(args))); /* main such call in lt (fx_s is 1/2, this is 1/5 of all calls) */
set_curlet(sc, e);
sc->z = sc->nil;
sc->code = T_Pair(closure_body(sc->code));
if_pair_set_up_begin(sc);
}
static void op_closure_ass(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
make_let_with_three_slots(sc, f, fx_call(sc, args),
lookup(sc, cadr(args)), lookup(sc,
caddr(args)));
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
}
static void op_closure_aas(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
sc->z = fx_call(sc, args);
make_let_with_three_slots(sc, f, sc->z, fx_call(sc, cdr(args)),
lookup(sc, caddr(args)));
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
}
static void op_closure_saa(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
sc->z = fx_call(sc, cdr(args));
make_let_with_three_slots(sc, f, lookup(sc, car(args)), sc->z,
fx_call(sc, cddr(args)));
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
}
static void op_closure_asa(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
sc->z = fx_call(sc, args);
make_let_with_three_slots(sc, f, sc->z, lookup(sc, cadr(args)),
fx_call(sc, cddr(args)));
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
}
static void op_closure_sas(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
make_let_with_three_slots(sc, f, lookup(sc, car(args)),
fx_call(sc, cdr(args)), lookup(sc,
caddr(args)));
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
}
static void op_closure_3a(s7_scheme * sc)
{ /* if inlined, tlist -50 */
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cdr(args)));
make_let_with_three_slots(sc, f, stack_protected1(sc),
stack_protected2(sc), fx_call(sc,
cddr(args)));
unstack(sc);
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
}
static void op_closure_4a(s7_scheme * sc)
{ /* sass */
s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code);
gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cddr(args)));
args = cdr(args);
stack_protected3(sc) = fx_call(sc, args); /* [-3]=second */
make_let_with_four_slots(sc, f, stack_protected1(sc),
stack_protected3(sc), stack_protected2(sc),
fx_call(sc, cddr(args)));
unstack(sc);
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
}
static void op_closure_na(s7_scheme * sc)
{
s7_pointer e, exprs = cdr(sc->code), pars, func =
opt1_lambda(sc->code), slot, last_slot;
s7_int id;
e = make_let(sc, closure_let(func));
sc->z = e;
pars = closure_args(func);
sc->value = fx_call(sc, exprs);
new_cell_no_check(sc, last_slot, T_SLOT);
slot_set_symbol_and_value(last_slot, car(pars), sc->value);
slot_set_next(last_slot, let_slots(e)); /* i.e. slot_end */
let_set_slots(e, last_slot);
for (pars = cdr(pars), exprs = cdr(exprs); is_pair(pars);
pars = cdr(pars), exprs = cdr(exprs)) {
sc->value = fx_call(sc, exprs); /* before new_cell since it might call the GC */
new_cell(sc, slot, T_SLOT); /* args < GC_TRIGGER checked in optimizer, but we're calling fx_call? */
slot_set_symbol_and_value(slot, car(pars), sc->value);
/* setting up the let might use unrelated-but-same-name symbols, so wait to set the symbol ids */
slot_set_next(slot, slot_end(sc));
slot_set_next(last_slot, slot);
last_slot = slot;
}
set_curlet(sc, e);
sc->z = sc->nil;
let_set_id(e, ++sc->let_number);
for (id = let_id(e), slot = let_slots(e); tis_slot(slot);
slot = next_slot(slot)) {
symbol_set_local_slot(slot_symbol(slot), id, slot);
set_local(slot_symbol(slot));
}
sc->code = T_Pair(closure_body(func));
if_pair_set_up_begin(sc);
}
static bool check_closure_any(s7_scheme * sc)
{
/* can't use closure_is_fine -- (lambda args 1) and (lambda (name . args) 1) are both arity -1 for the internal arity checkers! */
if ((symbol_ctr(car(sc->code)) != 1) ||
(unchecked_local_value(car(sc->code)) !=
opt1_lambda_unchecked(sc->code))) {
s7_pointer f;
f = lookup_unexamined(sc, car(sc->code));
if ((f != opt1_lambda_unchecked(sc->code)) &&
((!f) ||
((typesflag(f) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE)
|| (!is_symbol(closure_args(f))))) {
sc->last_function = f;
return (false);
}
set_opt1_lambda(sc->code, f);
}
return (true);
}
static void op_any_closure_na(s7_scheme * sc)
{ /* for (lambda a ...) ? */
s7_pointer func, p, old_args = cdr(sc->code); /* args aren't evaluated yet */
s7_int num_args;
func = opt1_lambda(sc->code);
num_args = integer(opt3_arglen(old_args));
if (num_args == 1)
sc->args = ((is_safe_closure(func))
&& (!sc->debug_or_profile)) ? set_plist_1(sc,
fx_call(sc,
old_args))
: list_1(sc, sc->value = fx_call(sc, old_args));
else if (num_args == 2) {
gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */
sc->args = fx_call(sc, cdr(old_args));
sc->args = ((is_safe_closure(func))
&& (!sc->debug_or_profile)) ? set_plist_2(sc,
stack_protected1
(sc),
sc->args) :
list_2(sc, stack_protected1(sc), sc->args);
unstack(sc);
} else {
sc->args = make_list(sc, num_args, sc->F);
for (p = sc->args; is_pair(p);
p = cdr(p), old_args = cdr(old_args))
set_car(p, fx_call(sc, old_args));
}
sc->curlet =
make_let_with_slot(sc, closure_let(func), closure_args(func),
sc->args);
sc->code = T_Pair(closure_body(func));
}
/* -------- */
#if S7_DEBUGGING
#define TC_REC_SIZE NUM_OPS
#define TC_REC_LOW_OP OP_TC_AND_A_OR_A_LA
static void init_tc_rec(s7_scheme * sc)
{
sc->tc_rec_calls = (int *) calloc(TC_REC_SIZE, sizeof(int));
add_saved_pointer(sc, sc->tc_rec_calls);
}
static s7_pointer g_report_missed_calls(s7_scheme * sc, s7_pointer args)
{
int i;
for (i = TC_REC_LOW_OP; i < NUM_OPS; i++)
if (sc->tc_rec_calls[i] == 0)
fprintf(stderr, "%s missed\n", op_names[i]);
return (sc->F);
}
static void tick_tc(s7_scheme * sc, int op)
{
sc->tc_rec_calls[op]++;
}
#else
#define tick_tc(Sc, Op)
#endif
static bool op_tc_case_la(s7_scheme * sc, s7_pointer code)
{
/* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */
s7_pointer clauses = cddr(code), la_slot =
let_slots(sc->curlet), endp, selp = cdr(code);
s7_int len = integer(opt3_arglen(cdr(code)));
if (len == 3) {
while (true) {
s7_pointer selector;
selector = fx_call(sc, selp);
if (selector == opt1_any(clauses))
endp = opt2_any(clauses);
else {
s7_pointer p = cdr(clauses);
endp =
(selector ==
opt1_any(p)) ? opt2_any(p) : opt2_any(cdr(p));
}
if (has_tc(endp))
slot_set_value(la_slot, fx_call(sc, cdr(endp)));
else
break;
}
} else
while (true) {
s7_pointer selector, p;
selector = fx_call(sc, selp);
for (p = clauses; is_pair(cdr(p)); p = cdr(p))
if (selector == opt1_any(p)) {
endp = opt2_any(p);
goto CASE_ALA_END;
}
endp = opt2_any(p);
CASE_ALA_END:
if (has_tc(endp))
slot_set_value(la_slot, fx_call(sc, cdr(endp)));
else
break;
}
if (has_fx(endp)) {
sc->value = fx_call(sc, endp);
return (true); /* goto START */
}
sc->code = endp;
return (false); /* goto BEGIN (not like op_tc_z below) */
}
static s7_pointer fx_tc_case_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_CASE_LA);
op_tc_case_la(sc, arg);
return (sc->value);
}
static bool op_tc_z(s7_scheme * sc, s7_pointer expr)
{
if (has_fx(expr)) {
sc->value = fx_call(sc, expr);
return (true);
}
sc->code = car(expr);
return (false);
}
static void op_tc_and_a_or_a_la(s7_scheme * sc, s7_pointer code)
{
s7_pointer fx_and = cdr(code), fx_or, fx_la, la_slot =
let_slots(sc->curlet);
fx_or = cdadr(fx_and);
fx_la = cdadr(fx_or);
/* cell_optimize here is slower! */
while (true) {
s7_pointer p;
if (fx_call(sc, fx_and) == sc->F) {
sc->value = sc->F;
return;
}
p = fx_call(sc, fx_or);
if (p != sc->F) {
sc->value = p;
return;
}
slot_set_value(la_slot, fx_call(sc, fx_la));
}
}
static s7_pointer fx_tc_and_a_or_a_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_AND_A_OR_A_LA);
op_tc_and_a_or_a_la(sc, arg);
return (sc->value);
}
static void op_tc_or_a_and_a_la(s7_scheme * sc, s7_pointer code)
{
s7_pointer fx_and, fx_or = cdr(code), fx_la, la_slot =
let_slots(sc->curlet);
fx_and = cdadr(fx_or);
fx_la = cdadr(fx_and);
while (true) {
s7_pointer p;
p = fx_call(sc, fx_or);
if (p != sc->F) {
sc->value = p;
return;
}
if (fx_call(sc, fx_and) == sc->F) {
sc->value = sc->F;
return;
}
slot_set_value(la_slot, fx_call(sc, fx_la));
}
}
static s7_pointer fx_tc_or_a_and_a_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_OR_A_AND_A_LA);
op_tc_or_a_and_a_la(sc, arg);
return (sc->value);
}
static void op_tc_and_a_or_a_a_la(s7_scheme * sc, s7_pointer code)
{
s7_pointer fx_and = cdr(code), fx_or1, fx_or2, fx_la, la_slot =
let_slots(sc->curlet);
fx_or1 = cdadr(fx_and);
fx_or2 = cdr(fx_or1);
fx_la = cdadr(fx_or2);
while (true) {
s7_pointer p;
if (fx_call(sc, fx_and) == sc->F) {
sc->value = sc->F;
return;
}
p = fx_call(sc, fx_or1);
if (p != sc->F) {
sc->value = p;
return;
}
p = fx_call(sc, fx_or2);
if (p != sc->F) {
sc->value = p;
return;
}
slot_set_value(la_slot, fx_call(sc, fx_la));
}
}
static s7_pointer fx_tc_and_a_or_a_a_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_AND_A_OR_A_A_LA);
op_tc_and_a_or_a_a_la(sc, arg);
return (sc->value);
}
static void op_tc_or_a_and_a_a_la(s7_scheme * sc, s7_pointer code)
{
s7_pointer fx_or = cdr(code), fx_and1, fx_and2, fx_la, la_slot =
let_slots(sc->curlet);
fx_and1 = cdadr(fx_or);
fx_and2 = cdr(fx_and1);
fx_la = cdadr(fx_and2);
while (true) {
s7_pointer p;
p = fx_call(sc, fx_or);
if (p != sc->F) {
sc->value = p;
return;
}
if ((fx_call(sc, fx_and1) == sc->F) ||
(fx_call(sc, fx_and2) == sc->F)) {
sc->value = sc->F;
return;
}
slot_set_value(la_slot, fx_call(sc, fx_la));
}
}
static s7_pointer fx_tc_or_a_and_a_a_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_OR_A_AND_A_A_LA);
op_tc_or_a_and_a_a_la(sc, arg);
return (sc->value);
}
static void op_tc_or_a_a_and_a_a_la(s7_scheme * sc, s7_pointer code)
{
s7_pointer fx_and1, fx_and2, fx_or1 =
cdr(code), fx_or2, fx_la, la_slot = let_slots(sc->curlet);
fx_or2 = cdr(fx_or1);
fx_and1 = cdadr(fx_or2);
fx_and2 = cdr(fx_and1);
fx_la = cdadr(fx_and2);
while (true) {
s7_pointer p;
p = fx_call(sc, fx_or1);
if (p != sc->F) {
sc->value = p;
return;
}
p = fx_call(sc, fx_or2);
if (p != sc->F) {
sc->value = p;
return;
}
if (fx_call(sc, fx_and1) == sc->F) {
sc->value = sc->F;
return;
}
if (fx_call(sc, fx_and2) == sc->F) {
sc->value = sc->F;
return;
}
slot_set_value(la_slot, fx_call(sc, fx_la));
}
}
static s7_pointer fx_tc_or_a_a_and_a_a_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA);
op_tc_or_a_a_and_a_a_la(sc, arg);
return (sc->value);
}
static void op_tc_and_a_or_a_laa(s7_scheme * sc, s7_pointer code)
{
s7_pointer fx_and = cdr(code), fx_or, fx_la, la_slot =
let_slots(sc->curlet), fx_laa, laa_slot;
fx_or = cdadr(fx_and);
fx_la = cdadr(fx_or);
fx_laa = cdr(fx_la);
laa_slot = next_slot(la_slot);
if ((fx_proc(fx_and) == fx_not_is_null_u)
&& (fx_proc(fx_or) == fx_is_null_t) && (fx_proc(fx_la) == fx_cdr_t)
&& (fx_proc(fx_laa) == fx_cdr_u)) {
s7_pointer la_val = slot_value(la_slot), laa_val =
slot_value(laa_slot);
while (true) {
if (is_null(laa_val)) {
sc->value = sc->F;
return;
}
if (is_null(la_val)) {
sc->value = sc->T;
return;
}
la_val = cdr(la_val);
laa_val = cdr(laa_val);
}
}
while (true) {
s7_pointer p;
if (fx_call(sc, fx_and) == sc->F) {
sc->value = sc->F;
return;
}
p = fx_call(sc, fx_or);
if (p != sc->F) {
sc->value = p;
return;
}
sc->rec_p1 = fx_call(sc, fx_la);
slot_set_value(laa_slot, fx_call(sc, fx_laa));
slot_set_value(la_slot, sc->rec_p1);
}
}
static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_AND_A_OR_A_LAA);
op_tc_and_a_or_a_laa(sc, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static void op_tc_or_a_and_a_laa(s7_scheme * sc, s7_pointer code)
{
s7_pointer fx_and, fx_or = cdr(code), fx_la, la_slot =
let_slots(sc->curlet), fx_laa, laa_slot;
fx_and = cdadr(fx_or);
fx_la = cdadr(fx_and);
fx_laa = cdr(fx_la);
laa_slot = next_slot(la_slot);
while (true) {
s7_pointer p;
p = fx_call(sc, fx_or);
if (p != sc->F) {
sc->value = p;
return;
}
if (fx_call(sc, fx_and) == sc->F) {
sc->value = sc->F;
return;
}
sc->rec_p1 = fx_call(sc, fx_la);
slot_set_value(laa_slot, fx_call(sc, fx_laa));
slot_set_value(la_slot, sc->rec_p1);
}
}
static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_OR_A_AND_A_LAA);
op_tc_or_a_and_a_laa(sc, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static void op_tc_or_a_and_a_a_l3a(s7_scheme * sc, s7_pointer code)
{
s7_pointer fx_and1, fx_and2, fx_or =
cdr(code), fx_la, fx_laa, laa_slot, fx_l3a, l3a_slot, la_slot =
let_slots(sc->curlet);
fx_and1 = opt3_pair(fx_or); /* (or_case) ? cdadr(fx_or) : cdaddr(fx_or); */
fx_and2 = cdr(fx_and1);
fx_la = cdadr(fx_and2);
fx_laa = cdr(fx_la);
laa_slot = next_slot(la_slot);
fx_l3a = cdr(fx_laa);
l3a_slot = next_slot(laa_slot);
if ((fx_proc(fx_and1) == fx_not_a) && (fx_proc(fx_and2) == fx_not_a)) {
fx_and1 = cdar(fx_and1);
fx_and2 = cdar(fx_and2);
while (true) {
s7_pointer p;
p = fx_call(sc, fx_or);
if (p != sc->F) {
sc->value = p;
return;
}
if ((fx_call(sc, fx_and1) != sc->F)
|| (fx_call(sc, fx_and2) != sc->F)) {
sc->value = sc->F;
return;
}
sc->rec_p1 = fx_call(sc, fx_la);
sc->rec_p2 = fx_call(sc, fx_laa);
slot_set_value(l3a_slot, fx_call(sc, fx_l3a));
slot_set_value(la_slot, sc->rec_p1);
slot_set_value(laa_slot, sc->rec_p2);
}
}
while (true) {
s7_pointer p;
p = fx_call(sc, fx_or);
if (p != sc->F) {
sc->value = p;
return;
}
if ((fx_call(sc, fx_and1) == sc->F)
|| (fx_call(sc, fx_and2) == sc->F)) {
sc->value = sc->F;
return;
}
sc->rec_p1 = fx_call(sc, fx_la);
sc->rec_p2 = fx_call(sc, fx_laa);
slot_set_value(l3a_slot, fx_call(sc, fx_l3a));
slot_set_value(la_slot, sc->rec_p1);
slot_set_value(laa_slot, sc->rec_p2);
}
}
static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_OR_A_AND_A_A_L3A);
op_tc_or_a_and_a_a_l3a(sc, arg);
sc->rec_p1 = sc->F;
sc->rec_p2 = sc->F;
return (sc->value);
}
static bool op_tc_if_a_z_la(s7_scheme * sc, s7_pointer code, bool cond)
{
s7_pointer if_test, if_true, la, la_slot = let_slots(sc->curlet);
if_test = (cond) ? cadr(code) : cdr(code);
if_true = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test);
la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test);
if (is_t_integer(slot_value(la_slot))) {
sc->pc = 0;
if (bool_optimize(sc, if_test)) {
opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc];
if (int_optimize(sc, la)) {
s7_pointer val;
slot_set_value(la_slot, val =
make_mutable_integer(sc,
integer(slot_value
(la_slot))));
while (!(o->v[0].fb(o))) {
integer(val) = o1->v[0].fi(o1);
}
return (op_tc_z(sc, if_true));
}
}
}
while (fx_call(sc, if_test) == sc->F) {
slot_set_value(la_slot, fx_call(sc, la));
}
return (op_tc_z(sc, if_true));
}
static s7_pointer fx_tc_if_a_z_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_Z_LA);
op_tc_if_a_z_la(sc, arg, false);
return (sc->value);
}
static s7_pointer fx_tc_cond_a_z_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_Z_LA);
op_tc_if_a_z_la(sc, arg, true);
return (sc->value);
}
static bool op_tc_if_a_la_z(s7_scheme * sc, s7_pointer code, bool cond)
{
s7_pointer if_test, if_false, la, la_slot = let_slots(sc->curlet);
if_test = (cond) ? cadr(code) : cdr(code);
if_false = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test);
la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test);
if (is_t_integer(slot_value(la_slot))) {
sc->pc = 0;
if (bool_optimize(sc, if_test)) {
opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc];
if (int_optimize(sc, la)) {
s7_pointer val;
slot_set_value(la_slot, val =
make_mutable_integer(sc,
integer(slot_value
(la_slot))));
while (o->v[0].fb(o)) {
integer(val) = o1->v[0].fi(o1);
}
return (op_tc_z(sc, if_false));
}
}
}
while (fx_call(sc, if_test) != sc->F) {
slot_set_value(la_slot, fx_call(sc, la));
}
return (op_tc_z(sc, if_false));
}
static s7_pointer fx_tc_if_a_la_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_LA_Z);
op_tc_if_a_la_z(sc, arg, false);
return (sc->value);
}
static s7_pointer fx_tc_cond_a_la_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_LA_Z);
op_tc_if_a_la_z(sc, arg, true);
return (sc->value);
}
typedef enum { TC_IF, TC_COND, TC_AND } tc_choice_t;
static bool op_tc_if_a_z_laa(s7_scheme * sc, s7_pointer code, bool z_first,
tc_choice_t cond)
{
s7_pointer if_test, if_z, la, laa, laa_slot, la_slot =
let_slots(sc->curlet);
s7_function tf;
if (cond == TC_IF) {
if_test = cdr(code);
if_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */
la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */
} else {
if_test = cadr(code);
if_z = opt1_pair(cdr(code)); /* if_z = (z_first) ? cdr(if_test) : cdr(caddr(code)) */
la = opt3_pair(cdr(code)); /* la = (z_first) ? cdr(cadaddr(code)) : cdadr(if_test) */
}
laa = cdr(la);
laa_slot = next_slot(la_slot);
#if (!WITH_GMP)
if (!no_bool_opt(code)) {
sc->pc = 0;
if (bool_optimize(sc, if_test)) {
opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2;
int32_t start_pc = sc->pc;
if ((is_t_integer(slot_value(la_slot))) &&
(is_t_integer(slot_value(laa_slot)))) {
if (int_optimize(sc, la)) {
o2 = sc->opts[sc->pc];
if (int_optimize(sc, laa)) {
s7_pointer val1, val2;
s7_int(*fi1) (opt_info * o);
s7_int(*fi2) (opt_info * o);
bool (*fb)(opt_info * o);
slot_set_value(la_slot, val1 =
make_mutable_integer(sc,
integer
(slot_value
(la_slot))));
slot_set_value(laa_slot, val2 =
make_mutable_integer(sc,
integer
(slot_value
(laa_slot))));
fb = o->v[0].fb;
fi1 = o1->v[0].fi;
fi2 = o2->v[0].fi;
if ((z_first) && ((fb == opt_b_ii_sc_lt)
|| (fb == opt_b_ii_sc_lt_0))
&& (fi1 == opt_i_ii_sc_sub)) {
s7_int lim = o->v[2].i, m = o1->v[2].i;
s7_pointer slot1 = o->v[1].p, slot2 =
o1->v[1].p;
while (integer(slot_value(slot1)) >= lim) {
s7_int i1 = integer(slot_value(slot2)) - m;
integer(val2) = fi2(o2);
integer(val1) = i1;
}
} else
while (fb(o) != z_first) {
s7_int i1;
i1 = fi1(o1);
integer(val2) = fi2(o2);
integer(val1) = i1;
}
return (op_tc_z(sc, if_z));
}
}
}
if ((is_t_real(slot_value(la_slot))) &&
(is_t_real(slot_value(laa_slot)))) {
sc->pc = start_pc;
if (float_optimize(sc, la)) {
o2 = sc->opts[sc->pc];
if (float_optimize(sc, laa)) {
s7_pointer val1, val2;
s7_double(*fd1) (opt_info * o);
s7_double(*fd2) (opt_info * o);
bool (*fb)(opt_info * o);
slot_set_value(la_slot, val1 =
s7_make_mutable_real(sc,
real(slot_value
(la_slot))));
slot_set_value(laa_slot, val2 =
s7_make_mutable_real(sc,
real(slot_value
(laa_slot))));
fb = o->v[0].fb;
fd1 = o1->v[0].fd;
fd2 = o2->v[0].fd;
if ((z_first) &&
(fb == opt_b_dd_sc_lt) &&
(fd1 == opt_d_dd_sc_sub)) {
s7_double lim = o->v[2].x, m = o1->v[2].x;
s7_pointer slot1 = o->v[1].p, slot2 =
o1->v[1].p;
while (real(slot_value(slot1)) >= lim) {
s7_double x1 = real(slot_value(slot2)) - m;
real(val2) = fd2(o2);
real(val1) = x1;
}
} else
while (fb(o) != z_first) {
s7_double x1;
x1 = fd1(o1);
real(val2) = fd2(o2);
real(val1) = x1;
}
return (op_tc_z(sc, if_z));
}
}
}
}
set_no_bool_opt(code);
}
#endif
tf = fx_proc(if_test);
if_test = car(if_test);
if (z_first) {
if ((fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_subtract_u1) && (fn_proc(if_test) == g_num_eq_xi) && /* was also (fx_proc(if_test) == fx_num_eq_ui) but we cloberred if_test above */
(is_pair(slot_value(la_slot))) && (is_t_integer(slot_value(laa_slot)))) { /* list-tail ferchrissake */
s7_int start, end = integer(caddr(if_test));
s7_pointer lst = slot_value(la_slot);
for (start = integer(slot_value(laa_slot)); start > end;
start--)
lst = cdr(lst);
slot_set_value(la_slot, lst);
} else
while (tf(sc, if_test) == sc->F) {
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
}
} else
while (tf(sc, if_test) != sc->F) {
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
}
return (op_tc_z(sc, if_z));
}
static s7_pointer fx_tc_if_a_z_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_Z_LAA);
op_tc_if_a_z_laa(sc, arg, true, TC_IF);
sc->rec_p1 = sc->F;
return (sc->value);
}
static s7_pointer fx_tc_cond_a_z_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_Z_LAA);
op_tc_if_a_z_laa(sc, arg, true, TC_COND);
sc->rec_p1 = sc->F;
return (sc->value);
}
static s7_pointer fx_tc_if_a_laa_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_LAA_Z);
op_tc_if_a_z_laa(sc, arg, false, TC_IF);
sc->rec_p1 = sc->F;
return (sc->value);
}
static s7_pointer fx_tc_cond_a_laa_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_LAA_Z);
op_tc_if_a_z_laa(sc, arg, false, TC_COND);
sc->rec_p1 = sc->F;
return (sc->value);
}
static void op_tc_when_laa(s7_scheme * sc, s7_pointer code)
{
s7_pointer if_test = cadr(code), body =
cddr(code), la_call, la, laa, laa_slot, la_slot =
let_slots(sc->curlet);
s7_function tf;
tf = fx_proc(cdr(code));
for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call));
la = cdar(la_call);
laa = cdr(la);
laa_slot = next_slot(la_slot);
while (tf(sc, if_test) != sc->F) {
s7_pointer p;
for (p = body; p != la_call; p = cdr(p))
fx_call(sc, p);
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
}
sc->value = sc->unspecified;
}
static bool op_tc_if_a_z_l3a(s7_scheme * sc, s7_pointer code, bool z_first)
{
s7_pointer if_test =
cdr(code), f_z, la, laa, l3a, laa_slot, l3a_slot, la_slot =
let_slots(sc->curlet);
s7_function tf;
f_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */
la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */
laa = cdr(la);
l3a = cdr(laa);
laa_slot = next_slot(la_slot);
l3a_slot = next_slot(laa_slot);
tf = fx_proc(if_test);
if_test = car(if_test);
while ((tf(sc, if_test) == sc->F) == z_first) {
sc->rec_p1 = fx_call(sc, la);
sc->rec_p2 = fx_call(sc, laa);
slot_set_value(l3a_slot, fx_call(sc, l3a));
slot_set_value(laa_slot, sc->rec_p2);
slot_set_value(la_slot, sc->rec_p1);
}
return (op_tc_z(sc, f_z));
}
static s7_pointer fx_tc_if_a_z_l3a(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_Z_L3A);
op_tc_if_a_z_l3a(sc, arg, true);
sc->rec_p1 = sc->F;
sc->rec_p2 = sc->F;
return (sc->value);
}
static s7_pointer fx_tc_if_a_l3a_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_L3A_Z);
op_tc_if_a_z_l3a(sc, arg, false);
sc->rec_p1 = sc->F;
sc->rec_p2 = sc->F;
return (sc->value);
}
static bool op_tc_if_a_z_if_a_z_la(s7_scheme * sc, s7_pointer code,
bool z_first, tc_choice_t cond)
{
s7_pointer if_test, if_true, if_false, f_test, f_z, la, endp, la_slot =
let_slots(sc->curlet);
bool tc_and = (cond == TC_AND);
if (cond != TC_COND) {
if_test = cdr(code);
if_true = (!tc_and) ? cdr(if_test) : sc->F;
if_false = (!tc_and) ? cadr(if_true) : cadr(if_test);
f_test = cdr(if_false);
f_z = (z_first) ? cdr(f_test) : cddr(f_test);
la = (z_first) ? cdaddr(f_test) : cdadr(f_test);
} else {
if_test = cadr(code); /* code: (cond (a1 z1) (a2 z2|la) (else la|z2)) */
if_true = cdr(if_test);
if_false = caddr(code); /* (a2 z2|la) */
f_test = if_false;
f_z = (z_first) ? cdr(f_test) : cdr(cadddr(code));
la = (z_first) ? cdadr(cadddr(code)) : cdadr(caddr(code));
}
#if (!WITH_GMP)
if (is_t_integer(slot_value(la_slot))) {
opt_info *o = sc->opts[0];
sc->pc = 0;
if (bool_optimize_nw(sc, if_test)) {
opt_info *o1 = sc->opts[sc->pc];
if (bool_optimize_nw(sc, f_test)) {
opt_info *o2 = sc->opts[sc->pc];
if (int_optimize(sc, la)) {
s7_pointer val;
slot_set_value(la_slot, val =
make_mutable_integer(sc,
integer(slot_value
(la_slot))));
if (tc_and)
while (true) {
if (!o->v[0].fb(o)) {
sc->value = sc->F;
return (true);
}
if (o1->v[0].fb(o1) == z_first) {
endp = f_z;
break;
}
integer(val) = o2->v[0].fi(o2);
} else
while (true) {
if (o->v[0].fb(o)) {
endp = if_true;
break;
}
if (o1->v[0].fb(o1) == z_first) {
endp = f_z;
break;
}
integer(val) = o2->v[0].fi(o2);
}
return (op_tc_z(sc, endp));
}
}
}
}
#endif
while (true) {
if ((fx_call(sc, if_test) == sc->F) == tc_and) {
if (tc_and) {
sc->value = sc->F;
return (true);
} else {
endp = if_true;
break;
}
}
if ((fx_call(sc, f_test) == sc->F) != z_first) {
endp = f_z;
break;
}
slot_set_value(la_slot, fx_call(sc, la));
}
return (op_tc_z(sc, endp));
}
static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA);
op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_IF);
return (sc->value);
}
static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_Z_IF_A_LA_Z);
op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_IF);
return (sc->value);
}
static s7_pointer fx_tc_cond_a_z_a_z_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_Z_A_Z_LA);
op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_COND);
return (sc->value);
}
static s7_pointer fx_tc_cond_a_z_a_la_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_Z_A_LA_Z);
op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_COND);
return (sc->value);
}
static s7_pointer fx_tc_and_a_if_a_z_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_AND_A_IF_A_Z_LA);
op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_AND);
return (sc->value);
}
static s7_pointer fx_tc_and_a_if_a_la_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_AND_A_IF_A_LA_Z);
op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_AND);
return (sc->value);
}
static bool op_tc_if_a_z_if_a_z_laa(s7_scheme * sc, bool cond,
s7_pointer code)
{
s7_pointer if_test, if_true, if_false, f_test, f_true, la, laa,
laa_slot, endp, slot1, la_slot = let_slots(sc->curlet);
if_test = (cond) ? cadr(code) : cdr(code);
if_true = cdr(if_test);
if (!cond)
if_false = cadr(if_true);
f_test = (cond) ? caddr(code) : cdr(if_false);
f_true = cdr(f_test);
la = (cond) ? opt3_pair(code) : cdadr(f_true); /* cdadr(cadddr(code)) */
laa = cdr(la);
laa_slot = next_slot(la_slot);
slot1 =
(fx_proc(if_test) ==
fx_is_null_t) ? la_slot : ((fx_proc(if_test) ==
fx_is_null_u) ? laa_slot : NULL);
if (slot1) {
if ((slot1 == laa_slot) && (fx_proc(f_test) == fx_is_null_t)
&& (fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_cdr_u)
&& (s7_is_boolean(car(if_true)))
&& (s7_is_boolean(car(f_true)))) {
s7_pointer la_val = slot_value(la_slot), laa_val =
slot_value(laa_slot);
while (true) {
if (is_null(laa_val)) {
sc->value = car(if_true);
return (true);
}
if (is_null(la_val)) {
sc->value = car(f_true);
return (true);
}
la_val = cdr(la_val);
laa_val = cdr(laa_val);
}
}
while (true) {
if (is_null(slot_value(slot1))) {
endp = if_true;
break;
}
if (fx_call(sc, f_test) != sc->F) {
endp = f_true;
break;
}
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
}
} else
while (true) {
if (fx_call(sc, if_test) != sc->F) {
endp = if_true;
break;
}
if (fx_call(sc, f_test) != sc->F) {
endp = f_true;
break;
}
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
}
return (op_tc_z(sc, endp));
}
static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LAA);
op_tc_if_a_z_if_a_z_laa(sc, false, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_Z_A_Z_LAA);
op_tc_if_a_z_if_a_z_laa(sc, true, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static bool op_tc_if_a_z_if_a_laa_z(s7_scheme * sc, bool cond,
s7_pointer code)
{
s7_pointer if_test, if_true, if_false, f_test, f_true, f_false, la,
laa, laa_slot, endp, la_slot = let_slots(sc->curlet);
if_test = (cond) ? cadr(code) : cdr(code);
if_true = cdr(if_test);
if (!cond)
if_false = cadr(if_true);
f_test = (cond) ? caddr(code) : cdr(if_false);
f_true = cdr(f_test);
f_false = (cond) ? cdr(cadddr(code)) : cdr(f_true);
la = (cond) ? opt3_pair(code) : cdar(f_true); /* cdadr(caddr(code)) */
laa = cdr(la);
laa_slot = next_slot(la_slot);
while (true) {
if (fx_call(sc, if_test) != sc->F) {
endp = if_true;
break;
}
if (fx_call(sc, f_test) == sc->F) {
endp = f_false;
break;
}
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
}
return (op_tc_z(sc, endp));
}
static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_Z_IF_A_LAA_Z);
op_tc_if_a_z_if_a_laa_z(sc, false, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static s7_pointer fx_tc_cond_a_z_a_laa_z(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_Z_A_LAA_Z);
op_tc_if_a_z_if_a_laa_z(sc, true, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme * sc, s7_pointer code)
{
s7_pointer if_test =
cdr(code), if_true, if_false, f_test, f_true, f_false, la1, la2,
laa1, laa2, laa_slot, l3a1, l3a2, l3a_slot, endp, la_slot =
let_slots(sc->curlet);
if_true = cdr(if_test);
if_false = cadr(if_true);
f_test = cdr(if_false);
f_true = cdr(f_test);
f_false = cdr(f_true);
la1 = cdar(f_true);
la2 = cdar(f_false);
laa1 = cdr(la1);
laa2 = cdr(la2);
laa_slot = next_slot(la_slot);
l3a1 = cdr(laa1);
l3a2 = cdr(laa2);
l3a_slot = next_slot(laa_slot);
while (true) {
if (fx_call(sc, if_test) != sc->F) {
endp = if_true;
break;
}
if (fx_call(sc, f_test) != sc->F) {
sc->rec_p1 = fx_call(sc, la1);
sc->rec_p2 = fx_call(sc, laa1);
slot_set_value(l3a_slot, fx_call(sc, l3a1));
} else {
sc->rec_p1 = fx_call(sc, la2);
sc->rec_p2 = fx_call(sc, laa2);
slot_set_value(l3a_slot, fx_call(sc, l3a2));
}
slot_set_value(laa_slot, sc->rec_p2);
slot_set_value(la_slot, sc->rec_p1);
}
return (op_tc_z(sc, endp));
}
static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A);
op_tc_if_a_z_if_a_l3a_l3a(sc, arg);
sc->rec_p1 = sc->F;
sc->rec_p2 = sc->F;
return (sc->value);
}
static bool op_tc_let_if_a_z_la(s7_scheme * sc, s7_pointer code)
{
s7_pointer body =
caddr(code), if_test, if_true, if_false, la, la_slot, let_slot,
let_var = caadr(code), outer_let = sc->curlet, inner_let;
sc->curlet =
make_let_with_slot(sc, sc->curlet, car(let_var),
fx_call(sc, cdr(let_var)));
inner_let = sc->curlet;
s7_gc_protect_via_stack(sc, inner_let);
let_slot = let_slots(sc->curlet);
let_var = cdr(let_var);
if_test = cdr(body);
if_true = cddr(body);
if_false = cadddr(body);
la = cdr(if_false);
la_slot = let_slots(outer_let);
while (fx_call(sc, if_test) == sc->F) {
slot_set_value(la_slot, fx_call(sc, la));
set_curlet(sc, outer_let);
slot_set_value(let_slot, fx_call(sc, let_var));
set_curlet(sc, inner_let);
}
unstack(sc);
if (!op_tc_z(sc, if_true))
return (false);
free_cell(sc, let_slots(inner_let));
free_cell(sc, inner_let);
return (true);
}
static s7_pointer fx_tc_let_if_a_z_la(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_LET_IF_A_Z_LA);
op_tc_let_if_a_z_la(sc, arg);
return (sc->value);
}
static bool op_tc_let_if_a_z_laa(s7_scheme * sc, s7_pointer code)
{
s7_pointer body =
caddr(code), if_test, if_true, if_false, la, la_slot, let_slot,
laa, laa_slot, let_var = caadr(code), outer_let =
sc->curlet, inner_let;
sc->curlet =
make_let_with_slot(sc, sc->curlet, car(let_var),
fx_call(sc, cdr(let_var)));
inner_let = sc->curlet;
s7_gc_protect_via_stack(sc, inner_let);
let_slot = let_slots(sc->curlet);
let_var = cdr(let_var);
if_test = cdr(body);
if_true = cddr(body);
if_false = cadddr(body);
la = cdr(if_false);
la_slot = let_slots(outer_let);
laa = cddr(if_false);
laa_slot = next_slot(la_slot);
#if (!WITH_GMP)
if (!no_bool_opt(code)) {
sc->pc = 0;
if (bool_optimize(sc, if_test)) {
opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2, *o3;
if ((is_t_integer(slot_value(la_slot))) &&
(is_t_integer(slot_value(laa_slot)))) {
if (int_optimize(sc, la)) {
o2 = sc->opts[sc->pc];
if (int_optimize(sc, laa)) {
o3 = sc->opts[sc->pc];
set_curlet(sc, outer_let);
if (int_optimize(sc, let_var)) {
s7_pointer val1, val2, val3;
set_curlet(sc, inner_let);
slot_set_value(la_slot, val1 =
make_mutable_integer(sc,
integer
(slot_value
(la_slot))));
slot_set_value(laa_slot, val2 =
make_mutable_integer(sc,
integer
(slot_value
(laa_slot))));
slot_set_value(let_slot, val3 =
make_mutable_integer(sc,
integer
(slot_value
(let_slot))));
while (!(o->v[0].fb(o))) {
s7_int i1;
i1 = o1->v[0].fi(o1);
integer(val2) = o2->v[0].fi(o2);
integer(val1) = i1;
integer(val3) = o3->v[0].fi(o3);
}
unstack(sc);
if (!op_tc_z(sc, if_true)) /* sc->inner_let in effect here since it was the last set above */
return (false);
free_cell(sc, let_slots(inner_let));
free_cell(sc, inner_let);
return (true);
}
}
}
}
}
set_no_bool_opt(code);
}
#endif
while (fx_call(sc, if_test) == sc->F) {
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
set_curlet(sc, outer_let);
slot_set_value(let_slot, fx_call(sc, let_var));
set_curlet(sc, inner_let);
}
unstack(sc);
if (!op_tc_z(sc, if_true))
return (false);
free_cell(sc, let_slots(inner_let));
free_cell(sc, inner_let);
return (true);
}
static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_LET_IF_A_Z_LAA);
op_tc_let_if_a_z_laa(sc, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static void op_tc_let_when_laa(s7_scheme * sc, bool when, s7_pointer code)
{
s7_pointer p, body =
caddr(code), if_test, if_true, la, let_slot, laa, let_var =
caadr(code), outer_let = sc->curlet, inner_let;
sc->curlet =
make_let_with_slot(sc, sc->curlet, car(let_var),
fx_call(sc, cdr(let_var)));
inner_let = sc->curlet;
s7_gc_protect_via_stack(sc, inner_let);
let_slot = let_slots(sc->curlet);
let_var = cdr(let_var);
if_test = cdr(body);
if_true = cddr(body);
for (p = if_true; is_pair(cdr(p)); p = cdr(p));
la = cdar(p);
laa = cddar(p);
if ((car(la) == slot_symbol(let_slots(outer_let))) &&
(car(laa) == slot_symbol(next_slot(let_slots(outer_let))))) {
if ((cdr(if_true) == p) && (!when)) {
s7_pointer a1, a2;
a1 = slot_value(let_slots(outer_let));
a2 = slot_value(next_slot(let_slots(outer_let)));
if ((is_input_port(a1)) && (is_output_port(a2))
&& (is_string_port(a1)) && (is_file_port(a2))
&& (!port_is_closed(a1)) && (!port_is_closed(a2))
&& (fx_proc(if_true) == fx_c_tU_direct)
&& (fx_proc(let_var) == fx_c_t_direct)
&& (((s7_p_pp_t) opt3_direct(cdar(if_true))) ==
write_char_p_pp)
&& (((s7_p_p_t) opt2_direct(cdar(let_var))) ==
read_char_p_p) && (fx_proc(if_test) == fx_is_eof_t)) {
int32_t c;
a1 = slot_value(let_slots(outer_let));
a2 = slot_value(next_slot(let_slots(outer_let)));
c = (int32_t)
s7_character(slot_value(let_slots(inner_let)));
while (c != EOF) {
inline_file_write_char(sc, (uint8_t) c, a2);
c = string_read_char(sc, a1);
}
} else
while (fx_call(sc, if_test) == sc->F) {
fx_call(sc, if_true);
set_curlet(sc, outer_let);
slot_set_value(let_slot, fx_call(sc, let_var));
set_curlet(sc, inner_let);
}
} else
while (true) {
p = fx_call(sc, if_test);
if (when) {
if (p == sc->F)
break;
} else {
if (p != sc->F)
break;
}
for (p = if_true; is_pair(cdr(p)); p = cdr(p))
fx_call(sc, p);
set_curlet(sc, outer_let);
slot_set_value(let_slot, fx_call(sc, let_var));
set_curlet(sc, inner_let);
}
} else {
s7_pointer laa_slot, la_slot = let_slots(outer_let);
laa_slot = next_slot(la_slot);
while (true) {
p = fx_call(sc, if_test);
if (when) {
if (p == sc->F)
break;
} else {
if (p != sc->F)
break;
}
for (p = if_true; is_pair(cdr(p)); p = cdr(p))
fx_call(sc, p);
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
set_curlet(sc, outer_let);
slot_set_value(let_slot, fx_call(sc, let_var));
set_curlet(sc, inner_let);
}
}
unstack(sc);
free_cell(sc, let_slots(inner_let));
free_cell(sc, inner_let);
sc->value = sc->unspecified;
}
static s7_pointer fx_tc_let_when_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_LET_WHEN_LAA);
op_tc_let_when_laa(sc, true, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static s7_pointer fx_tc_let_unless_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_LET_WHEN_LAA);
op_tc_let_when_laa(sc, false, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
static bool op_tc_if_a_z_let_if_a_z_laa(s7_scheme * sc, s7_pointer code)
{
s7_pointer if1_test =
cdr(code), if1_true, if2, if2_test, if2_true, la, laa, laa_slot,
endp, let_expr, let_vars, inner_let, outer_let =
sc->curlet, slot, var, la_slot = let_slots(sc->curlet);
if1_true = cdr(if1_test); /* cddr(code) */
let_expr = cadr(if1_true); /* cadddr(code) */
let_vars = cadr(let_expr);
if2 = caddr(let_expr);
if2_test = cdr(if2);
if2_true = cdr(if2_test); /* cddr(if2) */
la = cdadr(if2_true); /* cdr(cadddr(if2)) */
laa = cdr(la);
laa_slot = next_slot(la_slot);
inner_let = make_let(sc, sc->curlet);
s7_gc_protect_via_stack(sc, inner_let);
slot = make_slot(sc, caar(let_vars), sc->F);
slot_set_next(slot, slot_end(sc));
let_set_slots(inner_let, slot);
symbol_set_local_slot_unincremented(caar(let_vars), let_id(inner_let),
slot);
for (var = cdr(let_vars); is_pair(var); var = cdr(var))
slot =
add_slot_at_end(sc, let_id(inner_let), slot, caar(var), sc->F);
while (true) {
if (fx_call(sc, if1_test) != sc->F) {
endp = if1_true;
break;
}
slot = let_slots(inner_let);
slot_set_value(slot, fx_call(sc, cdar(let_vars)));
set_curlet(sc, inner_let);
for (var = cdr(let_vars), slot = next_slot(slot); is_pair(var);
var = cdr(var), slot = next_slot(slot))
slot_set_value(slot, fx_call(sc, cdar(var)));
if (fx_call(sc, if2_test) != sc->F) {
endp = if2_true;
break;
}
sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
slot_set_value(la_slot, sc->rec_p1);
set_curlet(sc, outer_let);
}
unstack(sc);
if (!op_tc_z(sc, endp)) /* might refer to inner_let slots */
return (false);
free_cell(sc, let_slots(inner_let)); /* true = has_fx, so we should be done with the let */
free_cell(sc, inner_let);
return (true);
}
static bool op_tc_let_cond(s7_scheme * sc, s7_pointer code)
{
s7_pointer outer_let = sc->curlet, inner_let, let_var =
caadr(code), let_slot, cond_body, slots, result;
s7_function letf;
bool read_case;
/* code here == body in check_tc */
sc->curlet =
make_let_with_slot(sc, sc->curlet, car(let_var),
fx_call(sc, cdr(let_var)));
inner_let = sc->curlet;
s7_gc_protect_via_stack(sc, inner_let);
let_slot = let_slots(sc->curlet);
let_var = cdr(let_var);
letf = fx_proc(let_var);
let_var = car(let_var);
if ((letf == fx_c_s_direct) && /* an experiment */
(symbol_id(cadr(let_var)) != let_id(outer_let))) { /* i.e. not an argument to the recursive function, and not set! (safe closure body) */
letf = (s7_p_p_t) opt2_direct(cdr(let_var));
let_var = lookup(sc, cadr(let_var));
}
cond_body = cdaddr(code);
slots = let_slots(outer_let);
/* in the named let no-var case slots may contain the let name (it's the funclet) */
if (integer(opt3_arglen(cdr(code))) == 0) /* (loop) etc -- no args */
while (true) {
s7_pointer p;
for (p = cond_body; is_pair(p); p = cdr(p))
if (fx_call(sc, car(p)) != sc->F) {
result = cdar(p);
if (has_tc(result)) {
set_curlet(sc, outer_let);
slot_set_value(let_slot, letf(sc, let_var));
set_curlet(sc, inner_let);
break;
} else
goto TC_LET_COND_DONE;
}
}
if (integer(opt3_arglen(cdr(code))) == 1)
while (true) {
s7_pointer p;
for (p = cond_body; is_pair(p); p = cdr(p))
if (fx_call(sc, car(p)) != sc->F) {
result = cdar(p);
if (has_tc(result)) {
slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */
set_curlet(sc, outer_let);
slot_set_value(let_slot, letf(sc, let_var)); /* inner let var */
set_curlet(sc, inner_let);
break;
} else
goto TC_LET_COND_DONE;
}
}
let_set_has_pending_value(outer_let);
read_case = ((letf == read_char_p_p) && (is_input_port(let_var))
&& (is_string_port(let_var))
&& (!port_is_closed(let_var)));
while (true) {
s7_pointer p;
for (p = cond_body; is_pair(p); p = cdr(p))
if (fx_call(sc, car(p)) != sc->F) {
result = cdar(p);
if (has_tc(result)) {
s7_pointer slot, arg;
for (slot = slots, arg = cdar(result); is_pair(arg);
slot = next_slot(slot), arg = cdr(arg))
slot_simply_set_pending_value(slot,
fx_call(sc, arg));
for (slot = slots; tis_slot(slot); slot = next_slot(slot)) /* using two swapping lets instead is slightly slower */
slot_set_value(slot, slot_pending_value(slot));
if (read_case)
slot_set_value(let_slot,
chars[string_read_char
(sc, let_var)]);
else {
set_curlet(sc, outer_let);
slot_set_value(let_slot, letf(sc, let_var));
set_curlet(sc, inner_let);
}
break;
} else
goto TC_LET_COND_DONE;
}
}
let_clear_has_pending_value(outer_let);
TC_LET_COND_DONE:
unstack(sc);
if (has_fx(result)) {
sc->value = fx_call(sc, result);
free_cell(sc, let_slots(inner_let));
free_cell(sc, inner_let);
return (true);
}
sc->code = car(result);
return (false);
}
static s7_pointer fx_tc_let_cond(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_LET_COND);
op_tc_let_cond(sc, arg);
return (sc->value);
}
static bool op_tc_cond_a_z_a_laa_laa(s7_scheme * sc, s7_pointer code)
{
s7_pointer c1 = cadr(code), c2 =
caddr(code), c3, la1, la2, laa1, laa2, laa_slot, la_slot =
let_slots(sc->curlet);
la1 = cdadr(c2);
laa1 = cddadr(c2);
c3 = opt3_pair(code); /* cadr(cadddr(code)) = cadr(else_clause) */
la2 = cdr(c3);
laa2 = cddr(c3);
laa_slot = next_slot(la_slot);
while (true) {
if (fx_call(sc, c1) != sc->F) {
c1 = cdr(c1);
break;
}
if (fx_call(sc, c2) != sc->F) {
sc->rec_p1 = fx_call(sc, la1);
slot_set_value(laa_slot, fx_call(sc, laa1));
} else {
sc->rec_p1 = fx_call(sc, la2);
slot_set_value(laa_slot, fx_call(sc, laa2));
}
slot_set_value(la_slot, sc->rec_p1);
}
return (op_tc_z(sc, c1));
}
static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_TC_COND_A_Z_A_LAA_LAA);
op_tc_cond_a_z_a_laa_laa(sc, arg);
sc->rec_p1 = sc->F;
return (sc->value);
}
#define RECUR_INITIAL_STACK_SIZE 1024
static void recur_resize(s7_scheme * sc)
{
s7_pointer stack;
block_t *ob, *nb;
stack = sc->rec_stack;
vector_length(stack) = sc->rec_len * 2;
ob = vector_block(stack);
nb = reallocate(sc, ob, vector_length(stack) * sizeof(s7_pointer));
block_info(nb) = NULL;
vector_block(stack) = nb;
vector_elements(stack) = (s7_pointer *) block_data(nb); /* GC looks only at elements within sc->rec_loc */
sc->rec_len = vector_length(stack);
sc->rec_els = vector_elements(stack);
}
static inline void recur_push(s7_scheme * sc, s7_pointer value)
{
if (sc->rec_loc == sc->rec_len)
recur_resize(sc);
sc->rec_els[sc->rec_loc] = value;
sc->rec_loc++;
}
static inline void recur_push_unchecked(s7_scheme * sc, s7_pointer value)
{
sc->rec_els[sc->rec_loc++] = value;
}
static s7_pointer recur_pop(s7_scheme * sc)
{
return (sc->rec_els[--sc->rec_loc]);
}
static s7_pointer recur_ref(s7_scheme * sc, s7_int loc)
{
return (sc->rec_els[sc->rec_loc - loc]);
}
static s7_pointer recur_pop2(s7_scheme * sc)
{
sc->rec_loc -= 2;
return (sc->rec_els[sc->rec_loc + 1]);
}
static s7_pointer recur_swap(s7_scheme * sc, s7_pointer value)
{
s7_pointer res;
res = sc->rec_els[sc->rec_loc - 1];
sc->rec_els[sc->rec_loc - 1] = value;
return (res);
}
static s7_pointer recur_make_stack(s7_scheme * sc)
{
if (!sc->rec_stack) {
sc->rec_stack = make_simple_vector(sc, RECUR_INITIAL_STACK_SIZE);
sc->rec_els = vector_elements(sc->rec_stack);
sc->rec_len = RECUR_INITIAL_STACK_SIZE;
}
sc->rec_loc = 0;
return (sc->rec_stack);
}
static void rec_set_test(s7_scheme * sc, s7_pointer p)
{
sc->rec_testp = p;
sc->rec_testf = fx_proc(sc->rec_testp);
sc->rec_testp = car(sc->rec_testp);
}
static void rec_set_res(s7_scheme * sc, s7_pointer p)
{
sc->rec_resp = p;
sc->rec_resf = fx_proc(sc->rec_resp);
sc->rec_resp = car(sc->rec_resp);
}
static void rec_set_f1(s7_scheme * sc, s7_pointer p)
{
sc->rec_f1p = p;
sc->rec_f1f = fx_proc(sc->rec_f1p);
sc->rec_f1p = car(sc->rec_f1p);
}
static void rec_set_f2(s7_scheme * sc, s7_pointer p)
{
sc->rec_f2p = p;
sc->rec_f2f = fx_proc(sc->rec_f2p);
sc->rec_f2p = car(sc->rec_f2p);
}
static void rec_set_f3(s7_scheme * sc, s7_pointer p)
{
sc->rec_f3p = p;
sc->rec_f3f = fx_proc(sc->rec_f3p);
sc->rec_f3p = car(sc->rec_f3p);
}
static void rec_set_f4(s7_scheme * sc, s7_pointer p)
{
sc->rec_f4p = p;
sc->rec_f4f = fx_proc(sc->rec_f4p);
sc->rec_f4p = car(sc->rec_f4p);
}
static void rec_set_f5(s7_scheme * sc, s7_pointer p)
{
sc->rec_f5p = p;
sc->rec_f5f = fx_proc(sc->rec_f5p);
sc->rec_f5p = car(sc->rec_f5p);
}
static void rec_set_f6(s7_scheme * sc, s7_pointer p)
{
sc->rec_f6p = p;
sc->rec_f6f = fx_proc(sc->rec_f6p);
sc->rec_f6p = car(sc->rec_f6p);
}
/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */
typedef enum { OPT_PTR, OPT_INT, OPT_DBL, OPT_INT_0 } opt_pid_t;
static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme * sc, bool a_op,
bool la_op, s7_pointer code)
{
s7_pointer caller = opt3_pair(code); /* false_p in check_recur */
#if (!WITH_GMP)
s7_pointer c_op;
c_op = car(caller);
if ((is_symbol(c_op)) &&
((is_global(c_op)) ||
((is_slot(global_slot(c_op))) &&
(lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) {
s7_pointer s_func = global_value(c_op), slot =
let_slots(sc->curlet);
if (is_c_function(s_func)) {
sc->pc = 0;
sc->rec_test_o = sc->opts[0];
if (bool_optimize(sc, cdr(code))) {
int32_t start_pc = sc->pc;
sc->rec_result_o = sc->opts[start_pc];
if (is_t_integer(slot_value(slot))) {
sc->rec_i_ii_f = s7_i_ii_function(s_func);
if ((sc->rec_i_ii_f) &&
(int_optimize
(sc, (a_op) ? cddr(code) : cdddr(code)))) {
sc->rec_a1_o = sc->opts[sc->pc];
if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) { /* cdadr? */
sc->rec_a2_o = sc->opts[sc->pc];
if (int_optimize(sc, cdr(opt3_pair(caller)))) {
sc->rec_val1 =
make_mutable_integer(sc,
integer(slot_value
(slot)));
slot_set_value(slot, sc->rec_val1);
return (OPT_INT);
}
}
}
}
}
}
}
#endif
rec_set_test(sc, cdr(code));
rec_set_res(sc, (a_op) ? cddr(code) : cdddr(code));
rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller));
rec_set_f2(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_fn = fn_proc(caller);
return (OPT_PTR);
}
static s7_int oprec_i_if_a_a_opa_laq(s7_scheme * sc)
{
s7_int i1;
if (sc->rec_test_o->v[0].fb(sc->rec_test_o))
return (sc->rec_result_o->v[0].fi(sc->rec_result_o));
i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o);
integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o);
return (sc->rec_i_ii_f(i1, oprec_i_if_a_a_opa_laq(sc)));
}
static s7_int oprec_i_if_a_opa_laq_a(s7_scheme * sc)
{
s7_int i1;
if (!sc->rec_test_o->v[0].fb(sc->rec_test_o))
return (sc->rec_result_o->v[0].fi(sc->rec_result_o));
i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o);
integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o);
return (sc->rec_i_ii_f(i1, oprec_i_if_a_opa_laq_a(sc)));
}
static s7_pointer oprec_if_a_a_opa_laq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
else {
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
set_car(sc->t2_2, oprec_if_a_a_opa_laq(sc));
set_car(sc->t2_1, recur_pop(sc));
set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1));
}
set_car(sc->t2_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer oprec_if_a_a_opla_aq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
set_car(sc->t2_1, oprec_if_a_a_opla_aq(sc));
set_car(sc->t2_2, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer oprec_if_a_opa_laq_a(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) == sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
if (sc->rec_testf(sc, sc->rec_testp) == sc->F)
set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
else {
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
set_car(sc->t2_2, oprec_if_a_opa_laq_a(sc));
set_car(sc->t2_1, recur_pop(sc));
set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1));
}
set_car(sc->t2_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer oprec_if_a_opla_aq_a(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) == sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
set_car(sc->t2_1, oprec_if_a_opla_aq_a(sc));
set_car(sc->t2_2, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static void wrap_recur_if_a_a_opa_laq(s7_scheme * sc, bool a_op,
bool la_op)
{
opt_pid_t choice;
tick_tc(sc, sc->cur_op);
choice = opinit_if_a_a_opa_laq(sc, a_op, la_op, sc->code);
if (choice == OPT_INT)
sc->value =
make_integer(sc,
(a_op) ? oprec_i_if_a_a_opa_laq(sc) :
oprec_i_if_a_opa_laq_a(sc));
else {
sc->rec_stack = recur_make_stack(sc);
if (a_op)
sc->value =
(la_op) ? oprec_if_a_a_opa_laq(sc) :
oprec_if_a_a_opla_aq(sc);
else
sc->value =
(la_op) ? oprec_if_a_opa_laq_a(sc) :
oprec_if_a_opla_aq_a(sc);
sc->rec_loc = 0;
}
}
static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_RECUR_IF_A_A_opA_LAq);
if (opinit_if_a_a_opa_laq(sc, true, true, arg) == OPT_INT)
sc->value = make_integer(sc, oprec_i_if_a_a_opa_laq(sc));
else {
sc->rec_stack = recur_make_stack(sc);
sc->value = oprec_if_a_a_opa_laq(sc);
sc->rec_loc = 0;
}
return (sc->value);
}
static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme * sc, s7_pointer arg)
{
tick_tc(sc, OP_RECUR_IF_A_opA_LAq_A);
if (opinit_if_a_a_opa_laq(sc, false, true, arg) == OPT_INT)
sc->value = make_integer(sc, oprec_i_if_a_opa_laq_a(sc));
else {
sc->rec_stack = recur_make_stack(sc);
sc->value = oprec_if_a_opa_laq_a(sc);
sc->rec_loc = 0;
}
return (sc->value);
}
/* -------- cond_a_a_opa_laq -------- */
static void opinit_cond_a_a_opa_laq(s7_scheme * sc)
{
s7_pointer caller = opt3_pair(sc->code);
rec_set_test(sc, cadr(sc->code));
rec_set_res(sc, cdadr(sc->code));
rec_set_f1(sc, cdr(caller));
rec_set_f2(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_fn = fn_proc(caller);
}
static s7_pointer op_recur_cond_a_a_opa_laq(s7_scheme * sc)
{
opinit_cond_a_a_opa_laq(sc);
return (oprec_if_a_a_opa_laq(sc));
}
/* -------- if_a_a_opa_laaq and if_a_opa_laaq_a and cond_a_a_opa_laaq -------- */
enum { IF1A_LA2, IF2A_LA2, COND2A_LA2 };
static void opinit_if_a_a_opa_laaq(s7_scheme * sc, int32_t a_op)
{
s7_pointer caller = opt3_pair(sc->code);
rec_set_test(sc,
(a_op == COND2A_LA2) ? cadr(sc->code) : cdr(sc->code));
rec_set_res(sc,
(a_op ==
IF2A_LA2) ? cddr(sc->code) : ((a_op ==
IF1A_LA2) ? cdddr(sc->code)
: cdadr(sc->code)));
rec_set_f1(sc, cdr(caller));
rec_set_f2(sc, cdr(opt3_pair(caller)));
rec_set_f3(sc, cddr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
sc->rec_fn = fn_proc(caller);
}
static s7_pointer oprec_if_a_a_opa_laaq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
else {
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
set_car(sc->t2_2, oprec_if_a_a_opa_laaq(sc));
set_car(sc->t2_1, recur_pop(sc));
set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1));
}
set_car(sc->t2_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer oprec_if_a_opa_laaq_a(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) == sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
set_car(sc->t2_2, oprec_if_a_opa_laaq_a(sc));
set_car(sc->t2_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer op_recur_if_a_a_opa_laaq(s7_scheme * sc)
{
opinit_if_a_a_opa_laaq(sc, IF2A_LA2);
return (oprec_if_a_a_opa_laaq(sc));
}
static s7_pointer op_recur_if_a_opa_laaq_a(s7_scheme * sc)
{
opinit_if_a_a_opa_laaq(sc, IF1A_LA2);
return (oprec_if_a_opa_laaq_a(sc));
}
static s7_pointer op_recur_cond_a_a_opa_laaq(s7_scheme * sc)
{
opinit_if_a_a_opa_laaq(sc, COND2A_LA2);
return (oprec_if_a_a_opa_laaq(sc));
}
/* -------- if_a_a_opa_l3aq -------- */
static void opinit_if_a_a_opa_l3aq(s7_scheme * sc)
{
s7_pointer caller = opt3_pair(sc->code), l3a = cdr(opt3_pair(caller));
rec_set_test(sc, cdr(sc->code));
rec_set_res(sc, cddr(sc->code));
rec_set_f1(sc, cdr(caller));
rec_set_f2(sc, l3a);
rec_set_f3(sc, cdr(l3a));
rec_set_f4(sc, cddr(l3a));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
sc->rec_slot3 = next_slot(sc->rec_slot2);
sc->rec_fn = fn_proc(caller);
}
static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p));
slot_set_value(sc->rec_slot2, recur_pop(sc));
slot_set_value(sc->rec_slot1, recur_pop(sc));
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
else {
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p));
slot_set_value(sc->rec_slot2, recur_pop(sc));
slot_set_value(sc->rec_slot1, recur_pop(sc));
set_car(sc->t2_2, oprec_if_a_a_opa_l3aq(sc));
set_car(sc->t2_1, recur_pop(sc));
set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1));
}
set_car(sc->t2_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme * sc)
{
opinit_if_a_a_opa_l3aq(sc);
return (oprec_if_a_a_opa_l3aq(sc));
}
/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */
static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme * sc, bool a_op)
{
s7_pointer caller = opt3_pair(sc->code);
#if (!WITH_GMP)
s7_pointer c_op;
c_op = car(caller);
if ((is_symbol(c_op)) &&
((is_global(c_op)) ||
((is_slot(global_slot(c_op))) &&
(lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) {
s7_pointer s_func = global_value(c_op), slot =
let_slots(sc->curlet);
if (is_c_function(s_func)) {
sc->pc = 0;
sc->rec_test_o = sc->opts[0];
if (bool_optimize(sc, cdr(sc->code))) {
int32_t start_pc = sc->pc;
sc->rec_result_o = sc->opts[start_pc];
if (is_t_integer(slot_value(slot))) {
sc->rec_i_ii_f = s7_i_ii_function(s_func);
if ((sc->rec_i_ii_f) &&
(int_optimize
(sc,
(a_op) ? cddr(sc->code) : cdddr(sc->code)))) {
sc->rec_a1_o = sc->opts[sc->pc];
if (int_optimize(sc, cdadr(caller))) {
sc->rec_a2_o = sc->opts[sc->pc];
if (int_optimize(sc, cdr(opt3_pair(caller)))) {
sc->rec_val1 =
make_mutable_integer(sc,
integer(slot_value
(slot)));
slot_set_value(slot, sc->rec_val1);
if (sc->pc != 4)
return (OPT_INT);
sc->rec_fb1 = sc->rec_test_o->v[0].fb;
sc->rec_fi1 = sc->rec_result_o->v[0].fi;
sc->rec_fi2 = sc->rec_a1_o->v[0].fi;
sc->rec_fi3 = sc->rec_a2_o->v[0].fi;
return (OPT_INT_0);
}
}
}
}
if (is_t_real(slot_value(slot))) {
sc->rec_d_dd_f = s7_d_dd_function(s_func);
if (sc->rec_d_dd_f) {
sc->pc = start_pc;
sc->rec_result_o = sc->opts[start_pc];
if (float_optimize
(sc,
(a_op) ? cddr(sc->code) : cdddr(sc->code))) {
sc->rec_a1_o = sc->opts[sc->pc];
if (float_optimize(sc, cdadr(caller))) {
sc->rec_a2_o = sc->opts[sc->pc];
if (float_optimize
(sc, cdr(opt3_pair(caller)))) {
sc->rec_val1 =
s7_make_mutable_real(sc,
real
(slot_value
(slot)));
slot_set_value(slot, sc->rec_val1);
return (OPT_DBL);
}
}
}
}
}
}
}
}
#endif
rec_set_test(sc, cdr(sc->code));
rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code));
rec_set_f1(sc, cdadr(caller));
rec_set_f2(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_fn = fn_proc(caller);
return (OPT_PTR);
}
static s7_int oprec_i_if_a_a_opla_laq(s7_scheme * sc)
{
s7_int i1, i2;
if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) /* if_(A) */
return (sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */
i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */
integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); /* slot1 = a2 */
i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */
integer(sc->rec_val1) = i1; /* slot1 = a1 */
return (sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq(sc), i2)); /* call op(la1, la2) */
}
static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme * sc)
{
s7_int i1, i2;
if (sc->rec_fb1(sc->rec_test_o))
return (sc->rec_fi1(sc->rec_result_o));
i1 = sc->rec_fi2(sc->rec_a1_o);
integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o);
if (sc->rec_fb1(sc->rec_test_o))
i2 = sc->rec_fi1(sc->rec_result_o);
else {
s7_int i3;
i2 = sc->rec_fi2(sc->rec_a1_o);
integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o);
i3 = oprec_i_if_a_a_opla_laq_0(sc);
integer(sc->rec_val1) = i2;
i2 = sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i3);
}
integer(sc->rec_val1) = i1;
return (sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i2));
}
static s7_double oprec_d_if_a_a_opla_laq(s7_scheme * sc)
{
s7_double x1, x2;
if (sc->rec_test_o->v[0].fb(sc->rec_test_o))
return (sc->rec_result_o->v[0].fd(sc->rec_result_o));
x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o);
real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o);
if (sc->rec_test_o->v[0].fb(sc->rec_test_o))
x2 = sc->rec_result_o->v[0].fd(sc->rec_result_o);
else {
s7_double x3;
x2 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o);
real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o);
x3 = oprec_d_if_a_a_opla_laq(sc);
real(sc->rec_val1) = x2;
x2 = sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x3);
}
real(sc->rec_val1) = x1;
return (sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x2));
}
static s7_pointer oprec_if_a_a_opla_laq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot1,
recur_swap(sc, oprec_if_a_a_opla_laq(sc)));
set_car(sc->t2_1, oprec_if_a_a_opla_laq(sc));
set_car(sc->t2_2, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_int oprec_i_if_a_opla_laq_a(s7_scheme * sc)
{
s7_int i1, i2;
if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o)))
return (sc->rec_result_o->v[0].fi(sc->rec_result_o));
i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o);
integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o);
i2 = oprec_i_if_a_opla_laq_a(sc);
integer(sc->rec_val1) = i1;
return (sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a(sc), i2));
}
static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme * sc)
{
s7_int i1, i2;
if (!sc->rec_fb1(sc->rec_test_o))
return (sc->rec_fi1(sc->rec_result_o));
i1 = sc->rec_fi2(sc->rec_a1_o);
integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o);
if (!sc->rec_fb1(sc->rec_test_o))
i2 = sc->rec_fi1(sc->rec_result_o);
else {
s7_int i3;
i2 = sc->rec_fi2(sc->rec_a1_o);
integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o);
i3 = oprec_i_if_a_opla_laq_a_0(sc);
integer(sc->rec_val1) = i2;
i2 = sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i3);
}
integer(sc->rec_val1) = i1;
return (sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i2));
}
static s7_double oprec_d_if_a_opla_laq_a(s7_scheme * sc)
{
s7_double x1, x2;
if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o)))
return (sc->rec_result_o->v[0].fd(sc->rec_result_o));
x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o);
real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o);
x2 = oprec_d_if_a_opla_laq_a(sc);
real(sc->rec_val1) = x1;
return (sc->rec_d_dd_f(oprec_d_if_a_opla_laq_a(sc), x2));
}
static s7_pointer oprec_if_a_opla_laq_a(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) == sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot1,
recur_swap(sc, oprec_if_a_opla_laq_a(sc)));
set_car(sc->t2_1, oprec_if_a_opla_laq_a(sc));
set_car(sc->t2_2, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static void wrap_recur_if_a_a_opla_laq(s7_scheme * sc, bool a_op)
{
opt_pid_t choice;
tick_tc(sc, sc->cur_op);
choice = opinit_if_a_a_opla_laq(sc, a_op);
if ((choice == OPT_INT) || (choice == OPT_INT_0)) {
if (choice == OPT_INT_0)
sc->value =
make_integer(sc,
(a_op) ? oprec_i_if_a_a_opla_laq_0(sc) :
oprec_i_if_a_opla_laq_a_0(sc));
else
sc->value =
make_integer(sc,
(a_op) ? oprec_i_if_a_a_opla_laq(sc) :
oprec_i_if_a_opla_laq_a(sc));
} else if (choice == OPT_PTR) {
sc->rec_stack = recur_make_stack(sc);
sc->value =
(a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc);
sc->rec_loc = 0;
} else
sc->value =
make_real(sc,
(a_op) ? oprec_d_if_a_a_opla_laq(sc) :
oprec_d_if_a_opla_laq_a(sc));
}
/* -------- if_a_a_opa_la_laq and if_a_opa_la_laq_a -------- */
static void opinit_if_a_a_opa_la_laq(s7_scheme * sc, bool a_op)
{
s7_pointer caller = opt3_pair(sc->code);
rec_set_test(sc, cdr(sc->code));
rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code));
rec_set_f1(sc, cdr(caller));
rec_set_f2(sc, cdaddr(caller));
rec_set_f3(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_fn = fn_proc(caller);
}
static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1,
recur_swap(sc, oprec_if_a_a_opa_la_laq(sc)));
set_car(sc->t3_2, oprec_if_a_a_opa_la_laq(sc));
set_car(sc->t3_3, recur_pop(sc));
set_car(sc->t3_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t3_1));
}
static s7_pointer oprec_if_a_opa_la_laq_a(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) == sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1,
recur_swap(sc, oprec_if_a_opa_la_laq_a(sc)));
set_car(sc->t3_2, oprec_if_a_opa_la_laq_a(sc));
set_car(sc->t3_3, recur_pop(sc));
set_car(sc->t3_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t3_1));
}
static s7_pointer op_recur_if_a_a_opa_la_laq(s7_scheme * sc)
{
opinit_if_a_a_opa_la_laq(sc, true);
return (oprec_if_a_a_opa_la_laq(sc));
}
static s7_pointer op_recur_if_a_opa_la_laq_a(s7_scheme * sc)
{
opinit_if_a_a_opa_la_laq(sc, false);
return (oprec_if_a_opa_la_laq_a(sc));
}
/* -------- if_a_a_opla_la_laq -------- */
static void opinit_if_a_a_opla_la_laq(s7_scheme * sc, bool a_op)
{
s7_pointer caller = opt3_pair(sc->code);
rec_set_test(sc, cdr(sc->code));
rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code));
rec_set_f1(sc, cdadr(caller));
rec_set_f2(sc, cdaddr(caller));
rec_set_f3(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_fn = fn_proc(caller);
}
static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1,
recur_swap(sc, oprec_if_a_a_opla_la_laq(sc)));
recur_push(sc, oprec_if_a_a_opla_la_laq(sc));
slot_set_value(sc->rec_slot1, recur_ref(sc, 3));
set_car(sc->t3_1, oprec_if_a_a_opla_la_laq(sc));
set_car(sc->t3_2, recur_pop(sc));
set_car(sc->t3_3, recur_pop2(sc));
return (sc->rec_fn(sc, sc->t3_1));
}
static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme * sc)
{
opinit_if_a_a_opla_la_laq(sc, true);
return (oprec_if_a_a_opla_la_laq(sc));
}
/* -------- if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) --------
* esteemed reader, please ignore this nonsense!
* The opt_info version was not a lot faster -- ~/old/tak-st.c: say 10% faster. The current fx-based
* version has immediate lookups, and since the data is (ahem) simple, the GC is not a factor.
* The opt version has its own overheads, and has to do the same amount of stack manipulations.
*/
static s7_pointer rec_x(s7_scheme * sc, s7_pointer code)
{
return (slot_value(sc->rec_slot1));
}
static s7_pointer rec_y(s7_scheme * sc, s7_pointer code)
{
return (slot_value(sc->rec_slot2));
}
static s7_pointer rec_z(s7_scheme * sc, s7_pointer code)
{
return (slot_value(sc->rec_slot3));
}
static s7_pointer rec_sub_z1(s7_scheme * sc, s7_pointer code)
{
s7_pointer x = slot_value(sc->rec_slot3);
return ((is_t_integer(x)) ? make_integer(sc, integer(x) - 1) :
minus_c1(sc, x));
}
static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme * sc)
{
s7_pointer la1, la2, la3, caller = opt3_pair(sc->code);
rec_set_test(sc, cdr(sc->code));
rec_set_res(sc, cddr(sc->code));
la1 = cadr(caller);
la2 = caddr(caller);
la3 = opt3_pair(caller);
rec_set_f1(sc, cdr(la1));
rec_set_f2(sc, cddr(la1));
if (sc->rec_f2f == fx_u)
sc->rec_f2f = rec_y;
rec_set_f3(sc, cdddr(la1));
rec_set_f4(sc, cdr(la2));
rec_set_f5(sc, cddr(la2));
rec_set_f6(sc, cdddr(la2));
if (sc->rec_f6f == fx_t)
sc->rec_f6f = rec_x;
sc->rec_f7p = cdr(la3);
sc->rec_f7f = fx_proc(sc->rec_f7p);
sc->rec_f7p = car(sc->rec_f7p);
sc->rec_f8p = cddr(la3);
sc->rec_f8f = fx_proc(sc->rec_f8p);
if (sc->rec_f8f == fx_t)
sc->rec_f8f = rec_x;
sc->rec_f8p = car(sc->rec_f8p);
sc->rec_f9p = cdddr(la3);
sc->rec_f9f = fx_proc(sc->rec_f9p);
if (sc->rec_f9f == fx_u)
sc->rec_f9f = rec_y;
sc->rec_f9p = car(sc->rec_f9p);
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
sc->rec_slot3 = next_slot(sc->rec_slot2);
if (cadddr(la1) == slot_symbol(sc->rec_slot3))
sc->rec_f3f = rec_z;
if (caddr(la2) == slot_symbol(sc->rec_slot3))
sc->rec_f5f = rec_z;
if ((sc->rec_f7f == fx_subtract_s1)
&& (cadadr(la3) == slot_symbol(sc->rec_slot3)))
sc->rec_f7f = rec_sub_z1;
}
static s7_pointer oprec_if_a_a_lopl3a_l3a_l3aq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
recur_push(sc, sc->rec_f6f(sc, sc->rec_f6p));
recur_push(sc, sc->rec_f7f(sc, sc->rec_f7p));
recur_push(sc, sc->rec_f8f(sc, sc->rec_f8p));
slot_set_value(sc->rec_slot3, sc->rec_f9f(sc, sc->rec_f9p));
slot_set_value(sc->rec_slot2, recur_pop(sc));
slot_set_value(sc->rec_slot1, recur_pop(sc));
recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc));
slot_set_value(sc->rec_slot3, recur_ref(sc, 2));
slot_set_value(sc->rec_slot2, recur_ref(sc, 3));
slot_set_value(sc->rec_slot1, recur_ref(sc, 4));
recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc));
slot_set_value(sc->rec_slot3, recur_ref(sc, 6));
slot_set_value(sc->rec_slot2, recur_ref(sc, 7));
slot_set_value(sc->rec_slot1, recur_ref(sc, 8));
slot_set_value(sc->rec_slot1, oprec_if_a_a_lopl3a_l3a_l3aq(sc));
slot_set_value(sc->rec_slot2, recur_pop(sc));
slot_set_value(sc->rec_slot3, recur_pop(sc));
sc->rec_loc -= 6;
return (oprec_if_a_a_lopl3a_l3a_l3aq(sc));
}
static s7_pointer op_recur_if_a_a_lopl3a_l3a_l3aq(s7_scheme * sc)
{
opinit_if_a_a_lopl3a_l3a_l3aq(sc);
return (oprec_if_a_a_lopl3a_l3a_l3aq(sc));
}
/* -------- if_a_a_and_a_laa_laa -------- */
static void opinit_if_a_a_and_a_laa_laa(s7_scheme * sc, s7_pointer code)
{
s7_pointer la1, la2, caller = opt3_pair(code);
rec_set_test(sc, cdr(code));
rec_set_res(sc, cddr(code));
la1 = caddr(caller);
la2 = cadddr(caller);
rec_set_f1(sc, cdr(caller));
rec_set_f2(sc, cdr(la1));
rec_set_f3(sc, cddr(la1));
rec_set_f4(sc, cdr(la2));
rec_set_f5(sc, cddr(la2));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
}
static s7_pointer oprec_if_a_a_and_a_laa_laa(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
if (sc->rec_f1f(sc, sc->rec_f1p) == sc->F)
return (sc->F);
recur_push(sc, slot_value(sc->rec_slot1));
recur_push(sc, slot_value(sc->rec_slot2));
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
if (oprec_if_a_a_and_a_laa_laa(sc) == sc->F) {
sc->rec_loc -= 2;
return (sc->F);
}
slot_set_value(sc->rec_slot2, recur_pop(sc));
slot_set_value(sc->rec_slot1, recur_pop(sc));
recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
return (oprec_if_a_a_and_a_laa_laa(sc));
}
static s7_pointer op_recur_if_a_a_and_a_laa_laa(s7_scheme * sc)
{
opinit_if_a_a_and_a_laa_laa(sc, sc->code);
return (oprec_if_a_a_and_a_laa_laa(sc));
}
static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme * sc,
s7_pointer arg)
{
tick_tc(sc, OP_RECUR_IF_A_A_AND_A_LAA_LAA);
/* sc->curlet is set already and will be restored by the caller */
sc->rec_stack = recur_make_stack(sc);
opinit_if_a_a_and_a_laa_laa(sc, arg);
sc->value = oprec_if_a_a_and_a_laa_laa(sc);
sc->rec_loc = 0;
return (sc->value);
}
/* -------- cond_a_a_a_a_opla_laq -------- */
static void opinit_cond_a_a_a_a_opla_laq(s7_scheme * sc, s7_pointer code,
bool cond_case)
{
s7_pointer caller = opt3_pair(code);
if (cond_case) {
rec_set_test(sc, cadr(code));
rec_set_res(sc, cdadr(code));
rec_set_f1(sc, caddr(code));
rec_set_f2(sc, cdaddr(code));
} else {
rec_set_test(sc, cdr(code));
rec_set_res(sc, cddr(code)); /* (if a b...) */
rec_set_f1(sc, opt1_pair(code)); /* cdr(cadddr(code)), (if a b (if c d...)) */
rec_set_f2(sc, cdr(opt1_pair(code)));
}
rec_set_f3(sc, cdadr(caller));
rec_set_f4(sc, opt3_pair(caller));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_fn = fn_proc(caller);
}
static s7_pointer oprec_cond_a_a_a_a_opla_laq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F)
return (sc->rec_f2f(sc, sc->rec_f2p));
recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1, sc->rec_f4f(sc, sc->rec_f4p));
slot_set_value(sc->rec_slot1,
recur_swap(sc, oprec_cond_a_a_a_a_opla_laq(sc)));
set_car(sc->t2_1, oprec_cond_a_a_a_a_opla_laq(sc));
set_car(sc->t2_2, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer op_recur_cond_a_a_a_a_opla_laq(s7_scheme * sc)
{
opinit_cond_a_a_a_a_opla_laq(sc, sc->code, true);
return (oprec_cond_a_a_a_a_opla_laq(sc));
}
static s7_pointer op_recur_if_a_a_if_a_a_opla_laq(s7_scheme * sc)
{
opinit_cond_a_a_a_a_opla_laq(sc, sc->code, false);
return (oprec_cond_a_a_a_a_opla_laq(sc));
}
static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme * sc,
s7_pointer arg)
{
tick_tc(sc, OP_RECUR_COND_A_A_A_A_opLA_LAq);
sc->rec_stack = recur_make_stack(sc);
opinit_cond_a_a_a_a_opla_laq(sc, arg, true);
sc->value = oprec_cond_a_a_a_a_opla_laq(sc);
sc->rec_loc = 0;
return (sc->value);
}
/* -------- cond_a_a_a_a_oplaa_laaq -------- */
static void opinit_cond_a_a_a_a_oplaa_laaq(s7_scheme * sc, bool cond_case)
{
s7_pointer caller = opt3_pair(sc->code); /* cadr(cadddr(sc->code)) = (cfunc laa laa) */
if (cond_case) {
rec_set_test(sc, cadr(sc->code));
rec_set_res(sc, cdadr(sc->code));
rec_set_f1(sc, caddr(sc->code));
rec_set_f2(sc, cdaddr(sc->code));
} else {
rec_set_test(sc, cdr(sc->code));
rec_set_res(sc, cddr(sc->code)); /* (if a b...) */
rec_set_f1(sc, opt1_pair(sc->code)); /* cdr(cadddr(sc->code)), (if a b (if c d...)) */
rec_set_f2(sc, cdr(opt1_pair(sc->code)));
}
sc->rec_f3p = cdadr(caller);
rec_set_f4(sc, cdr(sc->rec_f3p));
sc->rec_f3f = fx_proc(sc->rec_f3p);
sc->rec_f3p = car(sc->rec_f3p);
sc->rec_f5p = opt3_pair(caller);
rec_set_f6(sc, cdr(sc->rec_f5p));
sc->rec_f5f = fx_proc(sc->rec_f5p);
sc->rec_f5p = car(sc->rec_f5p);
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
sc->rec_fn = fn_proc(caller);
}
static s7_pointer oprec_cond_a_a_a_a_oplaa_laaq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F)
return (sc->rec_f2f(sc, sc->rec_f2p));
recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
sc->value = oprec_cond_a_a_a_a_oplaa_laaq(sc); /* second laa arg */
slot_set_value(sc->rec_slot2, recur_pop(sc));
slot_set_value(sc->rec_slot1, recur_pop(sc));
recur_push_unchecked(sc, sc->value);
set_car(sc->t2_1, oprec_cond_a_a_a_a_oplaa_laaq(sc)); /* first laa arg */
set_car(sc->t2_2, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer op_recur_cond_a_a_a_a_oplaa_laaq(s7_scheme * sc)
{
opinit_cond_a_a_a_a_oplaa_laaq(sc, true);
return (oprec_cond_a_a_a_a_oplaa_laaq(sc));
}
static s7_pointer op_recur_if_a_a_if_a_a_oplaa_laaq(s7_scheme * sc)
{
opinit_cond_a_a_a_a_oplaa_laaq(sc, false);
return (oprec_cond_a_a_a_a_oplaa_laaq(sc));
}
/* -------- cond_a_a_a_a_opa_laaq -------- */
static void opinit_cond_a_a_a_a_opa_laaq(s7_scheme * sc)
{
s7_pointer caller = opt3_pair(sc->code);
rec_set_test(sc, cadr(sc->code));
rec_set_res(sc, cdadr(sc->code));
sc->rec_f1p = caddr(sc->code);
rec_set_f2(sc, cdr(sc->rec_f1p));
sc->rec_f1f = fx_proc(sc->rec_f1p);
sc->rec_f1p = car(sc->rec_f1p);
rec_set_f3(sc, cdr(caller));
rec_set_f4(sc, opt3_pair(caller));
rec_set_f5(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
sc->rec_fn = fn_proc(caller);
}
static s7_pointer oprec_cond_a_a_a_a_opa_laaq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F)
return (sc->rec_f2f(sc, sc->rec_f2p));
recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
set_car(sc->t2_2, oprec_cond_a_a_a_a_opa_laaq(sc));
set_car(sc->t2_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer op_recur_cond_a_a_a_a_opa_laaq(s7_scheme * sc)
{
opinit_cond_a_a_a_a_opa_laaq(sc);
return (oprec_cond_a_a_a_a_opa_laaq(sc));
}
/* -------- cond_a_a_a_laa_opa_laaq -------- */
static void opinit_cond_a_a_a_laa_opa_laaq(s7_scheme * sc, bool cond)
{
s7_pointer caller = opt3_pair(sc->code); /* opA_LAA */
rec_set_test(sc, (cond) ? cadr(sc->code) : cdr(sc->code));
rec_set_res(sc, (cond) ? cdadr(sc->code) : cddr(sc->code));
sc->rec_f1p = (cond) ? caddr(sc->code) : cdr(cadddr(sc->code));
sc->rec_f2p = cdadr(sc->rec_f1p);
rec_set_f3(sc, cdr(sc->rec_f2p));
sc->rec_f1f = fx_proc(sc->rec_f1p);
sc->rec_f1p = car(sc->rec_f1p);
sc->rec_f2f = fx_proc(sc->rec_f2p);
sc->rec_f2p = car(sc->rec_f2p);
rec_set_f4(sc, cdr(caller));
sc->rec_f5p = cdr(opt3_pair(caller)); /* (L)AA */
rec_set_f6(sc, cdr(sc->rec_f5p));
sc->rec_f5f = fx_proc(sc->rec_f5p);
sc->rec_f5p = car(sc->rec_f5p);
sc->rec_fn = fn_proc(caller);
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
}
static s7_pointer oprec_cond_a_a_a_laa_opa_laaq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) {
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
return (oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */
}
recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
else if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) {
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */
} else {
recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc));
set_car(sc->t2_1, recur_pop(sc));
set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1));
}
set_car(sc->t2_1, recur_pop(sc));
return (sc->rec_fn(sc, sc->t2_1));
}
static s7_pointer op_recur_cond_a_a_a_laa_opa_laaq(s7_scheme * sc)
{
opinit_cond_a_a_a_laa_opa_laaq(sc, true);
return (oprec_cond_a_a_a_laa_opa_laaq(sc));
}
static s7_pointer op_recur_if_a_a_if_a_laa_opa_laaq(s7_scheme * sc)
{ /* if version, same logic as cond above */
opinit_cond_a_a_a_laa_opa_laaq(sc, false);
return (oprec_cond_a_a_a_laa_opa_laaq(sc));
}
/* -------- cond_a_a_a_laa_lopa_laaq -------- */
static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme * sc)
{
s7_pointer caller = opt3_pair(sc->code);
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
#if (!WITH_GMP)
if ((is_t_integer(slot_value(sc->rec_slot1))) &&
(is_t_integer(slot_value(sc->rec_slot2)))) {
sc->pc = 0;
sc->rec_test_o = sc->opts[0];
if (bool_optimize(sc, cadr(sc->code))) {
sc->rec_result_o = sc->opts[sc->pc];
if (int_optimize(sc, cdadr(sc->code))) {
s7_pointer laa1 = caddr(sc->code);
sc->rec_a1_o = sc->opts[sc->pc];
if (bool_optimize(sc, laa1)) {
sc->rec_a2_o = sc->opts[sc->pc];
if (int_optimize(sc, cdadr(laa1))) {
sc->rec_a3_o = sc->opts[sc->pc];
if (int_optimize(sc, cddadr(laa1))) {
s7_pointer laa2 =
cadr(cadddr(sc->code)), laa3 = caddr(laa2);
sc->rec_a4_o = sc->opts[sc->pc];
if (int_optimize(sc, cdr(laa2))) {
sc->rec_a5_o = sc->opts[sc->pc];
if (int_optimize(sc, cdr(laa3))) {
sc->rec_a6_o = sc->opts[sc->pc];
if (int_optimize(sc, cddr(laa3))) {
sc->rec_val1 =
make_mutable_integer(sc,
integer
(slot_value
(sc->rec_slot1)));
slot_set_value(sc->rec_slot1,
sc->rec_val1);
sc->rec_val2 =
make_mutable_integer(sc,
integer
(slot_value
(sc->rec_slot2)));
slot_set_value(sc->rec_slot2,
sc->rec_val2);
if (sc->pc != 8)
return (OPT_INT);
sc->rec_fb1 =
sc->rec_test_o->v[0].fb;
sc->rec_fb2 =
sc->rec_a1_o->v[0].fb;
sc->rec_fi1 =
sc->rec_result_o->v[0].fi;
sc->rec_fi2 =
sc->rec_a2_o->v[0].fi;
sc->rec_fi3 =
sc->rec_a3_o->v[0].fi;
sc->rec_fi4 =
sc->rec_a4_o->v[0].fi;
sc->rec_fi5 =
sc->rec_a5_o->v[0].fi;
sc->rec_fi6 =
sc->rec_a6_o->v[0].fi;
return (OPT_INT_0);
}
}
}
}
}
}
}
}
}
#endif
rec_set_test(sc, cadr(sc->code));
rec_set_res(sc, cdadr(sc->code));
sc->rec_f1p = caddr(sc->code);
sc->rec_f2p = cdadr(sc->rec_f1p);
rec_set_f3(sc, cdr(sc->rec_f2p));
sc->rec_f1f = fx_proc(sc->rec_f1p);
sc->rec_f1p = car(sc->rec_f1p);
sc->rec_f2f = fx_proc(sc->rec_f2p);
sc->rec_f2p = car(sc->rec_f2p);
rec_set_f4(sc, cdr(caller));
sc->rec_f5p = opt3_pair(caller);
rec_set_f6(sc, cdr(sc->rec_f5p));
sc->rec_f5f = fx_proc(sc->rec_f5p);
sc->rec_f5p = car(sc->rec_f5p);
return (OPT_PTR);
}
static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme * sc)
{
s7_int i1, i2;
if (sc->rec_test_o->v[0].fb(sc->rec_test_o))
return (sc->rec_result_o->v[0].fi(sc->rec_result_o));
if (sc->rec_a1_o->v[0].fb(sc->rec_a1_o)) {
i1 = sc->rec_a2_o->v[0].fi(sc->rec_a2_o);
integer(sc->rec_val2) = sc->rec_a3_o->v[0].fi(sc->rec_a3_o);
integer(sc->rec_val1) = i1;
return (oprec_i_cond_a_a_a_laa_lopa_laaq(sc));
}
i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o);
i2 = sc->rec_a5_o->v[0].fi(sc->rec_a5_o);
integer(sc->rec_val2) = sc->rec_a6_o->v[0].fi(sc->rec_a6_o);
integer(sc->rec_val1) = i2;
integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq(sc);
integer(sc->rec_val1) = i1;
return (oprec_i_cond_a_a_a_laa_lopa_laaq(sc));
}
static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq_0(s7_scheme * sc)
{
s7_int i1, i2;
if (sc->rec_fb1(sc->rec_test_o))
return (sc->rec_fi1(sc->rec_result_o));
if (sc->rec_fb2(sc->rec_a1_o)) {
i1 = sc->rec_fi2(sc->rec_a2_o);
integer(sc->rec_val2) = sc->rec_fi3(sc->rec_a3_o);
integer(sc->rec_val1) = i1;
return (oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc));
}
i1 = sc->rec_fi4(sc->rec_a4_o);
i2 = sc->rec_fi5(sc->rec_a5_o);
integer(sc->rec_val2) = sc->rec_fi6(sc->rec_a6_o);
integer(sc->rec_val1) = i2;
integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc);
integer(sc->rec_val1) = i1;
return (oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc));
}
static s7_pointer oprec_cond_a_a_a_laa_lopa_laaq(s7_scheme * sc)
{
if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
return (sc->rec_resf(sc, sc->rec_resp));
if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) {
recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
return (oprec_cond_a_a_a_laa_lopa_laaq(sc));
}
recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
slot_set_value(sc->rec_slot2, oprec_cond_a_a_a_laa_lopa_laaq(sc));
slot_set_value(sc->rec_slot1, recur_pop(sc));
return (oprec_cond_a_a_a_laa_lopa_laaq(sc));
}
static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme * sc)
{
opt_pid_t choice;
tick_tc(sc, sc->cur_op);
choice = opinit_cond_a_a_a_laa_lopa_laaq(sc);
if (choice != OPT_PTR)
sc->value =
make_integer(sc,
(choice ==
OPT_INT) ? oprec_i_cond_a_a_a_laa_lopa_laaq(sc) :
oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc));
else {
sc->rec_stack = recur_make_stack(sc);
sc->value = oprec_cond_a_a_a_laa_lopa_laaq(sc);
sc->rec_loc = 0;
}
}
/* -------- and_a_or_a_laa_laa -------- */
static void opinit_and_a_or_a_laa_laa(s7_scheme * sc, s7_pointer code)
{
s7_pointer orp = cdr(opt3_pair(code));
rec_set_test(sc, cdr(code));
rec_set_res(sc, orp);
rec_set_f1(sc, cdr(cadr(orp)));
rec_set_f2(sc, cddr(cadr(orp)));
rec_set_f3(sc, cdr(caddr(orp)));
rec_set_f4(sc, cddr(caddr(orp)));
sc->rec_slot1 = let_slots(sc->curlet);
sc->rec_slot2 = next_slot(sc->rec_slot1);
}
static s7_pointer oprec_and_a_or_a_laa_laa(s7_scheme * sc)
{
s7_pointer p;
if (sc->rec_testf(sc, sc->rec_testp) == sc->F)
return (sc->F);
p = sc->rec_resf(sc, sc->rec_resp);
if (p != sc->F)
return (p);
recur_push(sc, slot_value(sc->rec_slot1));
recur_push(sc, slot_value(sc->rec_slot2));
recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
slot_set_value(sc->rec_slot2, sc->rec_f2f(sc, sc->rec_f2p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
p = oprec_and_a_or_a_laa_laa(sc);
if (p != sc->F) {
sc->rec_loc -= 2;
return (p);
}
slot_set_value(sc->rec_slot2, recur_pop(sc));
slot_set_value(sc->rec_slot1, recur_pop(sc));
recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
slot_set_value(sc->rec_slot2, sc->rec_f4f(sc, sc->rec_f4p));
slot_set_value(sc->rec_slot1, recur_pop(sc));
return (oprec_and_a_or_a_laa_laa(sc));
}
static s7_pointer op_recur_and_a_or_a_laa_laa(s7_scheme * sc)
{
opinit_and_a_or_a_laa_laa(sc, sc->code);
return (oprec_and_a_or_a_laa_laa(sc));
}
static s7_pointer fx_recur_and_a_or_a_laa_laa(s7_scheme * sc,
s7_pointer arg)
{
tick_tc(sc, OP_RECUR_AND_A_OR_A_LAA_LAA);
sc->rec_stack = recur_make_stack(sc);
opinit_and_a_or_a_laa_laa(sc, arg);
sc->value = oprec_and_a_or_a_laa_laa(sc);
sc->rec_loc = 0;
return (sc->value);
}
static void wrap_recur(s7_scheme * sc, s7_pointer(*recur) (s7_scheme * sc))
{
tick_tc(sc, sc->cur_op);
sc->rec_stack = recur_make_stack(sc);
sc->value = recur(sc);
sc->rec_loc = 0;
}
/* -------------------------------- */
static void op_safe_c_p(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_no_args_direct(sc, OP_SAFE_C_P_1);
sc->code = T_Pair(cadr(sc->code));
}
static void op_safe_c_p_1(s7_scheme * sc)
{
set_car(sc->t1_1, sc->value);
sc->value = fn_proc(sc->code) (sc, sc->t1_1);
}
static void op_safe_c_ssp(s7_scheme * sc)
{
check_stack_size(sc);
push_stack_no_args_direct(sc, OP_SAFE_C_SSP_1);
sc->code = opt3_pair(sc->code);
}
static void op_safe_c_ssp_1(s7_scheme * sc)
{
set_car(sc->t3_3, sc->value);
set_car(sc->t3_1, lookup(sc, cadr(sc->code)));
set_car(sc->t3_2, lookup(sc, caddr(sc->code)));
sc->value = fn_proc(sc->code) (sc, sc->t3_1);
}
static void op_safe_c_ssp_mv_1(s7_scheme * sc)
{
sc->args = cons_unchecked(sc, lookup(sc, cadr(sc->code)), cons(sc, lookup(sc, caddr(sc->code)), sc->value)); /* not ulist here */
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static s7_pointer op_c_s_opsq(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code), val;
val = lookup(sc, car(args));
set_car(sc->t1_1, lookup(sc, opt1_sym(args)));
sc->args = list_2(sc, val, fn_proc(cadr(args)) (sc, sc->t1_1));
return (fn_proc(sc->code) (sc, sc->args));
}
static inline void op_s(s7_scheme * sc)
{
sc->code = lookup(sc, car(sc->code));
if (!is_applicable(sc->code))
apply_error(sc, sc->code, sc->nil);
sc->args = sc->nil; /* op_s -> apply, so we'll apply sc->code to sc->args */
}
static s7_pointer op_s_c(s7_scheme * sc)
{
s7_pointer code = sc->code;
sc->code = lookup_checked(sc, car(code));
if (!is_applicable(sc->code))
apply_error(sc, sc->code, cdr(code));
sc->args =
(needs_copied_args(sc->code)) ? list_1(sc,
cadr(code)) :
set_plist_1(sc, cadr(code));
return (NULL);
}
static Inline bool op_s_s(s7_scheme * sc)
{
s7_pointer code = sc->code;
sc->code = lookup_checked(sc, car(code));
if ((is_c_function(sc->code)) &&
(c_function_required_args(sc->code) == 1) &&
(!needs_copied_args(sc->code))) {
set_car(sc->t1_1, lookup(sc, cadr(code)));
sc->value = c_function_call(sc->code) (sc, sc->t1_1);
return (true); /* goto START; */
}
if (!is_applicable(sc->code))
apply_error(sc, sc->code, cdr(code));
if (dont_eval_args(sc->code))
sc->args = list_1(sc, cadr(code));
else
sc->args =
(needs_copied_args(sc->code)) ? list_1(sc,
lookup(sc,
cadr(code))) :
set_plist_1(sc, lookup(sc, cadr(code)));
return (false); /* goto APPLY; */
}
static void op_x_a(s7_scheme * sc, s7_pointer f)
{
s7_pointer code = sc->code;
sc->code = f;
if (!is_applicable(sc->code))
apply_error(sc, sc->code, cdr(code));
if (dont_eval_args(sc->code))
sc->args = list_1(sc, cadr(code));
else if (!needs_copied_args(sc->code))
sc->args = set_plist_1(sc, fx_call(sc, cdr(code)));
else {
sc->args = fx_call(sc, cdr(code));
sc->args = list_1(sc, sc->args);
}
}
static void op_x_aa(s7_scheme * sc, s7_pointer f)
{
s7_pointer code = sc->code;
sc->code = f;
if (!is_applicable(sc->code))
apply_error(sc, sc->code, cdr(code));
if (dont_eval_args(sc->code))
sc->args = list_2(sc, cadr(code), caddr(code));
else {
sc->args = fx_call(sc, cddr(code));
if (!needs_copied_args(sc->code))
sc->args = set_plist_2(sc, fx_call(sc, cdr(code)), sc->args);
else {
sc->args = list_1(sc, sc->args);
sc->value = fx_call(sc, cdr(code));
sc->args = cons(sc, sc->value, sc->args);
}
}
}
static void op_p_s_1(s7_scheme * sc)
{
/* we get multiple values here (from op calc = "p" not "s") but don't need to handle it ourselves:
* let v be #(#_abs), so ((v 0) -2), (v 0 -2), ((values v 0) -2), and (((values v 0)) -2) are all 2
* or: (define (f1) (values vector-ref (vector 1 2 3))) (define arg 1) (define (f2) ((f1) arg)) (f2) (f2)
* so apply calls apply_pair which handles multiple values explicitly.
*/
if (dont_eval_args(sc->value))
sc->args = cdr(sc->code);
else {
sc->args = lookup_checked(sc, cadr(sc->code));
if (needs_copied_args(sc->value))
sc->args = list_1(sc, sc->args);
else
sc->args = set_plist_1(sc, sc->args);
}
sc->code = sc->value; /* goto APPLY */
}
static void op_safe_c_star_na(s7_scheme * sc)
{
s7_pointer args, p;
sc->args =
safe_list_if_possible(sc, integer(opt3_arglen(cdr(sc->code))));
for (args = cdr(sc->code), p = sc->args; is_pair(args);
args = cdr(args), p = cdr(p))
set_car(p, fx_call(sc, args));
sc->code = opt1_cfunc(sc->code);
apply_c_function_star(sc);
clear_list_in_use(sc->args);
}
static void op_safe_c_star(s7_scheme * sc)
{
sc->code = opt1_cfunc(sc->code);
apply_c_function_star_fill_defaults(sc, 0);
}
static void op_safe_c_star_a(s7_scheme * sc)
{
s7_pointer p;
p = fx_call(sc, cdr(sc->code));
if (is_keyword(p))
s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, value_is_missing_string, car(sc->code),
p));
/* scheme-level define* here also gives "not a parameter name" */
sc->args = list_1(sc, p);
sc->code = opt1_cfunc(sc->code);
/* one arg, so it's not a keyword; all we need to do is fill in the default */
apply_c_function_star_fill_defaults(sc, 1);
}
static void op_safe_c_star_aa(s7_scheme * sc)
{
sc->temp1 = fx_call(sc, cdr(sc->code)); /* temp1 use in optimizer, various do loops */
set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
set_car(sc->t2_1, sc->temp1);
sc->temp1 = sc->nil;
sc->args = sc->t2_1;
sc->code = opt1_cfunc(sc->code);
apply_c_function_star(sc);
}
static void op_safe_c_ps(s7_scheme * sc)
{
push_stack_no_args_direct(sc, OP_SAFE_C_PS_1); /* got to wait in this case */
sc->code = cadr(sc->code);
}
static void op_safe_c_ps_1(s7_scheme * sc)
{
set_car(sc->t2_2, lookup(sc, caddr(sc->code)));
set_car(sc->t2_1, sc->value);
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
}
static void op_safe_c_ps_mv(s7_scheme * sc)
{ /* (define (hi a) (+ (values 1 2) a)) */
sc->args =
pair_append(sc, sc->value,
list_1(sc, lookup(sc, caddr(sc->code))));
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static void op_safe_c_sp(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code);
check_stack_size(sc);
push_stack(sc, (opcode_t) opt1_any(args), lookup(sc, car(args)),
sc->code);
sc->code = cadr(args);
}
static void op_safe_c_sp_1(s7_scheme * sc)
{
/* we get here from many places (op_safe_c_sp for example), but all are safe */
set_car(sc->t2_1, sc->args);
set_car(sc->t2_2, sc->value);
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
}
static void op_safe_c_sp_mv(s7_scheme * sc)
{
sc->args = cons(sc, sc->args, sc->value); /* not ulist */
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static void op_safe_add_sp_1(s7_scheme * sc)
{
if ((is_t_integer(sc->args)) && (is_t_integer(sc->value)))
sc->value =
add_if_overflow_to_real_or_big_integer(sc, integer(sc->args),
integer(sc->value));
else
sc->value = add_p_pp(sc, sc->args, sc->value);
}
static void op_safe_multiply_sp_1(s7_scheme * sc)
{
if ((is_t_real(sc->args)) && (is_t_real(sc->value)))
sc->value = make_real(sc, real(sc->args) * real(sc->value));
else
sc->value = multiply_p_pp(sc, sc->args, sc->value);
}
static void op_safe_c_pc(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code);
check_stack_size(sc); /* b dyn */
push_stack(sc, OP_SAFE_C_PC_1, opt3_con(args), sc->code);
sc->code = car(args);
}
static void op_safe_c_pc_mv(s7_scheme * sc)
{
sc->args = pair_append(sc, sc->value, list_1(sc, sc->args)); /* not plist! */
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static void op_safe_c_pc_1(s7_scheme * sc)
{
set_car(sc->t2_1, sc->value);
set_car(sc->t2_2, sc->args);
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
}
static void op_safe_c_cp(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code);
/* it's possible in a case like this to overflow the stack -- s7test has a deeply
* nested expression involving (+ c (+ c (+ ... ))) all opt'd as safe_c_cp -- if we're close
* to the stack end at the start, it runs off the end. Normally the stack increase in
* the reader protects us, but a call/cc can replace the original stack with a much smaller one.
*/
check_stack_size(sc);
push_stack(sc, (opcode_t) opt1_any(args), opt3_any(args), sc->code); /* to safe_add_sp_1 for example */
sc->code = cadr(args);
}
static Inline void op_safe_c_s(s7_scheme * sc)
{
set_car(sc->t1_1, lookup(sc, cadr(sc->code)));
sc->value = fn_proc(sc->code) (sc, sc->t1_1);
}
static Inline void op_safe_c_ss(s7_scheme * sc)
{
set_car(sc->t2_1, lookup(sc, cadr(sc->code)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(sc->code))));
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
}
static void op_safe_c_sc(s7_scheme * sc)
{
set_car(sc->t2_1, lookup(sc, cadr(sc->code)));
set_car(sc->t2_2, opt2_con(cdr(sc->code)));
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
}
static void op_cl_a(s7_scheme * sc)
{
set_car(sc->t1_1, fx_call(sc, cdr(sc->code)));
sc->value = fn_proc(sc->code) (sc, sc->t1_1);
}
static void op_cl_aa(s7_scheme * sc)
{
gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code)));
set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
set_car(sc->t2_1, T_Pos(stack_protected1(sc)));
unstack(sc);
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
}
static void op_cl_fa(s7_scheme * sc)
{
s7_pointer code = cdadr(sc->code);
set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
set_car(sc->t2_1,
make_closure(sc, car(code), cdr(code),
T_CLOSURE | ((is_symbol(car(code))) ? T_COPY_ARGS
: 0), CLOSURE_ARITY_NOT_SET));
/* arg1 lambda can be any arity, but it must be applicable to one arg (the "a" above) */
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
}
static void op_map_for_each_fa(s7_scheme * sc)
{
s7_pointer f = cddr(sc->code), code = sc->code;
sc->value = fx_call(sc, f);
if (is_null(sc->value))
sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil;
else {
sc->code = opt3_pair(code); /* cdadr(code); */
f = inline_make_closure(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 1); /* arity=1 checked in optimizer */
sc->value =
(fn_proc_unchecked(code)) ? g_for_each_closure(sc, f,
sc->value) :
g_map_closure(sc, f, sc->value);
}
}
static void op_map_for_each_faa(s7_scheme * sc)
{
s7_pointer f = cddr(sc->code), code = sc->code;
sc->value = fx_call(sc, f);
sc->args = fx_call(sc, cdr(f));
if ((is_null(sc->value)) || (is_null(sc->args)))
sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil;
else {
sc->code = opt3_pair(code); /* cdadr(code); */
f = inline_make_closure(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 2); /* arity=2 checked in optimizer */
sc->value =
(fn_proc_unchecked(code)) ? g_for_each_closure_2(sc, f,
sc->value,
sc->args) :
g_map_closure_2(sc, f, sc->value, sc->args);
}
}
static void op_cl_na(s7_scheme * sc)
{
s7_pointer args, p, val;
val = safe_list_if_possible(sc, integer(opt3_arglen(cdr(sc->code))));
if (in_heap(val))
gc_protect_via_stack(sc, val);
for (args = cdr(sc->code), p = val; is_pair(args);
args = cdr(args), p = cdr(p))
set_car(p, fx_call(sc, args));
sc->value = fn_proc(sc->code) (sc, val);
if (in_heap(val)) {
/* the fn_proc call might push its own op (e.g. for-each/map) so we have to check for that */
if (main_stack_op(sc) == OP_GC_PROTECT)
unstack(sc);
} else
clear_list_in_use(val);
}
static void op_cl_sas(s7_scheme * sc)
{
set_car(sc->t3_2, fx_call(sc, cddr(sc->code)));
set_car(sc->t3_1, lookup(sc, cadr(sc->code)));
set_car(sc->t3_3, lookup(sc, cadddr(sc->code)));
sc->value = fn_proc(sc->code) (sc, sc->t3_1);
}
static void op_safe_c_pp(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code);
check_stack_size(sc);
/* has_fx check here is slower, we assume car(args) below is a pair (else cp/sp/ap?) */
if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) {
sc->args = fx_proc_unchecked(args) (sc, car(args));
push_stack_direct(sc, (opcode_t) opt1_any(args)); /* args = first value, func(args, value) if no mv */
sc->code = cadr(args);
} else {
push_stack_no_args_direct(sc, OP_SAFE_C_PP_1); /* first arg = p, if mv -> op_safe_c_pp_3 */
sc->code = car(args);
}
}
static void op_safe_c_pp_1(s7_scheme * sc)
{
/* it is much slower to check has_gx here! */
push_stack(sc, (opcode_t) opt1_any(cdr(sc->code)), sc->value, sc->code); /* args[i.e. sc->value] = first value, func(args, value) if no mv */
sc->code = caddr(sc->code);
}
static void op_safe_c_pp_3_mv(s7_scheme * sc)
{
/* we get here if the first arg returned multiple values */
push_stack(sc, OP_SAFE_C_PP_5, copy_proper_list(sc, sc->value), sc->code); /* copy is needed here */
sc->code = caddr(sc->code);
}
static void op_safe_c_pp_5(s7_scheme * sc)
{
/* 1 mv, 2 normal (else mv->6), sc->args was copied above (and this is a safe c function so its args are in no danger) */
if (is_null(sc->args))
sc->args = list_1(sc, sc->value); /* plist here and below, but this is almost never called */
else {
s7_pointer p;
for (p = sc->args; is_pair(cdr(p)); p = cdr(p));
set_cdr(p, list_1(sc, sc->value));
}
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static void op_safe_c_pp_6_mv(s7_scheme * sc)
{
/* both args mv */
sc->args = pair_append(sc, sc->args, sc->value);
/*
* fn_proc(sc->code) here is g_add_2, but we have any number of args from a values call
* the original (unoptimized) function is (hopefully) c_function_base(opt1_cfunc(sc->code))?
* (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10
*/
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static void op_safe_c_3p(s7_scheme * sc)
{
/* check_stack_size(sc); */
push_stack_no_args_direct(sc, OP_SAFE_C_3P_1);
sc->code = cadr(sc->code);
}
static void op_safe_c_3p_1(s7_scheme * sc)
{
sc->args = sc->value; /* possibly fx/gx? and below */
push_stack_direct(sc, OP_SAFE_C_3P_2);
sc->code = caddr(sc->code);
}
static void op_safe_c_3p_1_mv(s7_scheme * sc)
{ /* here only if sc->value is mv */
sc->args = sc->value;
push_stack_direct(sc, OP_SAFE_C_3P_2_MV);
sc->code = caddr(sc->code);
}
static void op_safe_c_3p_2(s7_scheme * sc)
{
gc_protect_via_stack(sc, sc->value);
push_stack_direct(sc, OP_SAFE_C_3P_3);
sc->code = cadddr(sc->code);
}
static void op_safe_c_3p_2_mv(s7_scheme * sc)
{ /* here from 1 + 2mv, or 1_mv with 2 or 2mv */
gc_protect_via_stack(sc, sc->value);
push_stack_direct(sc, OP_SAFE_C_3P_3_MV);
sc->code = cadddr(sc->code);
}
static void op_safe_c_3p_3(s7_scheme * sc)
{
set_car(sc->t3_3, sc->value);
set_car(sc->t3_1, sc->args);
set_car(sc->t3_2, stack_protected1(sc));
unstack(sc);
sc->value = fn_proc(sc->code) (sc, sc->t3_1);
}
static void op_safe_c_3p_3_mv(s7_scheme * sc)
{
s7_pointer p1, p2, p3, p, ps1;
if ((is_pair(sc->args)) && (car(sc->args) == sc->unused))
p1 = cdr(sc->args);
else
p1 = list_1(sc, sc->args);
ps1 = stack_protected1(sc);
if ((is_pair(ps1)) && (car(ps1) == sc->unused))
p2 = cdr(ps1);
else
p2 = list_1(sc, ps1);
if ((is_pair(sc->value)) && (car(sc->value) == sc->unused))
p3 = cdr(sc->value);
else
p3 = list_1(sc, sc->value);
unstack(sc);
for (p = p1; is_pair(cdr(p)); p = cdr(p));
set_cdr(p, p2);
for (p = cdr(p); is_pair(cdr(p)); p = cdr(p));
set_cdr(p, p3);
sc->args = p1;
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static Inline bool collect_np_args(s7_scheme * sc, opcode_t op,
s7_pointer args)
{
s7_pointer p;
sc->args = args;
for (p = sc->code; is_pair(p); p = cdr(p))
if (has_fx(p))
sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */
else if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1))
sc->args = cons(sc, sc->value =
fx_proc_unchecked(p) (sc, car(p)), sc->args);
else {
push_stack(sc, op, sc->args, cdr(p));
sc->code = T_Pair(car(p));
return (true);
}
return (false);
}
static bool op_any_c_np(s7_scheme * sc)
{ /* code: (func . args) where at least one arg is not fxable */
s7_pointer p;
sc->args = sc->nil;
for (p = cdr(sc->code); is_pair(p); p = cdr(p))
if (has_fx(p))
sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */
else if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1))
sc->args = cons(sc, sc->value =
fx_proc_unchecked(p) (sc, car(p)), sc->args);
else {
if (sc->op_stack_now >= sc->op_stack_end)
resize_op_stack(sc);
push_op_stack(sc, sc->code);
check_stack_size(sc);
push_stack(sc, ((intptr_t)
((is_pair(cdr(p))) ? OP_ANY_C_NP_1 :
OP_ANY_C_NP_2)), sc->args, cdr(p));
sc->code = T_Pair(car(p));
return (true);
}
/* here fx/gx got all the args */
sc->args = proper_list_reverse_in_place(sc, sc->args);
sc->value = fn_proc(sc->code) (sc, sc->args);
return (false);
}
static Inline bool op_any_c_np_1(s7_scheme * sc)
{
/* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is on op-stack */
if (collect_np_args(sc, OP_ANY_C_NP_1, cons(sc, sc->value, sc->args)))
return (true);
sc->args = proper_list_reverse_in_place(sc, sc->args);
sc->code = pop_op_stack(sc);
sc->value = fn_proc(sc->code) (sc, sc->args);
return (false);
}
static void op_any_c_np_2(s7_scheme * sc)
{
sc->args = proper_list_reverse_in_place(sc, sc->args =
cons(sc, sc->value, sc->args));
sc->code = pop_op_stack(sc);
sc->value = fn_proc(sc->code) (sc, sc->args);
}
static s7_pointer revappend(s7_scheme * sc, s7_pointer a, s7_pointer b)
{
/* (map (lambda (x) (if (odd? x) (apply values '(1 2 3)) (values))) (list 1 2 3 4)) is a bad case -- we have to copy the incoming list (in op_map_gather) */
s7_pointer p = b, q;
if (is_not_null(a)) {
a = copy_proper_list(sc, a);
do { /* while (is_not_null(a)) */
q = cdr(a);
set_cdr(a, p);
p = a;
a = q;
}
while (is_pair(a));
}
return (p);
}
static bool op_any_c_np_mv_1(s7_scheme * sc)
{
/* we're looping through fp cases here, so sc->value can be non-mv after the first */
if (collect_np_args
(sc, OP_ANY_C_NP_MV_1,
(is_multiple_value(sc->value)) ? revappend(sc, sc->value,
sc->args) : cons(sc,
sc->value,
sc->args)))
return (true);
sc->args = proper_list_reverse_in_place(sc, sc->args);
sc->code = pop_op_stack(sc);
sc->code = c_function_base(opt1_cfunc(sc->code));
return (false);
}
static void op_any_closure_np(s7_scheme * sc)
{
s7_pointer p;
check_stack_size(sc);
if (sc->op_stack_now >= sc->op_stack_end)
resize_op_stack(sc);
push_op_stack(sc, sc->code);
p = cdr(sc->code);
if (has_fx(p)) {
sc->args = fx_call(sc, p);
sc->args = list_1(sc, sc->args);
for (p = cdr(p); (is_pair(p)) && (has_fx(p)); p = cdr(p))
sc->args = cons_unchecked(sc, fx_call(sc, p), sc->args);
} else
sc->args = sc->nil;
push_stack(sc, ((intptr_t)
((is_pair(cdr(p))) ? OP_ANY_CLOSURE_NP_1 :
OP_ANY_CLOSURE_NP_2)), sc->args, cdr(p));
sc->code = T_Pair(car(p));
}
static void op_any_closure_np_end(s7_scheme * sc)
{
s7_pointer x, z, f;
uint64_t id;
sc->args = proper_list_reverse_in_place(sc, sc->args); /* needed in either case -- closure_args(f) is not reversed */
sc->code = pop_op_stack(sc);
f = opt1_lambda(sc->code);
if (is_safe_closure(f)) {
id = ++sc->let_number;
set_curlet(sc, closure_let(f));
let_set_id(sc->curlet, id);
for (x = let_slots(sc->curlet), z = sc->args; tis_slot(x);
x = next_slot(x)) {
s7_pointer nz;
slot_set_value(x, car(z));
symbol_set_local_slot(slot_symbol(x), id, x);
nz = cdr(z);
free_cell(sc, z);
z = nz;
}
if (tis_slot(x))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, not_enough_arguments_string, sc->code,
sc->args));
} else {
s7_pointer e, p, last_slot;
e = make_let(sc, closure_let(f));
sc->z = e;
id = let_id(e);
p = closure_args(f);
last_slot = make_slot(sc, car(p), car(sc->args));
slot_set_next(last_slot, slot_end(sc));
let_set_slots(e, last_slot);
symbol_set_local_slot(car(p), id, last_slot);
z = cdr(sc->args);
free_cell(sc, sc->args);
for (p = cdr(p); is_pair(p); p = cdr(p)) {
s7_pointer nz;
last_slot = add_slot_at_end(sc, id, last_slot, car(p), car(z)); /* sets last_slot */
nz = cdr(z);
free_cell(sc, z);
z = nz;
}
set_curlet(sc, e);
sc->z = sc->nil;
if (is_pair(p))
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, not_enough_arguments_string, sc->code,
sc->args));
}
if (is_pair(z)) /* these checks are needed because multiple-values might evade earlier arg num checks */
s7_error(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, too_many_arguments_string, sc->code,
sc->args));
f = closure_body(f);
if (is_pair(cdr(f)))
push_stack_no_args(sc, sc->begin_op, cdr(f));
sc->code = car(f);
}
static bool op_safe_c_ap(s7_scheme * sc)
{
s7_pointer val, code = cdr(sc->code);
val = cdr(code);
if ((has_gx(val)) && (symbol_ctr(caar(val)) == 1)) {
val = fx_proc_unchecked(val) (sc, car(val));
gc_protect_via_stack(sc, val);
set_car(sc->t2_1, fx_call(sc, code));
set_car(sc->t2_2, val);
unstack(sc);
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
return (false);
}
check_stack_size(sc);
sc->args = fx_call(sc, code);
push_stack_direct(sc, (opcode_t) opt1_any(code)); /* safe_c_sp cases, mv->safe_c_sp_mv */
sc->code = car(val);
return (true);
}
static bool op_safe_c_pa(s7_scheme * sc)
{
s7_pointer args = cdr(sc->code);
if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) {
s7_pointer val;
val = fx_proc_unchecked(args) (sc, car(args));
gc_protect_via_stack(sc, val);
set_car(sc->t2_2, fx_call(sc, cdr(args)));
set_car(sc->t2_1, val);
unstack(sc);
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
return (false);
}
check_stack_size(sc);
push_stack_no_args(sc, OP_SAFE_C_PA_1, sc->code);
sc->code = car(args);
return (true);
}
static void op_safe_c_pa_1(s7_scheme * sc)
{
s7_pointer val = sc->value;
gc_protect_via_stack(sc, val); /* not a temp */
set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
set_car(sc->t2_1, val);
unstack(sc);
sc->value = fn_proc(sc->code) (sc, sc->t2_1);
}
static void op_safe_c_pa_mv(s7_scheme * sc)
{
s7_pointer p, val;
val = copy_proper_list(sc, sc->value); /* this is necessary since the fx_proc below can clobber sc->value */
gc_protect_via_stack(sc, val);
for (p = val; is_pair(cdr(p)); p = cdr(p)); /* must be more than 1 member of list or it's not mv */
sc->args = fx_call(sc, cddr(sc->code));
cdr(p) = set_plist_1(sc, sc->args); /* do we need to copy sc->args if it is immutable (i.e. plist)? */
sc->args = val;
unstack(sc);
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static void op_safe_c_opsq_p(s7_scheme * sc)
{
s7_pointer args = cadr(sc->code);
check_stack_size(sc); /* snd-test 23 */
set_car(sc->t1_1, lookup(sc, cadr(args)));
sc->args = fn_proc(args) (sc, sc->t1_1);
push_stack_direct(sc, (opcode_t) opt1_any(cdr(sc->code)));
sc->code = caddr(sc->code);
}
static void op_c_na(s7_scheme * sc)
{ /* (set-cdr! lst ()) */
s7_pointer args, p, new_args;
new_args = make_list(sc, integer(opt3_arglen(cdr(sc->code))), sc->nil);
sc->args = new_args;
for (args = cdr(sc->code), p = new_args; is_pair(args);
args = cdr(args), p = cdr(p))
set_car(p, fx_call(sc, args));
sc->value = fn_proc(sc->code) (sc, new_args);
}
static void op_c_p_mv(s7_scheme * sc)
{ /* op_c_p_1 -> mv case: (define (hi) (format (values #f "~A ~D" 1 2))) */
sc->code = c_function_base(opt1_cfunc(sc->code)); /* see comment above */
sc->args = copy_proper_list(sc, sc->value);
}
static void op_c_a(s7_scheme * sc)
{
sc->value = fx_call(sc, cdr(sc->code)); /* gc protect result before list_1 */
sc->args = list_1(sc, sc->value);
sc->value = fn_proc(sc->code) (sc, sc->args);
}
static void op_c_p(s7_scheme * sc)
{
push_stack_no_args_direct(sc, OP_C_P_1);
sc->code = T_Pair(cadr(sc->code));
}
static inline void op_c_ss(s7_scheme * sc)
{
sc->args =
list_2(sc, lookup(sc, cadr(sc->code)),
lookup(sc, caddr(sc->code)));
sc->value = fn_proc(sc->code) (sc, sc->args);
}
static void op_c_ap(s7_scheme * sc)
{
sc->args = fx_call(sc, cdr(sc->code));
push_stack_direct(sc, OP_C_AP_1); /* op_c_ap_1 sends us to apply which calls check_stack_size I think */
sc->code = caddr(sc->code);
}
static void op_c_ap_mv(s7_scheme * sc)
{
clear_multiple_value(sc->value);
sc->args = cons(sc, sc->args, sc->value);
sc->code = c_function_base(opt1_cfunc(sc->code));
}
static void op_c_aa(s7_scheme * sc)
{
gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code)));
stack_protected2(sc) = fx_call(sc, cddr(sc->code));
sc->value = list_2(sc, stack_protected1(sc), stack_protected2(sc));
unstack(sc); /* fn_proc here is unsafe so clear stack first */
sc->value = fn_proc(sc->code) (sc, sc->value);
}
static inline void op_c_s(s7_scheme * sc)
{
sc->args = list_1(sc, lookup(sc, cadr(sc->code)));
sc->value = fn_proc(sc->code) (sc, sc->args);
}
static Inline void op_apply_ss(s7_scheme * sc)
{
/* these used to check sc->code (i.e. "apply") if not h_optimized, but that still assumed we'd apply cadr to cddr.
* should we check that apply has not been set!?
*/
sc->args = lookup(sc, opt2_sym(sc->code)); /* is this right if code=macro? */
sc->code = lookup(sc, cadr(sc->code)); /* global search here was slower (e.g. tauto) */
if (needs_copied_args(sc->code))
sc->args = copy_proper_list_with_arglist_error(sc, sc->args);
else if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */
apply_list_error(sc, sc->args);
}
static void op_apply_sa(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code);
sc->args = fx_call(sc, cdr(p));
sc->code = lookup_global(sc, car(p));
if (needs_copied_args(sc->code))
sc->args = copy_proper_list_with_arglist_error(sc, sc->args);
else if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */
apply_list_error(sc, sc->args);
}
static void op_apply_sl(s7_scheme * sc)
{
s7_pointer p = cdr(sc->code);
sc->args = fx_call(sc, cdr(p));
sc->code = lookup_global(sc, car(p));
}
static void op_eval_args2(s7_scheme * sc)
{
sc->code = pop_op_stack(sc);
sc->args =
(is_null(sc->args)) ? list_1(sc,
sc->value) :
proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args));
}
static void op_eval_args3(s7_scheme * sc)
{
s7_pointer val = sc->code;
if (is_symbol(val))
val = lookup_checked(sc, val);
sc->args =
proper_list_reverse_in_place(sc,
cons_unchecked(sc, val,
cons(sc, sc->value,
sc->args)));
sc->code = pop_op_stack(sc);
}
static void op_eval_args5(s7_scheme * sc)
{ /* sc->value is the last arg, sc->code is the previous */
sc->args =
proper_list_reverse_in_place(sc,
cons_unchecked(sc, sc->value,
cons(sc, sc->code,
sc->args)));
sc->code = pop_op_stack(sc);
}
static bool eval_args_no_eval_args(s7_scheme * sc)
{
if ((is_any_macro(sc->value)) /* || (is_syntax(sc->value)) */ ) {
if (!s7_is_proper_list(sc, cdr(sc->code)))
s7_error(sc, sc->syntax_error_symbol,
set_elist_2(sc,
wrap_string(sc,
"improper list of arguments: ~S",
30), sc->code));
sc->args = cdr(sc->code);
if (is_symbol(car(sc->code))) { /* not ((f p) args...) where (f p) has returned a macro, op_macro_d assumes car is a symbol */
if (is_macro(sc->value))
set_optimize_op(sc->code, OP_MACRO_D);
if (is_macro_star(sc->value))
set_optimize_op(sc->code, OP_MACRO_STAR_D);
}
sc->code = sc->value;
return (true);
}
/* (define progn begin) (progn (display "hi") (+ 1 23)) */
if (is_syntactic_pair(sc->code))
sc->cur_op = optimize_op(sc->code);
else {
sc->cur_op = syntax_opcode(sc->value);
pair_set_syntax_op(sc->code, sc->cur_op);
}
return (false);
}
static void op_read_internal(s7_scheme * sc)
{
/* 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 current-input-port is now closed,
* and the original is inaccessible! So we get a segfault in token. We don't want to put
* a port_is_closed check there because token only rarely is in this danger. I think this
* is the only place where we can be about to call token, and someone has screwed up our port.
*/
if (port_is_closed(current_input_port(sc)))
s7_error(sc, sc->read_error_symbol, /* not read_error here because it paws through the port string which doesn't exist here */
set_elist_1(sc,
wrap_string(sc,
"our input port got clobbered!",
29)));
sc->tok = token(sc);
switch (sc->tok) {
case TOKEN_EOF:
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(current_input_port(sc)); /* this info is used to track down missing close parens */
sc->current_file = port_filename(current_input_port(sc));
break;
}
}
static void op_read_done(s7_scheme * sc)
{
pop_input_port(sc);
if (sc->tok == TOKEN_EOF)
sc->value = eof_object;
sc->current_file = NULL; /* this is for error handling */
}
static bool op_read_quasiquote(s7_scheme * sc)
{
/* this was pushed when the backquote was seen, then eventually we popped back to it */
sc->value = g_quasiquote_1(sc, sc->value, false);
/* doing quasiquote at read time means there are minor inconsistencies in various combinations or quote/' and quasiquote/`.
* A quoted ` will expand but quoted quasiquote will not (` can't be redefined, but quasiquote can). see s7test.scm for examples.
*/
return (main_stack_op(sc) != OP_READ_LIST);
}
static bool pop_read_list(s7_scheme * sc)
{
/* push-stack OP_READ_LIST is always no_code and op is always OP_READ_LIST (and not used), sc->curlet is apparently not needed here */
unstack_with(sc, OP_READ_LIST);
sc->args = sc->stack_end[2];
if (!is_null(sc->args))
return (false);
sc->args = cons(sc, sc->value, sc->args);
pair_set_current_input_location(sc, sc->args);
return (true);
}
static bool op_load_return_if_eof(s7_scheme * sc)
{
if (sc->tok != TOKEN_EOF) {
push_stack_op_let(sc, OP_LOAD_RETURN_IF_EOF);
push_stack_op_let(sc, OP_READ_INTERNAL);
sc->code = sc->value;
return (true); /* we read an expression, now evaluate it, and return to read the next */
}
sc->current_file = NULL;
return (false);
}
static bool op_load_close_and_pop_if_eof(s7_scheme * sc)
{
/* (load "file") in scheme: read and evaluate all exprs, then upon EOF, close current and pop input port stack */
if (sc->tok != TOKEN_EOF) {
push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was push args, code */
if ((!is_string_port(current_input_port(sc))) ||
(port_position(current_input_port(sc)) <
port_data_size(current_input_port(sc))))
push_stack_op_let(sc, OP_READ_INTERNAL);
else
sc->tok = TOKEN_EOF;
sc->code = sc->value;
return (true); /* we read an expression, now evaluate it, and return to read the next */
}
if ((S7_DEBUGGING) && (!is_loader_port(current_input_port(sc))))
fprintf(stderr, "%s not loading?\n",
display(current_input_port(sc)));
/* if *#readers* func hits error, clear_loader_port might not be undone? */
s7_close_input_port(sc, current_input_port(sc));
pop_input_port(sc);
sc->current_file = NULL;
if (is_multiple_value(sc->value)) /* (load "file") where "file" is (values 1 2 3) */
sc->value = splice_in_values(sc, multiple_value(sc->value));
return (false);
}
static bool op_read_apply_values(s7_scheme * sc)
{
sc->value =
list_2_unchecked(sc, sc->unquote_symbol,
list_2(sc, sc->apply_values_symbol, sc->value));
return (main_stack_op(sc) != OP_READ_LIST);
}
static goto_t op_read_dot(s7_scheme * sc)
{
token_t c;
c = token(sc);
if (c != TOKEN_RIGHT_PAREN) { /* '(1 . (2) 3) -> '(1 2 3), Guile says "missing close paren" */
if (is_pair(sc->value)) {
s7_pointer p;
for (p = sc->value; is_pair(p); p = cdr(p))
sc->args = cons(sc, car(p), sc->args);
sc->tok = c;
return (goto_read_tok);
}
back_up_stack(sc);
read_error(sc, "stray dot?"); /* (+ 1 . 2 3) or (list . ) */
}
/* args = previously read stuff, value = thing just after the dot and before the ')':
* (list 1 2 . 3) -> value: 3, args: (2 1 list), '(1 . 2) -> value: 2, args: (1)
* but we also get here in a lambda arg list: (lambda (a b . c) #f) -> value: c, args: (b a)
*/
sc->value = any_list_reverse_in_place(sc, sc->value, sc->args);
return ((main_stack_op(sc) ==
OP_READ_LIST) ? goto_pop_read_list : goto_start);
}
static bool op_read_quote(s7_scheme * sc)
{
/* can't check for sc->value = sc->nil here because we want ''() to be different from '() */
if ((sc->safety > IMMUTABLE_VECTOR_SAFETY) &&
((is_pair(sc->value)) || (is_any_vector(sc->value))
|| (is_string(sc->value))))
set_immutable(sc->value);
sc->value = list_2(sc, sc->quote_symbol, sc->value);
return (main_stack_op(sc) != OP_READ_LIST);
}
static bool op_read_unquote(s7_scheme * sc)
{
/* here if sc->value is a constant, the unquote is pointless (should we complain?)
* also currently stray "," can be ignored: (abs , 1) -- scanning the stack for quasiquote or quote seems to be unreliable
*/
if ((is_pair(sc->value)) || (is_symbol(sc->value)))
sc->value = list_2(sc, sc->unquote_symbol, sc->value);
return (main_stack_op(sc) != OP_READ_LIST);
}
/* safety check is at read time, so (immutable? (let-temporarily (((*s7* 'safety) 2)) #(1 2 3))) is #f
* but (immutable? (let-temporarily (((*s7* 'safety) 2)) (eval-string "#(1 2 3)"))) is #t
* at run time we just see the vector
*/
static bool op_read_vector(s7_scheme * sc)
{
sc->value = (sc->args == int_one) ? g_vector(sc, sc->value) : g_multivector(sc, integer(sc->args), sc->value); /* sc->args was sc->w earlier from read_sharp */
/* here and below all of the sc->value list can be freed, but my tests showed no speed up even in large cases */
if (sc->safety > IMMUTABLE_VECTOR_SAFETY)
set_immutable(sc->value);
return (main_stack_op(sc) != OP_READ_LIST);
}
static bool op_read_int_vector(s7_scheme * sc)
{
sc->value =
(sc->args == int_one) ? g_int_vector(sc,
sc->value) :
g_int_multivector(sc, integer(sc->args), sc->value);
if (sc->safety > IMMUTABLE_VECTOR_SAFETY)
set_immutable(sc->value);
return (main_stack_op(sc) != OP_READ_LIST);
}
static bool op_read_float_vector(s7_scheme * sc)
{
sc->value =
(sc->args == int_one) ? g_float_vector(sc,
sc->value) :
g_float_multivector(sc, integer(sc->args), sc->value);
if (sc->safety > IMMUTABLE_VECTOR_SAFETY)
set_immutable(sc->value);
return (main_stack_op(sc) != OP_READ_LIST);
}
static bool op_read_byte_vector(s7_scheme * sc)
{
sc->value =
(sc->args == int_one) ? g_byte_vector(sc,
sc->value) :
g_byte_multivector(sc, integer(sc->args), sc->value);
if (sc->safety > IMMUTABLE_VECTOR_SAFETY)
set_immutable(sc->value);
return (main_stack_op(sc) != OP_READ_LIST);
}
static inline void eval_last_arg(s7_scheme * sc, s7_pointer car_code)
{
/* here we've reached the last arg (sc->code == nil), it is not a pair */
if (!is_null(cdr(sc->code)))
improper_arglist_error(sc);
sc->code = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : car_code; /* this has to precede the set_type below */
sc->args =
(is_null(sc->args)) ? list_1(sc,
sc->code) :
proper_list_reverse_in_place(sc, cons(sc, sc->code, sc->args));
sc->code = pop_op_stack(sc);
}
static inline void eval_args_pair_car(s7_scheme * sc)
{
s7_pointer code = cdr(sc->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(code))
push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args);
else {
if (!is_pair(code)) /* (= 0 '(1 . 2) . 3) */
improper_arglist_error(sc);
if ((is_null(cdr(code))) && (!is_pair(car(code))))
push_stack(sc, OP_EVAL_ARGS3, sc->args, car(code));
else
push_stack(sc, OP_EVAL_ARGS4, sc->args, code);
}
sc->code = car(sc->code);
}
static bool eval_car_pair(s7_scheme * sc)
{
s7_pointer code = sc->code, carc = car(code);
/* 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, code);
if (is_symbol_and_syntactic(car(carc)))
/* was checking for is_syntactic (pair or symbol) here but that can be confused by successive optimizer passes: (define (hi) (((lambda () list)) 1 2 3)) etc */
{
if ((car(carc) == sc->quote_symbol) && /* ('and #f) */
((!is_pair(cdr(carc))) || /* ((quote . #\h) (2 . #\i)) ! */
(is_symbol_and_syntactic(cadr(carc))))) /* ('or #f) but not ('#_or #f) */
apply_error(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc,
cdr(code));
#if 0
/* if ((lambda ...)), check for ((lambda () ...)) and unwrap it to ...: need an operator here to skip these checks (and need optimization of lambda body etc) */
/* this is slower than going to op_lambda via eval_car_pair below, both much slower than code without the idiotic lambda */
if (car(carc) == sc->lambda_symbol) {
if ((is_null(cadr(carc))) && (is_pair(cddr(carc))) && (is_null(cdddr(carc))) && /* else wrap in (let ()...) */
(!((is_pair(caddr(carc))) && (is_syntax(caaddr(carc)))
&& (is_syntax_definer(caaddr(carc)))))) {
sc->stack_end -= 4; /* avoid debugger complaint */
sc->code = caddr(carc);
return (true);
}
}
#endif
sc->code = carc;
if (!no_cell_opt(carc)) {
if ((car(carc) == sc->if_symbol) && (is_pair(cdr(code))) && /* check that we got one or two args */
((is_null(cddr(code))) ||
((is_pair(cddr(code))) && (is_null(cdddr(code)))))) {
check_if(sc, carc);
if ((fx_function[optimize_op(carc)]) && (is_fxable(sc, cadr(code))) && ((is_null(cddr(code))) || (is_fxable(sc, caddr(code))))) { /* checked cdddr above */
fx_annotate_args(sc, cdr(code), sc->curlet);
set_fx_direct(code, fx_function[optimize_op(carc)]);
set_optimize_op(code,
(is_null(cddr(code))) ? OP_A_A :
OP_A_AA);
return (false); /* goto eval in trailers */
}
}
set_no_cell_opt(carc);
}
sc->cur_op = (opcode_t) symbol_syntax_op_checked(sc->code);
pair_set_syntax_op(sc->code, sc->cur_op);
return (true);
}
if ((is_pair(cdr(code))) && (is_optimized(carc))) {
if ((fx_function[optimize_op(carc)]) &&
(is_fxable(sc, cadr(code))) &&
((is_null(cddr(code))) ||
((is_fxable(sc, caddr(code))) && (is_null(cdddr(code)))))) {
fx_annotate_args(sc, cdr(code), sc->curlet);
set_fx_direct(code, fx_function[optimize_op(carc)]);
set_optimize_op(code,
(is_null(cddr(code))) ? OP_A_A : OP_A_AA);
sc->code = carc;
return (false); /* goto eval in trailers */
}
if ((is_null(cddr(code))) && (is_symbol(cadr(code)))) {
set_optimize_op(code, OP_P_S);
set_opt3_sym(code, cadr(code));
}
/* OP_P_ALL_A runs into opt2 fx overwrites in a case like ((values set!) x 32) */
else
set_optimize_op(code, OP_PAIR_PAIR);
} else
set_optimize_op(code, OP_PAIR_PAIR);
push_stack(sc, OP_EVAL_ARGS, sc->nil, carc);
sc->code = car(carc);
return (false);
}
static inline bool eval_args_last_arg(s7_scheme * sc)
{
s7_pointer car_code = car(sc->code); /* we're at the last arg, sc->value is the previous one, not yet saved in the args list */
if (is_pair(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;
return (true);
}
/* get the last arg */
sc->code =
(is_symbol(car_code)) ? lookup_checked(sc, car_code) : car_code;
/* get the current arg, which is not a list */
sc->args =
proper_list_reverse_in_place(sc,
cons_unchecked(sc, sc->code,
cons(sc, sc->value,
sc->args)));
sc->code = pop_op_stack(sc);
return (false);
}
static void op_pair_pair(s7_scheme * sc)
{
if (sc->stack_end >= (sc->stack_resize_trigger - 8)) {
check_for_cyclic_code(sc, sc->code);
resize_stack(sc);
}
push_stack(sc, OP_EVAL_ARGS, sc->nil, sc->code); /* eval args goes immediately to cdr(sc->code) */
/* don't put check_stack_size here! */
push_stack(sc, OP_EVAL_ARGS, sc->nil, car(sc->code));
sc->code = caar(sc->code);
}
static goto_t trailers(s7_scheme * sc)
{
s7_pointer code = sc->code;
if (is_pair(code)) {
s7_pointer carc = car(code);
if (is_symbol(carc)) {
/* car is a symbol, sc->code a list */
if (is_syntactic_symbol(carc)) {
sc->cur_op = (opcode_t) symbol_syntax_op_checked(code);
pair_set_syntax_op(sc->code, sc->cur_op);
return (goto_top_no_pop);
}
sc->value = lookup_global(sc, carc);
set_optimize_op(code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */
return (goto_eval_args_top);
}
if (is_pair(carc)) /* ((if x y z) a b) etc */
return ((eval_car_pair(sc)) ? goto_top_no_pop : goto_eval);
/* here we can get syntax objects like quote */
if (is_syntax(carc)) {
sc->cur_op = (opcode_t) syntax_opcode(carc);
pair_set_syntax_op(sc->code, sc->cur_op);
return (goto_top_no_pop);
}
/* car must be the function to be applied, or (for example) a syntax variable like quote that has been used locally */
set_optimize_op(code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */
sc->value = T_Pos(carc);
return (goto_eval_args_top);
}
if (is_symbol(code)) {
sc->value = lookup_checked(sc, code);
set_optimize_op(code,
(is_keyword(code)) ? OP_CON : ((is_global(code)) ?
OP_GLOBAL_SYM :
OP_SYM));
} else {
sc->value = T_Pos(code);
set_optimize_op(code, OP_CON);
}
return (goto_start);
}
static Inline void op_map_gather(s7_scheme * sc)
{
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)));
}
}
/* ---------------- unknown ops ---------------- */
static bool fixup_unknown_op(s7_pointer code, s7_pointer func, opcode_t op)
{
set_optimize_op(code, op);
if (is_any_closure(func))
set_opt1_lambda(code, func); /* perhaps set_opt1_lambda_add here and throughout op_unknown* */
return (true);
}
static bool unknown_unknown(s7_scheme * sc, s7_pointer code, opcode_t op)
{
if ((is_symbol(car(code))) &&
(!is_slot(lookup_slot_from(car(code), sc->curlet))))
unbound_variable_error(sc, car(code));
set_optimize_op(code, op);
return (true);
}
static bool is_immutable_and_stable(s7_scheme * sc, s7_pointer func)
{
s7_pointer p;
if (symbol_ctr(func) != 1) /* protect against (define-constant (p) (define-constant (p) ...)) */
return (false);
if ((is_global(func)) && (is_immutable_slot(global_slot(func))))
return (true);
for (p = sc->curlet; is_let(p); p = let_outlet(p))
if ((is_funclet(p)) && (funclet_function(p) != func))
return (false);
p = lookup_slot_from(func, sc->curlet);
return (is_immutable_slot(p));
}
static bool op_unknown(s7_scheme * sc)
{
s7_pointer code, f = sc->last_function;
if (!f) /* can be NULL if unbound variable */
unbound_variable_error(sc, car(sc->code));
/* perhaps set op to OP_CLEAR_OPTS and return(true) above */
#if SHOW_EVAL_OPS
fprintf(stderr, "%s %s %s\n", __func__, display(f),
s7_type_names[type(f)]);
#endif
code = sc->code;
switch (type(f)) {
case T_CLOSURE:
case T_CLOSURE_STAR:
if (!has_methods(f)) {
int32_t hop = 0;
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
if (is_null(closure_args(f))) {
s7_pointer body = closure_body(f);
bool safe_case = is_safe_closure(f);
set_opt1_lambda(code, f);
if (is_null(cdr(body))) {
if ((safe_case) && (is_fxable(sc, car(body)))) {
set_safe_closure(f); /* safe because no args so no reference to funclet? needed because op_safe_thunk_a will check for it */
fx_annotate_arg(sc, body, sc->curlet);
set_safe_optimize_op(code, hop + OP_SAFE_THUNK_A);
set_closure_one_form_fx_arg(f);
sc->value = fx_safe_thunk_a(sc, sc->code);
return (false);
}
clear_has_fx(code);
}
set_safe_optimize_op(code,
hop +
((safe_case) ? OP_SAFE_THUNK :
OP_THUNK));
return (true);
}
if (is_closure_star(f)) {
set_safe_optimize_op(code,
hop +
((is_safe_closure(f)) ?
OP_SAFE_CLOSURE_STAR_NA_0 :
OP_CLOSURE_STAR_NA));
set_opt1_lambda(code, f);
return (true);
}
}
break;
case T_GOTO:
return (fixup_unknown_op(code, f, OP_IMPLICIT_GOTO));
case T_ITERATOR:
return (fixup_unknown_op(code, f, OP_IMPLICIT_ITERATE));
case T_MACRO:
return (fixup_unknown_op(code, f, OP_MACRO_D));
case T_MACRO_STAR:
return (fixup_unknown_op(code, f, OP_MACRO_STAR_D));
default:
if ((is_symbol(car(code))) &&
(!is_slot(lookup_slot_from(car(code), sc->curlet))))
unbound_variable_error(sc, car(code));
}
return (fixup_unknown_op(code, f, OP_S));
}
static bool fxify_closure_star_g(s7_scheme * sc, s7_pointer f,
s7_pointer code)
{
if ((!has_methods(f)) && (closure_star_arity_to_int(sc, f) != 0)) {
int32_t hop = 0;
bool safe_case;
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
fx_annotate_arg(sc, cdr(code), sc->curlet);
set_opt3_arglen(cdr(code), int_one);
safe_case = is_safe_closure(f);
if ((safe_case) && (is_null(cdr(closure_args(f)))))
set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1);
else if (lambda_has_simple_defaults(f)) {
if (arglist_has_rest(sc, closure_args(f)))
fixup_unknown_op(code, f,
hop +
((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 :
OP_CLOSURE_STAR_NA));
else
fixup_unknown_op(code, f, hop + ((safe_case) ?
((is_null
(cdr(closure_args(f))))
? OP_SAFE_CLOSURE_STAR_A1
: OP_SAFE_CLOSURE_STAR_A)
: OP_CLOSURE_STAR_A));
return (true);
}
fixup_unknown_op(code, f,
hop +
((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 :
OP_CLOSURE_STAR_NA));
return (true);
}
return (false);
}
static bool op_unknown_g(s7_scheme * sc)
{
s7_pointer code, f = sc->last_function;
bool sym_case;
if (!f)
unbound_variable_error(sc, car(sc->code));
if (SHOW_EVAL_OPS)
fprintf(stderr, "%s %s\n", __func__, display(f));
code = sc->code;
sym_case = is_normal_symbol(cadr(code));
if ((sym_case) && (!is_any_macro(f)) && /* if f is a macro, its argument can be unbound legitimately */
(!is_slot(lookup_slot_from(cadr(code), sc->curlet))))
return (unknown_unknown(sc, sc->code, (is_normal_symbol(cadr(sc->code))) ? OP_CLEAR_OPTS : OP_S_C)); /* not OP_S_S here! */
if ((is_unknopt(code)) && (!is_closure(f)))
return (fixup_unknown_op(code, f, (sym_case) ? OP_S_S : OP_S_C));
switch (type(f)) {
case T_C_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
if ((c_function_required_args(f) > 1) ||
(c_function_all_args(f) == 0))
break;
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
if (sym_case) {
set_c_function(code, f);
if (is_safe_procedure(f)) {
set_optimize_op(code, OP_SAFE_C_S);
sc->value = fx_c_s(sc, sc->code);
} else {
set_optimize_op(code, OP_C_S);
op_c_s(sc);
}
return (false);
}
if (is_safe_procedure(f)) {
set_optimize_op(code, OP_SAFE_C_NC);
set_c_function(code, f);
return (true);
}
break;
case T_CLOSURE:
if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == 1)) {
s7_pointer body = closure_body(f);
int32_t hop = 0;
set_opt2_sym(code, cadr(code));
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
/* code here might be (f x) where f is passed elsewhere as a function parameter,
* first time through we look it up, find a safe-closure and optimize as (say) safe_closure_s_a,
* next time it is something else, etc. Rather than keep optimizing it locally, we need to
* back out: safe_closure_s_* -> safe_closure_s -> closure_s -> op_s_s. Ideally we'd know
* this was a parameter or whatever. The tricky case is local letrec(f) calling f which initially
* thinks it is not safe, then later is set safe correctly, now outer func is called again,
* this time f is safe, and we're ok from then on.
*/
if (is_unknopt(code)) {
/* fprintf(stderr, "unknopt %s %s %s %s %p %d %s\n",
op_names[optimize_op(car(body))], display(f), display(car(body)), display(code), code, is_safe_closure(f), describe_type_bits(sc, f));
*/
switch (op_no_hop(code)) {
case OP_CLOSURE_S:
set_optimize_op(code,
(is_safe_closure(f)) ?
OP_SAFE_CLOSURE_S : OP_S_S);
break;
case OP_CLOSURE_S_O:
case OP_SAFE_CLOSURE_S:
set_optimize_op(code, OP_CLOSURE_S);
break;
case OP_SAFE_CLOSURE_S_O:
case OP_SAFE_CLOSURE_S_A:
case OP_SAFE_CLOSURE_S_TO_S:
case OP_SAFE_CLOSURE_S_TO_SC:
set_optimize_op(code,
(is_safe_closure(f)) ?
OP_SAFE_CLOSURE_S : OP_CLOSURE_S);
break;
default:
set_optimize_op(code, OP_S_S);
break;
}
set_opt1_lambda(code, f);
return (true);
}
if (is_safe_closure(f)) {
if (is_null(cdr(body))) {
if (is_fxable(sc, car(body)))
fxify_closure_s(sc, f, code, sc->curlet, hop);
else
set_safe_optimize_op(code,
hop + OP_SAFE_CLOSURE_S_O);
/* hop if is_constant(sc, car(code)) is not foolproof here (see t967.scm):
* (define (f) (define-constant (f1) ... (f1))...) where each call on f makes a different f1
*/
} else
set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S);
} else if (is_null(cdr(body)))
set_optimize_op(code, hop + OP_CLOSURE_S_O);
else
set_optimize_op(code, hop + OP_CLOSURE_S);
set_is_unknopt(code);
set_opt1_lambda(code, f);
return (true);
}
break;
case T_CLOSURE_STAR:
if (fxify_closure_star_g(sc, f, code))
return (true);
break;
case T_GOTO:
fx_annotate_arg(sc, cdr(code), sc->curlet);
set_opt3_arglen(cdr(code), int_one);
return (fixup_unknown_op(code, f, OP_IMPLICIT_GOTO_A));
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
case T_BYTE_VECTOR:
if ((sym_case) || /* (v i) */
(is_t_integer(cadr(code)))) { /* (v 4/3) */
fx_annotate_arg(sc, cdr(code), sc->curlet);
return (fixup_unknown_op(code, f, OP_IMPLICIT_VECTOR_REF_A));
}
break;
case T_STRING:
fx_annotate_arg(sc, cdr(code), sc->curlet);
return (fixup_unknown_op(code, f, OP_IMPLICIT_STRING_REF_A));
case T_PAIR:
fx_annotate_arg(sc, cdr(code), sc->curlet);
return (fixup_unknown_op(code, f, OP_IMPLICIT_PAIR_REF_A));
case T_C_OBJECT:
if (s7_is_aritable(sc, f, 1)) {
fx_annotate_arg(sc, cdr(code), sc->curlet);
return (fixup_unknown_op(code, f, OP_IMPLICIT_C_OBJECT_REF_A));
}
break;
case T_LET:
if (sym_case) {
fx_annotate_arg(sc, cdr(code), sc->curlet);
return (fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_A));
}
set_opt3_con(code, cadr(code));
return (fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_C));
case T_HASH_TABLE:
fx_annotate_arg(sc, cdr(code), sc->curlet);
return (fixup_unknown_op(code, f, OP_IMPLICIT_HASH_TABLE_REF_A));
case T_CONTINUATION:
fx_annotate_arg(sc, cdr(code), sc->curlet);
return (fixup_unknown_op(code, f, OP_IMPLICIT_CONTINUATION_A));
case T_MACRO:
return (fixup_unknown_op(code, f, OP_MACRO_D));
case T_MACRO_STAR:
return (fixup_unknown_op(code, f, OP_MACRO_STAR_D));
default:
break;
}
if ((is_symbol(car(code))) &&
(!is_slot(lookup_slot_from(car(code), sc->curlet))))
unbound_variable_error(sc, car(code));
return (fixup_unknown_op(code, f, (sym_case) ? OP_S_S : OP_S_C));
}
static bool op_unknown_a(s7_scheme * sc)
{
s7_pointer code, f = sc->last_function;
if (!f)
unbound_variable_error(sc, car(sc->code));
if (SHOW_EVAL_OPS)
fprintf(stderr, "%s %s\n", __func__, display(f));
code = sc->code;
switch (type(f)) {
case T_C_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
if ((c_function_required_args(f) > 1) ||
(c_function_all_args(f) == 0))
break;
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
clear_has_fx(code);
set_c_function(code, f);
if (is_safe_procedure(f)) {
set_optimize_op(code, OP_SAFE_C_A);
sc->value = fx_c_a(sc, code);
} else {
set_optimize_op(code, OP_C_A);
op_c_a(sc);
}
return (false);
case T_CLOSURE:
if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == 1)) {
s7_pointer body = closure_body(f);
bool one_form, safe_case = is_safe_closure(f);
int32_t hop = 0;
one_form = is_null(cdr(body));
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
fxify_closure_a(sc, f, one_form, safe_case, hop, code,
sc->curlet);
/* we might not be in "f" I think, tree_memq(sc, code, body)?? */
if ((safe_case) &&
(!has_fx(cdr(code))) &&
(is_very_safe_closure(f)) &&
(!tree_has_definers_or_binders(sc, body)) &&
(s7_tree_memq(sc, code, body)))
fx_tree(sc, cdr(code), car(closure_args(f)), NULL, NULL,
false);
set_opt1_lambda(code, f);
return (true);
}
break;
case T_CLOSURE_STAR:
if (fxify_closure_star_g(sc, f, code))
return (true);
break;
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
case T_BYTE_VECTOR:
return (fixup_unknown_op(code, f, OP_IMPLICIT_VECTOR_REF_A));
case T_STRING:
return (fixup_unknown_op(code, f, OP_IMPLICIT_STRING_REF_A));
case T_PAIR:
return (fixup_unknown_op(code, f, OP_IMPLICIT_PAIR_REF_A));
case T_C_OBJECT:
return (fixup_unknown_op(code, f, OP_IMPLICIT_C_OBJECT_REF_A));
case T_HASH_TABLE:
return (fixup_unknown_op(code, f, OP_IMPLICIT_HASH_TABLE_REF_A));
case T_GOTO:
return (fixup_unknown_op(code, f, OP_IMPLICIT_GOTO_A));
case T_CONTINUATION:
return (fixup_unknown_op(code, f, OP_IMPLICIT_CONTINUATION_A));
case T_MACRO:
return (fixup_unknown_op(code, f, OP_MACRO_D));
case T_MACRO_STAR:
return (fixup_unknown_op(code, f, OP_MACRO_STAR_D));
case T_LET:
{
s7_pointer arg1 = cadr(code);
if ((is_pair(arg1)) && (car(arg1) == sc->quote_symbol)) {
set_opt3_con(code, cadadr(code));
return (fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_C));
}
set_opt3_any(code, cadr(code));
return (fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_A));
}
default:
break;
}
if ((is_symbol(car(code))) &&
(!is_slot(lookup_slot_from(car(code), sc->curlet))))
unbound_variable_error(sc, car(code));
return (fixup_unknown_op(code, f, OP_S_A)); /* closure with methods etc */
}
static bool op_unknown_gg(s7_scheme * sc)
{
bool s1, s2;
s7_pointer code, f = sc->last_function;
if (!f)
unbound_variable_error(sc, car(sc->code));
if (SHOW_EVAL_OPS)
fprintf(stderr, "%s %s\n", __func__, display(f));
code = sc->code;
s1 = is_normal_symbol(cadr(code));
s2 = is_normal_symbol(caddr(code));
if ((s1) && (!is_slot(lookup_slot_from(cadr(code), sc->curlet))))
return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
if ((s2) && (!is_slot(lookup_slot_from(caddr(code), sc->curlet))))
return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
switch (type(f)) {
case T_C_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
if ((c_function_required_args(f) > 2) ||
(c_function_all_args(f) < 2))
break;
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
if (is_safe_procedure(f)) {
if (s1) {
set_optimize_op(code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC);
if (s2)
set_opt2_sym(cdr(code), caddr(code));
else
set_opt2_con(cdr(code), caddr(code));
} else {
set_optimize_op(code, (s2) ? OP_SAFE_C_CS : OP_SAFE_C_NC);
if (s2) {
set_opt1_con(cdr(code),
(is_pair(cadr(code))) ? cadadr(code) :
cadr(code));
set_opt2_sym(cdr(code), caddr(code));
}
}
} else {
set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA);
fx_annotate_args(sc, cdr(code), sc->curlet);
}
set_opt3_arglen(cdr(code), int_two);
set_c_function(code, f);
return (true);
case T_CLOSURE:
if (has_methods(f))
break;
if (closure_arity_to_int(sc, f) == 2) {
s7_pointer body = closure_body(f);
bool one_form, safe_case = is_safe_closure(f);
int32_t hop = 0;
one_form = is_null(cdr(body));
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
if ((s1) && (s2)) {
set_opt2_sym(code, caddr(code));
if (!one_form)
set_optimize_op(code,
hop +
((safe_case) ? OP_SAFE_CLOSURE_SS :
OP_CLOSURE_SS));
else if (!safe_case)
set_optimize_op(code, hop + OP_CLOSURE_SS_O);
else if (!is_fxable(sc, car(body)))
set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_O);
else {
fx_annotate_arg(sc, body, sc->curlet);
fx_tree(sc, body, car(closure_args(f)),
cadr(closure_args(f)), NULL, false);
set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A);
set_closure_one_form_fx_arg(f);
}
} else if (s1) {
set_opt2_con(code, caddr(code));
if (one_form)
set_safe_optimize_op(code,
hop +
((safe_case) ?
OP_SAFE_CLOSURE_SC_O :
OP_CLOSURE_SC_O));
else
set_optimize_op(code,
hop +
((safe_case) ? OP_SAFE_CLOSURE_SC :
OP_CLOSURE_SC));
} else {
set_opt3_arglen(cdr(code), int_two);
fx_annotate_args(sc, cdr(code), sc->curlet);
if (safe_case)
set_safe_optimize_op(code,
hop +
((one_form) ? OP_SAFE_CLOSURE_AA_O
: OP_SAFE_CLOSURE_AA));
else
set_safe_optimize_op(code,
hop +
((one_form) ? OP_CLOSURE_AA_O :
OP_CLOSURE_AA));
}
set_opt1_lambda(code, f);
return (true);
}
break;
case T_CLOSURE_STAR:
if ((closure_star_arity_to_int(sc, f) != 0) &&
(closure_star_arity_to_int(sc, f) != 1)) {
fx_annotate_args(sc, cdr(code), sc->curlet);
if (!has_methods(f)) {
fixup_closure_star_aa(sc, f, code,
(is_immutable_and_stable
(sc, car(code))) ? 1 : 0);
set_opt1_lambda(code, f);
} else
set_optimize_op(code, OP_S_AA);
return (true);
}
break;
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
case T_BYTE_VECTOR:
case T_PAIR:
set_opt3_arglen(cdr(code), int_two);
fx_annotate_args(sc, cdr(code), sc->curlet);
return (fixup_unknown_op
(code, f,
(is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA :
OP_IMPLICIT_VECTOR_REF_AA));
case T_MACRO:
return (fixup_unknown_op(code, f, OP_MACRO_D));
case T_MACRO_STAR:
return (fixup_unknown_op(code, f, OP_MACRO_STAR_D));
default:
break;
}
if ((is_symbol(car(code))) &&
(!is_slot(lookup_slot_from(car(code), sc->curlet))))
unbound_variable_error(sc, car(code));
fx_annotate_args(sc, cdr(code), sc->curlet);
return (fixup_unknown_op(code, f, OP_S_AA));
}
static bool op_unknown_ns(s7_scheme * sc)
{
s7_pointer code, arg, f = sc->last_function;
int32_t num_args;
if (!f)
unbound_variable_error(sc, car(sc->code));
if (SHOW_EVAL_OPS)
fprintf(stderr, "%s %s\n", __func__, display(f));
code = sc->code;
num_args = integer(opt3_arglen(cdr(code)));
for (arg = cdr(code); is_pair(arg); arg = cdr(arg))
if (!is_slot(lookup_slot_from(car(arg), sc->curlet)))
unbound_variable_error(sc, car(arg));
switch (type(f)) {
case T_C_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
if ((c_function_required_args(f) > num_args) ||
(c_function_all_args(f) < num_args))
break;
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
if (is_safe_procedure(f)) {
if (num_args == 3) {
set_safe_optimize_op(code, OP_SAFE_C_SSS);
set_opt1_sym(cdr(code), caddr(code));
set_opt2_sym(cdr(code), cadddr(code));
} else
set_safe_optimize_op(code, OP_SAFE_C_NS);
} else {
set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA);
fx_annotate_args(sc, cdr(code), sc->curlet);
}
set_c_function(code, f);
return (true);
case T_CLOSURE:
if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == num_args)) {
int32_t hop = 0;
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
fx_annotate_args(sc, cdr(code), sc->curlet);
if (num_args == 3)
return (fixup_unknown_op
(code, f,
hop +
((is_safe_closure(f)) ? OP_SAFE_CLOSURE_3S :
OP_CLOSURE_3S)));
if (num_args == 4)
return (fixup_unknown_op
(code, f,
hop +
((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS :
OP_CLOSURE_4S)));
return (fixup_unknown_op
(code, f,
hop +
((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS :
OP_CLOSURE_NS)));
}
/* if (is_symbol(closure_args(f))) closure_any in some form? this never happens */
break;
case T_CLOSURE_STAR:
if ((!has_methods(f)) && ((closure_star_arity_to_int(sc, f) < 0)
||
((closure_star_arity_to_int(sc, f) *
2) >= num_args))) {
int32_t hop = 0;
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
fx_annotate_args(sc, cdr(code), sc->curlet);
if ((is_safe_closure(f)) && (num_args == 3)
&& (closure_star_arity_to_int(sc, f) == 3))
return (fixup_unknown_op
(code, f, OP_SAFE_CLOSURE_STAR_3A));
return (fixup_unknown_op
(code, f,
hop +
((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA :
OP_CLOSURE_STAR_NA)));
}
break;
case T_MACRO:
return (fixup_unknown_op(code, f, OP_MACRO_D));
case T_MACRO_STAR:
return (fixup_unknown_op(code, f, OP_MACRO_STAR_D));
/* vector/pair */
default:
break;
}
return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
}
/* #define op_unknown_aa(Sc) ({fprintf(stderr, "aa: %s[%d]\n", __func__, __LINE__); op_unknown_aa_1(Sc);}) */
static bool op_unknown_aa(s7_scheme * sc)
{
s7_pointer code, f = sc->last_function;
if (!f)
unbound_variable_error(sc, car(sc->code));
if (SHOW_EVAL_OPS)
fprintf(stderr, "%s %s\n", __func__, display(f));
code = sc->code;
#if S7_DEBUGGING
if (!is_t_integer(opt3_arglen(cdr(code)))) {
fprintf(stderr, "not int\n");
abort();
}
if (!has_fx(cdr(code))) {
fprintf(stderr, "not fx cdr\n");
abort();
}
if (!has_fx(cddr(code))) {
fprintf(stderr, "not fx cddr\n");
abort();
}
#endif
#if 0
set_opt3_arglen(cdr(code), int_two);
fx_annotate_args(sc, cdr(code), sc->curlet);
#endif
switch (type(f)) {
case T_C_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
if ((c_function_required_args(f) > 2) ||
(c_function_all_args(f) < 2))
break;
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
if (is_safe_procedure(f)) {
if (!safe_c_aa_to_ag_ga(sc, code, 0)) {
set_safe_optimize_op(code, OP_SAFE_C_AA);
set_opt3_pair(code, cddr(code));
}
} else
set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA);
set_c_function(code, f);
return (true);
case T_CLOSURE:
if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == 2)) {
s7_pointer body = closure_body(f);
bool one_form, safe_case = is_safe_closure(f);
int32_t hop = 0;
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
one_form = is_null(cdr(body));
if (!one_form)
set_safe_optimize_op(code,
hop +
((safe_case) ? OP_SAFE_CLOSURE_AA :
OP_CLOSURE_AA));
else if (!safe_case)
set_optimize_op(code, hop + OP_CLOSURE_AA_O);
else if (!is_fxable(sc, car(body)))
set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_O);
else {
fx_annotate_arg(sc, body, sc->curlet);
set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_A);
set_closure_one_form_fx_arg(f);
}
set_opt1_lambda(code, f);
return (true);
}
break;
case T_CLOSURE_STAR:
if (!has_methods(f)) {
fixup_closure_star_aa(sc, f, code,
(is_immutable_and_stable(sc, car(code)))
? 1 : 0);
set_opt1_lambda(code, f);
} else
set_optimize_op(code, OP_S_AA);
return (true);
case T_INT_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
case T_BYTE_VECTOR:
case T_PAIR:
return (fixup_unknown_op
(code, f,
(is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA :
OP_IMPLICIT_VECTOR_REF_AA));
case T_MACRO:
return (fixup_unknown_op(code, f, OP_MACRO_D));
case T_MACRO_STAR:
return (fixup_unknown_op(code, f, OP_MACRO_STAR_D));
default:
break;
}
if ((is_symbol(car(code))) &&
(!is_slot(lookup_slot_from(car(code), sc->curlet))))
unbound_variable_error(sc, car(code));
return (fixup_unknown_op(code, f, OP_S_AA));
}
static bool is_normal_happy_symbol(s7_scheme * sc, s7_pointer sym)
{
if (!is_normal_symbol(sym))
return (false);
if (!is_slot(lookup_slot_from(sym, sc->curlet)))
unbound_variable_error(sc, sym);
return (true);
}
static bool op_unknown_na(s7_scheme * sc)
{
s7_pointer code, f = sc->last_function;
int32_t num_args;
if (!f)
unbound_variable_error(sc, car(sc->code));
if (SHOW_EVAL_OPS)
fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(f),
display(sc->code));
code = sc->code;
num_args = (is_pair(cdr(code))) ? integer(opt3_arglen(cdr(code))) : 0;
if (num_args == 0)
return (fixup_unknown_op(code, f, OP_S)); /* via op_closure*-fx where original had 0 args, safe case -> op_safe_closure*_0 */
switch (type(f)) {
case T_C_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
if ((c_function_required_args(f) > num_args) ||
(c_function_all_args(f) < num_args))
break;
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
if (is_safe_procedure(f)) {
if (num_args == 3) {
int32_t pairs = 0, symbols = 0, quotes = 0; /* specialize aaa->ssc etc, this makes less difference than I expected */
s7_pointer p;
for (p = cdr(code); is_pair(p); p = cdr(p)) {
s7_pointer car_p = car(p);
if (is_normal_happy_symbol(sc, car_p))
symbols++;
else if (is_pair(car_p)) {
pairs++;
if (is_proper_quote(sc, car_p))
quotes++;
}
}
if (optimize_safe_c_func_three_args
(sc, code, f, 0 /* hop */ , pairs, symbols, quotes,
sc->curlet) == OPT_T)
return (true);
set_opt3_pair(cdr(code), cdddr(code));
set_opt3_pair(code, cddr(code));
set_safe_optimize_op(code, OP_SAFE_C_AAA);
} else
set_safe_optimize_op(code,
(num_args ==
4) ? OP_SAFE_C_4A : OP_SAFE_C_NA);
} else
set_safe_optimize_op(code,
(is_semisafe(f)) ? OP_CL_NA : OP_C_NA);
fx_annotate_args(sc, cdr(code), sc->curlet);
set_c_function(code, f);
return (true);
case T_CLOSURE:
if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == num_args)) {
int32_t hop = 0;
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
fx_annotate_args(sc, cdr(code), sc->curlet);
if (is_safe_closure(f)) {
if (num_args != 3)
set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_NA);
else if (is_normal_happy_symbol(sc, cadr(code)))
set_safe_optimize_op(code,
hop +
((is_normal_happy_symbol
(sc,
caddr(code))) ?
OP_SAFE_CLOSURE_SSA :
OP_SAFE_CLOSURE_SAA));
else if ((!is_pair(caddr(code)))
&& (!is_pair(cadddr(code))))
set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AGG);
else
set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_3A);
} else if (num_args != 3)
set_safe_optimize_op(code,
hop +
((num_args ==
4) ? OP_CLOSURE_4A :
OP_CLOSURE_NA));
else if ((is_normal_happy_symbol(sc, caddr(code)))
&& (is_normal_happy_symbol(sc, cadddr(code))))
set_safe_optimize_op(code, hop + OP_CLOSURE_ASS);
else if (is_normal_happy_symbol(sc, cadr(code)))
set_safe_optimize_op(code,
hop +
((is_normal_happy_symbol
(sc,
cadddr(code))) ? OP_CLOSURE_SAS :
OP_CLOSURE_SAA));
else if (is_normal_happy_symbol(sc, caddr(code)))
set_safe_optimize_op(code, hop + OP_CLOSURE_ASA);
else if (is_normal_happy_symbol(sc, cadddr(code)))
set_safe_optimize_op(code, hop + OP_CLOSURE_AAS);
else
set_safe_optimize_op(code, hop + OP_CLOSURE_3A);
set_opt1_lambda(code, f);
return (true);
}
if (is_symbol(closure_args(f))) {
optimize_closure_dotted_args(sc, code, f, 0, num_args,
sc->curlet);
if (optimize_op(code) == OP_ANY_CLOSURE_NA)
return (true);
}
break;
case T_CLOSURE_STAR:
if ((!has_methods(f)) && ((closure_star_arity_to_int(sc, f) < 0)
||
((closure_star_arity_to_int(sc, f) *
2) >= num_args))) {
int32_t hop = 0;
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
if (num_args > 0) {
set_opt3_arglen(cdr(code), small_int(num_args));
fx_annotate_args(sc, cdr(code), sc->curlet);
}
if (is_safe_closure(f))
switch (num_args) {
case 0:
return (fixup_unknown_op
(code, f, hop + OP_SAFE_CLOSURE_STAR_NA_0));
case 1:
return (fixup_unknown_op
(code, f, hop + OP_SAFE_CLOSURE_STAR_NA_1));
case 2:
return (fixup_unknown_op
(code, f, hop + OP_SAFE_CLOSURE_STAR_NA_2));
case 3:
if (closure_star_arity_to_int(sc, f) == 3)
return (fixup_unknown_op
(code, f, OP_SAFE_CLOSURE_STAR_3A));
default:
return (fixup_unknown_op
(code, f, hop + OP_SAFE_CLOSURE_STAR_NA));
}
return (fixup_unknown_op(code, f, hop + OP_CLOSURE_STAR_NA));
}
break;
case T_MACRO:
return (fixup_unknown_op(code, f, OP_MACRO_D));
case T_MACRO_STAR:
return (fixup_unknown_op(code, f, OP_MACRO_STAR_D));
/* implicit vector doesn't happen */
default:
break;
}
/* closure happens if wrong-number-of-args passed -- probably no need for op_s_all_a */
return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
}
static bool op_unknown_np(s7_scheme * sc)
{
s7_pointer code, f = sc->last_function;
int32_t num_args;
if (!f)
unbound_variable_error(sc, car(sc->code));
if (SHOW_EVAL_OPS)
fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__,
display(f), type_name(sc, f, NO_ARTICLE),
display(sc->code));
code = sc->code;
num_args = (is_pair(cdr(code))) ? integer(opt3_arglen(cdr(code))) : 0;
switch (type(f)) {
case T_C_FUNCTION:
case T_C_RST_ARGS_FUNCTION:
if ((c_function_required_args(f) > num_args) ||
(c_function_all_args(f) < num_args))
break;
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
if (num_args == 1)
set_any_c_np(sc, f, code, sc->curlet, num_args,
(is_safe_procedure(f)) ? OP_SAFE_C_P : OP_C_P);
else if ((num_args == 2) && (is_safe_procedure(f))) {
set_any_c_np(sc, f, code, sc->curlet, 2, OP_SAFE_C_PP);
opt_sp_1(sc, c_function_call(f), code);
gx_annotate_args(sc, cdr(code), sc->curlet);
} else
if ((num_args == 3) &&
((is_safe_procedure(f)) ||
((is_semisafe(f)) && (((car(code) != sc->assoc_symbol)
&& (car(code) !=
sc->member_symbol))
||
(unsafe_is_safe
(sc, cadddr(code), sc->curlet))))))
set_any_c_np(sc, f, code, sc->curlet, 3, OP_SAFE_C_3P);
else
set_any_c_np(sc, f, code, sc->curlet, num_args, OP_ANY_C_NP);
return (true);
case T_CLOSURE:
if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == num_args)) {
int32_t hop = 0;
if (is_immutable_and_stable(sc, car(code)))
hop = 1;
switch (num_args) {
case 1:
if (is_safe_closure(f)) {
s7_pointer body = closure_body(f);
if ((is_null(cdr(body))) && (is_fxable(sc, car(body)))) {
set_optimize_op(code, hop + OP_SAFE_CLOSURE_P_A);
fx_annotate_arg(sc, body, sc->curlet);
} else
set_optimize_op(code, hop + OP_SAFE_CLOSURE_P);
} else
set_optimize_op(code, hop + OP_CLOSURE_P);
set_opt1_lambda(code, f);
set_opt3_arglen(cdr(code), int_one);
set_unsafely_optimized(code);
break;
case 2:
if (is_fxable(sc, cadr(code))) {
fx_annotate_arg(sc, cdr(code), sc->curlet);
set_optimize_op(code,
hop +
((is_safe_closure(f)) ?
OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP));
} else if (is_fxable(sc, caddr(code))) {
fx_annotate_arg(sc, cddr(code), sc->curlet);
set_optimize_op(code,
hop +
((is_safe_closure(f)) ?
OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA));
} else
set_optimize_op(code,
hop +
((is_safe_closure(f)) ?
OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP));
set_opt1_lambda(code, f);
set_opt3_arglen(cdr(code), int_two); /* for later op_unknown_np */
set_unsafely_optimized(code);
break;
case 3:
set_any_closure_np(sc, f, code, sc->curlet, 3,
hop + OP_ANY_CLOSURE_3P);
break;
case 4:
set_any_closure_np(sc, f, code, sc->curlet, 4,
hop + OP_ANY_CLOSURE_4P);
break;
default:
set_any_closure_np(sc, f, code, sc->curlet, num_args,
hop + OP_ANY_CLOSURE_NP);
break;
}
return (true);
}
break;
case T_MACRO:
return (fixup_unknown_op(code, f, OP_MACRO_D));
case T_MACRO_STAR:
return (fixup_unknown_op(code, f, OP_MACRO_STAR_D));
}
return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
}
static bool unknown_any(s7_scheme * sc, s7_pointer f, s7_pointer code)
{
sc->last_function = f;
if (is_null(cdr(code)))
return (op_unknown(sc));
if ((is_null(cddr(code))) && (!is_pair(cadr(code))))
return (op_unknown_g(sc));
set_opt3_arglen(cdr(code),
make_integer(sc, proper_list_length(cdr(code))));
return (op_unknown_np(sc));
}
/* ---------------- eval type checkers ---------------- */
#if WITH_GCC
#define h_c_function_is_ok(Sc, P) ({s7_pointer _P_; _P_ = P; ((op_has_hop(_P_)) || (c_function_is_ok(Sc, _P_)));})
#else
#define h_c_function_is_ok(Sc, P) ((op_has_hop(P)) || (c_function_is_ok(Sc, P)))
#endif
#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))))
#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, caddr(P))))
#define c_function_is_ok_cadr_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, caddr(P))))
#define c_function_is_ok_cadr_cadadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, opt3_pair(P)))) /* cadadr(P) */
#define c_function_is_ok_cadr_caddadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, opt3_pair(P)))) /* caddadr(P) */
/* closure_is_ok_1 checks the type and the body length indications
* closure_is_fine_1 just checks the type (safe or unsafe closure)
* closure_is_ok calls _ok_1, closure_is_fine calls _fine_1
* closure_np_is_ok accepts safe/unsafe etc
*/
static inline bool closure_is_ok_1(s7_scheme * sc, s7_pointer code,
uint16_t type, int32_t args)
{
s7_pointer f;
if ((S7_DEBUGGING) && (symbol_ctr(car(code)) == 1))
fprintf(stderr, "%s ctr is 1, %p != %p\n", display(car(code)),
unchecked_local_value(car(code)),
opt1_lambda_unchecked(code));
f = lookup_unexamined(sc, car(code));
if ((f == opt1_lambda_unchecked(code)) || ((f) && (typesflag(f) == type) && ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) && /* 3 type bits to replace this but not hit enough to warrant them */
(set_opt1_lambda(code, f))))
return (true);
sc->last_function = f;
return (false);
}
static inline bool closure_is_fine_1(s7_scheme * sc, s7_pointer code,
uint16_t type, int32_t args)
{
s7_pointer f;
f = lookup_unexamined(sc, car(code));
if ((f == opt1_lambda_unchecked(code)) ||
((f) &&
((typesflag(f) & (TYPE_MASK | T_SAFE_CLOSURE)) == type) &&
((closure_arity(f) == args)
|| (closure_arity_to_int(sc, f) == args))
&& (set_opt1_lambda(code, f))))
return (true);
sc->last_function = f;
return (false);
}
static inline bool closure_np_is_ok_1(s7_scheme * sc, s7_pointer code,
int32_t args)
{
s7_pointer f;
f = lookup_unexamined(sc, car(code));
if ((f == opt1_lambda_unchecked(code)) ||
((f) && (is_closure(f)) && (set_opt1_lambda(code, f))))
return (true);
sc->last_function = f;
return (false);
}
#define closure_is_ok(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_ok_1(Sc, Code, Type, Args)))
#define closure_np_is_ok(Sc, Code, Args) ((symbol_ctr(car(Code)) == 1) || (closure_np_is_ok_1(Sc, Code, Args)))
#define closure_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_fine_1(Sc, Code, Type, Args)))
#define closure_star_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_star_is_fine_1(Sc, Code, Type, Args)))
static inline bool closure_is_eq(s7_scheme * sc)
{
sc->last_function = lookup_unexamined(sc, car(sc->code));
return (sc->last_function == opt1_lambda_unchecked(sc->code));
}
static bool star_arity_is_ok(s7_scheme * sc, s7_pointer val, int32_t args)
{
int32_t arity;
arity = closure_star_arity_to_int(sc, val);
return ((arity < 0) || ((arity * 2) >= args));
}
static bool closure_star_is_fine_1(s7_scheme * sc, s7_pointer code,
uint16_t type, int32_t args)
{
s7_pointer val;
val = lookup_unexamined(sc, car(code));
if ((val == opt1_lambda_unchecked(code)) ||
((val) &&
((typesflag(val) & (T_SAFE_CLOSURE | TYPE_MASK)) == type) &&
(star_arity_is_ok(sc, val, args)) &&
(set_opt1_lambda(code, val))))
return (true);
sc->last_function = val;
return (false);
}
/* closure_is_fine: */
#define FINE_UNSAFE_CLOSURE (T_CLOSURE)
#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE)
/* closure_star_is_fine: */
#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR)
#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE)
/* closure_is_ok: */
#define OK_UNSAFE_CLOSURE_P (T_CLOSURE | T_ONE_FORM)
#define OK_SAFE_CLOSURE_P (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM)
#define OK_UNSAFE_CLOSURE_M (T_CLOSURE | T_MULTIFORM)
#define OK_SAFE_CLOSURE_M (T_CLOSURE | T_SAFE_CLOSURE | T_MULTIFORM)
#define OK_SAFE_CLOSURE_A (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM_FX_ARG)
/* since T_HAS_METHODS is on if there might be methods, this can protect us from that case */
/* ---------------- eval ---------------- */
static s7_pointer eval(s7_scheme * sc, opcode_t first_op)
{
if (SHOW_EVAL_OPS)
safe_print(fprintf
(stderr, "eval[%d]:, %s %s %s\n", __LINE__,
op_names[first_op], display_80(sc->code),
display_80(sc->args)));
sc->cur_op = first_op;
goto TOP_NO_POP;
while (true) { /* "continue" in this procedure refers to this loop */
pop_stack(sc);
goto TOP_NO_POP;
BEGIN:
if (is_pair(cdr(T_Pair(sc->code))))
push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
sc->code = car(sc->code);
set_current_code(sc, sc->code);
EVAL:
sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_choice) */
TOP_NO_POP:
if (SHOW_EVAL_OPS)
safe_print(fprintf
(stderr, "%s (%d), code: %s\n",
op_names[sc->cur_op], (int) (sc->cur_op),
display_80(sc->code)));
/* it is only slightly faster to use labels as values (computed gotos) here. In my timing tests (June-2018), the best case speedup was in titer.scm
* callgrind numbers 4808 to 4669; another good case was tread.scm: 2410 to 2386. Most timings were a draw. computed-gotos-s7.c has the code,
* macroized so it will work if such gotos aren't available. I think I'll stick with a switch statement.
* Another seductive idea is to put the function in the tree, not an index to it (the optimize_op business above),
* then the switch below is not needed, and we free up 16 type bits. C does not guarantee tail calls (I think)
* so we'd have each function return the next, and eval would be (while (true) f = f(sc) but would the function
* call overhead be less expensive than the switch? (We get most functions inlined in the current code).
* with some fake fx_calls for the P cases, many of these could be
* sc->value = fx_function[sc->cur_op](sc, sc->code); continue;
* so the switch statement is unnecessary -- maybe a table eval_functions[cur_op] eventually
*/
switch (sc->cur_op) {
/* safe c_functions */
case OP_SAFE_C_NC:
if (!c_function_is_ok(sc, sc->code))
break; /* break refers to the switch statement */
case HOP_SAFE_C_NC:
sc->value = fc_call(sc, sc->code);
continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */
case OP_SAFE_C_S:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_g(sc))
goto EVAL;
continue;
}
case HOP_SAFE_C_S:
op_safe_c_s(sc);
continue;
case OP_SAFE_C_SS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SS:
op_safe_c_ss(sc);
continue;
case OP_SAFE_C_NS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_NS:
sc->value = fx_c_ns(sc, sc->code);
continue;
case OP_SAFE_C_SC:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SC:
op_safe_c_sc(sc);
continue;
case OP_SAFE_C_CS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_CS:
sc->value = fx_c_cs(sc, sc->code);
continue;
case OP_SAFE_C_CQ:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_CQ:
sc->value = fx_c_cq(sc, sc->code);
continue;
case OP_SAFE_C_FF:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_SAFE_C_FF:
sc->value = fx_c_ff(sc, sc->code);
continue;
case OP_SAFE_C_P:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_P:
op_safe_c_p(sc);
goto EVAL;
case OP_SAFE_C_P_1:
op_safe_c_p_1(sc);
continue;
case OP_ANY_C_NP:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_ANY_C_NP:
if (op_any_c_np(sc))
goto EVAL;
continue;
case OP_ANY_C_NP_1:
if (op_any_c_np_1(sc))
goto EVAL;
continue;
case OP_ANY_C_NP_2:
op_any_c_np_2(sc);
continue;
case OP_ANY_C_NP_MV_1:
if (op_any_c_np_mv_1(sc))
goto EVAL;
goto APPLY;
case OP_SAFE_C_SSP:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SSP:
op_safe_c_ssp(sc);
goto EVAL;
case OP_SAFE_C_SSP_1:
op_safe_c_ssp_1(sc);
continue;
case OP_SAFE_C_SSP_MV_1:
op_safe_c_ssp_mv_1(sc);
goto APPLY;
case OP_SAFE_C_A:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_C_A:
sc->value = fx_c_a(sc, sc->code);
continue;
case OP_SAFE_C_opAq:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_opAq:
sc->value = fx_c_opaq(sc, sc->code);
continue;
case OP_SAFE_C_opAAq:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_opAAq:
sc->value = fx_c_opaaq(sc, sc->code);
continue;
case OP_SAFE_C_opAAAq:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_opAAAq:
sc->value = fx_c_opaaaq(sc, sc->code);
continue;
case OP_SAFE_C_S_opAq:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_S_opAq:
sc->value = fx_c_s_opaq(sc, sc->code);
continue;
case OP_SAFE_C_opAq_S:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_opAq_S:
sc->value = fx_c_opaq_s(sc, sc->code);
continue;
case OP_SAFE_C_S_opAAq:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_S_opAAq:
sc->value = fx_c_s_opaaq(sc, sc->code);
continue;
case OP_SAFE_C_S_opAAAq:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_S_opAAAq:
sc->value = fx_c_s_opaaaq(sc, sc->code);
continue;
case OP_SAFE_C_AA:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_C_AA:
sc->value = fx_c_aa(sc, sc->code);
continue;
case OP_SAFE_C_SA:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_C_SA:
sc->value = fx_c_sa(sc, sc->code);
continue;
case OP_SAFE_C_AS:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_C_AS:
sc->value = fx_c_as(sc, sc->code);
continue;
case OP_SAFE_C_CA:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_C_CA:
sc->value = fx_c_ca(sc, sc->code);
continue;
case OP_SAFE_C_AC:
if (!c_function_is_ok(sc, sc->code)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_C_AC:
sc->value = fx_c_ac(sc, sc->code);
continue;
case OP_SAFE_C_AAA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_AAA:
sc->value = fx_c_aaa(sc, sc->code);
continue;
case OP_SAFE_C_SAA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SAA:
sc->value = fx_c_saa(sc, sc->code);
continue;
case OP_SAFE_C_SSA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SSA:
sc->value = fx_c_ssa(sc, sc->code);
continue;
case HOP_SSA_DIRECT:
sc->value = op_ssa_direct(sc, sc->code);
continue;
case HOP_HASH_TABLE_INCREMENT:
sc->value = fx_hash_table_increment(sc, sc->code);
continue; /* a placeholder, almost never called */
case OP_SAFE_C_SAS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SAS:
sc->value = fx_c_sas(sc, sc->code);
continue;
case OP_SAFE_C_ASS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_ASS:
sc->value = fx_c_ass(sc, sc->code);
continue;
case OP_SAFE_C_AGG:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_AGG:
sc->value = fx_c_agg(sc, sc->code);
continue;
case OP_SAFE_C_CAC:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_CAC:
sc->value = fx_c_cac(sc, sc->code);
continue;
case OP_SAFE_C_CSA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_CSA:
sc->value = fx_c_csa(sc, sc->code);
continue;
case OP_SAFE_C_SCA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SCA:
sc->value = fx_c_sca(sc, sc->code);
continue;
case OP_SAFE_C_4A:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_4A:
sc->value = fx_c_4a(sc, sc->code);
continue;
case OP_SAFE_C_NA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_NA:
sc->value = fx_c_na(sc, sc->code);
continue;
case OP_SAFE_C_ALL_CA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_ALL_CA:
sc->value = fx_c_all_ca(sc, sc->code);
continue;
case OP_SAFE_C_SCS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SCS:
sc->value = fx_c_scs(sc, sc->code);
continue;
case OP_SAFE_C_SSC:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SSC:
sc->value = fx_c_ssc(sc, sc->code);
continue;
case OP_SAFE_C_SCC:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SCC:
sc->value = fx_c_scc(sc, sc->code);
continue;
case OP_SAFE_C_CSC:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_CSC:
sc->value = fx_c_csc(sc, sc->code);
continue;
case OP_SAFE_C_CCS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_CCS:
sc->value = fx_c_ccs(sc, sc->code);
continue;
case OP_SAFE_C_CSS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_CSS:
sc->value = fx_c_css(sc, sc->code);
continue;
case OP_SAFE_C_SSS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SSS:
sc->value = fx_c_sss(sc, sc->code);
continue;
case OP_SAFE_C_opNCq:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opNCq:
sc->value = fx_c_opncq(sc, sc->code);
continue;
case OP_SAFE_C_opSq:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSq:
sc->value = fx_c_opsq(sc, sc->code);
continue;
case OP_SAFE_C_op_opSqq:
if (!c_function_is_ok_cadr_cadadr(sc, sc->code))
break;
case HOP_SAFE_C_op_opSqq:
sc->value = fx_c_op_opsqq(sc, sc->code);
continue;
case OP_SAFE_C_op_S_opSqq:
if (!c_function_is_ok_cadr_caddadr(sc, sc->code))
break;
case HOP_SAFE_C_op_S_opSqq:
sc->value = fx_c_op_s_opsqq(sc, sc->code);
continue;
case OP_SAFE_C_op_opSq_Sq:
if (!c_function_is_ok_cadr_cadadr(sc, sc->code))
break;
case HOP_SAFE_C_op_opSq_Sq:
sc->value = fx_c_op_opsq_sq(sc, sc->code);
continue;
case OP_SAFE_C_PS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_PS:
op_safe_c_ps(sc);
goto EVAL;
case OP_SAFE_C_PS_1:
op_safe_c_ps_1(sc);
continue;
case OP_SAFE_C_PS_MV:
op_safe_c_ps_mv(sc);
goto APPLY;
case OP_SAFE_C_PC:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_PC:
op_safe_c_pc(sc);
goto EVAL;
case OP_SAFE_C_PC_1:
op_safe_c_pc_1(sc);
continue;
case OP_SAFE_C_PC_MV:
op_safe_c_pc_mv(sc);
goto APPLY;
case OP_SAFE_C_SP:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_SP:
op_safe_c_sp(sc);
goto EVAL;
case OP_SAFE_C_SP_1:
op_safe_c_sp_1(sc);
continue;
case OP_SAFE_C_SP_MV:
op_safe_c_sp_mv(sc);
goto APPLY;
case OP_SAFE_CONS_SP_1:
sc->value = cons(sc, sc->args, sc->value);
continue;
case OP_SAFE_LIST_SP_1:
sc->value = list_2(sc, sc->args, sc->value);
continue;
case OP_SAFE_ADD_SP_1:
op_safe_add_sp_1(sc);
continue;
case OP_SAFE_MULTIPLY_SP_1:
op_safe_multiply_sp_1(sc);
continue;
case OP_SAFE_C_AP:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_AP:
if (op_safe_c_ap(sc))
goto EVAL;
continue;
case OP_SAFE_C_PA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_PA:
if (op_safe_c_pa(sc))
goto EVAL;
continue;
case OP_SAFE_C_PA_1:
op_safe_c_pa_1(sc);
continue;
case OP_SAFE_C_PA_MV:
op_safe_c_pa_mv(sc);
goto APPLY;
case OP_SAFE_C_CP:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_CP:
op_safe_c_cp(sc);
goto EVAL;
case OP_SAFE_C_PP:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_PP:
op_safe_c_pp(sc);
goto EVAL;
case OP_SAFE_C_PP_1:
op_safe_c_pp_1(sc);
goto EVAL;
case OP_SAFE_C_PP_3_MV:
op_safe_c_pp_3_mv(sc);
goto EVAL;
case OP_SAFE_C_PP_5:
op_safe_c_pp_5(sc);
goto APPLY;
case OP_SAFE_C_PP_6_MV:
op_safe_c_pp_6_mv(sc);
goto APPLY;
case OP_SAFE_C_3P:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_3P:
op_safe_c_3p(sc);
goto EVAL;
case OP_SAFE_C_3P_1:
op_safe_c_3p_1(sc);
goto EVAL;
case OP_SAFE_C_3P_2:
op_safe_c_3p_2(sc);
goto EVAL;
case OP_SAFE_C_3P_3:
op_safe_c_3p_3(sc);
continue;
case OP_SAFE_C_3P_1_MV:
op_safe_c_3p_1_mv(sc);
goto EVAL;
case OP_SAFE_C_3P_2_MV:
op_safe_c_3p_2_mv(sc);
goto EVAL;
case OP_SAFE_C_3P_3_MV:
op_safe_c_3p_3_mv(sc);
goto APPLY;
case OP_SAFE_C_opSSq:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSSq:
sc->value = fx_c_opssq(sc, sc->code);
continue;
case OP_SAFE_C_opSCq:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSCq:
sc->value = fx_c_opscq(sc, sc->code);
continue;
case OP_SAFE_C_opCSq:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opCSq:
sc->value = fx_c_opcsq(sc, sc->code);
continue;
case OP_SAFE_C_S_opSq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_SAFE_C_S_opSq:
sc->value = fx_c_s_opsq(sc, sc->code);
continue;
case OP_SAFE_C_C_opSq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_SAFE_C_C_opSq:
sc->value = fx_c_c_opsq(sc, sc->code);
continue;
case OP_SAFE_C_C_opSSq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_SAFE_C_C_opSSq:
sc->value = fx_c_c_opssq(sc, sc->code);
continue;
case OP_SAFE_C_opCSq_C:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opCSq_C:
sc->value = fx_c_opcsq_c(sc, sc->code);
continue;
case OP_SAFE_C_opSSq_C:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSSq_C:
sc->value = fx_c_opssq_c(sc, sc->code);
continue;
case OP_SAFE_C_opSSq_S:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSSq_S:
sc->value = fx_c_opssq_s(sc, sc->code);
continue;
case OP_SAFE_C_op_opSSqq_S:
if (!c_function_is_ok_cadr_cadadr(sc, sc->code))
break;
case HOP_SAFE_C_op_opSSqq_S:
sc->value = fx_c_op_opssqq_s(sc, sc->code);
continue;
case OP_SAFE_C_opSCq_C:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSCq_C:
sc->value = fx_c_opscq_c(sc, sc->code);
continue;
case OP_SAFE_C_opCSq_S:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opCSq_S:
sc->value = fx_c_opcsq_s(sc, sc->code);
continue;
case OP_SAFE_C_S_opSCq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_SAFE_C_S_opSCq:
sc->value = fx_c_s_opscq(sc, sc->code);
continue;
case OP_SAFE_C_C_opSCq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_SAFE_C_C_opSCq:
sc->value = fx_c_c_opscq(sc, sc->code);
continue;
case OP_SAFE_C_S_opSSq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_SAFE_C_S_opSSq:
sc->value = fx_c_s_opssq(sc, sc->code);
continue;
case OP_SAFE_C_S_opCSq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_SAFE_C_S_opCSq:
sc->value = fx_c_s_opcsq(sc, sc->code);
continue;
case OP_SAFE_C_opSq_S:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSq_S:
sc->value = fx_c_opsq_s(sc, sc->code);
continue;
case OP_SAFE_C_opSq_P:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSq_P:
op_safe_c_opsq_p(sc);
goto EVAL;
case OP_SAFE_C_opSq_CS:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSq_CS:
sc->value = fx_c_opsq_cs(sc, sc->code);
continue;
case OP_SAFE_C_opSq_C:
if (!c_function_is_ok_cadr(sc, sc->code))
break;
case HOP_SAFE_C_opSq_C:
sc->value = fx_c_opsq_c(sc, sc->code);
continue;
case OP_SAFE_C_opSq_opSq:
if (!c_function_is_ok_cadr_caddr(sc, sc->code))
break;
case HOP_SAFE_C_opSq_opSq:
sc->value = fx_c_opsq_opsq(sc, sc->code);
continue;
case OP_SAFE_C_opSSq_opSSq:
if (!c_function_is_ok_cadr_caddr(sc, sc->code))
break;
case HOP_SAFE_C_opSSq_opSSq:
sc->value = fx_c_opssq_opssq(sc, sc->code);
continue;
case OP_SAFE_C_opSSq_opSq:
if (!c_function_is_ok_cadr_caddr(sc, sc->code))
break;
case HOP_SAFE_C_opSSq_opSq:
sc->value = fx_c_opssq_opsq(sc, sc->code);
continue;
case OP_SAFE_C_opSq_opSSq:
if (!c_function_is_ok_cadr_caddr(sc, sc->code))
break;
case HOP_SAFE_C_opSq_opSSq:
sc->value = fx_c_opsq_opssq(sc, sc->code);
continue;
/* semisafe c_functions */
case OP_CL_S:
if (!cl_function_is_ok(sc, sc->code))
break;
case HOP_CL_S:
op_safe_c_s(sc);
continue;
case OP_CL_SS:
if (!cl_function_is_ok(sc, sc->code))
break;
case HOP_CL_SS:
op_safe_c_ss(sc);
continue; /* safe_c case has the code we want */
case OP_CL_S_opSq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_CL_S_opSq:
sc->value = fx_c_s_opsq(sc, sc->code);
continue;
case OP_CL_A:
if (!cl_function_is_ok(sc, sc->code)) {
set_optimize_op(sc->code, OP_S_A);
goto EVAL;
}
case HOP_CL_A:
op_cl_a(sc);
continue;
case OP_CL_AA:
if (!cl_function_is_ok(sc, sc->code))
break;
case HOP_CL_AA:
op_cl_aa(sc);
continue;
case OP_CL_SAS:
if (!cl_function_is_ok(sc, sc->code))
break;
case HOP_CL_SAS:
op_cl_sas(sc);
continue;
case OP_CL_NA:
if (!cl_function_is_ok(sc, sc->code))
break;
case HOP_CL_NA:
op_cl_na(sc);
continue;
case OP_CL_FA:
if (!cl_function_is_ok(sc, sc->code))
break;
case HOP_CL_FA:
op_cl_fa(sc);
continue; /* op_c_fs was not faster if fx_s below */
case OP_MAP_FOR_EACH_FA:
op_map_for_each_fa(sc);
continue; /* here only if for-each or map + one seq */
case OP_MAP_FOR_EACH_FAA:
op_map_for_each_faa(sc);
continue; /* here only if for-each or map + twp seqs */
/* unsafe c_functions */
case OP_C:
if (!c_function_is_ok(sc, sc->code)) {
set_optimize_op(sc->code, OP_S);
goto EVAL;
}
case HOP_C:
sc->value = fn_proc(sc->code) (sc, sc->nil);
continue;
case OP_C_S:
if (!c_function_is_ok(sc, sc->code)) {
set_optimize_op(sc->code, OP_S_S);
goto EVAL;
}
case HOP_C_S:
op_c_s(sc);
continue;
case OP_READ_S:
if (!c_function_is_ok(sc, sc->code)) {
set_optimize_op(sc->code, OP_S_S);
goto EVAL;
}
case HOP_READ_S:
op_read_s(sc);
continue;
case OP_C_A:
if (!c_function_is_ok(sc, sc->code)) {
set_optimize_op(sc->code, OP_S_A);
goto EVAL;
}
case HOP_C_A:
op_c_a(sc);
continue;
case OP_C_P:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_C_P:
op_c_p(sc);
goto EVAL;
case OP_C_P_1:
sc->value = fn_proc(sc->code) (sc, list_1(sc, sc->value));
continue;
case OP_C_P_MV:
op_c_p_mv(sc);
goto APPLY;
case OP_C_SS:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_C_SS:
op_c_ss(sc);
continue;
case OP_C_AP:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_C_AP:
op_c_ap(sc);
goto EVAL;
case OP_C_AP_1:
sc->value = fn_proc(sc->code) (sc, sc->args =
list_2(sc, sc->args,
sc->value));
continue;
case OP_C_AP_MV:
op_c_ap_mv(sc);
goto APPLY;
case OP_C_AA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_C_AA:
op_c_aa(sc);
continue;
case OP_C_S_opSq:
if (!c_function_is_ok_caddr(sc, sc->code))
break;
case HOP_C_S_opSq:
sc->value = op_c_s_opsq(sc);
continue;
case OP_C_NA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_C_NA:
op_c_na(sc);
continue;
case OP_APPLY_SS:
op_apply_ss(sc);
goto APPLY;
case OP_APPLY_SA:
op_apply_sa(sc);
goto APPLY;
case OP_APPLY_SL:
op_apply_sl(sc);
goto APPLY;
case OP_CALL_WITH_EXIT:
if (!c_function_is_ok(sc, sc->code))
break;
check_lambda_args(sc, cadadr(sc->code), NULL);
case HOP_CALL_WITH_EXIT:
op_call_with_exit(sc);
goto BEGIN;
case OP_CALL_CC:
op_call_cc(sc);
goto BEGIN;
case OP_CALL_WITH_EXIT_O:
if (!c_function_is_ok(sc, sc->code))
break;
check_lambda_args(sc, cadadr(sc->code), NULL);
case HOP_CALL_WITH_EXIT_O:
op_call_with_exit_o(sc);
goto EVAL;
case OP_C_CATCH:
if (!c_function_is_ok(sc, sc->code))
break;
check_lambda_args(sc, cadr(cadddr(sc->code)), NULL);
case HOP_C_CATCH:
op_c_catch(sc);
goto BEGIN;
case OP_C_CATCH_ALL:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_C_CATCH_ALL:
op_c_catch_all(sc);
goto BEGIN;
case OP_C_CATCH_ALL_O:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_C_CATCH_ALL_O:
op_c_catch_all(sc);
goto EVAL;
case OP_C_CATCH_ALL_A:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_C_CATCH_ALL_A:
op_c_catch_all_a(sc);
continue;
case OP_WITH_IO:
if (op_with_io_op(sc))
goto EVAL;
goto BEGIN;
case OP_WITH_IO_1:
if (!is_string(sc->value)) {
op_with_io_1_method(sc);
continue;
}
sc->code = op_with_io_1(sc);
goto BEGIN;
case OP_WITH_IO_C:
sc->value = cadr(sc->code);
sc->code = op_with_io_1(sc);
goto BEGIN;
case OP_WITH_OUTPUT_TO_STRING:
op_with_output_to_string(sc);
goto BEGIN;
case OP_CALL_WITH_OUTPUT_STRING:
op_call_with_output_string(sc);
goto BEGIN;
case OP_S:
op_s(sc);
goto APPLY;
case OP_S_C:
op_s_c(sc);
goto APPLY;
case OP_S_S:
if (op_s_s(sc))
continue;
goto APPLY;
case OP_S_A:
op_x_a(sc, lookup_checked(sc, car(sc->code)));
goto APPLY;
case OP_A_A:
op_x_a(sc, fx_call(sc, sc->code));
goto APPLY;
case OP_S_AA:
op_x_aa(sc, lookup_checked(sc, car(sc->code)));
goto APPLY;
case OP_A_AA:
op_x_aa(sc, fx_call(sc, sc->code));
goto APPLY;
case OP_P_S:
push_stack_no_args(sc, OP_P_S_1, sc->code);
sc->code = car(sc->code);
goto EVAL;
case OP_P_S_1:
op_p_s_1(sc);
goto APPLY;
case OP_SAFE_C_STAR:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_STAR:
op_safe_c_star(sc);
continue;
case OP_SAFE_C_STAR_A:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_STAR_A:
op_safe_c_star_a(sc);
continue;
case OP_SAFE_C_STAR_AA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_STAR_AA:
op_safe_c_star_aa(sc);
continue;
case OP_SAFE_C_STAR_NA:
if (!c_function_is_ok(sc, sc->code))
break;
case HOP_SAFE_C_STAR_NA:
op_safe_c_star_na(sc);
continue;
case OP_THUNK:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 0)) {
if (op_unknown(sc))
goto EVAL;
continue;
}
case HOP_THUNK:
op_thunk(sc);
goto EVAL;
case OP_SAFE_THUNK:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 0)) {
if (op_unknown(sc))
goto EVAL;
continue;
}
case HOP_SAFE_THUNK:
op_safe_thunk(sc);
goto EVAL;
case OP_THUNK_ANY:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1))
break; /* symbol as arglist */
case HOP_THUNK_ANY:
op_thunk_any(sc);
goto BEGIN;
case OP_SAFE_THUNK_A:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 0)) {
if (op_unknown(sc))
goto EVAL;
continue;
}
case HOP_SAFE_THUNK_A:
sc->value = op_safe_thunk_a(sc, sc->code);
continue;
case OP_CLOSURE_S:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {
if (op_unknown_g(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_S:
op_closure_s(sc);
goto EVAL;
case OP_CLOSURE_S_O:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {
if (op_unknown_g(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_S_O:
op_closure_s_o(sc);
goto EVAL;
case OP_SAFE_CLOSURE_S:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {
if (op_unknown_g(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_S:
op_safe_closure_s(sc);
goto EVAL;
case OP_SAFE_CLOSURE_S_O:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {
if (op_unknown_g(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_S_O:
op_safe_closure_s_o(sc);
goto EVAL;
case OP_SAFE_CLOSURE_S_A:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {
if (op_unknown_g(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_S_A:
sc->value = op_safe_closure_s_a(sc, sc->code);
continue;
case OP_SAFE_CLOSURE_S_TO_S:
if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {
if (op_unknown_g(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_S_TO_S:
sc->value = fx_safe_closure_s_to_s(sc, sc->code);
continue;
case OP_SAFE_CLOSURE_S_TO_SC:
if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {
if (op_unknown_g(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_S_TO_SC:
sc->value = fx_proc(cdr(sc->code)) (sc, sc->code);
continue;
case OP_SAFE_CLOSURE_A_TO_SC:
if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_A_TO_SC:
sc->value = fx_proc(sc->code) (sc, sc->code);
continue;
case OP_CLOSURE_P:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_P:
op_closure_p(sc);
goto EVAL;
case OP_CLOSURE_P_1:
op_closure_p_1(sc);
goto BEGIN;
case OP_SAFE_CLOSURE_P:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_P:
op_safe_closure_p(sc);
goto EVAL;
case OP_SAFE_CLOSURE_P_1:
op_safe_closure_p_1(sc);
goto BEGIN;
case OP_SAFE_CLOSURE_P_A:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_P_A:
op_safe_closure_p_a(sc);
goto EVAL;
case OP_SAFE_CLOSURE_P_A_1:
op_safe_closure_p_a_1(sc);
continue;
case OP_CLOSURE_A:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_A:
op_closure_a(sc);
push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
sc->code = car(sc->code);
goto EVAL;
case OP_CLOSURE_A_O:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_A_O:
op_closure_a(sc);
sc->code = car(sc->code);
goto EVAL;
case OP_SAFE_CLOSURE_A:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_A:
op_safe_closure_a(sc);
goto EVAL;
case OP_SAFE_CLOSURE_A_O:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_A_O:
op_safe_closure_a_o(sc);
goto EVAL;
case OP_SAFE_CLOSURE_A_A:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_A_A:
sc->value = op_safe_closure_a_a(sc, sc->code);
continue;
case OP_CLOSURE_AP:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_AP:
op_closure_ap(sc);
goto EVAL;
case OP_CLOSURE_AP_1:
op_closure_ap_1(sc);
goto BEGIN;
case OP_CLOSURE_PA:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_PA:
op_closure_pa(sc);
goto EVAL;
case OP_CLOSURE_PA_1:
op_closure_pa_1(sc);
goto BEGIN;
case OP_CLOSURE_PP:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_PP:
op_closure_pp(sc);
goto EVAL;
case OP_CLOSURE_PP_1:
op_closure_pp_1(sc);
goto EVAL;
case OP_SAFE_CLOSURE_AP:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_AP:
op_safe_closure_ap(sc);
goto EVAL;
case OP_SAFE_CLOSURE_AP_1:
op_safe_closure_ap_1(sc);
goto BEGIN;
case OP_SAFE_CLOSURE_PA:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_PA:
op_safe_closure_pa(sc);
goto EVAL;
case OP_SAFE_CLOSURE_PA_1:
op_safe_closure_pa_1(sc);
goto BEGIN;
case OP_SAFE_CLOSURE_PP:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_PP:
op_safe_closure_pp(sc);
goto EVAL;
case OP_SAFE_CLOSURE_PP_1:
op_safe_closure_pp_1(sc);
goto EVAL;
case OP_ANY_CLOSURE_3P:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_ANY_CLOSURE_3P:
op_any_closure_3p(sc);
goto EVAL;
case OP_ANY_CLOSURE_3P_1:
if (!op_any_closure_3p_1(sc))
goto EVAL;
goto BEGIN;
case OP_ANY_CLOSURE_3P_2:
if (!op_any_closure_3p_2(sc))
goto EVAL;
goto BEGIN;
case OP_ANY_CLOSURE_3P_3:
op_any_closure_3p_3(sc);
goto BEGIN;
case OP_ANY_CLOSURE_4P:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 4)) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_ANY_CLOSURE_4P:
op_any_closure_4p(sc);
goto EVAL;
case OP_ANY_CLOSURE_4P_1:
if (!op_any_closure_4p_1(sc))
goto EVAL;
goto BEGIN;
case OP_ANY_CLOSURE_4P_2:
if (!op_any_closure_4p_2(sc))
goto EVAL;
goto BEGIN;
case OP_ANY_CLOSURE_4P_3:
if (!op_any_closure_4p_3(sc))
goto EVAL;
goto BEGIN;
case OP_ANY_CLOSURE_4P_4:
op_any_closure_4p_4(sc);
goto BEGIN;
case OP_CLOSURE_FA:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2))
break;
case HOP_CLOSURE_FA:
op_closure_fa(sc);
goto EVAL;
case OP_CLOSURE_SS:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_SS:
op_closure_ss(sc);
goto EVAL;
case OP_CLOSURE_SS_O:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_SS_O:
op_closure_ss_o(sc);
goto EVAL;
case OP_SAFE_CLOSURE_SS:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_SS:
op_safe_closure_ss(sc);
goto EVAL;
case OP_SAFE_CLOSURE_SS_O:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_SS_O:
op_safe_closure_ss_o(sc);
goto EVAL;
case OP_SAFE_CLOSURE_SS_A:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_SS_A:
sc->value = op_safe_closure_ss_a(sc, sc->code);
continue;
case OP_CLOSURE_3S:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {
if (op_unknown_ns(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_3S:
op_closure_3s(sc);
goto EVAL;
case OP_CLOSURE_4S:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {
if (op_unknown_ns(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_4S:
op_closure_4s(sc);
goto EVAL;
case OP_CLOSURE_SC:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_SC:
op_closure_sc(sc);
goto EVAL;
case OP_CLOSURE_SC_O:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_SC_O:
op_closure_sc_o(sc);
goto EVAL;
case OP_SAFE_CLOSURE_SC:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_SC:
op_safe_closure_sc(sc);
goto EVAL;
case OP_SAFE_CLOSURE_SC_O:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {
if (op_unknown_gg(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_SC_O:
op_safe_closure_sc_o(sc);
goto EVAL;
case OP_CLOSURE_AA:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_AA:
op_closure_aa(sc);
goto EVAL;
case OP_CLOSURE_AA_O:
if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_AA_O:
op_closure_aa_o(sc);
goto EVAL;
case OP_SAFE_CLOSURE_AA:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_AA:
op_safe_closure_aa(sc);
goto EVAL;
case OP_SAFE_CLOSURE_AA_O:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_AA_O:
op_safe_closure_aa_o(sc);
goto EVAL;
case OP_SAFE_CLOSURE_AA_A:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_AA_A:
sc->value = fx_safe_closure_aa_a(sc, sc->code);
continue;
case OP_SAFE_CLOSURE_SSA:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_SSA:
op_safe_closure_ssa(sc);
goto BEGIN;
case OP_SAFE_CLOSURE_SAA:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_SAA:
op_safe_closure_saa(sc);
goto BEGIN;
case OP_SAFE_CLOSURE_AGG:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_AGG:
op_safe_closure_agg(sc);
goto BEGIN;
case OP_SAFE_CLOSURE_3A:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_3A:
op_safe_closure_3a(sc);
goto EVAL;
case OP_SAFE_CLOSURE_NS:
if (!closure_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE,
integer(opt3_arglen(cdr(sc->code))))) {
if (op_unknown_ns(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_NS:
op_safe_closure_ns(sc);
goto EVAL;
case OP_SAFE_CLOSURE_NA:
if (!closure_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE,
integer(opt3_arglen(cdr(sc->code))))) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_NA:
op_safe_closure_na(sc);
goto EVAL;
case OP_SAFE_CLOSURE_3S:
if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {
if (op_unknown_ns(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_3S:
op_safe_closure_3s(sc);
goto BEGIN;
case OP_SAFE_CLOSURE_3S_A:
if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {
if (op_unknown_ns(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_3S_A:
sc->value = op_safe_closure_3s_a(sc, sc->code);
continue;
case OP_CLOSURE_NS:
if (!closure_is_fine
(sc, sc->code, FINE_UNSAFE_CLOSURE,
integer(opt3_arglen(cdr(sc->code))))) {
if (op_unknown_ns(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_NS:
op_closure_ns(sc);
goto EVAL;
case OP_CLOSURE_ASS:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_ASS:
op_closure_ass(sc);
goto EVAL;
case OP_CLOSURE_AAS:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_AAS:
op_closure_aas(sc);
goto EVAL;
case OP_CLOSURE_SAA:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_SAA:
op_closure_saa(sc);
goto EVAL;
case OP_CLOSURE_ASA:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_ASA:
op_closure_asa(sc);
goto EVAL;
case OP_CLOSURE_SAS:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_SAS:
op_closure_sas(sc);
goto EVAL;
case OP_CLOSURE_3A:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_3A:
op_closure_3a(sc);
goto EVAL;
case OP_CLOSURE_4A:
if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_4A:
op_closure_4a(sc);
goto EVAL;
case OP_CLOSURE_NA:
if (!closure_is_fine
(sc, sc->code, FINE_UNSAFE_CLOSURE,
integer(opt3_arglen(cdr(sc->code))))) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_NA:
op_closure_na(sc);
goto EVAL;
case OP_ANY_CLOSURE_NA:
if (!check_closure_any(sc))
break;
case HOP_ANY_CLOSURE_NA:
op_any_closure_na(sc);
goto BEGIN;
case OP_ANY_CLOSURE_NP:
if (!closure_np_is_ok
(sc, sc->code, integer(opt3_arglen(cdr(sc->code))))) {
if (op_unknown_np(sc))
goto EVAL;
continue;
}
case HOP_ANY_CLOSURE_NP:
op_any_closure_np(sc);
goto EVAL;
case OP_ANY_CLOSURE_NP_1:
if (!
(collect_np_args
(sc, OP_ANY_CLOSURE_NP_1, cons(sc, sc->value, sc->args))))
op_any_closure_np_end(sc);
goto EVAL;
case OP_ANY_CLOSURE_NP_2:
sc->args = cons(sc, sc->value, sc->args);
op_any_closure_np_end(sc);
goto EVAL;
case OP_ANY_CLOSURE_NP_MV_1:
if (!
(collect_np_args
(sc, OP_ANY_CLOSURE_NP_MV_1,
(is_multiple_value(sc->value)) ? revappend(sc, sc->value,
sc->args) :
cons(sc, sc->value, sc->args))))
op_any_closure_np_end(sc);
goto EVAL;
case OP_TC_AND_A_OR_A_LA:
tick_tc(sc, sc->cur_op);
op_tc_and_a_or_a_la(sc, sc->code);
continue;
case OP_TC_OR_A_AND_A_LA:
tick_tc(sc, sc->cur_op);
op_tc_or_a_and_a_la(sc, sc->code);
continue;
case OP_TC_AND_A_OR_A_LAA:
tick_tc(sc, sc->cur_op);
op_tc_and_a_or_a_laa(sc, sc->code);
continue;
case OP_TC_OR_A_AND_A_LAA:
tick_tc(sc, sc->cur_op);
op_tc_or_a_and_a_laa(sc, sc->code);
continue;
case OP_TC_AND_A_OR_A_A_LA:
tick_tc(sc, sc->cur_op);
op_tc_and_a_or_a_a_la(sc, sc->code);
continue;
case OP_TC_OR_A_AND_A_A_LA:
tick_tc(sc, sc->cur_op);
op_tc_or_a_and_a_a_la(sc, sc->code);
continue;
case OP_TC_OR_A_A_AND_A_A_LA:
tick_tc(sc, sc->cur_op);
op_tc_or_a_a_and_a_a_la(sc, sc->code);
continue;
case OP_TC_OR_A_AND_A_A_L3A:
tick_tc(sc, sc->cur_op);
op_tc_or_a_and_a_a_l3a(sc, sc->code);
continue;
case OP_TC_IF_A_Z_LA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_la(sc, sc->code, false))
continue;
goto EVAL;
case OP_TC_IF_A_LA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_la_z(sc, sc->code, false))
continue;
goto EVAL;
case OP_TC_COND_A_Z_LA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_la(sc, sc->code, true))
continue;
goto EVAL;
case OP_TC_COND_A_LA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_la_z(sc, sc->code, true))
continue;
goto EVAL;
case OP_TC_IF_A_LAA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_laa(sc, sc->code, false, TC_IF))
continue;
goto EVAL;
case OP_TC_IF_A_Z_LAA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_laa(sc, sc->code, true, TC_IF))
continue;
goto EVAL;
case OP_TC_COND_A_Z_LAA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_laa(sc, sc->code, true, TC_COND))
continue;
goto EVAL;
case OP_TC_COND_A_LAA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_laa(sc, sc->code, false, TC_COND))
continue;
goto EVAL;
case OP_TC_WHEN_LAA:
tick_tc(sc, sc->cur_op);
op_tc_when_laa(sc, sc->code);
continue;
case OP_TC_IF_A_Z_L3A:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_l3a(sc, sc->code, true))
continue;
goto EVAL;
case OP_TC_IF_A_L3A_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_l3a(sc, sc->code, false))
continue;
goto EVAL;
case OP_TC_IF_A_Z_IF_A_Z_LA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_IF))
continue;
goto EVAL;
case OP_TC_IF_A_Z_IF_A_LA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_IF))
continue;
goto EVAL;
case OP_TC_COND_A_Z_A_Z_LA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_COND))
continue;
goto EVAL;
case OP_TC_COND_A_Z_A_LA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_COND))
continue;
goto EVAL;
case OP_TC_AND_A_IF_A_LA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_AND))
continue;
goto EVAL;
case OP_TC_AND_A_IF_A_Z_LA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_AND))
continue;
goto EVAL;
case OP_TC_IF_A_Z_IF_A_Z_LAA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code))
continue;
goto EVAL;
case OP_TC_IF_A_Z_IF_A_LAA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_laa_z(sc, false, sc->code))
continue;
goto EVAL;
case OP_TC_COND_A_Z_A_Z_LAA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code))
continue;
goto EVAL;
case OP_TC_COND_A_Z_A_LAA_Z:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_laa_z(sc, true, sc->code))
continue;
goto EVAL;
case OP_TC_LET_IF_A_Z_LA:
tick_tc(sc, sc->cur_op);
if (op_tc_let_if_a_z_la(sc, sc->code))
continue;
goto EVAL;
case OP_TC_LET_IF_A_Z_LAA:
tick_tc(sc, sc->cur_op);
if (op_tc_let_if_a_z_laa(sc, sc->code))
continue;
goto EVAL;
case OP_TC_LET_WHEN_LAA:
tick_tc(sc, sc->cur_op);
op_tc_let_when_laa(sc, true, sc->code);
continue;
case OP_TC_LET_UNLESS_LAA:
tick_tc(sc, sc->cur_op);
op_tc_let_when_laa(sc, false, sc->code);
continue;
case OP_TC_COND_A_Z_A_LAA_LAA:
tick_tc(sc, sc->cur_op);
if (op_tc_cond_a_z_a_laa_laa(sc, sc->code))
continue;
goto EVAL;
case OP_TC_IF_A_Z_IF_A_L3A_L3A:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code))
continue;
goto EVAL;
case OP_TC_IF_A_Z_LET_IF_A_Z_LAA:
tick_tc(sc, sc->cur_op);
if (op_tc_if_a_z_let_if_a_z_laa(sc, sc->code))
continue;
goto EVAL;
case OP_TC_CASE_LA:
tick_tc(sc, sc->cur_op);
if (op_tc_case_la(sc, sc->code))
continue;
goto BEGIN;
case OP_TC_LET_COND:
tick_tc(sc, sc->cur_op);
if (op_tc_let_cond(sc, sc->code))
continue;
goto EVAL;
case OP_RECUR_IF_A_A_opA_LAq:
wrap_recur_if_a_a_opa_laq(sc, true, true);
continue;
case OP_RECUR_IF_A_A_opLA_Aq:
wrap_recur_if_a_a_opa_laq(sc, true, false);
continue;
case OP_RECUR_IF_A_opA_LAq_A:
wrap_recur_if_a_a_opa_laq(sc, false, true);
continue;
case OP_RECUR_IF_A_opLA_Aq_A:
wrap_recur_if_a_a_opa_laq(sc, false, false);
continue;
case OP_RECUR_IF_A_A_opA_LAAq:
wrap_recur(sc, op_recur_if_a_a_opa_laaq);
continue;
case OP_RECUR_IF_A_A_opA_L3Aq:
wrap_recur(sc, op_recur_if_a_a_opa_l3aq);
continue;
case OP_RECUR_IF_A_opA_LAAq_A:
wrap_recur(sc, op_recur_if_a_opa_laaq_a);
continue;
case OP_RECUR_IF_A_A_opLA_LAq:
wrap_recur_if_a_a_opla_laq(sc, true);
continue;
case OP_RECUR_IF_A_opLA_LAq_A:
wrap_recur_if_a_a_opla_laq(sc, false);
continue;
case OP_RECUR_IF_A_A_opA_LA_LAq:
wrap_recur(sc, op_recur_if_a_a_opa_la_laq);
continue;
case OP_RECUR_IF_A_opA_LA_LAq_A:
wrap_recur(sc, op_recur_if_a_opa_la_laq_a);
continue;
case OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq:
wrap_recur(sc, op_recur_if_a_a_lopl3a_l3a_l3aq);
continue;
case OP_RECUR_IF_A_A_AND_A_LAA_LAA:
wrap_recur(sc, op_recur_if_a_a_and_a_laa_laa);
continue;
case OP_RECUR_IF_A_A_opLA_LA_LAq:
wrap_recur(sc, op_recur_if_a_a_opla_la_laq);
continue;
case OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq:
wrap_recur(sc, op_recur_if_a_a_if_a_laa_opa_laaq);
continue;
case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq:
wrap_recur(sc, op_recur_if_a_a_if_a_a_opla_laq);
continue;
case OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq:
wrap_recur(sc, op_recur_if_a_a_if_a_a_oplaa_laaq);
continue;
case OP_RECUR_COND_A_A_opA_LAq:
wrap_recur(sc, op_recur_cond_a_a_opa_laq);
continue;
case OP_RECUR_COND_A_A_opA_LAAq:
wrap_recur(sc, op_recur_cond_a_a_opa_laaq);
continue;
case OP_RECUR_COND_A_A_A_A_opLA_LAq:
wrap_recur(sc, op_recur_cond_a_a_a_a_opla_laq);
continue;
case OP_RECUR_COND_A_A_A_A_opA_LAAq:
wrap_recur(sc, op_recur_cond_a_a_a_a_opa_laaq);
continue;
case OP_RECUR_COND_A_A_A_A_opLAA_LAAq:
wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq);
continue;
case OP_RECUR_COND_A_A_A_LAA_opA_LAAq:
wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq);
continue;
case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq:
wrap_recur_cond_a_a_a_laa_lopa_laaq(sc);
continue;
case OP_RECUR_AND_A_OR_A_LAA_LAA:
wrap_recur(sc, op_recur_and_a_or_a_laa_laa);
continue;
case OP_SAFE_CLOSURE_STAR_A:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_A:
op_safe_closure_star_a(sc, sc->code);
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_A1:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_A1:
op_safe_closure_star_a1(sc, sc->code);
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_KA:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_KA:
op_safe_closure_star_ka(sc, sc->code);
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_AA:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_AA:
op_safe_closure_star_aa(sc, sc->code);
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_AA_O:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_AA_O:
op_safe_closure_star_aa(sc, sc->code);
sc->code = car(sc->code);
goto EVAL;
case OP_SAFE_CLOSURE_STAR_3A:
if (!closure_star_is_fine
(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 3)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_3A:
if (op_safe_closure_star_aaa(sc, sc->code))
goto EVAL;
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_NA:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR,
(is_pair(cdr(sc->code))) ?
integer(opt3_arglen(cdr(sc->code))) : 0)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_NA:
if (op_safe_closure_star_na(sc, sc->code))
goto EVAL;
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_NA_0:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 0)) {
if (op_unknown(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_NA_0:
if (op_safe_closure_star_na_0(sc, sc->code))
goto EVAL;
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_NA_1:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_NA_1:
if (op_safe_closure_star_na_1(sc, sc->code))
goto EVAL;
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_NA_2:
if (!closure_star_is_fine
(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_SAFE_CLOSURE_STAR_NA_2:
if (op_safe_closure_star_na_2(sc, sc->code))
goto EVAL;
goto BEGIN;
case OP_CLOSURE_STAR_A:
if (!closure_star_is_fine
(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {
if (op_unknown_a(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_STAR_A:
op_closure_star_a(sc, sc->code);
goto BEGIN;
case OP_CLOSURE_STAR_KA:
if (!closure_star_is_fine
(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {
if (op_unknown_aa(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_STAR_KA:
op_closure_star_ka(sc, sc->code);
goto BEGIN;
case OP_CLOSURE_STAR_NA:
if (!closure_star_is_fine
(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR,
(is_pair(cdr(sc->code))) ?
integer(opt3_arglen(cdr(sc->code))) : 0)) {
if (op_unknown_na(sc))
goto EVAL;
continue;
}
case HOP_CLOSURE_STAR_NA:
if (op_closure_star_na(sc, sc->code))
goto EVAL;
goto BEGIN;
case OP_UNKNOWN:
sc->last_function = lookup_checked(sc, car(sc->code));
if (op_unknown(sc))
goto EVAL;
continue;
case OP_UNKNOWN_NS:
sc->last_function = lookup_checked(sc, car(sc->code));
if (op_unknown_ns(sc))
goto EVAL;
continue;
case OP_UNKNOWN_G:
sc->last_function = lookup_checked(sc, car(sc->code));
if (op_unknown_g(sc))
goto EVAL;
continue;
case OP_UNKNOWN_GG:
sc->last_function = lookup_checked(sc, car(sc->code));
if (op_unknown_gg(sc))
goto EVAL;
continue;
case OP_UNKNOWN_A:
sc->last_function = lookup_checked(sc, car(sc->code));
if (op_unknown_a(sc))
goto EVAL;
continue;
case OP_UNKNOWN_AA:
sc->last_function = lookup_checked(sc, car(sc->code));
if (op_unknown_aa(sc))
goto EVAL;
continue;
case OP_UNKNOWN_NA:
sc->last_function = lookup_checked(sc, car(sc->code));
if (op_unknown_na(sc))
goto EVAL;
continue;
case OP_UNKNOWN_NP:
sc->last_function = lookup_checked(sc, car(sc->code));
if (op_unknown_np(sc))
goto EVAL;
continue;
case OP_IMPLICIT_VECTOR_REF_A:
if (op_implicit_vector_ref_a(sc) != goto_start) {
if (op_unknown_a(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_VECTOR_REF_AA:
if (op_implicit_vector_ref_aa(sc) != goto_start) {
if (op_unknown_aa(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_STRING_REF_A:
if (op_implicit_string_ref_a(sc) != goto_start) {
if (op_unknown_a(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_HASH_TABLE_REF_A:
if (!op_implicit_hash_table_ref_a(sc)) {
if (op_unknown_a(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_CONTINUATION_A:
if (!op_implicit_continuation_a(sc)) {
if (op_unknown_a(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_ITERATE:
if (!op_implicit_iterate(sc)) {
if (op_unknown(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_LET_REF_C:
if (!op_implicit_let_ref_c(sc)) {
if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc)))
goto EVAL;
}
continue;
case OP_IMPLICIT_LET_REF_A:
if (!op_implicit_let_ref_a(sc)) {
if (op_unknown_a(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_PAIR_REF_A:
if (!op_implicit_pair_ref_a(sc)) {
if (op_unknown_a(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_PAIR_REF_AA:
if (!op_implicit_pair_ref_aa(sc)) {
if (op_unknown_aa(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_C_OBJECT_REF_A:
if (!op_implicit_c_object_ref_a(sc)) {
if (op_unknown_a(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_GOTO:
if (!op_implicit_goto(sc)) {
if (op_unknown(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_GOTO_A:
if (!op_implicit_goto_a(sc)) {
if (op_unknown_a(sc))
goto EVAL;
}
continue;
case OP_IMPLICIT_VECTOR_SET_3:
if (op_implicit_vector_set_3(sc))
goto EVAL;
continue;
case OP_IMPLICIT_VECTOR_SET_4:
if (op_implicit_vector_set_4(sc))
goto EVAL;
continue;
case OP_IMPLICIT_S7_LET_REF_S:
sc->value = s7_let_field(sc, opt3_sym(sc->code));
continue;
case OP_IMPLICIT_S7_LET_SET_SA:
sc->value =
s7_let_field_set(sc, opt3_sym(cdr(sc->code)),
fx_call(sc, cddr(sc->code)));
continue;
case OP_UNOPT:
goto UNOPT;
case OP_SYM:
sc->value = lookup_checked(sc, sc->code);
continue;
case OP_GLOBAL_SYM:
sc->value = lookup_global(sc, sc->code);
continue;
case OP_CON:
sc->value = sc->code;
continue;
case OP_PAIR_PAIR:
op_pair_pair(sc);
goto EVAL; /* car is pair ((if x car cadr) ...) */
case OP_PAIR_ANY:
sc->value = car(sc->code);
goto EVAL_ARGS_TOP;
case OP_PAIR_SYM:
sc->value = lookup_global(sc, car(sc->code));
goto EVAL_ARGS_TOP;
case OP_EVAL_ARGS5:
op_eval_args5(sc);
goto APPLY;
case OP_EVAL_ARGS2:
op_eval_args2(sc);
goto APPLY; /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2] */
case OP_EVAL_ARGS3:
op_eval_args3(sc);
goto APPLY; /* sc->value is the next-to-last arg, and we know the last arg is not a list (so values can't mess us up!) */
case OP_EVAL_ARGS4:
sc->args = cons(sc, sc->value, sc->args);
goto EVAL_ARGS_PAIR;
case OP_EVAL_ARGS1:
sc->args = cons(sc, sc->value, sc->args);
goto EVAL_ARGS;
EVAL_ARGS_TOP:
case OP_EVAL_ARGS:
if (dont_eval_args(sc->value)) {
if (eval_args_no_eval_args(sc))
goto APPLY;
goto TOP_NO_POP;
}
sc->code = cdr(sc->code);
/* sc->value is the func (but can be anything if the code is messed up: (#\a 3))
* we don't have to delay lookup of the func because arg evaluation order is not specified, so
* (let ((func +)) (func (let () (set! func -) 3) 2))
* can return 5.
*/
push_op_stack(sc, sc->value);
if (sc->op_stack_now >= sc->op_stack_end)
resize_op_stack(sc);
sc->args = sc->nil;
EVAL_ARGS: /* first time, value = op, args = nil, code is args */
if (is_pair(sc->code)) { /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */
if ((sc->safety > NO_SAFETY) &&
(tree_is_cyclic(sc, sc->code)))
eval_error(sc,
"attempt to evaluate a circular list: ~A",
39, sc->code);
EVAL_ARGS_PAIR:
if (is_pair(car(sc->code))) {
eval_args_pair_car(sc);
goto EVAL;
}
if (is_pair(cdr(sc->code))) {
s7_pointer car_code = car(sc->code); /* not a pair */
sc->code = cdr(sc->code);
sc->value =
(is_symbol(car_code)) ? lookup_checked(sc,
car_code) :
T_Pos(car_code);
/* sc->value is the current arg's value, sc->code is pointing to the next */
/* cdr(sc->code) might not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */
if (is_null(cdr(sc->code))) {
if (eval_args_last_arg(sc))
goto EVAL;
/* drop into APPLY */
} else {
/* here we know sc->code is a pair, cdr(sc->code) is not null, sc->value is the previous arg's value */
sc->args = cons(sc, sc->value, sc->args);
goto EVAL_ARGS_PAIR;
}
} else
eval_last_arg(sc, car(sc->code));
/* drop into APPLY */
} else /* got all args -- go to apply */
/* *(--sc->op_stack_now) is the "function" (sc->value perhaps), sc->code is the arglist end, sc->args might be the preceding args reversed? */
if (is_not_null(sc->code))
improper_arglist_error(sc);
else {
sc->code = pop_op_stack(sc);
sc->args = proper_list_reverse_in_place(sc, sc->args);
}
/* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower.
* the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead,
* and the function-local overhead currently otherwise 0 if inlined.
*/
APPLY:
case OP_APPLY:
/* set_current_code(sc, history_cons(sc, sc->code, sc->args)); */
#if SHOW_EVAL_OPS
safe_print(fprintf
(stderr, " apply %s (%s) to %s\n",
display_80(sc->code),
s7_type_names[type(sc->code)],
display_80(sc->args)));
#endif
switch (type(sc->code)) {
case T_C_FUNCTION:
apply_c_function(sc);
continue;
case T_C_ANY_ARGS_FUNCTION:
apply_c_any_args_function(sc);
continue;
case T_C_FUNCTION_STAR:
apply_c_function_star(sc);
continue;
case T_C_OPT_ARGS_FUNCTION:
apply_c_opt_args_function(sc);
continue;
case T_C_RST_ARGS_FUNCTION:
apply_c_rst_args_function(sc);
continue;
case T_CONTINUATION:
apply_continuation(sc);
continue;
case T_GOTO:
call_with_exit(sc);
continue;
case T_C_OBJECT:
apply_c_object(sc);
continue;
case T_STRING:
apply_string(sc);
continue;
case T_HASH_TABLE:
apply_hash_table(sc);
continue;
case T_ITERATOR:
apply_iterator(sc);
continue;
case T_LET:
apply_let(sc);
continue;
case T_INT_VECTOR:
case T_BYTE_VECTOR:
case T_FLOAT_VECTOR:
case T_VECTOR:
apply_vector(sc);
continue;
case T_SYNTAX:
apply_syntax(sc);
goto TOP_NO_POP;
case T_PAIR:
if (apply_pair(sc))
continue;
goto APPLY;
case T_CLOSURE:
apply_closure(sc);
goto APPLY_LAMBDA;
case T_CLOSURE_STAR:
if (apply_closure_star(sc))
goto EVAL;
goto BEGIN;
case T_C_MACRO:
apply_c_macro(sc);
goto EVAL;
case T_MACRO:
apply_macro(sc);
goto APPLY_LAMBDA;
case T_BACRO:
apply_bacro(sc);
goto APPLY_LAMBDA;
case T_MACRO_STAR:
apply_macro_star(sc);
goto BEGIN;
case T_BACRO_STAR:
apply_bacro_star(sc);
goto BEGIN;
default:
apply_error(sc, sc->code, sc->args);
}
case OP_MACRO_STAR_D:
if (op_macro_star_d(sc))
goto EVAL_ARGS_TOP;
goto BEGIN;
case OP_MACRO_D:
if (op_macro_d(sc))
goto EVAL_ARGS_TOP;
APPLY_LAMBDA:
case OP_APPLY_LAMBDA:
apply_lambda(sc);
goto BEGIN;
case OP_LAMBDA_STAR_DEFAULT:
if (op_lambda_star_default(sc))
goto EVAL;
goto BEGIN;
case OP_MACROEXPAND_1:
switch (op_macroexpand_1(sc)) {
case goto_begin:
goto BEGIN;
case goto_eval:
goto EVAL;
case goto_start:
continue;
default:
goto APPLY_LAMBDA;
}
case OP_MACROEXPAND:
switch (op_macroexpand(sc)) {
case goto_begin:
goto BEGIN;
case goto_eval:
goto EVAL;
case goto_start:
continue;
default:
goto APPLY_LAMBDA;
}
HEAPSORT:if (op_heapsort(sc))
continue;
if (sc->value != sc->F)
goto APPLY;
case OP_SORT1:
op_sort1(sc);
goto APPLY;
case OP_SORT2:
if (op_sort2(sc))
continue;
goto HEAPSORT;
case OP_SORT:
if (!op_sort(sc))
goto HEAPSORT;
case OP_SORT3:
if (op_sort3(sc))
continue;
goto HEAPSORT;
case OP_SORT_PAIR_END:
sc->value = vector_into_list(sc, sc->value, car(sc->args));
continue;
case OP_SORT_VECTOR_END:
sc->value = vector_into_fi_vector(sc->value, car(sc->args));
continue;
case OP_SORT_STRING_END:
sc->value = vector_into_string(sc->value, car(sc->args));
continue;
case OP_MAP_GATHER:
op_map_gather(sc);
case OP_MAP:
if (op_map(sc))
continue;
goto APPLY;
case OP_MAP_GATHER_1:
op_map_gather(sc);
case OP_MAP_1:
if (op_map_1(sc))
continue;
goto BEGIN;
case OP_MAP_GATHER_2:
case OP_MAP_GATHER_3:
op_map_gather(sc);
case OP_MAP_2:
if (op_map_2(sc))
continue;
goto EVAL;
case OP_FOR_EACH:
if (op_for_each(sc))
continue;
goto APPLY;
case OP_FOR_EACH_1:
if (op_for_each_1(sc))
continue;
goto BEGIN;
case OP_FOR_EACH_2:
case OP_FOR_EACH_3:
if (op_for_each_2(sc))
continue;
goto EVAL;
case OP_MEMBER_IF:
case OP_MEMBER_IF1:
if (op_member_if(sc))
continue;
goto APPLY;
case OP_ASSOC_IF:
case OP_ASSOC_IF1:
if (op_assoc_if(sc))
continue;
goto APPLY;
case OP_SAFE_DOTIMES:
SAFE_DOTIMES: /* check_do */
switch (op_safe_dotimes(sc)) {
case goto_safe_do_end_clauses:
if (is_null(sc->code))
continue;
goto DO_END_CODE;
case goto_do_end_clauses:
goto DO_END_CLAUSES;
case goto_eval:
goto EVAL;
case goto_top_no_pop:
goto TOP_NO_POP;
default:
goto BEGIN;
}
case OP_SAFE_DO:
SAFE_DO: /* from check_do */
switch (op_safe_do(sc)) {
case goto_safe_do_end_clauses:
if (is_null(sc->code)) /* I don't think multiple values (as test result) can happen here -- all safe do loops involve counters by 1 to some integer end */
continue;
goto DO_END_CODE;
case goto_do_unchecked:
goto DO_UNCHECKED;
default:
goto BEGIN;
}
case OP_DOTIMES_P:
DOTIMES_P: /* from check_do */
switch (op_dotimes_p(sc)) {
case goto_do_end_clauses:
goto DO_END_CLAUSES;
case goto_do_unchecked:
goto DO_UNCHECKED;
default:
goto EVAL;
}
case OP_DOX:
DOX: /* from check_do */
switch (op_dox(sc)) {
case goto_do_end_clauses:
goto DO_END_CLAUSES;
case goto_start:
continue;
case goto_top_no_pop:
goto TOP_NO_POP; /* includes dox_step_o */
default:
goto BEGIN;
}
DO_NO_BODY:
case OP_DO_NO_BODY_FX_VARS:
op_do_no_body_fx_vars(sc);
goto EVAL;
case OP_DO_NO_BODY_FX_VARS_STEP:
if (op_do_no_body_fx_vars_step(sc))
goto DO_END_CLAUSES;
goto EVAL;
case OP_DO_NO_BODY_FX_VARS_STEP_1:
if (op_do_no_body_fx_vars_step_1(sc))
goto DO_END_CLAUSES;
goto EVAL;
case OP_DO_NO_VARS_NO_OPT:
op_do_no_vars_no_opt(sc); /* fall through */
case OP_DO_NO_VARS_NO_OPT_1:
if (op_do_no_vars_no_opt_1(sc))
goto DO_END_CLAUSES;
goto BEGIN;
case OP_DO_NO_VARS:
if (op_do_no_vars(sc))
goto DO_END_CLAUSES;
goto BEGIN;
case OP_SAFE_DOTIMES_STEP_O:
if (op_safe_dotimes_step_o(sc))
goto DO_END_CLAUSES;
goto EVAL;
case OP_SAFE_DOTIMES_STEP:
if (op_safe_dotimes_step(sc))
goto DO_END_CLAUSES;
goto EVAL;
case OP_SAFE_DO_STEP:
if (op_safe_do_step(sc))
goto DO_END_CLAUSES;
goto BEGIN;
case OP_SIMPLE_DO:
if (op_simple_do(sc))
goto DO_END_CLAUSES;
goto BEGIN;
case OP_SIMPLE_DO_STEP:
if (op_simple_do_step(sc))
goto DO_END_CLAUSES;
goto BEGIN;
case OP_DOTIMES_STEP_O:
if (op_dotimes_step_o(sc))
goto DO_END_CLAUSES;
goto EVAL;
case OP_DOX_INIT:
if (op_dox_init(sc))
goto DO_END_CLAUSES;
goto BEGIN;
case OP_DOX_STEP:
if (op_dox_step(sc))
goto DO_END_CLAUSES;
goto BEGIN;
case OP_DOX_STEP_O:
if (op_dox_step_o(sc))
goto DO_END_CLAUSES;
goto EVAL;
case OP_DOX_NO_BODY:
op_dox_no_body(sc);
continue;
case OP_DOX_PENDING_NO_BODY:
op_dox_pending_no_body(sc);
goto DO_END_CLAUSES;
case OP_DO_INIT:
if (op_do_init(sc))
goto DO_END;
goto EVAL;
case OP_DO:
if (is_null(check_do(sc)))
switch (optimize_op(sc->code)) {
case OP_DOX:
goto DOX;
case OP_SAFE_DOTIMES:
goto SAFE_DOTIMES;
case OP_DOTIMES_P:
goto DOTIMES_P;
case OP_SAFE_DO:
goto SAFE_DO;
case OP_DO_NO_BODY_FX_VARS:
goto DO_NO_BODY;
case OP_DO_NO_VARS:
if (op_do_no_vars(sc))
goto DO_END_CLAUSES;
goto BEGIN;
case OP_DOX_NO_BODY:
op_dox_no_body(sc);
continue;
case OP_DOX_PENDING_NO_BODY:
op_dox_pending_no_body(sc);
goto DO_END_CLAUSES;
default:
if (op_simple_do(sc))
goto DO_END_CLAUSES;
goto BEGIN;
}
case OP_DO_UNCHECKED:
op_do_unchecked(sc);
DO_UNCHECKED:
if (do_unchecked(sc))
goto EVAL;
DO_END:
case OP_DO_END:
if (op_do_end(sc))
goto EVAL;
case OP_DO_END1:
switch (op_do_end1(sc)) {
case goto_start:
continue;
case goto_eval:
goto EVAL;
case goto_begin:
goto BEGIN;
case goto_feed_to:
goto FEED_TO;
case goto_do_end:
goto DO_END;
default:
break;
}
case OP_DO_STEP:
if (op_do_step(sc))
goto DO_END;
goto EVAL;
case OP_DO_STEP2:
if (op_do_step2(sc))
goto DO_END;
goto EVAL;
DO_END_CLAUSES:
if (do_end_clauses(sc))
continue;
DO_END_CODE:
switch (do_end_code(sc)) {
case goto_feed_to:
goto FEED_TO;
case goto_eval:
goto EVAL;
default:
continue;
}
case OP_BEGIN_UNCHECKED:
set_current_code(sc, sc->code);
sc->code = T_Pair(cdr(sc->code));
goto BEGIN;
case OP_BEGIN:
if (op_begin(sc, sc->code))
continue;
sc->code = T_Pair(cdr(sc->code));
case OP_BEGIN_HOOK:
if (sc->begin_hook) {
/* call_begin_hook might clobber sc->code? via s7_eval_string probably yes */
set_current_code(sc, sc->code);
if (call_begin_hook(sc))
return (sc->F);
}
case OP_BEGIN_NO_HOOK:
goto BEGIN;
case OP_BEGIN_2_UNCHECKED:
push_stack_no_args(sc, OP_EVAL, caddr(sc->code));
sc->code = cadr(sc->code);
goto EVAL;
case OP_BEGIN_AA:
sc->value = fx_begin_aa(sc, sc->code);
continue;
case OP_BEGIN_NA:
sc->value = fx_begin_na(sc, sc->code);
continue;
case OP_EVAL:
goto EVAL;
case OP_EVAL_STRING:
op_eval_string(sc);
goto EVAL;
case OP_QUOTE:
sc->value = check_quote(sc, sc->code);
continue;
case OP_QUOTE_UNCHECKED:
sc->value = cadr(sc->code);
continue;
case OP_DEFINE_FUNCHECKED:
define_funchecked(sc);
continue;
case OP_DEFINE_CONSTANT1:
op_define_constant1(sc);
continue;
case OP_DEFINE_CONSTANT:
if (op_define_constant(sc))
continue;
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 (op_define_unchecked(sc))
goto TOP_NO_POP;
case OP_DEFINE1:
if (op_define1(sc) == goto_apply)
goto APPLY;
case OP_DEFINE_WITH_SETTER:
op_define_with_setter(sc);
continue;
case OP_SET_LET_S: /* (set! (*s7* 'print-length) i) */
sc->code = cdr(sc->code);
if (set_pair_p_3
(sc, lookup_slot_from(caar(sc->code), sc->curlet),
cadr(cadar(sc->code)), lookup(sc, cadr(sc->code))))
goto APPLY;
continue;
case OP_SET_LET_FX: /* (set! (hook 'result) 123) or (set! (H 'c) 32) */
sc->code = cdr(sc->code);
if (set_pair_p_3
(sc, lookup_slot_from(caar(sc->code), sc->curlet),
cadr(cadar(sc->code)), fx_call(sc, cdr(sc->code))))
goto APPLY;
continue;
case OP_SET_PAIR_ZA: /* unknown setter pair, but value is easy */
sc->code = cdr(sc->code);
sc->value = fx_call(sc, cdr(sc->code));
case OP_SET_PAIR_P_1:
if (op_set_pair_p_1(sc))
goto APPLY;
continue;
case OP_SET_PAIR:
if (op_set_pair(sc))
goto APPLY;
continue;
case OP_SET_PAIR_P:
op_set_pair_p(sc);
goto EVAL;
case OP_SET_PAIR_A:
op_set_pair_a(sc);
continue;
case OP_SET_PWS:
op_set_pws(sc);
continue;
case OP_SET_DILAMBDA_SA_A:
op_set_dilambda_sa_a(sc);
continue;
case OP_SET_DILAMBDA_P:
op_set_dilambda_p(sc);
goto EVAL;
case OP_SET_DILAMBDA:
op_set_dilambda(sc); /* fall through */
case OP_SET_DILAMBDA_P_1:
switch (op_set_dilambda_p_1(sc)) {
case goto_begin:
goto BEGIN;
case goto_apply:
goto APPLY;
default:
continue;
}
case OP_INCREMENT_BY_1:
op_increment_by_1(sc);
continue;
case OP_DECREMENT_BY_1:
op_decrement_by_1(sc);
continue;
case OP_INCREMENT_SS:
op_increment_ss(sc);
continue;
case OP_INCREMENT_SA:
op_increment_sa(sc);
continue;
case OP_INCREMENT_SAA:
op_increment_saa(sc);
continue;
case OP_INCREMENT_SP:
op_increment_sp(sc);
goto EVAL;
case OP_INCREMENT_SP_1:
op_increment_sp_1(sc);
continue;
case OP_INCREMENT_SP_MV:
op_increment_sp_mv(sc);
continue;
case OP_SET_SYMBOL_C:
op_set_symbol_c(sc);
continue;
case OP_SET_SYMBOL_S:
op_set_symbol_s(sc);
continue;
case OP_SET_SYMBOL_A:
op_set_symbol_a(sc);
continue;
case OP_SET_SYMBOL_P:
op_set_symbol_p(sc);
goto EVAL;
case OP_SET_CONS:
op_set_cons(sc);
continue;
case OP_SET_SAFE:
op_set_safe(sc);
continue;
case OP_SET_FROM_SETTER:
slot_set_value(sc->code, sc->value);
continue; /* mv caught in splice_in_values */
case OP_SET_FROM_LET_TEMP:
op_set_from_let_temp(sc);
continue;
case OP_SET2:
switch (op_set2(sc)) {
case goto_eval:
goto EVAL;
case goto_top_no_pop:
goto TOP_NO_POP;
case goto_start:
continue;
case goto_apply:
goto APPLY;
default:
goto EVAL_ARGS;
}
case OP_SET:
check_set(sc);
case OP_SET_UNCHECKED:
if (is_pair(cadr(sc->code))) /* has setter */
switch (set_implicit(sc)) {
case goto_top_no_pop:
goto TOP_NO_POP;
case goto_start:
continue;
case goto_apply:
goto APPLY;
default:
goto EVAL_ARGS;
}
case OP_SET_NORMAL:
if (op_set_normal(sc))
goto EVAL;
case OP_SET1:
if (op_set1(sc))
continue;
goto APPLY;
case OP_SET_WITH_LET_1:
if (op_set_with_let_1(sc))
goto TOP_NO_POP;
goto SET_WITH_LET;
case OP_SET_WITH_LET_2:
if (op_set_with_let_2(sc))
continue;
SET_WITH_LET:
activate_with_let(sc, sc->value); /* this activates sc->value, so the set! will happen in that environment */
if (is_pair(cadr(sc->code)))
switch (set_implicit(sc)) {
case goto_top_no_pop:
goto TOP_NO_POP;
case goto_start:
continue;
case goto_apply:
goto APPLY;
default:
goto EVAL_ARGS;
}
s7_error(sc, sc->out_of_range_symbol,
set_elist_2(sc, wrap_string(sc, "can't set ~A", 12),
sc->args));
case OP_IF:
op_if(sc);
goto EVAL;
case OP_IF_UNCHECKED:
op_if_unchecked(sc);
goto EVAL;
case OP_IF1:
if (op_if1(sc))
goto EVAL;
continue;
#define if_a_p(sc) if (is_true(sc, fx_call(sc, cdr(sc->code))))
#define if_not_a_p(sc) if (is_false(sc, fx_call(sc, opt3_pair(sc->code)))) /* cdadr(sc->code) */
case OP_IF_A_C_C:
sc->value =
(is_true(sc, fx_call(sc, cdr(sc->code)))) ?
opt1_con(sc->code)
: opt2_con(sc->code);
continue;
case OP_IF_A_A:
sc->value =
(is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc,
opt1_pair
(sc->code))
: sc->unspecified;
continue;
case OP_IF_S_A_A:
sc->value =
(is_true(sc, lookup(sc, cadr(sc->code)))) ? fx_call(sc,
opt1_pair
(sc->code))
: fx_call(sc, opt2_pair(sc->code));
continue;
case OP_IF_A_A_A:
sc->value =
(is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc,
opt1_pair
(sc->code))
: fx_call(sc, opt2_pair(sc->code));
continue;
case OP_IF_A_A_P:
if_a_p(sc) {
sc->value = fx_call(sc, opt1_pair(sc->code));
continue;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_A_P_A:
if_a_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = fx_call(sc, opt2_pair(sc->code));
continue;
case OP_IF_NOT_A_A:
sc->value =
(is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ?
fx_call(sc, opt2_pair(sc->code)) : sc->unspecified;
continue;
case OP_IF_NOT_A_A_A:
sc->value =
(is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ?
fx_call(sc, opt2_pair(sc->code)) : fx_call(sc,
opt3_pair
(sc->code));
continue;
case OP_IF_AND2_S_A:
sc->value = fx_if_and2_s_a(sc, sc->code);
continue;
#define call_bfunc(Sc, Expr) ((s7_bfunc)opt3_any(cdr(Sc->code)))(Sc, Expr)
case OP_IF_B_A:
sc->value =
(call_bfunc(sc, cadr(sc->code))) ? fx_call(sc,
opt1_pair
(sc->code))
: sc->unspecified;
continue;
case OP_IF_B_A_P:
if (call_bfunc(sc, cadr(sc->code))) {
sc->value = fx_call(sc, opt1_pair(sc->code));
continue;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_B_P_A:
if (call_bfunc(sc, cadr(sc->code))) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = fx_call(sc, opt2_pair(sc->code));
continue;
case OP_IF_B_P_P:
if (call_bfunc(sc, cadr(sc->code))) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
#define if_s_p(sc) if (is_true(sc, lookup(sc, cadr(sc->code))))
#define if_not_s_p(sc) if (is_false(sc, lookup(sc, opt1_sym(cdr(sc->code))))) /* cadadr(sc->code) */
case OP_IF_S_P:
if_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_S_R:
if_s_p(sc) {
sc->value = sc->unspecified;
continue;
}
sc->code = opt1_any(sc->code);
goto EVAL;
case OP_IF_S_P_P:
if_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_S_N:
if_not_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_S_N_N:
if_not_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_S_P_A:
if_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = fx_call(sc, opt2_pair(sc->code));
continue;
case OP_IF_A_P:
if_a_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_A_R:
if_a_p(sc) {
sc->value = sc->unspecified;
continue;
}
sc->code = opt1_any(sc->code);
goto EVAL;
case OP_IF_A_P_P:
if_a_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_A_N:
if_not_a_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_A_N_N:
if_not_a_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_B_P:
if (call_bfunc(sc, cadr(sc->code))) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_B_R:
if (call_bfunc(sc, cadr(sc->code))) {
sc->value = sc->unspecified;
continue;
}
sc->code = opt1_any(sc->code);
goto EVAL;
case OP_IF_B_N_N:
if (call_bfunc(sc, car(opt3_pair(sc->code)))) {
sc->code = opt2_any(sc->code);
goto EVAL;
}
sc->code = opt1_any(sc->code);
goto EVAL;
#define if_is_type_s_p(sc) if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code))))
#define if_is_not_type_s_p(sc) if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code))))
case OP_IF_IS_TYPE_S_P:
if_is_type_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_IS_TYPE_S_R:
if_is_type_s_p(sc) {
sc->value = sc->unspecified;
continue;
}
sc->code = opt1_any(sc->code);
goto EVAL;
case OP_IF_IS_TYPE_S_P_P:
if_is_type_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_IS_TYPE_S_N:
if_is_not_type_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_IS_TYPE_S_N_N:
if_is_not_type_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_IS_TYPE_S_A_A:
if_is_type_s_p(sc) sc->value = fx_call(sc, cddr(sc->code));
else
sc->value = fx_call(sc, opt2_pair(sc->code));
continue;
case OP_IF_IS_TYPE_S_P_A:
if_is_type_s_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = fx_call(sc, opt2_pair(sc->code));
continue;
#define if_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, fn_proc(cadr(sc->code))(sc, sc->t1_1)))
#define if_not_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_false(sc, fn_proc(opt1_pair(cdr(sc->code)))(sc, sc->t1_1))) /* cadadr */
case OP_IF_opSq_P:
if_opsq_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_opSq_R:
if_opsq_p(sc) {
sc->value = sc->unspecified;
continue;
}
sc->code = opt1_any(sc->code);
goto EVAL;
case OP_IF_opSq_P_P:
if_opsq_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_opSq_N:
if_not_opsq_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_opSq_N_N:
if_not_opsq_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
#define if_and2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code))))))
#define if_not_and2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))))
case OP_IF_AND2_P:
if_and2_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_AND2_R:
if_and2_p(sc) {
sc->value = sc->unspecified;
continue;
}
sc->code = opt1_any(sc->code);
goto EVAL;
case OP_IF_AND2_P_P:
if_and2_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_AND2_N:
if_not_and2_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_AND2_N_N:
if_not_and2_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
#define if_or2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code))))))
#define if_not_or2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))))
case OP_IF_OR2_P:
if_or2_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_OR2_R:
if_or2_p(sc) {
sc->value = sc->unspecified;
continue;
}
sc->code = opt1_any(sc->code);
goto EVAL;
case OP_IF_OR2_P_P:
if_or2_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_OR2_N:
if_not_or2_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_OR2_N_N:
if_not_or2_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
#define if_and3_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && \
(is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt1_pair(cdr(sc->code))))))
#define if_not_and3_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || \
(is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt1_pair(cdr(sc->code))))))
case OP_IF_AND3_P:
if_and3_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_AND3_R:
if_and3_p(sc) {
sc->value = sc->unspecified;
continue;
}
sc->code = opt1_any(sc->code);
goto EVAL;
case OP_IF_AND3_P_P:
if_and3_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
case OP_IF_AND3_N:
if_not_and3_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->value = sc->unspecified;
continue;
case OP_IF_AND3_N_N:
if_not_and3_p(sc) {
sc->code = opt1_any(sc->code);
goto EVAL;
}
sc->code = opt2_any(sc->code);
goto EVAL;
#define if_p_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code));} while (0)
case OP_IF_P_P:
if_p_push(OP_IF_PP);
goto EVAL;
case OP_IF_P_N:
if_p_push(OP_IF_PR);
goto EVAL;
case OP_IF_P_P_P:
if_p_push(OP_IF_PPP);
goto EVAL;
case OP_IF_P_R:
if_p_push(OP_IF_PR);
goto EVAL;
case OP_IF_P_N_N:
if_p_push(OP_IF_PRR);
goto EVAL;
#define if_bp_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code));} while (0)
case OP_IF_ANDP_P:
if_bp_push(OP_IF_PP);
goto AND_P;
case OP_IF_ANDP_R:
if_bp_push(OP_IF_PR);
goto AND_P;
case OP_IF_ANDP_P_P:
if_bp_push(OP_IF_PPP);
goto AND_P;
case OP_IF_ANDP_N:
if_bp_push(OP_IF_PR);
goto AND_P;
case OP_IF_ANDP_N_N:
if_bp_push(OP_IF_PRR);
goto AND_P;
case OP_IF_ORP_P:
if_bp_push(OP_IF_PP);
goto OR_P;
case OP_IF_ORP_R:
if_bp_push(OP_IF_PR);
goto OR_P;
case OP_IF_ORP_P_P:
if_bp_push(OP_IF_PPP);
goto OR_P;
case OP_IF_ORP_N:
if_bp_push(OP_IF_PR);
goto OR_P;
case OP_IF_ORP_N_N:
if_bp_push(OP_IF_PRR);
goto OR_P;
case OP_IF_PP:
if (sc->value != sc->F)
goto EVAL;
sc->value = sc->unspecified;
continue;
case OP_IF_PR:
if (sc->value == sc->F)
goto EVAL;
sc->value = sc->unspecified;
continue;
case OP_IF_PPP:
sc->code =
(sc->value != sc->F) ? car(sc->code) : cadr(sc->code);
goto EVAL;
case OP_IF_PRR:
sc->code =
(sc->value == sc->F) ? car(sc->code) : cadr(sc->code);
goto EVAL;
case OP_COND_FEED:
if (op_cond_feed(sc))
goto EVAL; /* else fall through */
case OP_COND_FEED_1:
if (op_cond_feed_1(sc))
goto EVAL;
continue;
case OP_WHEN:
check_when(sc);
goto EVAL;
case OP_WHEN_S:
if (op_when_s(sc))
continue;
goto EVAL;
case OP_WHEN_A:
if (op_when_a(sc))
continue;
goto EVAL;
case OP_WHEN_P:
op_when_p(sc);
goto EVAL;
case OP_WHEN_AND_2A:
if (op_when_and_2a(sc))
continue;
goto EVAL;
case OP_WHEN_AND_3A:
if (op_when_and_3a(sc))
continue;
goto EVAL;
case OP_WHEN_AND_AP:
if (op_when_and_ap(sc))
continue;
goto EVAL;
case OP_WHEN_PP:
if (op_when_pp(sc))
continue;
goto EVAL;
case OP_UNLESS:
check_unless(sc);
goto EVAL;
case OP_UNLESS_S:
if (op_unless_s(sc))
continue;
goto EVAL;
case OP_UNLESS_A:
if (op_unless_a(sc))
continue;
goto EVAL;
case OP_UNLESS_P:
op_unless_p(sc);
goto EVAL;
case OP_UNLESS_PP:
if (op_unless_pp(sc))
continue;
goto EVAL;
case OP_NAMED_LET_NO_VARS:
op_named_let_no_vars(sc);
goto BEGIN;
case OP_NAMED_LET:
if (op_named_let(sc))
goto BEGIN;
goto EVAL;
case OP_NAMED_LET_A:
op_named_let_a(sc);
goto BEGIN;
case OP_NAMED_LET_AA:
op_named_let_aa(sc);
goto BEGIN;
case OP_NAMED_LET_FX:
if (op_named_let_fx(sc))
goto BEGIN;
goto EVAL;
case OP_LET:
if (op_let(sc))
goto BEGIN;
goto EVAL;
case OP_LET_UNCHECKED:
if (op_let_unchecked(sc))
goto BEGIN;
goto EVAL;
case OP_LET1:
if (op_let1(sc))
goto BEGIN;
goto EVAL;
case OP_LET_NO_VARS:
op_let_no_vars(sc);
goto BEGIN;
case OP_LET_A_A_OLD:
op_let_a_a_old(sc);
continue;
case OP_LET_A_A_NEW:
op_let_a_a_new(sc);
continue;
case OP_LET_A_FX_OLD:
op_let_a_fx_old(sc);
continue;
case OP_LET_A_FX_NEW:
op_let_a_fx_new(sc);
continue;
case OP_LET_FX_OLD:
op_let_fx_old(sc);
goto BEGIN;
case OP_LET_FX_NEW:
op_let_fx_new(sc);
goto BEGIN;
case OP_LET_2A_OLD:
op_let_2a_old(sc);
goto EVAL;
case OP_LET_2A_NEW:
op_let_2a_new(sc);
goto EVAL;
case OP_LET_3A_OLD:
op_let_3a_old(sc);
goto EVAL;
case OP_LET_3A_NEW:
op_let_3a_new(sc);
goto EVAL;
case OP_LET_ONE_OLD:
op_let_one_old(sc);
goto EVAL;
case OP_LET_ONE_NEW:
op_let_one_new(sc);
goto EVAL;
case OP_LET_ONE_P_OLD:
op_let_one_p_old(sc);
goto EVAL;
case OP_LET_ONE_P_NEW:
op_let_one_p_new(sc);
goto EVAL;
case OP_LET_A_OLD:
op_let_a_old(sc);
sc->code = cdr(sc->code);
goto BEGIN;
case OP_LET_A_NEW:
op_let_a_new(sc);
sc->code = cdr(sc->code);
goto BEGIN;
case OP_LET_A_OLD_2:
op_let_a_old(sc);
push_stack_no_args(sc, OP_EVAL, caddr(sc->code));
sc->code = cadr(sc->code);
goto EVAL;
case OP_LET_A_NEW_2:
op_let_a_new(sc);
push_stack_no_args(sc, OP_EVAL, caddr(sc->code));
sc->code = cadr(sc->code);
goto EVAL;
case OP_LET_A_P_OLD:
op_let_a_old(sc);
sc->code = cadr(sc->code);
goto EVAL;
case OP_LET_A_P_NEW:
op_let_a_new(sc);
sc->code = cadr(sc->code);
goto EVAL;
case OP_LET_ONE_OLD_1:
op_let_one_old_1(sc);
goto BEGIN;
case OP_LET_ONE_P_OLD_1:
op_let_one_p_old_1(sc);
goto EVAL;
case OP_LET_ONE_NEW_1:
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code),
sc->value);
goto BEGIN;
case OP_LET_ONE_P_NEW_1:
sc->curlet =
make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code),
sc->value);
sc->code = car(sc->code);
goto EVAL;
case OP_LET_opSSq_OLD:
op_let_opssq_old(sc);
goto BEGIN;
case OP_LET_opSSq_NEW:
op_let_opssq_new(sc);
goto BEGIN;
case OP_LET_opSSq_E_OLD:
op_let_opssq_e_old(sc);
goto EVAL;
case OP_LET_opSSq_E_NEW:
op_let_opssq_e_new(sc);
goto EVAL;
case OP_LET_opaSSq_OLD:
op_let_opassq_old(sc);
goto BEGIN;
case OP_LET_opaSSq_NEW:
op_let_opassq_new(sc);
goto BEGIN;
case OP_LET_opaSSq_E_OLD:
op_let_opassq_e_old(sc);
goto EVAL;
case OP_LET_opaSSq_E_NEW:
op_let_opassq_e_new(sc);
goto EVAL;
case OP_LET_STAR_FX:
op_let_star_fx(sc);
goto BEGIN;
case OP_LET_STAR_FX_A:
op_let_star_fx_a(sc);
continue;
case OP_NAMED_LET_STAR:
op_named_let_star(sc);
goto EVAL;
case OP_LET_STAR2:
op_let_star2(sc);
goto EVAL;
case OP_LET_STAR:
if (check_let_star(sc))
goto EVAL;
goto BEGIN;
case OP_LET_STAR1:
if (op_let_star1(sc))
goto EVAL;
goto BEGIN;
case OP_LETREC:
check_letrec(sc, true);
case OP_LETREC_UNCHECKED:
if (op_letrec_unchecked(sc))
goto EVAL;
goto BEGIN;
case OP_LETREC1:
if (op_letrec1(sc))
goto EVAL;
goto BEGIN;
case OP_LETREC_STAR:
check_letrec(sc, false);
case OP_LETREC_STAR_UNCHECKED:
if (op_letrec_star_unchecked(sc))
goto EVAL;
goto BEGIN;
case OP_LETREC_STAR1:
if (op_letrec_star1(sc))
goto EVAL;
goto BEGIN;
case OP_LET_TEMPORARILY:
check_let_temporarily(sc);
case OP_LET_TEMP_UNCHECKED:
op_let_temp_unchecked(sc);
goto LET_TEMP_INIT1;
case OP_LET_TEMP_INIT1:
set_caddr(sc->args, cons(sc, sc->value, caddr(sc->args)));
LET_TEMP_INIT1:
if (op_let_temp_init1(sc))
goto EVAL;
case OP_LET_TEMP_INIT2:
switch (op_let_temp_init2(sc)) {
case goto_begin:
goto BEGIN;
case goto_eval:
goto EVAL;
default:
break;
}
case OP_LET_TEMP_DONE:
push_stack(sc, OP_GC_PROTECT, sc->args, sc->value); /* fall through */
case OP_LET_TEMP_DONE1:
if (op_let_temp_done1(sc))
continue;
goto EVAL;
case OP_LET_TEMP_S7:
if (op_let_temp_s7(sc))
goto BEGIN;
sc->value = sc->nil;
continue;
case OP_LET_TEMP_FX:
if (op_let_temp_fx(sc))
goto BEGIN;
sc->value = sc->nil;
continue;
case OP_LET_TEMP_FX_1:
if (op_let_temp_fx_1(sc))
goto BEGIN;
sc->value = sc->nil;
continue;
case OP_LET_TEMP_SETTER:
if (op_let_temp_setter(sc))
goto BEGIN;
sc->value = sc->nil;
continue;
case OP_LET_TEMP_A_A:
sc->value = fx_let_temp_a_a(sc, sc->code);
continue;
case OP_LET_TEMP_UNWIND:
op_let_temp_unwind(sc);
continue;
case OP_LET_TEMP_S7_UNWIND:
op_let_temp_s7_unwind(sc);
continue;
case OP_LET_TEMP_SETTER_UNWIND:
op_let_temp_setter_unwind(sc);
continue;
case OP_COND:
check_cond(sc);
case OP_COND_UNCHECKED:
if (op_cond_unchecked(sc))
goto EVAL;
case OP_COND1:
if (op_cond1(sc))
goto TOP_NO_POP;
FEED_TO:
if (feed_to(sc))
goto APPLY;
goto EVAL;
case OP_FEED_TO_1:
sc->code = sc->value;
goto APPLY; /* sc->args saved in feed_to via push_stack */
case OP_COND_SIMPLE:
if (op_cond_simple(sc))
goto EVAL;
case OP_COND1_SIMPLE:
if (op_cond1_simple(sc))
goto TOP_NO_POP;
goto BEGIN;
case OP_COND_SIMPLE_O:
if (op_cond_simple_o(sc))
goto EVAL;
case OP_COND1_SIMPLE_O:
if (op_cond1_simple_o(sc))
continue;
goto EVAL;
case OP_COND_FX_FX:
sc->value = fx_cond_fx_fx(sc, sc->code);
continue;
case OP_COND_FX_NP:
if (op_cond_fx_np(sc))
continue;
goto EVAL;
case OP_COND_FX_NP_1:
if (op_cond_fx_np_1(sc))
continue;
goto EVAL;
case OP_COND_FX_NP_O:
if (op_cond_fx_np_o(sc))
continue;
goto EVAL;
case OP_COND_FX_2E:
if (op_cond_fx_2e(sc))
continue;
goto EVAL;
case OP_COND_FX_3E:
if (op_cond_fx_3e(sc))
continue;
goto EVAL;
case OP_AND:
if (check_and(sc, sc->code))
continue;
case OP_AND_P:
sc->code = cdr(sc->code);
AND_P: /* this code (and OR_P below) is ugly, but the pretty version (procedurized) is much slower */
if (has_fx(sc->code)) { /* all fx_proc's are set via fx_choose which can return nil, but it is not cleared when type is */
/* so, if (fx_proc(sc->code)) here and in OR_P is not safe */
sc->value = fx_call(sc, sc->code);
if (is_false(sc, sc->value))
continue;
sc->code = cdr(sc->code);
if (is_null(sc->code)) /* this order of checks appears to be faster than any of the alternatives */
continue;
goto AND_P;
}
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_P1:
if ((is_false(sc, sc->value)) || (is_null(sc->code)))
continue;
goto AND_P;
case OP_AND_AP:
if (op_and_ap(sc))
continue;
goto EVAL;
case OP_AND_2A:
sc->value = fx_and_2a(sc, sc->code);
continue;
case OP_AND_3A:
sc->value = fx_and_3a(sc, sc->code);
continue;
case OP_AND_N:
sc->value = fx_and_n(sc, sc->code);
continue;
case OP_AND_S_2:
sc->value = fx_and_s_2(sc, sc->code);
continue;
case OP_AND_PAIR_P:
if (op_and_pair_p(sc))
continue;
goto EVAL;
case OP_AND_SAFE_P1:
op_and_safe_p1(sc);
goto EVAL;
case OP_AND_SAFE_P2:
if (op_and_safe_p2(sc))
continue;
goto EVAL;
case OP_AND_SAFE_P3:
if (op_and_safe_p3(sc))
continue;
goto EVAL;
case OP_AND_SAFE_P_REST:
if (is_true(sc, sc->value))
sc->value = fx_and_n(sc, sc->code);
continue;
case OP_OR:
if (check_or(sc, sc->code))
continue;
case OP_OR_P:
sc->code = cdr(sc->code);
OR_P:
if (has_fx(sc->code)) {
sc->value = fx_call(sc, sc->code);
if (is_true(sc, sc->value))
continue;
sc->code = cdr(sc->code);
if (is_null(sc->code))
continue;
goto OR_P;
}
if (is_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_P1:
if ((is_true(sc, sc->value)) || (is_null(sc->code)))
continue;
goto OR_P;
case OP_OR_AP:
if (op_or_ap(sc))
continue;
goto EVAL;
case OP_OR_2A:
sc->value = fx_or_2a(sc, sc->code);
continue;
case OP_OR_S_2:
sc->value = fx_or_s_2(sc, sc->code);
continue;
case OP_OR_S_TYPE_2:
sc->value = fx_or_s_type_2(sc, sc->code);
continue;
case OP_OR_3A:
sc->value = fx_or_3a(sc, sc->code);
continue;
case OP_OR_N:
sc->value = fx_or_n(sc, sc->code);
continue;
case OP_EVAL_MACRO:
op_eval_macro(sc);
goto EVAL;
case OP_EVAL_MACRO_MV:
if (op_eval_macro_mv(sc))
continue;
goto EVAL;
case OP_EXPANSION:
op_finish_expansion(sc);
continue;
case OP_DEFINE_BACRO:
case OP_DEFINE_BACRO_STAR:
case OP_DEFINE_EXPANSION:
case OP_DEFINE_EXPANSION_STAR:
case OP_DEFINE_MACRO:
case OP_DEFINE_MACRO_STAR:
op_define_macro(sc);
continue;
case OP_MACRO:
case OP_BACRO:
case OP_MACRO_STAR:
case OP_BACRO_STAR:
op_macro(sc);
continue;
case OP_LAMBDA:
sc->value = op_lambda(sc, sc->code);
continue;
case OP_LAMBDA_UNCHECKED:
sc->value = op_lambda_unchecked(sc, sc->code);
continue;
case OP_LAMBDA_STAR:
op_lambda_star(sc);
continue;
case OP_LAMBDA_STAR_UNCHECKED:
op_lambda_star_unchecked(sc);
continue;
case OP_CASE: /* car(sc->code) is the selector */
/* selector A, key type: E=eq (symbol/char), I=integer, G=any, S=single keys and single bodies */
if (check_case(sc))
goto EVAL; /* else drop into CASE_G_G -- selector is a symbol or constant */
case OP_CASE_G_G:
if (op_case_g_g(sc))
goto TOP_NO_POP;
goto FEED_TO;
case OP_CASE_A_G_G:
sc->value = fx_call(sc, cdr(sc->code));
if (op_case_g_g(sc))
goto TOP_NO_POP;
goto FEED_TO;
case OP_CASE_S_G_G:
sc->value = lookup_checked(sc, cadr(sc->code));
if (op_case_g_g(sc))
goto TOP_NO_POP;
goto FEED_TO;
case OP_CASE_P_G_G:
push_stack_no_args_direct(sc, OP_CASE_G_G);
sc->code = cadr(sc->code);
goto EVAL;
case OP_CASE_P_E_S:
push_stack_no_args_direct(sc, OP_CASE_E_S);
sc->code = cadr(sc->code);
goto EVAL;
case OP_CASE_P_S_S:
push_stack_no_args_direct(sc, OP_CASE_S_S);
sc->code = cadr(sc->code);
goto EVAL;
case OP_CASE_P_G_S:
push_stack_no_args_direct(sc, OP_CASE_G_S);
sc->code = cadr(sc->code);
goto EVAL;
case OP_CASE_P_E_G:
push_stack_no_args_direct(sc, OP_CASE_E_G);
sc->code = cadr(sc->code);
goto EVAL;
case OP_CASE_P_S_G:
push_stack_no_args_direct(sc, OP_CASE_S_G);
sc->code = cadr(sc->code);
goto EVAL;
case OP_CASE_A_E_S:
sc->value = fx_call(sc, cdr(sc->code));
op_case_e_s(sc);
goto EVAL;
case OP_CASE_S_E_S:
sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */
case OP_CASE_E_S:
op_case_e_s(sc);
goto EVAL;
case OP_CASE_A_S_S:
sc->value = fx_call(sc, cdr(sc->code));
op_case_s_s(sc);
goto EVAL;
case OP_CASE_S_S_S:
sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */
case OP_CASE_S_S:
op_case_s_s(sc);
goto EVAL;
#if (!WITH_GMP)
case OP_CASE_P_I_S:
push_stack_no_args_direct(sc, OP_CASE_I_S);
sc->code = cadr(sc->code);
goto EVAL;
case OP_CASE_A_I_S:
sc->value = fx_call(sc, cdr(sc->code));
if (op_case_i_s(sc))
continue;
goto EVAL;
case OP_CASE_S_I_S:
sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */
case OP_CASE_I_S:
if (op_case_i_s(sc))
continue;
goto EVAL;
#endif
case OP_CASE_S_G_S:
sc->value = lookup_checked(sc, cadr(sc->code));
op_case_g_s(sc);
goto EVAL;
case OP_CASE_A_G_S:
sc->value = fx_call(sc, cdr(sc->code)); /* fall through */
case OP_CASE_G_S:
op_case_g_s(sc);
goto EVAL;
case OP_CASE_A_E_G:
sc->value = fx_call(sc, cdr(sc->code));
if (op_case_e_g_1(sc, sc->value, is_simple(sc->value)))
goto TOP_NO_POP;
goto FEED_TO;
case OP_CASE_S_E_G:
sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */
case OP_CASE_E_G:
if (op_case_e_g_1(sc, sc->value, is_simple(sc->value)))
goto TOP_NO_POP;
goto FEED_TO;
case OP_CASE_A_S_G:
sc->value = fx_call(sc, cdr(sc->code));
if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value)))
goto TOP_NO_POP;
goto FEED_TO;
case OP_CASE_S_S_G:
sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */
case OP_CASE_S_G:
if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value)))
goto TOP_NO_POP;
goto FEED_TO;
case OP_ERROR_QUIT:
if (sc->stack_end <= sc->stack_start)
stack_reset(sc); /* sets stack_end to stack_start, then pushes op_barrier and op_eval_done */
return (sc->F);
case OP_ERROR_HOOK_QUIT:
op_error_hook_quit(sc);
case OP_FLUSH_VALUES:
if (is_multiple_value(sc->value))
sc->value = sc->nil; /* cancel int/float_optimize */
case OP_EVAL_DONE:
return (sc->F);
case OP_SPLICE_VALUES: /* if splice_in_values hits eval_done, it needs to continue the splice after returning, so we get here */
splice_in_values(sc, sc->args);
continue;
case OP_GC_PROTECT:
case OP_BARRIER:
case OP_NO_VALUES:
case OP_CATCH_ALL:
case OP_CATCH:
case OP_CATCH_1:
case OP_CATCH_2:
continue;
case OP_GET_OUTPUT_STRING: /* from call-with-output-string and with-output-to-string -- return the port string directly */
op_get_output_string(sc);
/* fall through */
case OP_UNWIND_OUTPUT:
op_unwind_output(sc);
continue;
case OP_UNWIND_INPUT:
op_unwind_input(sc);
continue;
case OP_DYNAMIC_UNWIND:
dynamic_unwind(sc, sc->code, sc->args);
continue;
case OP_DYNAMIC_UNWIND_PROFILE:
g_profile_out(sc, set_plist_1(sc, sc->args));
continue;
case OP_PROFILE_IN:
g_profile_in(sc, set_plist_1(sc, sc->curlet));
continue;
case OP_DYNAMIC_WIND:
if (op_dynamic_wind(sc) == goto_apply)
goto APPLY;
continue;
case OP_DEACTIVATE_GOTO:
call_exit_active(sc->args) = false;
continue; /* deactivate the exiter */
case OP_WITH_LET_S:
if (op_with_let_s(sc))
goto BEGIN;
continue;
case OP_WITH_LET:
check_with_let(sc);
case OP_WITH_LET_UNCHECKED:
if (op_with_let_unchecked(sc))
goto EVAL;
case OP_WITH_LET1:
if (sc->value != sc->curlet)
activate_with_let(sc, sc->value);
goto BEGIN;
case OP_WITH_UNLET_S:
sc->value = with_unlet_s(sc);
continue;
case OP_WITH_BAFFLE:
check_with_baffle(sc);
case OP_WITH_BAFFLE_UNCHECKED:
if (op_with_baffle_unchecked(sc))
continue;
goto BEGIN;
case OP_READ_INTERNAL:
op_read_internal(sc);
continue;
case OP_READ_DONE:
op_read_done(sc);
continue;
case OP_LOAD_RETURN_IF_EOF:
if (op_load_return_if_eof(sc))
goto EVAL;
return (sc->F);
case OP_LOAD_CLOSE_AND_POP_IF_EOF:
if (op_load_close_and_pop_if_eof(sc))
goto EVAL;
continue;
POP_READ_LIST:
if (pop_read_list(sc))
goto READ_NEXT;
READ_LIST:
case OP_READ_LIST: /* sc->args is sc->nil at first */
sc->args = cons(sc, sc->value, sc->args);
READ_NEXT:
case OP_READ_NEXT: /* this is 75% of the token calls, so expanding it saves lots of time */
{
int32_t c;
s7_pointer pt = current_input_port(sc);
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: /* read first element of list (ignore callgrind confusion -- this happens a lot) */
{
sc->strbuf[0] = (unsigned char) c;
push_stack_no_let_no_code(sc, OP_READ_LIST,
sc->args);
check_stack_size(sc); /* s7test */
sc->value = port_read_name(pt) (sc, pt);
sc->args = list_1(sc, sc->value);
pair_set_current_input_location(sc, sc->args);
c = port_read_white_space(pt) (sc, pt);
goto READ_C;
}
}
if (sc->tok == TOKEN_ATOM) {
c = read_atom(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));
read_error(sc, "stray dot after '('?"); /* (car '( . )) */
}
if (sc->tok == TOKEN_EOF)
return (missing_close_paren_error(sc));
push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil);
/* check_stack_size(sc); */
sc->value = read_expression(sc);
if (main_stack_op(sc) == OP_READ_LIST)
goto POP_READ_LIST;
continue;
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_let_no_code(sc, OP_READ_LIST, sc->args);
sc->value = read_expression(sc);
continue;
case ';':
sc->tok = port_read_semicolon(pt) (sc, pt);
break;
case '"':
sc->tok = TOKEN_DOUBLE_QUOTE;
read_double_quote(sc);
goto READ_LIST;
case '`':
sc->tok = TOKEN_BACK_QUOTE;
push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
sc->value = read_expression(sc);
if (main_stack_op(sc) == OP_READ_LIST)
goto POP_READ_LIST;
continue;
case ',':
sc->tok = read_comma(sc, pt); /* at_mark or comma */
push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
sc->value = read_expression(sc);
continue;
case '#':
sc->tok = read_sharp(sc, pt);
break;
case '\0':
case EOF:
return (missing_close_paren_error(sc));
default:
sc->strbuf[0] = (unsigned char) 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 = proper_list_reverse_in_place(sc, sc->args);
if ((is_expansion(car(sc->value))) && (sc->is_expanding))
switch (op_expansion(sc)) {
case goto_begin:
goto BEGIN;
case goto_apply_lambda:
goto APPLY_LAMBDA;
default:
break;
}
break;
case TOKEN_EOF:
return (missing_close_paren_error(sc)); /* can't happen, I believe */
case TOKEN_ATOM:
sc->value =
port_read_name(current_input_port(sc)) (sc,
current_input_port
(sc));
goto READ_LIST;
case TOKEN_SHARP_CONST:
if (read_sharp_const(sc))
goto READ_TOK;
goto READ_LIST;
case TOKEN_DOUBLE_QUOTE:
read_double_quote(sc);
goto READ_LIST;
case TOKEN_DOT:
read_dot_and_expression(sc);
break;
default:
read_tok_default(sc);
break;
}
if (main_stack_op(sc) == OP_READ_LIST)
goto POP_READ_LIST;
continue;
case OP_READ_DOT:
switch (op_read_dot(sc)) {
case goto_start:
continue;
case goto_pop_read_list:
goto POP_READ_LIST;
default:
goto READ_TOK;
}
case OP_READ_QUOTE:
if (op_read_quote(sc))
continue;
goto POP_READ_LIST;
case OP_READ_QUASIQUOTE:
if (op_read_quasiquote(sc))
continue;
goto POP_READ_LIST;
case OP_READ_UNQUOTE:
if (op_read_unquote(sc))
continue;
goto POP_READ_LIST;
case OP_READ_APPLY_VALUES:
if (op_read_apply_values(sc))
continue;
goto POP_READ_LIST;
case OP_READ_VECTOR:
if (op_read_vector(sc))
continue;
goto POP_READ_LIST;
case OP_READ_INT_VECTOR:
if (op_read_int_vector(sc))
continue;
goto POP_READ_LIST;
case OP_READ_FLOAT_VECTOR:
if (op_read_float_vector(sc))
continue;
goto POP_READ_LIST;
case OP_READ_BYTE_VECTOR:
if (op_read_byte_vector(sc))
continue;
goto POP_READ_LIST;
case OP_CLEAR_OPTS:
break;
default:
fprintf(stderr, "unknown operator: %" p64 " in %s\n",
sc->cur_op, display(current_code(sc)));
return (sc->F);
}
if (!tree_is_cyclic(sc, sc->code))
clear_all_optimizations(sc, sc->code);
UNOPT:
switch (trailers(sc)) {
case goto_top_no_pop:
goto TOP_NO_POP;
case goto_eval_args_top:
goto EVAL_ARGS_TOP;
case goto_eval:
goto EVAL;
default:
break;
}
}
return (sc->F);
}
/* -------------------------------- *s7* let -------------------------------- */
/* maybe features field in *s7*, others are *libraries*, *load-path*, *cload-directory*, *autoload*, *#readers* #-readers? */
typedef enum { SL_NO_FIELD =
0, SL_STACK_TOP, SL_STACK_SIZE, SL_STACKTRACE_DEFAULTS,
SL_HEAP_SIZE, SL_FREE_HEAP_SIZE,
SL_GC_FREED, SL_GC_PROTECTED_OBJECTS, SL_GC_TOTAL_FREED, SL_GC_INFO,
SL_FILE_NAMES, SL_ROOTLET_SIZE, SL_C_TYPES, SL_SAFETY,
SL_UNDEFINED_IDENTIFIER_WARNINGS, SL_UNDEFINED_CONSTANT_WARNINGS,
SL_GC_STATS, SL_MAX_HEAP_SIZE,
SL_MAX_PORT_DATA_SIZE, SL_MAX_STACK_SIZE, SL_CPU_TIME, SL_CATCHES,
SL_STACK, SL_MAX_STRING_LENGTH,
SL_MAX_FORMAT_LENGTH, SL_MAX_LIST_LENGTH, SL_MAX_VECTOR_LENGTH,
SL_MAX_VECTOR_DIMENSIONS,
SL_DEFAULT_HASH_TABLE_LENGTH, SL_INITIAL_STRING_PORT_LENGTH,
SL_DEFAULT_RATIONALIZE_ERROR,
SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON,
SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH,
SL_BIGNUM_PRECISION, SL_MEMORY_USAGE, SL_FLOAT_FORMAT_PRECISION,
SL_HISTORY, SL_HISTORY_ENABLED,
SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_AUTOLOADING,
SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, SL_MUFFLE_WARNINGS,
SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM,
SL_OUTPUT_PORT_DATA_SIZE, SL_DEBUG, SL_VERSION,
SL_GC_TEMPS_SIZE, SL_GC_RESIZE_HEAP_FRACTION,
SL_GC_RESIZE_HEAP_BY_4_FRACTION, SL_OPENLETS, SL_EXPANSIONS,
SL_NUM_FIELDS
} s7_let_field_t;
static const char *s7_let_field_names[SL_NUM_FIELDS] =
{ "no-field", "stack-top", "stack-size", "stacktrace-defaults",
"heap-size", "free-heap-size",
"gc-freed", "gc-protected-objects", "gc-total-freed", "gc-info",
"file-names", "rootlet-size", "c-types", "safety",
"undefined-identifier-warnings", "undefined-constant-warnings",
"gc-stats", "max-heap-size",
"max-port-data-size", "max-stack-size", "cpu-time", "catches", "stack",
"max-string-length",
"max-format-length", "max-list-length", "max-vector-length",
"max-vector-dimensions",
"default-hash-table-length", "initial-string-port-length",
"default-rationalize-error",
"default-random-state", "equivalent-float-epsilon",
"hash-table-float-epsilon", "print-length",
"bignum-precision", "memory-usage", "float-format-precision",
"history", "history-enabled",
"history-size", "profile", "profile-info", "autoloading?",
"accept-all-keyword-arguments", "muffle-warnings?",
"most-positive-fixnum", "most-negative-fixnum",
"output-port-data-size", "debug", "version",
"gc-temps-size", "gc-resize-heap-fraction",
"gc-resize-heap-by-4-fraction", "openlets", "expansions?"
};
static s7_int s7_let_length(void)
{
return (SL_NUM_FIELDS - 1);
}
static s7_pointer s7_let_add_field(s7_scheme * sc, const char *name,
s7_let_field_t field)
{
s7_pointer sym;
sym = make_symbol(sc, name);
symbol_set_s7_let(sym, field);
return (sym);
}
static void init_s7_let(s7_scheme * sc)
{
int32_t i;
for (i = SL_STACK_TOP; i < SL_NUM_FIELDS; i++)
s7_let_add_field(sc, s7_let_field_names[i], (s7_let_field_t) i);
}
/* handling all *s7* fields via fallbacks lets us use direct field accesses in the rest of s7, and avoids
* using ca 100 cells for the let slots/values. We would need the fallbacks anyway for 'files et al.
* Since most of the fields need special setters, it's actually less code this way. See old/s7-let-s7.c.
*/
#if (!_WIN32) /* (!MS_WINDOWS) */
#include <sys/resource.h>
#endif
static s7_pointer kmg(s7_scheme * sc, s7_int bytes)
{
block_t *b;
int len = 0;
b = mallocate(sc, 128);
if (bytes < 1000)
len = snprintf((char *) block_data(b), 128, "%" ld64, bytes);
else if (bytes < 1000000)
len =
snprintf((char *) block_data(b), 128, "%.1fk", bytes / 1000.0);
else if (bytes < 1000000000)
len =
snprintf((char *) block_data(b), 128, "%.1fM",
bytes / 1000000.0);
else
len =
snprintf((char *) block_data(b), 128, "%.1fG",
bytes / 1000000000.0);
return (cons
(sc, make_integer(sc, bytes), block_to_string(sc, b, len)));
}
static s7_pointer memory_usage(s7_scheme * sc)
{
s7_int gc_loc, i, k, len, in_use = 0, vlen = 0, flen = 0, ilen =
0, blen = 0, hlen = 0;
s7_pointer mu_let;
gc_list_t *gp;
s7_int ts[NUM_TYPES];
#if (!_WIN32) /* (!MS_WINDOWS) */
struct rusage info;
struct timeval ut;
#endif
mu_let = s7_inlet(sc, sc->nil);
gc_loc = gc_protect_1(sc, mu_let);
#if (!_WIN32) /* (!MS_WINDOWS) */
getrusage(RUSAGE_SELF, &info);
ut = info.ru_utime;
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-time"),
make_real(sc,
ut.tv_sec +
(floor(ut.tv_usec / 1000.0) /
1000.0)));
#ifdef __APPLE__
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "process-resident-size"),
kmg(sc, info.ru_maxrss));
/* apple docs say this is in kilobytes, but apparently that is an error */
#else
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "process-resident-size"),
kmg(sc, info.ru_maxrss * 1024));
/* why does this number sometimes have no relation to RES in top? */
#endif
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "IO"),
cons(sc, make_integer(sc, info.ru_inblock),
make_integer(sc, info.ru_oublock)));
#endif
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size"),
make_integer(sc, sc->rootlet_entries));
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-size"),
cons(sc, make_integer(sc, sc->heap_size),
kmg(sc,
sc->heap_size * (sizeof(s7_cell) +
2 *
sizeof
(s7_pointer)))));
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cell-size"),
make_integer(sc, sizeof(s7_cell)));
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "gc-total-freed"),
make_integer(sc, sc->gc_total_freed));
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "gc-total-time"),
make_real(sc,
(double) (sc->gc_total_time) /
ticks_per_second()));
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "small_ints"),
cons(sc, make_integer(sc, NUM_SMALL_INTS),
kmg(sc,
NUM_SMALL_INTS *
sizeof(s7_cell))));
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "permanent-cells"), cons(sc,
make_integer
(sc,
sc->permanent_cells),
kmg
(sc,
sc->permanent_cells
*
sizeof
(s7_cell))));
{
gc_obj_t *g;
for (i = 0, g = sc->permanent_objects; g;
i++, g = (gc_obj_t *) (g->nxt));
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "permanent_objects"),
make_integer(sc, i));
for (i = 0, g = sc->permanent_lets; g;
i++, g = (gc_obj_t *) (g->nxt));
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "permanent_lets"),
make_integer(sc, i));
}
/* show how many active cells there are of each type (this is where all the memory_usage cpu time goes) */
for (i = 0; i < NUM_TYPES; i++)
ts[i] = 0;
for (k = 0; k < sc->heap_size; k++)
ts[unchecked_type(sc->heap[k])]++;
sc->w = sc->nil;
for (i = 0; i < NUM_TYPES; i++) {
if (i > 0)
in_use += ts[i];
if (ts[i] > 50)
sc->w =
cons_unchecked(sc,
cons(sc,
make_symbol(sc,
(i ==
0) ? "free" :
type_name_from_type(i,
NO_ARTICLE)),
make_integer(sc, ts[i])), sc->w);
}
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "cells-in-use/free"),
cons(sc, make_integer(sc, in_use),
make_integer(sc,
sc->free_heap_top -
sc->free_heap)));
if (is_pair(sc->w))
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "types"),
proper_list_reverse_in_place(sc,
sc->w));
sc->w = sc->nil;
/* same for permanent cells requires traversing saved_pointers and the alloc and big_alloc blocks up to alloc_k, or keeping explicit counts */
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "gc-protected-objects"),
cons(sc,
make_integer(sc,
sc->protected_objects_size
- sc->gpofl_loc),
make_integer(sc,
sc->protected_objects_size)));
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "setters"),
make_integer(sc,
sc->protected_setters_loc));
/* check the symbol table, counting gensyms etc */
{
s7_int syms = 0, gens = 0, keys = 0, mx_list = 0;
s7_pointer *els;
for (i = 0, els = vector_elements(sc->symbol_table);
i < SYMBOL_TABLE_SIZE; i++) {
s7_pointer x;
for (k = 0, x = els[i]; is_not_null(x); x = cdr(x), k++) {
syms++;
if (is_gensym(car(x)))
gens++;
if (is_keyword(car(x)))
keys++;
}
if (k > mx_list)
mx_list = k;
}
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "symbol-table"),
s7_list(sc, 9,
make_integer(sc,
SYMBOL_TABLE_SIZE),
make_symbol(sc, "max-bin"),
make_integer(sc, mx_list),
make_symbol(sc, "symbols"),
cons(sc, make_integer(sc, syms),
make_integer(sc,
syms - gens -
keys)),
make_symbol(sc, "gensyms"),
make_integer(sc, gens),
make_symbol(sc, "keys"),
make_integer(sc, keys)));
}
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "stack"),
cons(sc,
make_integer(sc,
current_stack_top(sc)),
make_integer(sc, sc->stack_size)));
len =
sc->autoload_names_top * (sizeof(const char **) + sizeof(s7_int) +
sizeof(bool));
for (i = 0; i < sc->autoload_names_loc; i++)
len += sc->autoload_names_sizes[i];
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "autoload"),
make_integer(sc, len));
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "circle_info"),
make_integer(sc,
sc->circle_info->size *
(sizeof(s7_pointer) +
sizeof(int32_t) +
sizeof(bool))));
/* check the gc lists (finalizations) */
len =
sc->strings->size + sc->vectors->size + sc->input_ports->size +
sc->output_ports->size + sc->input_string_ports->size +
sc->continuations->size + sc->c_objects->size +
sc->hash_tables->size + sc->gensyms->size + sc->undefineds->size +
sc->lambdas->size + sc->multivectors->size + sc->weak_refs->size +
sc->weak_hash_iterators->size + sc->opt1_funcs->size;
{
int loc;
loc =
sc->strings->loc + sc->vectors->loc + sc->input_ports->loc +
sc->output_ports->loc + sc->input_string_ports->loc +
sc->continuations->loc + sc->c_objects->loc +
sc->hash_tables->loc + sc->gensyms->loc + sc->undefineds->loc +
sc->lambdas->loc + sc->multivectors->loc + sc->weak_refs->loc +
sc->weak_hash_iterators->loc + sc->opt1_funcs->loc;
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-lists"),
cons_unchecked(sc,
make_integer(sc, loc),
cons(sc,
make_integer(sc,
len),
make_integer(sc,
len *
sizeof
(s7_pointer)))));
}
/* strings */
gp = sc->strings;
for (len = 0, i = 0; i < (int32_t) (gp->loc); i++)
len += string_length(gp->list[i]);
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "strings"),
cons(sc, make_integer(sc, gp->loc),
make_integer(sc, len)));
/* vectors */
for (k = 0, gp = sc->vectors; k < 2; k++, gp = sc->multivectors)
for (i = 0; i < gp->loc; i++) {
s7_pointer v = gp->list[i];
if (is_float_vector(v))
flen += vector_length(v);
else if (is_int_vector(v))
ilen += vector_length(v);
else if (is_byte_vector(v))
blen += vector_length(v);
else
vlen += vector_length(v);
}
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "vectors"),
s7_list(sc, 9,
make_integer(sc,
sc->vectors->loc +
sc->multivectors->loc),
make_symbol(sc, "vlen"),
make_integer(sc, vlen),
make_symbol(sc, "fvlen"),
make_integer(sc, flen),
make_symbol(sc, "ivlen"),
make_integer(sc, ilen),
make_symbol(sc, "bvlen"),
make_integer(sc, blen)));
/* hash-tables */
for (i = 0, gp = sc->hash_tables; i < gp->loc; i++) {
s7_pointer v = gp->list[i];
hlen += ((hash_table_mask(v) + 1) * sizeof(hash_entry_t *));
hlen += (hash_table_entries(v) * sizeof(hash_entry_t));
}
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "hash-tables"),
cons(sc,
make_integer(sc, sc->hash_tables->loc),
make_integer(sc, hlen)));
/* ports */
gp = sc->input_ports;
for (i = 0, len = 0; i < gp->loc; i++) {
s7_pointer v = gp->list[i];
if (port_data(v))
len += port_data_size(v);
}
gp = sc->input_string_ports;
for (i = 0, len = 0; i < gp->loc; i++) {
s7_pointer v = gp->list[i];
if (port_data(v))
len += port_data_size(v);
}
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-ports"),
cons(sc,
make_integer(sc,
sc->input_ports->loc +
sc->
input_string_ports->loc),
make_integer(sc, len)));
gp = sc->output_ports;
for (i = 0, len = 0; i < gp->loc; i++) {
s7_pointer v = gp->list[i];
if (port_data(v))
len += port_data_size(v);
}
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "output-ports"),
cons(sc,
make_integer(sc,
sc->output_ports->loc),
make_integer(sc, len)));
{
s7_pointer p;
for (i = 0, p = sc->format_ports; p;
p = (s7_pointer) port_next(p));
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "format-ports"),
make_integer(sc, i));
}
/* continuations (sketchy!) */
gp = sc->continuations;
for (i = 0, len = 0; i < gp->loc; i++)
if (is_continuation(gp->list[i]))
len += continuation_stack_size(gp->list[i]);
if (len > 0)
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "continuations"),
cons(sc,
make_integer(sc,
sc->
continuations->loc),
make_integer(sc,
len *
sizeof(s7_pointer))));
/* c-objects */
if (sc->c_objects->loc > 0)
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "c-objects"),
make_integer(sc, sc->c_objects->loc));
#if WITH_GMP
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "bignums"),
s7_list(sc, 5,
make_integer(sc,
sc->big_integers->loc),
make_integer(sc,
sc->big_ratios->loc),
make_integer(sc,
sc->big_reals->loc),
make_integer(sc,
sc->
big_complexes->loc),
make_integer(sc,
sc->big_random_states->loc)));
#endif
/* free-lists (mallocate) */
{
block_t *b;
for (i = 0, len = 0, sc->w = sc->nil; i < TOP_BLOCK_LIST; i++) {
for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++);
sc->w = cons(sc, make_integer(sc, k), sc->w);
len += ((sizeof(block_t) + (1LL << i)) * k);
}
for (b = sc->block_lists[TOP_BLOCK_LIST], k = 0; b;
b = block_next(b), k++)
len += (sizeof(block_t) + block_size(b));
sc->w = cons(sc, make_integer(sc, k), sc->w);
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "free-lists"),
list_2(sc,
cons(sc,
make_symbol(sc, "bytes"),
kmg(sc, len)), cons(sc,
make_symbol
(sc,
"bins"),
proper_list_reverse_in_place
(sc,
sc->w))));
sc->w = sc->nil;
add_slot_unchecked_with_id(sc, mu_let,
make_symbol(sc, "approximate-s7-size"),
kmg(sc,
((sc->permanent_cells +
NUM_SMALL_INTS +
sc->heap_size) *
sizeof(s7_cell)) +
((2 * sc->heap_size +
SYMBOL_TABLE_SIZE +
sc->stack_size) *
sizeof(s7_pointer)) + len + hlen +
(vlen * sizeof(s7_pointer)) +
(flen * sizeof(s7_double)) +
(ilen * sizeof(s7_int)) + blen));
}
s7_gc_unprotect_at(sc, gc_loc);
return (mu_let);
}
static s7_pointer sl_c_types(s7_scheme * sc)
{
s7_pointer res;
int32_t i;
sc->w = sc->nil;
for (i = 0; i < sc->num_c_object_types; i++) /* c-object type (tag) is i */
sc->w = cons(sc, sc->c_object_types[i]->scheme_name, sc->w);
res = proper_list_reverse_in_place(sc, sc->w); /* so car(types) has tag 0 */
sc->w = sc->nil;
return (res);
}
static s7_pointer sl_file_names(s7_scheme * sc)
{
int32_t i;
s7_pointer p;
sc->w = sc->nil;
for (i = 0; i <= sc->file_names_top; i++)
sc->w = cons(sc, sc->file_names[i], sc->w);
p = proper_list_reverse_in_place(sc, sc->w);
sc->w = sc->nil;
return (p);
}
static s7_pointer sl_int_fixup(s7_scheme * sc, s7_pointer val)
{
#if WITH_GMP
return (s7_int_to_big_integer(sc, s7_integer_checked(sc, val)));
#else
return (val);
#endif
}
static s7_pointer sl_history(s7_scheme * sc)
{
#if WITH_HISTORY
return (cull_history
(sc,
(sc->cur_code ==
sc->history_sink) ? sc->old_cur_code : sc->cur_code));
#else
return (sc->cur_code);
#endif
}
static s7_pointer sl_active_catches(s7_scheme * sc)
{
int64_t i;
s7_pointer x, lst = sc->nil;
for (i = current_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 sl_stack_entries(s7_scheme * sc, s7_pointer stack,
int64_t top)
{
int64_t i;
s7_pointer 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 < NUM_OPS)) {
lst =
cons_unchecked(sc,
list_4(sc, func, args, e,
s7_make_string(sc, op_names[op])),
lst);
sc->w = lst;
}
}
sc->w = sc->nil;
return (reverse_in_place_unchecked(sc, sc->nil, lst));
}
static s7_pointer s7_let_field(s7_scheme * sc, s7_pointer sym)
{
switch (symbol_s7_let(sym)) {
case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS:
return (make_boolean(sc, sc->accept_all_keyword_arguments));
case SL_AUTOLOADING:
return (s7_make_boolean(sc, sc->is_autoloading));
case SL_BIGNUM_PRECISION:
return (make_integer(sc, sc->bignum_precision));
case SL_CATCHES:
return (sl_active_catches(sc));
case SL_CPU_TIME:
return (s7_make_real
(sc, (double) clock() / (double) CLOCKS_PER_SEC));
case SL_C_TYPES:
return (sl_c_types(sc));
case SL_DEBUG:
return (make_integer(sc, sc->debug));
case SL_DEFAULT_HASH_TABLE_LENGTH:
return (make_integer(sc, sc->default_hash_table_length));
case SL_DEFAULT_RANDOM_STATE:
return (sc->default_rng);
case SL_DEFAULT_RATIONALIZE_ERROR:
return (make_real(sc, sc->default_rationalize_error));
case SL_EQUIVALENT_FLOAT_EPSILON:
return (s7_make_real(sc, sc->equivalent_float_epsilon));
case SL_FILE_NAMES:
return (sl_file_names(sc));
case SL_FLOAT_FORMAT_PRECISION:
return (make_integer(sc, sc->float_format_precision));
case SL_FREE_HEAP_SIZE:
return (make_integer(sc, sc->free_heap_top - sc->free_heap));
case SL_GC_FREED:
return (make_integer(sc, sc->gc_freed));
case SL_GC_TOTAL_FREED:
return (make_integer(sc, sc->gc_total_freed));
case SL_GC_INFO:
return (list_3
(sc, make_integer(sc, sc->gc_calls),
make_integer(sc, sc->gc_total_time), make_integer(sc,
ticks_per_second
())));
case SL_GC_PROTECTED_OBJECTS:
return (sc->protected_objects);
case SL_GC_STATS:
return (make_integer(sc, sc->gc_stats));
case SL_GC_TEMPS_SIZE:
return (make_integer(sc, sc->gc_temps_size));
case SL_GC_RESIZE_HEAP_FRACTION:
return (make_real(sc, sc->gc_resize_heap_fraction));
case SL_GC_RESIZE_HEAP_BY_4_FRACTION:
return (make_real(sc, sc->gc_resize_heap_by_4_fraction));
case SL_HASH_TABLE_FLOAT_EPSILON:
return (s7_make_real(sc, sc->hash_table_float_epsilon));
case SL_HEAP_SIZE:
return (make_integer(sc, sc->heap_size));
case SL_HISTORY:
return (sl_history(sc));
case SL_HISTORY_ENABLED:
return (s7_make_boolean(sc, s7_history_enabled(sc)));
case SL_HISTORY_SIZE:
return (make_integer(sc, sc->history_size));
case SL_INITIAL_STRING_PORT_LENGTH:
return (make_integer(sc, sc->initial_string_port_length));
case SL_MAX_FORMAT_LENGTH:
return (make_integer(sc, sc->max_format_length));
case SL_MAX_HEAP_SIZE:
return (make_integer(sc, sc->max_heap_size));
case SL_MAX_LIST_LENGTH:
return (make_integer(sc, sc->max_list_length));
case SL_MAX_PORT_DATA_SIZE:
return (make_integer(sc, sc->max_port_data_size));
case SL_MAX_STACK_SIZE:
return (make_integer(sc, sc->max_stack_size));
case SL_MAX_STRING_LENGTH:
return (make_integer(sc, sc->max_string_length));
case SL_MAX_VECTOR_DIMENSIONS:
return (make_integer(sc, sc->max_vector_dimensions));
case SL_MAX_VECTOR_LENGTH:
return (make_integer(sc, sc->max_vector_length));
case SL_MEMORY_USAGE:
return (memory_usage(sc));
case SL_MOST_NEGATIVE_FIXNUM:
return (sl_int_fixup(sc, leastfix));
case SL_MOST_POSITIVE_FIXNUM:
return (sl_int_fixup(sc, mostfix));
case SL_MUFFLE_WARNINGS:
return (s7_make_boolean(sc, sc->muffle_warnings));
case SL_OPENLETS:
return (s7_make_boolean(sc, sc->has_openlets));
case SL_EXPANSIONS:
return (s7_make_boolean(sc, sc->is_expanding));
case SL_OUTPUT_PORT_DATA_SIZE:
return (make_integer(sc, sc->output_port_data_size));
case SL_PRINT_LENGTH:
return (make_integer(sc, sc->print_length));
case SL_PROFILE:
return (make_integer(sc, sc->profile));
case SL_PROFILE_INFO:
return (profile_info_out(sc));
case SL_ROOTLET_SIZE:
return (make_integer(sc, sc->rootlet_entries));
case SL_SAFETY:
return (make_integer(sc, sc->safety));
case SL_STACK:
return (sl_stack_entries(sc, sc->stack, current_stack_top(sc)));
case SL_STACKTRACE_DEFAULTS:
return (sc->stacktrace_defaults);
case SL_STACK_SIZE:
return (make_integer(sc, sc->stack_size));
case SL_STACK_TOP:
return (make_integer(sc, (sc->stack_end - sc->stack_start) / 4));
case SL_UNDEFINED_CONSTANT_WARNINGS:
return (s7_make_boolean(sc, sc->undefined_constant_warnings));
case SL_UNDEFINED_IDENTIFIER_WARNINGS:
return (s7_make_boolean(sc, sc->undefined_identifier_warnings));
case SL_VERSION:
return (s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE));
default:
return (s7_error
(sc, sc->out_of_range_symbol,
set_elist_2(sc,
wrap_string(sc,
"can't get (*s7* '~S); no such field in *s7*",
43), sym)));
}
return (sc->undefined);
}
s7_pointer s7_let_field_ref(s7_scheme * sc, s7_pointer sym)
{
if (is_symbol(sym)) {
if (is_keyword(sym))
sym = keyword_symbol(sym);
if (symbol_s7_let(sym) != SL_NO_FIELD)
return (s7_let_field(sc, sym));
}
return (sc->undefined);
}
static s7_pointer g_s7_let_ref_fallback(s7_scheme * sc, s7_pointer args)
{
s7_pointer sym = cadr(args);
if (!is_symbol(sym))
return (simple_wrong_type_argument
(sc, sc->let_ref_symbol, sym, T_SYMBOL));
if (is_keyword(sym))
sym = keyword_symbol(sym);
return (s7_let_field(sc, sym));
}
static s7_pointer s7_let_iterate(s7_scheme * sc, s7_pointer iterator)
{
s7_pointer symbol, value, osw;
iterator_position(iterator)++;
if (iterator_position(iterator) >= SL_NUM_FIELDS)
return (iterator_quit(iterator));
symbol =
make_symbol(sc, s7_let_field_names[iterator_position(iterator)]);
osw = sc->w; /* protect against s7_let_field list making (why?) */
if ((iterator_position(iterator) == SL_STACK) ||
(iterator_position(iterator) == SL_GC_PROTECTED_OBJECTS) ||
(iterator_position(iterator) == SL_MEMORY_USAGE))
value = sc->F; /* (format #f "~W" (inlet *s7*)) or (let->list *s7*) etc */
else
value = s7_let_field(sc, symbol);
sc->w = osw;
if (iterator_let_cons(iterator)) {
s7_pointer p;
p = iterator_let_cons(iterator);
set_car(p, symbol);
set_cdr(p, value);
return (p);
}
return (cons(sc, symbol, value));
}
static s7_pointer s7_let_make_iterator(s7_scheme * sc, s7_pointer iter)
{
iterator_position(iter) = SL_NO_FIELD;
iterator_next(iter) = s7_let_iterate;
iterator_let_cons(iter) = NULL;
return (iter);
}
static s7_pointer sl_real_geq_0(s7_scheme * sc, s7_pointer sym,
s7_pointer val)
{
if (!is_real(val))
return (simple_wrong_type_argument(sc, sym, val, T_REAL));
return ((s7_real(val) >= 0.0) ? val : simple_out_of_range(sc, sym, val,
wrap_string
(sc,
"should not be negative",
22)));
}
static s7_pointer sl_integer_gt_0(s7_scheme * sc, s7_pointer sym,
s7_pointer val)
{
if (!s7_is_integer(val))
return (simple_wrong_type_argument(sc, sym, val, T_INTEGER));
return ((s7_integer_checked(sc, val) >
0) ? val : simple_out_of_range(sc, sym, val, wrap_string(sc,
"should be positive",
18)));
}
static s7_pointer sl_integer_geq_0(s7_scheme * sc, s7_pointer sym,
s7_pointer val)
{
if (!s7_is_integer(val))
return (simple_wrong_type_argument(sc, sym, val, T_INTEGER));
return ((s7_integer_checked(sc, val) >=
0) ? val : simple_out_of_range(sc, sym, val, wrap_string(sc,
"should not be negative",
22)));
}
#if WITH_HISTORY
static void sl_set_history_size(s7_scheme * sc, s7_int iv)
{
s7_pointer p1, p2, p3;
if (iv > MAX_HISTORY_SIZE)
iv = MAX_HISTORY_SIZE;
if (iv > sc->true_history_size) {
/* splice in the new cells, reattach the circles */
s7_pointer next1, next2, next3;
next1 = cdr(sc->eval_history1);
next2 = cdr(sc->eval_history2);
next3 = cdr(sc->history_pairs);
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));
set_cdr(sc->history_pairs,
permanent_list(sc, iv - sc->true_history_size));
for (p3 = cdr(sc->history_pairs); is_pair(cdr(p3)); p3 = cdr(p3))
set_car(p3, permanent_list(sc, 1));
set_car(p3, permanent_list(sc, 1));
set_cdr(p3, next3);
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 buffers 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;
}
}
#endif
#if WITH_GMP
static s7_pointer set_bignum_precision(s7_scheme * sc, int32_t precision)
{
mp_prec_t bits;
s7_pointer bpi;
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,
wrap_integer2(sc, precision),
"has to be greater than 1"));
bits = (mp_prec_t) precision;
mpfr_set_default_prec(bits);
mpc_set_default_precision(bits);
bpi = big_pi(sc);
s7_symbol_set_value(sc, sc->pi_symbol, bpi);
slot_set_value(initial_slot(sc->pi_symbol), bpi); /* if #_pi occurs after precision set, make sure #_pi is still legit (not a free cell) */
return (sc->F);
}
#endif
static s7_pointer sl_unsettable_error(s7_scheme * sc, s7_pointer sym)
{
return (s7_error
(sc, sc->immutable_error_symbol,
set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S)", 20),
sym)));
}
static s7_pointer g_s7_let_set_fallback(s7_scheme * sc, s7_pointer args)
{
s7_pointer sym = cadr(args), val = caddr(args);
s7_int iv;
if (!is_symbol(sym))
return (simple_wrong_type_argument
(sc, sc->let_set_symbol, sym, T_SYMBOL));
if (is_keyword(sym))
sym = keyword_symbol(sym);
switch (symbol_s7_let(sym)) {
case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS:
if (s7_is_boolean(val)) {
sc->accept_all_keyword_arguments = s7_boolean(sc, val);
return (val);
}
return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
case SL_AUTOLOADING:
if (s7_is_boolean(val)) {
sc->is_autoloading = s7_boolean(sc, val);
return (val);
}
return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
case SL_BIGNUM_PRECISION:
iv = s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
sc->bignum_precision = iv;
#if WITH_GMP
set_bignum_precision(sc, sc->bignum_precision);
mpfr_set_prec(sc->mpfr_1, sc->bignum_precision);
mpfr_set_prec(sc->mpfr_2, sc->bignum_precision);
mpc_set_prec(sc->mpc_1, sc->bignum_precision);
mpc_set_prec(sc->mpc_2, sc->bignum_precision);
#endif
return (val);
case SL_CATCHES:
case SL_CPU_TIME:
case SL_C_TYPES:
return (sl_unsettable_error(sc, sym));
case SL_DEBUG:
if (!s7_is_integer(val))
return (simple_wrong_type_argument(sc, sym, val, T_INTEGER));
sc->debug = s7_integer_checked(sc, val);
sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0));
if ((sc->debug > 0) &&
(!is_memq
(make_symbol(sc, "debug.scm"),
s7_symbol_value(sc, sc->features_symbol))))
s7_load(sc, "debug.scm");
return (val);
case SL_DEFAULT_HASH_TABLE_LENGTH:
sc->default_hash_table_length =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_DEFAULT_RANDOM_STATE:
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));
case SL_DEFAULT_RATIONALIZE_ERROR:
sc->default_rationalize_error =
s7_real(sl_real_geq_0(sc, sym, val));
return (val);
case SL_EQUIVALENT_FLOAT_EPSILON:
sc->equivalent_float_epsilon =
s7_real(sl_real_geq_0(sc, sym, val));
return (val);
case SL_FILE_NAMES:
return (sl_unsettable_error(sc, sym));
case SL_FLOAT_FORMAT_PRECISION: /* float-format-precision should not be huge => hangs in snprintf -- what's a reasonable limit here? */
iv = s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val));
sc->float_format_precision =
(iv <
MAX_FLOAT_FORMAT_PRECISION) ? iv : MAX_FLOAT_FORMAT_PRECISION;
return (val);
case SL_FREE_HEAP_SIZE:
case SL_GC_FREED:
case SL_GC_TOTAL_FREED:
case SL_GC_PROTECTED_OBJECTS:
return (sl_unsettable_error(sc, sym));
case SL_GC_TEMPS_SIZE:
sc->gc_temps_size =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_GC_RESIZE_HEAP_FRACTION:
sc->gc_resize_heap_fraction = s7_real(sl_real_geq_0(sc, sym, val));
return (val);
case SL_GC_RESIZE_HEAP_BY_4_FRACTION:
sc->gc_resize_heap_by_4_fraction =
s7_real(sl_real_geq_0(sc, sym, val));
return (val);
case SL_GC_STATS:
if (s7_is_boolean(val)) {
sc->gc_stats = ((val == sc->T) ? GC_STATS : 0);
return (val);
}
if (!s7_is_integer(val))
return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
sc->gc_stats = s7_integer_checked(sc, val);
if (sc->gc_stats < 16) /* gc_stats is uint32_t */
return (val);
sc->gc_stats = 0;
return (simple_out_of_range
(sc, sym, val,
wrap_string(sc, "should be between 0 and 15", 26)));
case SL_GC_INFO:
if (val != sc->F)
return (simple_wrong_type_argument_with_type
(sc, sym, val,
wrap_string(sc,
"#f (to clear gc_calls and gc_total_time)",
40)));
sc->gc_total_time = 0;
sc->gc_calls = 0;
return (sc->F);
case SL_HASH_TABLE_FLOAT_EPSILON:
sc->hash_table_float_epsilon =
s7_real(sl_real_geq_0(sc, sym, val));
return (val);
case SL_HEAP_SIZE:
iv = s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val));
if (iv > sc->heap_size)
resize_heap_to(sc, iv);
return (val);
case SL_HISTORY: /* (set! (*s7* 'history) val) */
replace_current_code(sc, val);
return (val);
case SL_HISTORY_ENABLED: /* (set! (*s7* 'history-enabled) #f|#t) */
if (s7_is_boolean(val))
return (s7_make_boolean
(sc, s7_set_history_enabled(sc, s7_boolean(sc, val))));
return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
case SL_HISTORY_SIZE:
iv = s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val));
#if WITH_HISTORY
sl_set_history_size(sc, iv);
#else
sc->history_size = iv;
#endif
return (val);
case SL_INITIAL_STRING_PORT_LENGTH:
sc->initial_string_port_length =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_MAX_FORMAT_LENGTH:
sc->max_format_length =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_MAX_HEAP_SIZE:
sc->max_heap_size =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_MAX_LIST_LENGTH:
sc->max_list_length =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_MAX_PORT_DATA_SIZE:
sc->max_port_data_size =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_MAX_STACK_SIZE:
iv = s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val));
if (iv < INITIAL_STACK_SIZE)
return (simple_out_of_range
(sc, sym, val,
wrap_string(sc,
"should be greater than the initial stack size",
45)));
sc->max_stack_size = (uint32_t) iv;
return (val);
case SL_MAX_STRING_LENGTH:
sc->max_string_length =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_MAX_VECTOR_DIMENSIONS:
sc->max_vector_dimensions =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_MAX_VECTOR_LENGTH:
sc->max_vector_length =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_MEMORY_USAGE:
case SL_MOST_NEGATIVE_FIXNUM:
case SL_MOST_POSITIVE_FIXNUM:
return (sl_unsettable_error(sc, sym));
case SL_MUFFLE_WARNINGS:
if (s7_is_boolean(val)) {
sc->muffle_warnings = s7_boolean(sc, val);
return (val);
}
return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
case SL_OPENLETS:
if (s7_is_boolean(val)) {
sc->has_openlets = s7_boolean(sc, val);
return (val);
}
return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
case SL_EXPANSIONS:
if (s7_is_boolean(val)) {
sc->is_expanding = s7_boolean(sc, val);
return (val);
}
return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
case SL_OUTPUT_PORT_DATA_SIZE:
sc->output_port_data_size =
s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val));
return (val);
case SL_PRINT_LENGTH:
sc->print_length =
s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val));
return (val);
case SL_PROFILE:
if (!s7_is_integer(val))
return (simple_wrong_type_argument(sc, sym, val, T_INTEGER));
sc->profile = s7_integer_checked(sc, val);
sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0));
if (sc->profile > 0) {
if (!is_memq
(make_symbol(sc, "profile.scm"),
s7_symbol_value(sc, sc->features_symbol)))
s7_load(sc, "profile.scm");
if (!sc->profile_data)
make_profile_info(sc);
if (!sc->profile_out)
sc->profile_out =
s7_make_function(sc, "profile-out", g_profile_out, 2,
0, false, NULL);
}
return (val);
case SL_PROFILE_INFO:
return ((val ==
sc->F) ? clear_profile_info(sc) :
simple_wrong_type_argument_with_type(sc, sym, val,
wrap_string(sc,
"#f (to clear the table)",
23)));
case SL_ROOTLET_SIZE:
return (sl_unsettable_error(sc, sym));
case SL_SAFETY:
if (!s7_is_integer(val))
return (simple_wrong_type_argument(sc, sym, val, T_INTEGER));
if ((s7_integer_checked(sc, val) > 2)
|| (s7_integer_checked(sc, val) < -1))
return (simple_out_of_range
(sc, sym, val,
wrap_string(sc,
"should be between -1 (no safety) and 2 (max safety)",
51)));
sc->safety = s7_integer_checked(sc, val);
return (val);
case SL_STACKTRACE_DEFAULTS:
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,
wrap_string(sc, "a list with 5 entries", 21)));
if (!is_t_integer(car(val)))
return (wrong_type_argument_with_type
(sc, sym, 1, car(val),
wrap_string(sc, "an integer (stack frames)", 25)));
if (!is_t_integer(cadr(val)))
return (wrong_type_argument_with_type
(sc, sym, 2, cadr(val),
wrap_string(sc, "an integer (cols-for-data)", 26)));
if (!is_t_integer(caddr(val)))
return (wrong_type_argument_with_type
(sc, sym, 3, caddr(val),
wrap_string(sc, "an integer (line length)", 24)));
if (!is_t_integer(cadddr(val)))
return (wrong_type_argument_with_type
(sc, sym, 4, cadddr(val),
wrap_string(sc, "an integer (comment position)",
29)));
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),
wrap_string(sc, "a boolean (treat-data-as-comment)",
33)));
sc->stacktrace_defaults = copy_proper_list(sc, val);
return (val);
case SL_STACK:
case SL_STACK_SIZE:
case SL_STACK_TOP:
return (sl_unsettable_error(sc, sym));
case SL_UNDEFINED_CONSTANT_WARNINGS:
if (s7_is_boolean(val)) {
sc->undefined_constant_warnings = s7_boolean(sc, val);
return (val);
}
return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN));
case SL_UNDEFINED_IDENTIFIER_WARNINGS:
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));
case SL_VERSION:
return (sl_unsettable_error(sc, sym));
default:
return (s7_error
(sc, sc->out_of_range_symbol,
set_elist_2(sc,
wrap_string(sc,
"can't set (*s7* '~S); no such field in *s7*",
43), sym)));
}
return (sc->undefined);
}
s7_pointer s7_let_field_set(s7_scheme * sc, s7_pointer sym,
s7_pointer new_value)
{
if (is_symbol(sym)) {
if (is_keyword(sym))
sym = keyword_symbol(sym);
if (symbol_s7_let(sym) != SL_NO_FIELD)
return (g_s7_let_set_fallback
(sc,
set_plist_3(sc, sc->s7_let_symbol, sym, new_value)));
}
return (sc->undefined);
}
/* ---------------- gdbinit annotated stacktrace ---------------- */
#if (!MS_WINDOWS)
/* s7bt, s7btfull: gdb stacktrace decoding */
static const char *decoded_name(s7_scheme * sc, s7_pointer p)
{
if (p == sc->value)
return ("value");
if (p == sc->args)
return ("args");
if (p == sc->code)
return ("code");
if (p == sc->cur_code)
return ("cur_code");
if (p == sc->curlet)
return ("curlet");
if (p == sc->nil)
return ("()");
if (p == sc->T)
return ("#t");
if (p == sc->F)
return ("#f");
if (p == eof_object)
return ("eof_object");
if (p == sc->undefined)
return ("undefined");
if (p == sc->unspecified)
return ("unspecified");
if (p == sc->no_value)
return ("no_value");
if (p == sc->unused)
return ("#<unused>");
if (p == sc->symbol_table)
return ("symbol_table");
if (p == sc->rootlet)
return ("rootlet");
if (p == sc->s7_let)
return ("*s7*");
if (p == sc->unlet)
return ("unlet");
if (p == current_input_port(sc))
return ("current-input-port");
if (p == current_output_port(sc))
return ("current-output-port");
if (p == sc->error_port)
return ("error_port");
if (p == sc->owlet)
return ("owlet");
if (p == sc->standard_input)
return ("*stdin*");
if (p == sc->standard_output)
return ("*stdout*");
if (p == sc->standard_error)
return ("*stderr*");
if (p == sc->else_symbol)
return ("else_symbol");
return ((p == sc->stack) ? "stack" : NULL);
}
static bool is_decodable(s7_scheme * sc, s7_pointer p)
{
int32_t i;
s7_pointer x;
s7_pointer *tp, *heap_top;
/* check symbol-table */
for (i = 0; i < SYMBOL_TABLE_SIZE; i++)
for (x = vector_element(sc->symbol_table, i); is_not_null(x);
x = cdr(x)) {
s7_pointer sym = car(x);
if ((sym == p) ||
((is_global(sym)) && (is_slot(global_slot(sym)))
&& (p == global_value(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);
/* 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(s7_scheme * sc)
{
FILE *fp;
fp = fopen("gdb.txt", "r");
if (fp) {
int64_t i, size;
size_t bytes;
bool in_quotes = false, old_stop = sc->stop_at_error;
uint8_t *bt;
block_t *bt_block;
sc->stop_at_error = false;
fseek(fp, 0, SEEK_END);
size = ftell(fp);
rewind(fp);
bt_block = mallocate(sc, (size + 1) * sizeof(uint8_t));
bt = (uint8_t *) block_data(bt_block);
bytes = fread(bt, sizeof(uint8_t), size, fp);
if (bytes != (size_t) size) {
fclose(fp);
liberate(sc, bt_block);
return ((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) &&
((bt[i] == '=') &&
(((bt[i + 1] == '0') && (bt[i + 2] == 'x')) ||
((bt[i + 1] == ' ') && (bt[i + 2] == '0')
&& (bt[i + 3] == 'x'))))) {
void *vp;
int32_t vals;
vals = sscanf((const char *) (bt + i + 1), "%p", &vp);
if ((vp) && (vals == 1)) {
int32_t k;
for (k = i + ((bt[i + 2] == 'x') ? 3 : 4);
(k < size) && (IS_DIGIT(bt[k], 16)); k++);
if ((bt[k] != ' ') || (bt[k + 1] != '"')) {
if (vp == (void *) sc) {
if (bt[i + 1] == ' ')
fputc(' ', stdout);
fprintf(stdout, "%s[s7]%s", BOLD_TEXT,
UNBOLD_TEXT);
i = k - 1;
} else {
s7_pointer p = (s7_pointer) vp;
const char *dname;
dname = decoded_name(sc, p);
if (dname) {
if (bt[i + 1] == ' ')
fputc(' ', stdout);
fprintf(stdout, "%s[sc->%s]%s", BOLD_TEXT,
dname, UNBOLD_TEXT);
}
if ((dname) || (is_decodable(sc, p))) {
if (bt[i + 1] == ' ')
fputc(' ', stdout);
i = k - 1;
if (s7_is_valid(sc, p)) {
s7_pointer strp;
if (dname)
fprintf(stdout, " ");
strp =
object_to_truncated_string(sc, p,
80);
fprintf(stdout, "%s%s%s", BOLD_TEXT,
string_value(strp),
UNBOLD_TEXT);
if ((is_pair(p)) && (has_location(p))) {
uint32_t line =
pair_line_number(p), file =
pair_file_number(p);
if (line > 0)
fprintf(stdout,
" %s(%s[%u])%s",
BOLD_TEXT,
string_value
(sc->file_names[file]),
line, UNBOLD_TEXT);
}
}
}
}
}
}
}
}
liberate(sc, bt_block);
sc->stop_at_error = old_stop;
}
return ((char *) "");
}
#endif
/* -------------------------------- initialization -------------------------------- */
static void init_fx_function(void)
{
fx_function = (s7_function *) calloc(NUM_OPS, sizeof(s7_function));
fx_function[HOP_SAFE_C_NC] = fx_c_nc;
fx_function[HOP_SAFE_C_S] = fx_c_s;
fx_function[HOP_SAFE_C_SC] = fx_c_sc;
fx_function[HOP_SAFE_C_CS] = fx_c_cs;
fx_function[HOP_SAFE_C_CQ] = fx_c_cq;
fx_function[HOP_SAFE_C_FF] = fx_c_ff;
fx_function[HOP_SAFE_C_SS] = fx_c_ss;
fx_function[HOP_SAFE_C_opNCq] = fx_c_opncq;
fx_function[HOP_SAFE_C_opSq] = fx_c_opsq;
fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq;
fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq;
fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq;
fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s;
fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c;
fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs;
fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq;
fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq;
fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c;
fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s;
fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq;
fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c;
fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c;
fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s;
fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq;
fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq;
fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq;
fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq;
fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq;
fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq;
fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq;
fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq;
fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq;
fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq;
fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq;
fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s;
fx_function[HOP_SAFE_C_SSC] = fx_c_ssc;
fx_function[HOP_SAFE_C_SSS] = fx_c_sss;
fx_function[HOP_SAFE_C_SCS] = fx_c_scs;
fx_function[HOP_SAFE_C_SCC] = fx_c_scc;
fx_function[HOP_SAFE_C_CSS] = fx_c_css;
fx_function[HOP_SAFE_C_CSC] = fx_c_csc;
fx_function[HOP_SAFE_C_CCS] = fx_c_ccs;
fx_function[HOP_SAFE_C_NS] = fx_c_ns;
fx_function[HOP_SAFE_C_A] = fx_c_a;
fx_function[HOP_SAFE_C_AA] = fx_c_aa;
fx_function[HOP_SAFE_C_SA] = fx_c_sa;
fx_function[HOP_SAFE_C_AS] = fx_c_as;
fx_function[HOP_SAFE_C_CA] = fx_c_ca;
fx_function[HOP_SAFE_C_AC] = fx_c_ac;
fx_function[HOP_SAFE_C_AAA] = fx_c_aaa;
fx_function[HOP_SAFE_C_CAC] = fx_c_cac;
fx_function[HOP_SAFE_C_CSA] = fx_c_csa;
fx_function[HOP_SAFE_C_SCA] = fx_c_sca;
fx_function[HOP_SAFE_C_SAS] = fx_c_sas;
fx_function[HOP_SAFE_C_SAA] = fx_c_saa;
fx_function[HOP_SAFE_C_SSA] = fx_c_ssa;
fx_function[HOP_SAFE_C_ASS] = fx_c_ass;
fx_function[HOP_SAFE_C_AGG] = fx_c_agg;
fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca;
fx_function[HOP_SAFE_C_NA] = fx_c_na;
fx_function[HOP_SAFE_C_4A] = fx_c_4a;
fx_function[HOP_SAFE_C_opAq] = fx_c_opaq;
fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq;
fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq;
fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s;
fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq;
fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq;
fx_function[HOP_SAFE_C_S_opAAAq] = fx_c_s_opaaaq;
fx_function[HOP_SSA_DIRECT] = fx_c_ssa_direct;
fx_function[HOP_HASH_TABLE_INCREMENT] = fx_hash_table_increment;
fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a;
fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a;
fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a;
fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a;
fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a;
fx_function[HOP_SAFE_CLOSURE_3S_A] = fx_safe_closure_3s_a;
fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s;
fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc;
fx_function[HOP_SAFE_CLOSURE_A_TO_SC] = fx_safe_closure_a_to_sc;
fx_function[OP_COND_FX_FX] = fx_cond_fx_fx;
fx_function[OP_IF_A_C_C] = fx_if_a_c_c;
fx_function[OP_IF_A_A] = fx_if_a_a;
fx_function[OP_IF_S_A_A] = fx_if_s_a_a;
fx_function[OP_IF_A_A_A] = fx_if_a_a_a;
fx_function[OP_IF_AND2_S_A] = fx_if_and2_s_a;
fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a;
fx_function[OP_IF_NOT_A_A_A] = fx_if_not_a_a_a;
fx_function[OP_IF_IS_TYPE_S_A_A] = fx_if_is_type_s_a_a;
fx_function[OP_OR_2A] = fx_or_2a;
fx_function[OP_OR_S_2] = fx_or_s_2;
fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2;
fx_function[OP_OR_3A] = fx_or_3a;
fx_function[OP_OR_N] = fx_or_n;
fx_function[OP_AND_2A] = fx_and_2a;
fx_function[OP_AND_S_2] = fx_and_s_2;
fx_function[OP_AND_3A] = fx_and_3a;
fx_function[OP_AND_N] = fx_and_n;
fx_function[OP_BEGIN_NA] = fx_begin_na;
fx_function[OP_BEGIN_AA] = fx_begin_aa;
fx_function[OP_LET_TEMP_A_A] = fx_let_temp_a_a;
fx_function[OP_IMPLICIT_S7_LET_REF_S] = fx_implicit_s7_let_ref_s;
fx_function[OP_IMPLICIT_S7_LET_SET_SA] = fx_implicit_s7_let_set_sa;
/* these are ok even if a "z" branch is taken -- in that case the body does not have the is_optimized bit, so is_fxable returns false */
fx_function[OP_TC_AND_A_OR_A_LA] = fx_tc_and_a_or_a_la;
fx_function[OP_TC_OR_A_AND_A_LA] = fx_tc_or_a_and_a_la;
fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la;
fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa;
fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa;
fx_function[OP_TC_AND_A_OR_A_A_LA] = fx_tc_and_a_or_a_a_la;
fx_function[OP_TC_OR_A_AND_A_A_LA] = fx_tc_or_a_and_a_a_la;
fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la;
fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z;
fx_function[OP_TC_COND_A_Z_LA] = fx_tc_cond_a_z_la;
fx_function[OP_TC_COND_A_LA_Z] = fx_tc_cond_a_la_z;
fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa;
fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z;
fx_function[OP_TC_COND_A_Z_LAA] = fx_tc_cond_a_z_laa;
fx_function[OP_TC_COND_A_LAA_Z] = fx_tc_cond_a_laa_z;
fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a;
fx_function[OP_TC_IF_A_L3A_Z] = fx_tc_if_a_l3a_z;
fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la;
fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z;
fx_function[OP_TC_COND_A_Z_A_Z_LA] = fx_tc_cond_a_z_a_z_la;
fx_function[OP_TC_COND_A_Z_A_LA_Z] = fx_tc_cond_a_z_a_la_z;
fx_function[OP_TC_AND_A_IF_A_Z_LA] = fx_tc_and_a_if_a_z_la;
fx_function[OP_TC_AND_A_IF_A_LA_Z] = fx_tc_and_a_if_a_la_z;
fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z;
fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa;
fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa;
fx_function[OP_TC_COND_A_Z_A_LAA_Z] = fx_tc_cond_a_z_a_laa_z;
fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a;
fx_function[OP_TC_CASE_LA] = fx_tc_case_la;
fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a;
fx_function[OP_TC_LET_IF_A_Z_LA] = fx_tc_let_if_a_z_la;
fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa;
fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa;
fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa;
fx_function[OP_TC_LET_COND] = fx_tc_let_cond;
fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa;
fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq;
fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a;
fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] =
fx_recur_if_a_a_and_a_laa_laa;
fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] =
fx_recur_cond_a_a_a_a_opla_laq;
fx_function[OP_RECUR_AND_A_OR_A_LAA_LAA] = fx_recur_and_a_or_a_laa_laa;
}
static void init_opt_functions(s7_scheme * sc)
{
#if (!WITH_PURE_S7)
s7_set_b_7pp_function(sc, global_value(sc->char_ci_lt_symbol),
char_ci_lt_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->char_ci_leq_symbol),
char_ci_leq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->char_ci_gt_symbol),
char_ci_gt_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->char_ci_geq_symbol),
char_ci_geq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->char_ci_eq_symbol),
char_ci_eq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_ci_lt_symbol),
string_ci_lt_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_ci_leq_symbol),
string_ci_leq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_ci_gt_symbol),
string_ci_gt_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_ci_geq_symbol),
string_ci_geq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_ci_eq_symbol),
string_ci_eq_b_7pp);
s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_lt_symbol),
char_ci_lt_b_unchecked);
s7_set_b_pp_unchecked_function(sc,
global_value(sc->char_ci_leq_symbol),
char_ci_leq_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_gt_symbol),
char_ci_gt_b_unchecked);
s7_set_b_pp_unchecked_function(sc,
global_value(sc->char_ci_geq_symbol),
char_ci_geq_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_eq_symbol),
char_ci_eq_b_unchecked);
s7_set_b_pp_unchecked_function(sc,
global_value(sc->string_ci_lt_symbol),
string_ci_lt_b_unchecked);
s7_set_b_pp_unchecked_function(sc,
global_value(sc->string_ci_leq_symbol),
string_ci_leq_b_unchecked);
s7_set_b_pp_unchecked_function(sc,
global_value(sc->string_ci_gt_symbol),
string_ci_gt_b_unchecked);
s7_set_b_pp_unchecked_function(sc,
global_value(sc->string_ci_geq_symbol),
string_ci_geq_b_unchecked);
s7_set_b_pp_unchecked_function(sc,
global_value(sc->string_ci_eq_symbol),
string_ci_eq_b_unchecked);
s7_set_p_pp_function(sc, global_value(sc->vector_append_symbol),
vector_append_p_pp);
s7_set_p_ppp_function(sc, global_value(sc->vector_append_symbol),
vector_append_p_ppp);
s7_set_i_i_function(sc, global_value(sc->integer_length_symbol),
integer_length_i_i);
s7_set_i_7p_function(sc, global_value(sc->string_length_symbol),
string_length_i_7p);
s7_set_i_7p_function(sc, global_value(sc->vector_length_symbol),
vector_length_i_7p);
s7_set_p_p_function(sc, global_value(sc->vector_to_list_symbol),
vector_to_list_p_p);
s7_set_p_p_function(sc, global_value(sc->string_to_list_symbol),
string_to_list_p_p);
s7_set_p_p_function(sc, global_value(sc->vector_length_symbol),
vector_length_p_p);
s7_set_b_7p_function(sc, global_value(sc->is_exact_symbol),
is_exact_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol),
is_inexact_b_7p);
#endif
s7_set_p_pp_function(sc, global_value(sc->float_vector_ref_symbol),
float_vector_ref_p_pp);
s7_set_d_7pi_function(sc, global_value(sc->float_vector_ref_symbol),
float_vector_ref_d_7pi);
s7_set_d_7pii_function(sc, global_value(sc->float_vector_ref_symbol),
float_vector_ref_d_7pii);
s7_set_d_7piii_function(sc, global_value(sc->float_vector_ref_symbol),
float_vector_ref_d_7piii);
s7_set_d_7pid_function(sc, global_value(sc->float_vector_set_symbol),
float_vector_set_d_7pid);
s7_set_d_7piid_function(sc, global_value(sc->float_vector_set_symbol),
float_vector_set_d_7piid);
s7_set_d_7piiid_function(sc, global_value(sc->float_vector_set_symbol),
float_vector_set_d_7piiid);
s7_set_p_pp_function(sc, global_value(sc->int_vector_ref_symbol),
int_vector_ref_p_pp);
s7_set_i_7pi_function(sc, global_value(sc->int_vector_ref_symbol),
int_vector_ref_i_7pi);
s7_set_i_7pii_function(sc, global_value(sc->int_vector_ref_symbol),
int_vector_ref_i_7pii);
s7_set_i_7piii_function(sc, global_value(sc->int_vector_ref_symbol),
int_vector_ref_i_7piii);
s7_set_i_7pii_function(sc, global_value(sc->int_vector_set_symbol),
int_vector_set_i_7pii);
s7_set_i_7piii_function(sc, global_value(sc->int_vector_set_symbol),
int_vector_set_i_7piii);
s7_set_i_7pi_function(sc, global_value(sc->byte_vector_ref_symbol),
byte_vector_ref_i_7pi);
s7_set_i_7pii_function(sc, global_value(sc->byte_vector_ref_symbol),
byte_vector_ref_i_7pii);
s7_set_i_7pii_function(sc, global_value(sc->byte_vector_set_symbol),
byte_vector_set_i_7pii);
s7_set_i_7piii_function(sc, global_value(sc->byte_vector_set_symbol),
byte_vector_set_i_7piii);
s7_set_p_pp_function(sc, global_value(sc->vector_ref_symbol),
vector_ref_p_pp);
s7_set_p_pi_function(sc, global_value(sc->vector_ref_symbol),
vector_ref_p_pi);
s7_set_p_pii_function(sc, global_value(sc->vector_ref_symbol),
vector_ref_p_pii);
s7_set_p_pip_function(sc, global_value(sc->vector_set_symbol),
vector_set_p_pip);
s7_set_p_piip_function(sc, global_value(sc->vector_set_symbol),
vector_set_p_piip);
s7_set_p_pi_unchecked_function(sc, global_value(sc->vector_ref_symbol),
vector_ref_p_pi_unchecked);
s7_set_p_pip_unchecked_function(sc,
global_value(sc->vector_set_symbol),
vector_set_p_pip_unchecked);
s7_set_p_ppp_function(sc, global_value(sc->vector_set_symbol),
vector_set_p_ppp);
s7_set_p_ppp_function(sc, global_value(sc->int_vector_set_symbol),
int_vector_set_p_ppp);
s7_set_p_pi_function(sc, global_value(sc->list_ref_symbol),
list_ref_p_pi);
s7_set_p_pip_function(sc, global_value(sc->list_set_symbol),
list_set_p_pip);
s7_set_p_pi_unchecked_function(sc, global_value(sc->list_ref_symbol),
list_ref_p_pi_unchecked);
s7_set_p_pip_unchecked_function(sc, global_value(sc->list_set_symbol),
list_set_p_pip_unchecked);
s7_set_p_p_function(sc, global_value(sc->cyclic_sequences_symbol),
cyclic_sequences_p_p);
s7_set_p_pp_function(sc, global_value(sc->let_ref_symbol), s7_let_ref);
s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol),
s7_let_set);
s7_set_p_pi_function(sc, global_value(sc->string_ref_symbol),
string_ref_p_pi);
s7_set_p_pp_function(sc, global_value(sc->string_ref_symbol),
string_ref_p_pp);
s7_set_p_pip_function(sc, global_value(sc->string_set_symbol),
string_set_p_pip);
s7_set_p_pi_unchecked_function(sc, global_value(sc->string_ref_symbol),
string_ref_p_pi_unchecked);
s7_set_p_pip_unchecked_function(sc,
global_value(sc->string_set_symbol),
string_set_p_pip_unchecked);
s7_set_p_pp_function(sc, global_value(sc->hash_table_ref_symbol),
hash_table_ref_p_pp);
s7_set_p_ppp_function(sc, global_value(sc->hash_table_set_symbol),
hash_table_set_p_ppp);
s7_set_p_ii_function(sc, global_value(sc->complex_symbol),
complex_p_ii);
s7_set_p_dd_function(sc, global_value(sc->complex_symbol),
complex_p_dd);
s7_set_p_i_function(sc, global_value(sc->number_to_string_symbol),
number_to_string_p_i);
s7_set_p_p_function(sc, global_value(sc->number_to_string_symbol),
number_to_string_p_p);
s7_set_p_pp_function(sc, global_value(sc->number_to_string_symbol),
number_to_string_p_pp);
s7_set_p_p_function(sc, global_value(sc->string_to_number_symbol),
string_to_number_p_p);
s7_set_p_pp_function(sc, global_value(sc->string_to_number_symbol),
string_to_number_p_pp);
s7_set_p_p_function(sc, global_value(sc->car_symbol), car_p_p);
s7_set_p_pp_function(sc, global_value(sc->set_car_symbol),
set_car_p_pp);
s7_set_p_p_function(sc, global_value(sc->cdr_symbol), cdr_p_p);
s7_set_p_pp_function(sc, global_value(sc->set_cdr_symbol),
set_cdr_p_pp);
s7_set_p_p_function(sc, global_value(sc->caar_symbol), caar_p_p);
s7_set_p_p_function(sc, global_value(sc->cadr_symbol), cadr_p_p);
s7_set_p_p_function(sc, global_value(sc->cdar_symbol), cdar_p_p);
s7_set_p_p_function(sc, global_value(sc->cddr_symbol), cddr_p_p);
s7_set_p_p_function(sc, global_value(sc->caddr_symbol), caddr_p_p);
s7_set_p_p_function(sc, global_value(sc->caadr_symbol), caadr_p_p);
s7_set_p_p_function(sc, global_value(sc->cadar_symbol), cadar_p_p);
s7_set_p_p_function(sc, global_value(sc->cdddr_symbol), cdddr_p_p);
s7_set_p_p_function(sc, global_value(sc->cdadr_symbol), cdadr_p_p);
s7_set_p_p_function(sc, global_value(sc->cddar_symbol), cddar_p_p);
s7_set_p_p_function(sc, global_value(sc->cdaar_symbol), cdaar_p_p);
s7_set_p_p_function(sc, global_value(sc->caaar_symbol), caaar_p_p);
s7_set_p_p_function(sc, global_value(sc->caddar_symbol), caddar_p_p);
s7_set_p_p_function(sc, global_value(sc->caaddr_symbol), caaddr_p_p);
s7_set_p_p_function(sc, global_value(sc->cadddr_symbol), cadddr_p_p);
s7_set_p_p_function(sc, global_value(sc->cadadr_symbol), cadadr_p_p);
s7_set_p_p_function(sc, global_value(sc->string_symbol), string_p_p);
s7_set_p_p_function(sc, global_value(sc->string_to_symbol_symbol),
string_to_symbol_p_p);
s7_set_p_p_function(sc, global_value(sc->symbol_to_string_symbol),
symbol_to_string_p_p);
s7_set_p_p_function(sc, global_value(sc->symbol_symbol),
string_to_symbol_p_p);
s7_set_p_pp_function(sc, global_value(sc->symbol_symbol), symbol_p_pp);
s7_set_p_function(sc, global_value(sc->newline_symbol), newline_p);
s7_set_p_p_function(sc, global_value(sc->newline_symbol), newline_p_p);
s7_set_p_p_function(sc, global_value(sc->display_symbol), display_p_p);
s7_set_p_pp_function(sc, global_value(sc->display_symbol),
display_p_pp);
s7_set_p_p_function(sc, global_value(sc->write_symbol), write_p_p);
s7_set_p_pp_function(sc, global_value(sc->write_symbol), write_p_pp);
s7_set_p_p_function(sc, global_value(sc->write_char_symbol),
write_char_p_p);
s7_set_p_pp_function(sc, global_value(sc->write_char_symbol),
write_char_p_pp);
s7_set_p_pp_function(sc, global_value(sc->write_string_symbol),
write_string_p_pp);
s7_set_p_pp_function(sc, global_value(sc->read_line_symbol),
read_line_p_pp);
s7_set_p_p_function(sc, global_value(sc->read_line_symbol),
read_line_p_p);
s7_set_p_pp_function(sc, global_value(sc->inlet_symbol), inlet_p_pp);
s7_set_i_7p_function(sc, global_value(sc->port_line_number_symbol),
s7_port_line_number);
s7_set_p_pp_function(sc, global_value(sc->cons_symbol), cons_p_pp);
s7_set_p_function(sc, global_value(sc->open_output_string_symbol),
s7_open_output_string);
s7_set_p_ppi_function(sc, global_value(sc->char_position_symbol),
char_position_p_ppi);
s7_set_p_pp_function(sc, global_value(sc->append_symbol), s7_append);
s7_set_p_pp_function(sc, global_value(sc->string_append_symbol),
string_append_p_pp);
s7_set_p_ppp_function(sc, global_value(sc->append_symbol),
append_p_ppp);
s7_set_p_function(sc, global_value(sc->values_symbol), values_p);
s7_set_p_p_function(sc, global_value(sc->values_symbol), values_p_p);
s7_set_p_pp_function(sc, global_value(sc->member_symbol), member_p_pp);
s7_set_p_pp_function(sc, global_value(sc->assoc_symbol), assoc_p_pp);
s7_set_i_i_function(sc, global_value(sc->abs_symbol), abs_i_i);
s7_set_d_d_function(sc, global_value(sc->abs_symbol), abs_d_d);
s7_set_p_p_function(sc, global_value(sc->abs_symbol), abs_p_p);
s7_set_p_p_function(sc, global_value(sc->magnitude_symbol),
magnitude_p_p);
s7_set_p_d_function(sc, global_value(sc->sin_symbol), sin_p_d);
s7_set_p_p_function(sc, global_value(sc->sin_symbol), sin_p_p);
s7_set_p_d_function(sc, global_value(sc->cos_symbol), cos_p_d);
s7_set_p_p_function(sc, global_value(sc->cos_symbol), cos_p_p);
s7_set_p_p_function(sc, global_value(sc->tan_symbol), tan_p_p);
s7_set_p_p_function(sc, global_value(sc->asin_symbol), asin_p_p);
s7_set_p_p_function(sc, global_value(sc->acos_symbol), acos_p_p);
s7_set_p_d_function(sc, global_value(sc->rationalize_symbol),
rationalize_p_d);
s7_set_p_i_function(sc, global_value(sc->rationalize_symbol),
rationalize_p_i);
s7_set_i_i_function(sc, global_value(sc->rationalize_symbol),
rationalize_i_i);
s7_set_p_p_function(sc, global_value(sc->truncate_symbol),
truncate_p_p);
s7_set_p_p_function(sc, global_value(sc->round_symbol), round_p_p);
s7_set_p_p_function(sc, global_value(sc->ceiling_symbol), ceiling_p_p);
s7_set_p_p_function(sc, global_value(sc->floor_symbol), floor_p_p);
s7_set_p_pp_function(sc, global_value(sc->max_symbol), max_p_pp);
s7_set_p_pp_function(sc, global_value(sc->min_symbol), min_p_pp);
s7_set_p_p_function(sc, global_value(sc->sqrt_symbol), sqrt_p_p);
s7_set_d_7dd_function(sc, global_value(sc->remainder_symbol),
remainder_d_7dd);
s7_set_i_7ii_function(sc, global_value(sc->remainder_symbol),
remainder_i_7ii);
s7_set_i_7ii_function(sc, global_value(sc->quotient_symbol),
quotient_i_7ii);
s7_set_d_7dd_function(sc, global_value(sc->modulo_symbol),
modulo_d_7dd);
s7_set_i_ii_function(sc, global_value(sc->modulo_symbol), modulo_i_ii);
s7_set_p_dd_function(sc, global_value(sc->multiply_symbol), mul_p_dd);
s7_set_p_dd_function(sc, global_value(sc->add_symbol), add_p_dd);
s7_set_p_dd_function(sc, global_value(sc->subtract_symbol),
subtract_p_dd);
s7_set_p_ii_function(sc, global_value(sc->subtract_symbol),
subtract_p_ii);
s7_set_p_pp_function(sc, global_value(sc->modulo_symbol), modulo_p_pp);
s7_set_p_pp_function(sc, global_value(sc->remainder_symbol),
remainder_p_pp);
s7_set_p_pp_function(sc, global_value(sc->quotient_symbol),
quotient_p_pp);
s7_set_p_pp_function(sc, global_value(sc->subtract_symbol),
subtract_p_pp);
s7_set_p_pp_function(sc, global_value(sc->add_symbol), add_p_pp);
s7_set_p_ppp_function(sc, global_value(sc->add_symbol), add_p_ppp);
s7_set_p_pp_function(sc, global_value(sc->multiply_symbol),
multiply_p_pp);
s7_set_p_ppp_function(sc, global_value(sc->multiply_symbol),
multiply_p_ppp);
s7_set_p_pp_function(sc, global_value(sc->divide_symbol), divide_p_pp);
s7_set_p_p_function(sc, global_value(sc->divide_symbol), invert_p_p);
s7_set_p_p_function(sc, global_value(sc->subtract_symbol), negate_p_p);
s7_set_p_p_function(sc, global_value(sc->random_symbol), random_p_p);
s7_set_d_7d_function(sc, global_value(sc->random_symbol), random_d_7d);
s7_set_i_7i_function(sc, global_value(sc->random_symbol), random_i_7i);
s7_set_p_d_function(sc, global_value(sc->float_vector_symbol),
float_vector_p_d);
s7_set_p_i_function(sc, global_value(sc->int_vector_symbol),
int_vector_p_i);
s7_set_i_i_function(sc, global_value(sc->round_symbol), round_i_i);
s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i);
s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i);
s7_set_i_i_function(sc, global_value(sc->truncate_symbol),
truncate_i_i);
s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d);
s7_set_d_dd_function(sc, global_value(sc->atan_symbol), atan_d_dd);
s7_set_d_d_function(sc, global_value(sc->tanh_symbol), tanh_d_d);
s7_set_p_p_function(sc, global_value(sc->exp_symbol), exp_p_p);
#if (!WITH_GMP)
s7_set_i_7ii_function(sc, global_value(sc->ash_symbol), ash_i_7ii);
s7_set_d_d_function(sc, global_value(sc->sin_symbol), sin_d_d);
s7_set_d_d_function(sc, global_value(sc->cos_symbol), cos_d_d);
s7_set_d_d_function(sc, global_value(sc->sinh_symbol), sinh_d_d);
s7_set_d_d_function(sc, global_value(sc->cosh_symbol), cosh_d_d);
s7_set_d_d_function(sc, global_value(sc->exp_symbol), exp_d_d);
s7_set_i_7d_function(sc, global_value(sc->round_symbol), round_i_7d);
s7_set_i_7d_function(sc, global_value(sc->floor_symbol), floor_i_7d);
s7_set_i_7d_function(sc, global_value(sc->ceiling_symbol),
ceiling_i_7d);
s7_set_i_7p_function(sc, global_value(sc->floor_symbol), floor_i_7p);
s7_set_i_7p_function(sc, global_value(sc->ceiling_symbol),
ceiling_i_7p);
s7_set_i_7d_function(sc, global_value(sc->truncate_symbol),
truncate_i_7d);
#endif
s7_set_d_d_function(sc, global_value(sc->add_symbol), add_d_d);
s7_set_d_d_function(sc, global_value(sc->subtract_symbol),
subtract_d_d);
s7_set_d_d_function(sc, global_value(sc->multiply_symbol),
multiply_d_d);
s7_set_d_7d_function(sc, global_value(sc->divide_symbol), divide_d_7d);
s7_set_d_dd_function(sc, global_value(sc->add_symbol), add_d_dd);
s7_set_d_dd_function(sc, global_value(sc->subtract_symbol),
subtract_d_dd);
s7_set_d_dd_function(sc, global_value(sc->multiply_symbol),
multiply_d_dd);
s7_set_d_7dd_function(sc, global_value(sc->divide_symbol),
divide_d_7dd);
s7_set_d_ddd_function(sc, global_value(sc->add_symbol), add_d_ddd);
s7_set_d_ddd_function(sc, global_value(sc->subtract_symbol),
subtract_d_ddd);
s7_set_d_ddd_function(sc, global_value(sc->multiply_symbol),
multiply_d_ddd);
s7_set_d_dddd_function(sc, global_value(sc->add_symbol), add_d_dddd);
s7_set_d_dddd_function(sc, global_value(sc->subtract_symbol),
subtract_d_dddd);
s7_set_d_dddd_function(sc, global_value(sc->multiply_symbol),
multiply_d_dddd);
s7_set_p_i_function(sc, global_value(sc->divide_symbol), divide_p_i);
s7_set_p_ii_function(sc, global_value(sc->divide_symbol), divide_p_ii);
s7_set_d_dd_function(sc, global_value(sc->max_symbol), max_d_dd);
s7_set_d_dd_function(sc, global_value(sc->min_symbol), min_d_dd);
s7_set_d_ddd_function(sc, global_value(sc->max_symbol), max_d_ddd);
s7_set_d_ddd_function(sc, global_value(sc->min_symbol), min_d_ddd);
s7_set_d_dddd_function(sc, global_value(sc->max_symbol), max_d_dddd);
s7_set_d_dddd_function(sc, global_value(sc->min_symbol), min_d_dddd);
s7_set_i_ii_function(sc, global_value(sc->max_symbol), max_i_ii);
s7_set_i_ii_function(sc, global_value(sc->min_symbol), min_i_ii);
s7_set_i_iii_function(sc, global_value(sc->max_symbol), max_i_iii);
s7_set_i_iii_function(sc, global_value(sc->min_symbol), min_i_iii);
s7_set_i_i_function(sc, global_value(sc->subtract_symbol),
subtract_i_i);
s7_set_i_ii_function(sc, global_value(sc->add_symbol), add_i_ii);
s7_set_i_iii_function(sc, global_value(sc->add_symbol), add_i_iii);
s7_set_i_ii_function(sc, global_value(sc->subtract_symbol),
subtract_i_ii);
s7_set_i_iii_function(sc, global_value(sc->subtract_symbol),
subtract_i_iii);
s7_set_i_ii_function(sc, global_value(sc->multiply_symbol),
multiply_i_ii);
s7_set_i_iii_function(sc, global_value(sc->multiply_symbol),
multiply_i_iii);
s7_set_i_i_function(sc, global_value(sc->lognot_symbol), lognot_i_i);
s7_set_i_ii_function(sc, global_value(sc->logior_symbol), logior_i_ii);
s7_set_i_ii_function(sc, global_value(sc->logxor_symbol), logxor_i_ii);
s7_set_i_ii_function(sc, global_value(sc->logand_symbol), logand_i_ii);
s7_set_i_iii_function(sc, global_value(sc->logior_symbol),
logior_i_iii);
s7_set_i_iii_function(sc, global_value(sc->logxor_symbol),
logxor_i_iii);
s7_set_i_iii_function(sc, global_value(sc->logand_symbol),
logand_i_iii);
s7_set_b_7ii_function(sc, global_value(sc->logbit_symbol),
logbit_b_7ii);
s7_set_b_7pp_function(sc, global_value(sc->logbit_symbol),
logbit_b_7pp);
s7_set_i_7p_function(sc, global_value(sc->numerator_symbol),
numerator_i_7p);
s7_set_i_7p_function(sc, global_value(sc->denominator_symbol),
denominator_i_7p);
s7_set_i_7p_function(sc, global_value(sc->char_to_integer_symbol),
char_to_integer_i_7p);
s7_set_i_7p_function(sc, global_value(sc->hash_table_entries_symbol),
hash_table_entries_i_7p);
s7_set_i_7p_function(sc, global_value(sc->tree_leaves_symbol),
tree_leaves_i_7p);
s7_set_p_p_function(sc, global_value(sc->char_to_integer_symbol),
char_to_integer_p_p);
s7_set_b_p_function(sc, global_value(sc->is_boolean_symbol),
s7_is_boolean);
s7_set_b_p_function(sc, global_value(sc->is_byte_vector_symbol),
is_byte_vector_b_p);
s7_set_b_p_function(sc, global_value(sc->is_c_object_symbol),
s7_is_c_object);
s7_set_b_p_function(sc, global_value(sc->is_char_symbol),
s7_is_character);
s7_set_b_p_function(sc, global_value(sc->is_complex_symbol),
s7_is_complex);
s7_set_b_p_function(sc, global_value(sc->is_continuation_symbol),
is_continuation_b_p);
s7_set_b_p_function(sc, global_value(sc->is_c_pointer_symbol),
s7_is_c_pointer);
s7_set_b_p_function(sc, global_value(sc->is_dilambda_symbol),
s7_is_dilambda);
s7_set_b_p_function(sc, global_value(sc->is_eof_object_symbol),
is_eof_object_b_p);
s7_set_b_7p_function(sc, global_value(sc->is_even_symbol),
is_even_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), is_odd_b_7p);
s7_set_b_p_function(sc, global_value(sc->is_float_symbol), is_float_b);
s7_set_b_p_function(sc, global_value(sc->is_float_vector_symbol),
s7_is_float_vector);
s7_set_b_p_function(sc, global_value(sc->is_gensym_symbol),
is_gensym_b_p);
s7_set_b_p_function(sc, global_value(sc->is_hash_table_symbol),
s7_is_hash_table);
s7_set_b_7p_function(sc, global_value(sc->is_infinite_symbol),
is_infinite_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_nan_symbol), is_nan_b_7p);
s7_set_b_p_function(sc, global_value(sc->is_input_port_symbol),
is_input_port_b);
s7_set_b_p_function(sc, global_value(sc->is_integer_symbol),
s7_is_integer);
s7_set_b_p_function(sc, global_value(sc->is_int_vector_symbol),
s7_is_int_vector);
s7_set_b_p_function(sc, global_value(sc->is_keyword_symbol),
s7_is_keyword);
s7_set_b_p_function(sc, global_value(sc->is_let_symbol), s7_is_let);
s7_set_b_p_function(sc, global_value(sc->is_list_symbol), is_list_b);
s7_set_b_p_function(sc, global_value(sc->is_macro_symbol), is_macro_b);
s7_set_b_p_function(sc, global_value(sc->is_number_symbol),
s7_is_number);
s7_set_b_p_function(sc, global_value(sc->is_output_port_symbol),
is_output_port_b);
s7_set_b_p_function(sc, global_value(sc->is_pair_symbol), s7_is_pair);
s7_set_b_p_function(sc, global_value(sc->is_null_symbol), is_null_b_p);
s7_set_b_7p_function(sc, global_value(sc->is_port_closed_symbol),
is_port_closed_b_7p);
s7_set_b_p_function(sc, global_value(sc->is_procedure_symbol),
s7_is_procedure);
s7_set_b_7p_function(sc, global_value(sc->is_proper_list_symbol),
s7_is_proper_list);
s7_set_b_p_function(sc, global_value(sc->is_random_state_symbol),
s7_is_random_state);
s7_set_b_p_function(sc, global_value(sc->is_rational_symbol),
s7_is_rational);
s7_set_b_p_function(sc, global_value(sc->is_real_symbol), s7_is_real);
s7_set_b_p_function(sc, global_value(sc->is_sequence_symbol),
is_sequence_b);
s7_set_b_p_function(sc, global_value(sc->is_string_symbol),
s7_is_string);
s7_set_b_p_function(sc, global_value(sc->is_symbol_symbol),
s7_is_symbol);
s7_set_b_p_function(sc, global_value(sc->is_syntax_symbol),
s7_is_syntax);
s7_set_b_p_function(sc, global_value(sc->is_vector_symbol),
s7_is_vector);
s7_set_b_7p_function(sc, global_value(sc->is_iterator_symbol),
is_iterator_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_char_alphabetic_symbol),
is_char_alphabetic_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_char_lower_case_symbol),
is_char_lower_case_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_char_numeric_symbol),
is_char_numeric_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_char_upper_case_symbol),
is_char_upper_case_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_char_whitespace_symbol),
is_char_whitespace_b_7p);
s7_set_b_p_function(sc, global_value(sc->is_openlet_symbol),
s7_is_openlet);
s7_set_b_7p_function(sc, global_value(sc->iterator_is_at_end_symbol),
iterator_is_at_end_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_zero_symbol),
is_zero_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_negative_symbol),
is_negative_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_positive_symbol),
is_positive_b_7p);
s7_set_b_7p_function(sc, global_value(sc->not_symbol), not_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_provided_symbol),
is_provided_b_7p);
s7_set_b_7p_function(sc, global_value(sc->is_defined_symbol),
is_defined_b_7p);
s7_set_b_7pp_function(sc, global_value(sc->is_defined_symbol),
is_defined_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->tree_memq_symbol),
s7_tree_memq);
s7_set_b_7p_function(sc, global_value(sc->tree_is_cyclic_symbol),
tree_is_cyclic);
s7_set_b_7pp_function(sc, global_value(sc->tree_set_memq_symbol),
tree_set_memq_b_7pp);
s7_set_p_pp_function(sc, global_value(sc->tree_set_memq_symbol),
tree_set_memq_p_pp);
s7_set_b_p_function(sc, global_value(sc->is_immutable_symbol),
s7_is_immutable);
s7_set_p_p_function(sc, global_value(sc->is_proper_list_symbol),
is_proper_list_p_p);
s7_set_p_p_function(sc, global_value(sc->is_pair_symbol), is_pair_p_p);
s7_set_p_p_function(sc, global_value(sc->is_char_symbol), is_char_p_p);
s7_set_p_p_function(sc, global_value(sc->is_constant_symbol),
is_constant_p_p);
s7_set_b_7p_function(sc, global_value(sc->is_constant_symbol),
is_constant_b_7p);
s7_set_p_p_function(sc, global_value(sc->type_of_symbol), s7_type_of);
s7_set_p_i_function(sc, global_value(sc->integer_to_char_symbol),
integer_to_char_p_i);
s7_set_p_p_function(sc, global_value(sc->integer_to_char_symbol),
integer_to_char_p_p);
s7_set_p_p_function(sc, global_value(sc->iterate_symbol), iterate_p_p);
s7_set_p_p_function(sc, global_value(sc->list_symbol), list_p_p);
s7_set_p_pp_function(sc, global_value(sc->list_symbol), list_p_pp);
s7_set_p_ppp_function(sc, global_value(sc->list_symbol), list_p_ppp);
s7_set_p_pp_function(sc, global_value(sc->list_tail_symbol),
list_tail_p_pp);
s7_set_p_pp_function(sc, global_value(sc->make_list_symbol),
make_list_p_pp);
s7_set_p_pp_function(sc, global_value(sc->assq_symbol), assq_p_pp);
s7_set_p_pp_function(sc, global_value(sc->assv_symbol), assv_p_pp);
s7_set_p_pp_function(sc, global_value(sc->memq_symbol), memq_p_pp);
s7_set_p_pp_function(sc, global_value(sc->memv_symbol), memv_p_pp);
s7_set_p_p_function(sc, global_value(sc->tree_leaves_symbol),
tree_leaves_p_p);
s7_set_p_p_function(sc, global_value(sc->length_symbol), s7_length);
s7_set_p_p_function(sc, global_value(sc->pair_line_number_symbol),
pair_line_number_p_p);
s7_set_p_p_function(sc, global_value(sc->port_line_number_symbol),
port_line_number_p_p);
s7_set_p_p_function(sc, global_value(sc->port_filename_symbol),
port_filename_p_p);
s7_set_p_p_function(sc, global_value(sc->c_pointer_info_symbol),
c_pointer_info_p_p);
s7_set_p_p_function(sc, global_value(sc->c_pointer_type_symbol),
c_pointer_type_p_p);
s7_set_p_p_function(sc, global_value(sc->c_pointer_weak1_symbol),
c_pointer_weak1_p_p);
s7_set_p_p_function(sc, global_value(sc->c_pointer_weak2_symbol),
c_pointer_weak2_p_p);
s7_set_p_p_function(sc, global_value(sc->is_char_alphabetic_symbol),
is_char_alphabetic_p_p);
s7_set_p_p_function(sc, global_value(sc->is_char_whitespace_symbol),
is_char_whitespace_p_p);
s7_set_p_p_function(sc, global_value(sc->is_char_numeric_symbol),
is_char_numeric_p_p);
s7_set_p_p_function(sc, global_value(sc->char_upcase_symbol),
char_upcase_p_p);
s7_set_p_p_function(sc, global_value(sc->read_char_symbol),
read_char_p_p);
s7_set_p_i_function(sc, global_value(sc->make_string_symbol),
make_string_p_i);
s7_set_p_ii_function(sc, global_value(sc->make_int_vector_symbol),
make_int_vector_p_ii);
s7_set_p_ii_function(sc, global_value(sc->make_byte_vector_symbol),
make_byte_vector_p_ii);
s7_set_p_pp_function(sc, global_value(sc->vector_symbol), vector_p_pp);
s7_set_p_p_function(sc, global_value(sc->signature_symbol),
s7_signature);
s7_set_p_p_function(sc, global_value(sc->copy_symbol), copy_p_p);
s7_set_p_p_function(sc, global_value(sc->object_to_let_symbol),
object_to_let_p_p);
s7_set_p_p_function(sc, global_value(sc->outlet_symbol), outlet_p_p);
#if WITH_SYSTEM_EXTRAS
s7_set_b_7p_function(sc, global_value(sc->is_directory_symbol),
is_directory_b_7p);
s7_set_b_7p_function(sc, global_value(sc->file_exists_symbol),
file_exists_b_7p);
#endif
s7_set_b_i_function(sc, global_value(sc->is_even_symbol), is_even_i);
s7_set_b_i_function(sc, global_value(sc->is_odd_symbol), is_odd_i);
s7_set_b_i_function(sc, global_value(sc->is_zero_symbol), is_zero_i);
s7_set_b_d_function(sc, global_value(sc->is_zero_symbol), is_zero_d);
s7_set_p_p_function(sc, global_value(sc->is_zero_symbol), is_zero_p_p);
s7_set_p_p_function(sc, global_value(sc->is_positive_symbol),
is_positive_p_p);
s7_set_p_p_function(sc, global_value(sc->is_negative_symbol),
is_negative_p_p);
s7_set_p_p_function(sc, global_value(sc->real_part_symbol),
real_part_p_p);
s7_set_p_p_function(sc, global_value(sc->imag_part_symbol),
imag_part_p_p);
s7_set_b_i_function(sc, global_value(sc->is_positive_symbol),
is_positive_i);
s7_set_b_d_function(sc, global_value(sc->is_positive_symbol),
is_positive_d);
s7_set_b_i_function(sc, global_value(sc->is_negative_symbol),
is_negative_i);
s7_set_b_d_function(sc, global_value(sc->is_negative_symbol),
is_negative_d);
s7_set_p_pi_function(sc, global_value(sc->lt_symbol), lt_p_pi);
s7_set_b_pi_function(sc, global_value(sc->lt_symbol), lt_b_pi);
s7_set_p_pi_function(sc, global_value(sc->leq_symbol), leq_p_pi);
s7_set_b_pi_function(sc, global_value(sc->leq_symbol), leq_b_pi);
s7_set_p_pi_function(sc, global_value(sc->gt_symbol), gt_p_pi);
s7_set_b_pi_function(sc, global_value(sc->gt_symbol), gt_b_pi);
s7_set_p_pi_function(sc, global_value(sc->geq_symbol), geq_p_pi);
s7_set_b_pi_function(sc, global_value(sc->geq_symbol), geq_b_pi);
/* no ip pd dp! */
s7_set_b_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_b_pi);
s7_set_p_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pi);
s7_set_p_pi_function(sc, global_value(sc->add_symbol), g_add_xi);
s7_set_p_pi_function(sc, global_value(sc->subtract_symbol), g_sub_xi);
s7_set_p_pi_function(sc, global_value(sc->multiply_symbol), g_mul_xi);
s7_set_p_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_p_ii);
s7_set_p_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_p_dd);
s7_set_p_pp_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pp);
s7_set_b_7pp_function(sc, global_value(sc->num_eq_symbol),
num_eq_b_7pp);
s7_set_b_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_b_ii);
s7_set_b_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_b_dd);
s7_set_p_ii_function(sc, global_value(sc->lt_symbol), lt_p_ii);
s7_set_p_dd_function(sc, global_value(sc->lt_symbol), lt_p_dd);
s7_set_p_pp_function(sc, global_value(sc->lt_symbol), lt_p_pp);
s7_set_b_7pp_function(sc, global_value(sc->lt_symbol), lt_b_7pp);
s7_set_b_ii_function(sc, global_value(sc->lt_symbol), lt_b_ii);
s7_set_b_dd_function(sc, global_value(sc->lt_symbol), lt_b_dd);
s7_set_b_ii_function(sc, global_value(sc->leq_symbol), leq_b_ii);
s7_set_p_dd_function(sc, global_value(sc->leq_symbol), leq_p_dd);
s7_set_p_ii_function(sc, global_value(sc->leq_symbol), leq_p_ii);
s7_set_b_dd_function(sc, global_value(sc->leq_symbol), leq_b_dd);
s7_set_p_pp_function(sc, global_value(sc->leq_symbol), leq_p_pp);
s7_set_b_7pp_function(sc, global_value(sc->leq_symbol), leq_b_7pp);
s7_set_b_ii_function(sc, global_value(sc->gt_symbol), gt_b_ii);
s7_set_b_dd_function(sc, global_value(sc->gt_symbol), gt_b_dd);
s7_set_p_dd_function(sc, global_value(sc->gt_symbol), gt_p_dd);
s7_set_p_ii_function(sc, global_value(sc->gt_symbol), gt_p_ii);
s7_set_p_pp_function(sc, global_value(sc->gt_symbol), gt_p_pp);
s7_set_b_7pp_function(sc, global_value(sc->gt_symbol), gt_b_7pp);
s7_set_b_ii_function(sc, global_value(sc->geq_symbol), geq_b_ii);
s7_set_b_dd_function(sc, global_value(sc->geq_symbol), geq_b_dd);
s7_set_p_ii_function(sc, global_value(sc->geq_symbol), geq_p_ii);
s7_set_p_dd_function(sc, global_value(sc->geq_symbol), geq_p_dd);
s7_set_p_pp_function(sc, global_value(sc->geq_symbol), geq_p_pp);
s7_set_b_7pp_function(sc, global_value(sc->geq_symbol), geq_b_7pp);
s7_set_b_pp_function(sc, global_value(sc->is_eq_symbol), s7_is_eq);
s7_set_p_pp_function(sc, global_value(sc->is_eq_symbol), is_eq_p_pp);
s7_set_b_7pp_function(sc, global_value(sc->is_eqv_symbol), s7_is_eqv);
s7_set_p_pp_function(sc, global_value(sc->is_eqv_symbol), is_eqv_p_pp);
s7_set_b_7pp_function(sc, global_value(sc->is_equal_symbol),
s7_is_equal);
s7_set_b_7pp_function(sc, global_value(sc->is_equivalent_symbol),
s7_is_equivalent);
s7_set_p_pp_function(sc, global_value(sc->is_equal_symbol),
is_equal_p_pp);
s7_set_p_pp_function(sc, global_value(sc->is_equivalent_symbol),
is_equivalent_p_pp);
s7_set_p_pp_function(sc, global_value(sc->char_eq_symbol),
char_eq_p_pp);
s7_set_b_7pp_function(sc, global_value(sc->char_lt_symbol),
char_lt_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->char_leq_symbol),
char_leq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->char_gt_symbol),
char_gt_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->char_geq_symbol),
char_geq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->char_eq_symbol),
char_eq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_lt_symbol),
string_lt_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_leq_symbol),
string_leq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_gt_symbol),
string_gt_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_geq_symbol),
string_geq_b_7pp);
s7_set_b_7pp_function(sc, global_value(sc->string_eq_symbol),
string_eq_b_7pp);
s7_set_b_pp_unchecked_function(sc, global_value(sc->char_lt_symbol),
char_lt_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->char_leq_symbol),
char_leq_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->char_gt_symbol),
char_gt_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->char_geq_symbol),
char_geq_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->char_eq_symbol),
char_eq_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->string_lt_symbol),
string_lt_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->string_leq_symbol),
string_leq_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->string_gt_symbol),
string_gt_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->string_geq_symbol),
string_geq_b_unchecked);
s7_set_b_pp_unchecked_function(sc, global_value(sc->string_eq_symbol),
string_eq_b_unchecked);
s7_set_b_7pp_function(sc, global_value(sc->is_aritable_symbol),
is_aritable_b_7pp);
}
static void init_features(s7_scheme * sc)
{
s7_provide(sc, "s7");
s7_provide(sc, "s7-" S7_VERSION);
s7_provide(sc, "ratio");
#if WITH_PURE_S7
s7_provide(sc, "pure-s7");
#endif
#if WITH_EXTRA_EXPONENT_MARKERS
s7_provide(sc, "dfls-exponents");
#endif
#if HAVE_OVERFLOW_CHECKS
s7_provide(sc, "overflow-checks");
#endif
#if WITH_SYSTEM_EXTRAS
s7_provide(sc, "system-extras");
#endif
#if WITH_IMMUTABLE_UNQUOTE
s7_provide(sc, "immutable-unquote");
#endif
#if S7_DEBUGGING
s7_provide(sc, "debugging");
#endif
#if HAVE_COMPLEX_NUMBERS
s7_provide(sc, "complex-numbers");
#endif
#if WITH_HISTORY
s7_provide(sc, "history");
#endif
#if WITH_C_LOADER
s7_provide(sc, "dlopen");
#endif
#if (!DISABLE_AUTOLOAD)
s7_provide(sc, "autoload");
#endif
#if S7_ALIGNED
s7_provide(sc, "aligned");
#endif
#ifdef __APPLE__
s7_provide(sc, "osx");
#endif
#ifdef __linux__
s7_provide(sc, "linux");
#endif
#ifdef __OpenBSD__
s7_provide(sc, "openbsd");
#endif
#ifdef __NetBSD__
s7_provide(sc, "netbsd");
#endif
#ifdef __FreeBSD__
s7_provide(sc, "freebsd");
#endif
#if MS_WINDOWS
s7_provide(sc, "windows");
#endif
#ifdef __bfin__
s7_provide(sc, "blackfin");
#endif
#ifdef __ANDROID__
s7_provide(sc, "android");
#endif
#ifdef __MSYS__
s7_provide(sc, "msys2");
#endif
#ifdef __MINGW32__ /* this is also defined in mingw64 */
s7_provide(sc, "mingw");
#endif
#ifdef __CYGWIN__
s7_provide(sc, "cygwin"); /* this is also defined in msys2 */
#endif
#ifdef __hpux
s7_provide(sc, "hpux");
#endif
#if defined(__sun) && defined(__SVR4)
s7_provide(sc, "solaris");
#endif
#if POINTER_32
s7_provide(sc, "32-bit");
#endif
#ifdef __SUNPRO_C
s7_provide(sc, "sunpro_c");
#endif
#if (defined(__clang__))
s7_provide(sc, "clang");
#endif
#if (defined(__GNUC__))
s7_provide(sc, "gcc");
#endif
#ifdef __EMSCRIPTEN__
s7_provide(sc, "emscripten");
#endif
}
static s7_pointer make_real_wrapper(s7_scheme * sc)
{
s7_pointer p;
p = (s7_pointer) calloc(1, sizeof(s7_cell));
add_saved_pointer(sc, p);
full_type(p) = T_REAL | T_UNHEAP | T_MUTABLE | T_IMMUTABLE;
return (p);
}
static s7_pointer make_integer_wrapper(s7_scheme * sc)
{
s7_pointer p;
p = (s7_pointer) calloc(1, sizeof(s7_cell));
add_saved_pointer(sc, p);
full_type(p) = T_INTEGER | T_UNHEAP | T_MUTABLE | T_IMMUTABLE; /* mutable to turn off set_has_number_name */
return (p);
}
static void init_wrappers(s7_scheme * sc)
{
int32_t i;
sc->integer_wrapper1 = make_integer_wrapper(sc);
sc->integer_wrapper2 = make_integer_wrapper(sc);
sc->integer_wrapper3 = make_integer_wrapper(sc);
sc->real_wrapper1 = make_real_wrapper(sc);
sc->real_wrapper2 = make_real_wrapper(sc);
sc->real_wrapper3 = make_real_wrapper(sc);
sc->real_wrapper4 = make_real_wrapper(sc);
sc->string_wrappers =
(s7_pointer *) malloc(NUM_STRING_WRAPPERS * sizeof(s7_pointer));
add_saved_pointer(sc, sc->string_wrappers);
sc->string_wrapper_pos = 0;
for (i = 0; i < NUM_STRING_WRAPPERS; i++) {
s7_pointer p;
p = (s7_pointer) calloc(1, sizeof(s7_cell));
add_saved_pointer(sc, p);
sc->string_wrappers[i] = p;
full_type(p) =
T_STRING | T_IMMUTABLE | T_SAFE_PROCEDURE | T_UNHEAP;
string_block(p) = NULL;
string_value(p) = NULL;
string_length(p) = 0;
string_hash(p) = 0;
}
}
static s7_pointer 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;
uint64_t hash;
uint32_t loc;
hash = raw_string_hash((const uint8_t *) name, safe_strlen(name));
loc = hash % SYMBOL_TABLE_SIZE;
x = new_symbol(sc, name, safe_strlen(name), hash, loc);
syn = alloc_pointer(sc);
set_full_type(syn,
T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_GLOBAL |
T_UNHEAP);
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) = doc;
set_global_slot(x, make_permanent_slot(sc, x, syn));
set_initial_slot(x, make_permanent_slot(sc, x, syn)); /* set_local_slot(x, global_slot(x)); */
set_type_bit(x, T_SYMBOL | T_SYNTACTIC | T_GLOBAL | T_UNHEAP);
symbol_set_local_slot_unchecked(x, 0LL, sc->nil);
symbol_clear_ctr(x);
return (x);
}
static s7_pointer definer_syntax(s7_scheme * sc, const char *name,
opcode_t op, s7_pointer min_args,
s7_pointer max_args, const char *doc)
{
s7_pointer x;
x = syntax(sc, name, op, min_args, max_args, doc);
set_syntax_is_definer(x);
return (x);
}
static s7_pointer binder_syntax(s7_scheme * sc, const char *name,
opcode_t op, s7_pointer min_args,
s7_pointer max_args, const char *doc)
{
s7_pointer x;
x = syntax(sc, name, op, min_args, max_args, doc);
set_syntax_is_binder(x);
return (x);
}
static s7_pointer copy_args_syntax(s7_scheme * sc, const char *name,
opcode_t op, s7_pointer min_args,
s7_pointer max_args, const char *doc)
{
s7_pointer x, p;
x = syntax(sc, name, op, min_args, max_args, doc);
p = global_value(x);
full_type(p) |= T_COPY_ARGS; /* (for-each and ''2) -- maybe this is a mistake? (currently segfault if not copied) */
return (x);
}
static s7_pointer make_unique(s7_scheme * sc, const char *name,
uint64_t typ)
{
s7_pointer p;
p = alloc_pointer(sc);
set_full_type(p, typ | T_IMMUTABLE | T_UNHEAP);
set_optimize_op(p, OP_CON);
if (typ == T_UNDEFINED) { /* sc->undefined here to avoid the undefined_constant_warning */
undefined_set_name_length(p, safe_strlen(name));
undefined_name(p) =
copy_string_with_length(name, undefined_name_length(p));
} else {
unique_name_length(p) = safe_strlen(name);
unique_name(p) =
copy_string_with_length(name, unique_name_length(p));
add_saved_pointer(sc, (void *) unique_name(p));
}
return (p);
}
static void init_setters(s7_scheme * sc)
{
sc->vector_set_function = global_value(sc->vector_set_symbol);
set_is_setter(sc->vector_set_symbol);
/* not float-vector-set! here */
sc->list_set_function = global_value(sc->list_set_symbol);
set_is_setter(sc->list_set_symbol);
sc->hash_table_set_function = global_value(sc->hash_table_set_symbol);
set_is_setter(sc->hash_table_set_symbol);
sc->let_set_function = global_value(sc->let_set_symbol);
set_is_setter(sc->let_set_symbol);
sc->string_set_function = global_value(sc->string_set_symbol);
set_is_setter(sc->string_set_symbol);
set_is_setter(sc->byte_vector_set_symbol);
set_is_setter(sc->set_car_symbol);
set_is_setter(sc->set_cdr_symbol);
set_is_safe_setter(sc->byte_vector_set_symbol);
set_is_safe_setter(sc->int_vector_set_symbol);
set_is_safe_setter(sc->float_vector_set_symbol);
set_is_safe_setter(sc->string_set_symbol);
#if (WITH_PURE_S7)
/* we need to be able at least to set (current-output-port) to #f */
c_function_set_setter(global_value(sc->current_input_port_symbol),
s7_make_function(sc, "#<set-*stdin*>",
g_set_current_input_port, 1, 0,
false, "*stdin* setter"));
c_function_set_setter(global_value(sc->current_output_port_symbol),
s7_make_function(sc, "#<set-*stdout*>",
g_set_current_output_port, 1, 0,
false, "*stdout* setter"));
#else
set_is_setter(sc->set_current_input_port_symbol);
set_is_setter(sc->set_current_output_port_symbol);
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_is_setter(sc->set_current_error_port_symbol);
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".
*/
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, "byte-vector-ref", "byte-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(global_value(sc->outlet_symbol),
s7_make_function(sc, "#<set-outlet>",
g_set_outlet, 2, 0, false,
"outlet setter"));
c_function_set_setter(global_value(sc->port_line_number_symbol),
s7_make_function(sc, "#<set-port-line-number>",
g_set_port_line_number, 1, 1,
false, "port line setter"));
c_function_set_setter(global_value(sc->port_position_symbol),
s7_make_function(sc, "#<set-port-position>",
g_set_port_position, 2, 0,
false, "port position setter"));
}
static void init_syntax(s7_scheme * sc)
{
#define H_quote "(quote obj) returns obj unevaluated. 'obj is an abbreviation for (quote obj)."
#define H_if "(if expr true-stuff optional-false-stuff) evaluates expr, then if it is true, evaluates true-stuff; otherwise, \
if optional-false-stuff exists, it is evaluated."
#define H_when "(when expr ...) evaluates expr, and if it is true, evaluates each form in its body, returning the value of the last"
#define H_unless "(unless expr ...) evaluates expr, and if it is false, evaluates each form in its body, returning the value of the last"
#define H_begin "(begin ...) evaluates each form in its body, returning the value of the last one"
#define H_set "(set! variable value) sets the value of variable to value."
#define H_let "(let ((var val)...) ...) binds each variable to its initial value, then evaluates its body,\
returning the value of the last form. The let variables are local to it, and \
are not available for use until all have been initialized."
#define H_let_star "(let* ((var val)...) ...) binds each variable to its initial value, then evaluates its body, \
returning the value of the last form. The let* variables are local to it, and are available immediately."
#define H_letrec "(letrec ((var (lambda ...)))...) is like let, but var can refer to itself in its value \
(i.e. you can define local recursive functions)"
#define H_letrec_star "(letrec* ((var val))...) is like letrec, but successive bindings are handled as in let*"
#define H_cond "(cond (expr clause...)...) is like if..then. Each expr is evaluated in order, and if one is not #f, \
the associated clauses are evaluated, whereupon cond returns."
#define H_and "(and expr expr ...) evaluates each of its arguments in order, quitting (and returning #f) \
as soon as one of them returns #f. If all are non-#f, it returns the last value."
#define H_or "(or expr expr ...) evaluates each of its arguments in order, quitting as soon as one of them is not #f. \
If all are #f, or returns #f."
#define H_case "(case val ((key...) clause...)...) looks for val in the various lists of keys, and if a \
match is found (via eqv?), the associated clauses are evaluated, and case returns."
#define H_do "(do (vars...) (loop control and return value) ...) is a do-loop."
#define H_lambda "(lambda args ...) returns a function."
#define H_lambda_star "(lambda* args ...) returns a function; the args list can have default values, \
the parameters themselves can be accessed via keywords."
#define H_define "(define var val) assigns val to the variable (symbol) var. (define (func args) ...) is \
shorthand for (define func (lambda args ...))"
#define H_define_star "(define* (func args) ...) defines a function with optional/keyword arguments."
#define H_define_constant "(define-constant var val) defines var to be a constant (it can't be set or bound), with the value val."
#define H_define_macro "(define-macro (mac args) ...) defines mac to be a macro."
#define H_define_macro_star "(define-macro* (mac args) ...) defines mac to be a macro with optional/keyword arguments."
#define H_macro "(macro args ...) defines an unnamed macro."
#define H_macro_star "(macro* args ...) defines an unnamed macro with optional/keyword arguments."
#define H_define_expansion "(define-expansion (mac args) ...) defines mac to be a read-time macro."
#define H_define_expansion_star "(define-expansion* (mac args) ...) defines mac to be a read-time macro*."
#define H_define_bacro "(define-bacro (mac args) ...) defines mac to be a bacro."
#define H_define_bacro_star "(define-bacro* (mac args) ...) defines mac to be a bacro with optional/keyword arguments."
#define H_bacro "(bacro args ...) defines an unnamed bacro."
#define H_bacro_star "(bacro* args ...) defines an unnamed bacro with optional/keyword arguments."
#define H_with_baffle "(with-baffle ...) evaluates its body in a context that blocks re-entry via call/cc."
#define H_macroexpand "(macroexpand macro-call) returns the result of the expansion phase of evaluating the macro call."
#define H_with_let "(with-let let ...) evaluates its body in the environment let."
#define H_let_temporarily "(let-temporarily ((var value)...) . body) sets each var to its new value, evals body, then returns each var to its original value."
sc->quote_symbol =
syntax(sc, "quote", OP_QUOTE, int_one, int_one, H_quote);
sc->if_symbol = syntax(sc, "if", OP_IF, int_two, int_three, H_if);
sc->when_symbol =
syntax(sc, "when", OP_WHEN, int_two, max_arity, H_when);
sc->unless_symbol =
syntax(sc, "unless", OP_UNLESS, int_two, max_arity, H_unless);
sc->begin_symbol = syntax(sc, "begin", OP_BEGIN, int_zero, max_arity, H_begin); /* (begin) is () */
sc->set_symbol = syntax(sc, "set!", OP_SET, int_two, int_two, H_set);
sc->cond_symbol =
copy_args_syntax(sc, "cond", OP_COND, int_one, max_arity, H_cond);
sc->and_symbol =
copy_args_syntax(sc, "and", OP_AND, int_zero, max_arity, H_and);
sc->or_symbol =
copy_args_syntax(sc, "or", OP_OR, int_zero, max_arity, H_or);
sc->case_symbol =
syntax(sc, "case", OP_CASE, int_two, max_arity, H_case);
sc->macroexpand_symbol =
syntax(sc, "macroexpand", OP_MACROEXPAND, int_one, int_one,
H_macroexpand);
sc->let_temporarily_symbol =
syntax(sc, "let-temporarily", OP_LET_TEMPORARILY, int_two,
max_arity, H_let_temporarily);
sc->define_symbol =
definer_syntax(sc, "define", OP_DEFINE, int_two, max_arity,
H_define);
sc->define_star_symbol =
definer_syntax(sc, "define*", OP_DEFINE_STAR, int_two, max_arity,
H_define_star);
sc->define_constant_symbol =
definer_syntax(sc, "define-constant", OP_DEFINE_CONSTANT, int_two,
max_arity, H_define_constant);
sc->define_macro_symbol =
definer_syntax(sc, "define-macro", OP_DEFINE_MACRO, int_two,
max_arity, H_define_macro);
sc->define_macro_star_symbol =
definer_syntax(sc, "define-macro*", OP_DEFINE_MACRO_STAR, int_two,
max_arity, H_define_macro_star);
sc->define_expansion_symbol =
definer_syntax(sc, "define-expansion", OP_DEFINE_EXPANSION,
int_two, max_arity, H_define_expansion);
sc->define_expansion_star_symbol =
definer_syntax(sc, "define-expansion*", OP_DEFINE_EXPANSION_STAR,
int_two, max_arity, H_define_expansion_star);
sc->define_bacro_symbol =
definer_syntax(sc, "define-bacro", OP_DEFINE_BACRO, int_two,
max_arity, H_define_bacro);
sc->define_bacro_star_symbol =
definer_syntax(sc, "define-bacro*", OP_DEFINE_BACRO_STAR, int_two,
max_arity, H_define_bacro_star);
sc->let_symbol =
binder_syntax(sc, "let", OP_LET, int_two, max_arity, H_let);
sc->let_star_symbol =
binder_syntax(sc, "let*", OP_LET_STAR, int_two, max_arity,
H_let_star);
sc->letrec_symbol =
binder_syntax(sc, "letrec", OP_LETREC, int_two, max_arity,
H_letrec);
sc->letrec_star_symbol =
binder_syntax(sc, "letrec*", OP_LETREC_STAR, int_two, max_arity,
H_letrec_star);
sc->do_symbol = binder_syntax(sc, "do", OP_DO, int_two, max_arity, H_do); /* 2 because body can be null */
sc->lambda_symbol =
binder_syntax(sc, "lambda", OP_LAMBDA, int_two, max_arity,
H_lambda);
sc->lambda_star_symbol =
binder_syntax(sc, "lambda*", OP_LAMBDA_STAR, int_two, max_arity,
H_lambda_star);
sc->macro_symbol =
binder_syntax(sc, "macro", OP_MACRO, int_two, max_arity, H_macro);
sc->macro_star_symbol =
binder_syntax(sc, "macro*", OP_MACRO_STAR, int_two, max_arity,
H_macro_star);
sc->bacro_symbol =
binder_syntax(sc, "bacro", OP_BACRO, int_two, max_arity, H_bacro);
sc->bacro_star_symbol =
binder_syntax(sc, "bacro*", OP_BACRO_STAR, int_two, max_arity,
H_bacro_star);
sc->with_let_symbol =
binder_syntax(sc, "with-let", OP_WITH_LET, int_one, max_arity,
H_with_let);
sc->with_baffle_symbol = binder_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */
set_local_slot(sc->with_let_symbol, global_slot(sc->with_let_symbol)); /* for set_locals */
set_immutable(sc->with_let_symbol);
sc->setter_symbol = make_symbol(sc, "setter");
#if WITH_IMMUTABLE_UNQUOTE
/* this code solves the various unquote redefinition troubles
* if "," -> "(unquote...)" in the reader, (let (, (lambda (x) (+ x 1))) ,,,,'1) -> 5
*/
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->body_symbol = make_symbol(sc, "body");
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->unbound_variable_symbol = make_symbol(sc, "unbound-variable");
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->autoload_error_symbol = make_symbol(sc, "autoload-error");
sc->out_of_range_symbol = make_symbol(sc, "out-of-range");
sc->out_of_memory_symbol = make_symbol(sc, "out-of-memory");
sc->no_catch_symbol = make_symbol(sc, "no-catch");
sc->io_error_symbol = make_symbol(sc, "io-error");
sc->missing_method_symbol = make_symbol(sc, "missing-method");
sc->invalid_escape_function_symbol =
make_symbol(sc, "invalid-escape-function");
sc->immutable_error_symbol = make_symbol(sc, "immutable-error");
sc->division_by_zero_symbol = make_symbol(sc, "division-by-zero");
sc->bad_result_symbol = make_symbol(sc, "bad-result");
sc->baffled_symbol = make_symbol(sc, "baffled!");
sc->value_symbol = make_symbol(sc, "value");
sc->type_symbol = make_symbol(sc, "type");
sc->position_symbol = make_symbol(sc, "position");
sc->file_symbol = make_symbol(sc, "file");
sc->line_symbol = make_symbol(sc, "line");
sc->function_symbol = make_symbol(sc, "function");
sc->else_symbol = make_symbol(sc, "else");
s7_make_slot(sc, sc->nil, sc->else_symbol, sc->else_symbol);
slot_set_value(initial_slot(sc->else_symbol), sc->T);
/* if we set #_else to 'else, it can pick up a local else value: (let ((else #f)) (cond (#_else 2)...)) */
sc->key_allow_other_keys_symbol =
s7_make_keyword(sc, "allow-other-keys");
sc->key_rest_symbol = s7_make_keyword(sc, "rest");
sc->key_if_symbol = s7_make_keyword(sc, "if"); /* internal optimizer local-let marker */
sc->key_readable_symbol = s7_make_keyword(sc, "readable");
sc->key_display_symbol = s7_make_keyword(sc, "display");
sc->key_write_symbol = s7_make_keyword(sc, "write");
}
static void init_rootlet(s7_scheme * sc)
{
s7_pointer sym;
init_syntax(sc);
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(sc,
"~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(sc,
"~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(sc,
"~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(sc,
"~A argument, ~S, is out of range (~A)"));
sc->gc_off = false;
#define defun(Scheme_Name, C_Name, Req, Opt, Rst) \
s7_define_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
#define unsafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \
s7_define_unsafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
#define semisafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \
s7_define_semisafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
#define b_defun(Scheme_Name, C_Name, Opt, SymId, Marker, Simple) \
define_bool_function(sc, Scheme_Name, g_ ## C_Name, Opt, H_ ## C_Name, Q_ ## C_Name, SymId, Marker, Simple, b_ ## C_Name ## _setter)
/* we need the sc->is_* symbols first for the procedure signature lists */
sc->is_boolean_symbol = make_symbol(sc, "boolean?");
sc->pl_bt = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->T);
sc->is_symbol_symbol =
b_defun("symbol?", is_symbol, 0, T_SYMBOL, mark_symbol_vector,
true);
sc->is_syntax_symbol =
b_defun("syntax?", is_syntax, 0, T_SYNTAX, just_mark_vector, true);
sc->is_gensym_symbol =
b_defun("gensym?", is_gensym, 0, T_FREE, mark_symbol_vector, true);
sc->is_keyword_symbol =
b_defun("keyword?", is_keyword, 0, T_FREE, just_mark_vector, true);
sc->is_let_symbol =
b_defun("let?", is_let, 0, T_LET, mark_vector_1, false);
sc->is_openlet_symbol =
b_defun("openlet?", is_openlet, 0, T_FREE, mark_vector_1, false);
sc->is_iterator_symbol =
b_defun("iterator?", is_iterator, 0, T_ITERATOR, mark_vector_1,
false);
sc->is_macro_symbol =
b_defun("macro?", is_macro, 0, T_FREE, mark_vector_1, false);
sc->is_c_pointer_symbol =
b_defun("c-pointer?", is_c_pointer, 1, T_C_POINTER, mark_vector_1,
false);
sc->is_input_port_symbol =
b_defun("input-port?", is_input_port, 0, T_INPUT_PORT,
mark_vector_1, true);
sc->is_output_port_symbol =
b_defun("output-port?", is_output_port, 0, T_OUTPUT_PORT,
mark_simple_vector, true);
sc->is_eof_object_symbol =
b_defun("eof-object?", is_eof_object, 0, T_EOF, just_mark_vector,
true);
sc->is_integer_symbol =
b_defun("integer?", is_integer, 0, (WITH_GMP) ? T_FREE : T_INTEGER,
mark_simple_vector, true);
sc->is_byte_symbol =
b_defun("byte?", is_byte, 0, T_FREE, mark_simple_vector, true);
sc->is_number_symbol =
b_defun("number?", is_number, 0, T_FREE, mark_simple_vector, true);
sc->is_real_symbol =
b_defun("real?", is_real, 0, T_FREE, mark_simple_vector, true);
sc->is_float_symbol =
b_defun("float?", is_float, 0, T_FREE, mark_simple_vector, true);
sc->is_complex_symbol =
b_defun("complex?", is_complex, 0, T_FREE, mark_simple_vector,
true);
sc->is_rational_symbol =
b_defun("rational?", is_rational, 0, T_FREE, mark_simple_vector,
true);
sc->is_random_state_symbol =
b_defun("random-state?", is_random_state, 0, T_RANDOM_STATE,
mark_simple_vector, true);
sc->is_char_symbol =
b_defun("char?", is_char, 0, T_CHARACTER, just_mark_vector, true);
sc->is_string_symbol =
b_defun("string?", is_string, 0, T_STRING, mark_simple_vector,
true);
sc->is_list_symbol =
b_defun("list?", is_list, 0, T_FREE, mark_vector_1, false);
sc->is_pair_symbol =
b_defun("pair?", is_pair, 0, T_PAIR, mark_vector_1, false);
sc->is_vector_symbol =
b_defun("vector?", is_vector, 0, T_FREE, mark_vector_1, false);
sc->is_float_vector_symbol =
b_defun("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR,
mark_simple_vector, true);
sc->is_int_vector_symbol =
b_defun("int-vector?", is_int_vector, 0, T_INT_VECTOR,
mark_simple_vector, true);
sc->is_byte_vector_symbol =
b_defun("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR,
mark_simple_vector, true);
sc->is_hash_table_symbol =
b_defun("hash-table?", is_hash_table, 0, T_HASH_TABLE,
mark_vector_1, false);
sc->is_continuation_symbol =
b_defun("continuation?", is_continuation, 0, T_CONTINUATION,
mark_vector_1, false);
sc->is_procedure_symbol =
b_defun("procedure?", is_procedure, 0, T_FREE, mark_vector_1,
false);
sc->is_dilambda_symbol =
b_defun("dilambda?", is_dilambda, 0, T_FREE, mark_vector_1, false);
/* set above */ b_defun("boolean?", is_boolean, 0, T_BOOLEAN,
just_mark_vector, true);
sc->is_proper_list_symbol =
b_defun("proper-list?", is_proper_list, 0, T_FREE, mark_vector_1,
false);
sc->is_sequence_symbol =
b_defun("sequence?", is_sequence, 0, T_FREE, mark_vector_1, false);
sc->is_null_symbol =
b_defun("null?", is_null, 0, T_NIL, just_mark_vector, true);
sc->is_undefined_symbol =
b_defun("undefined?", is_undefined, 0, T_UNDEFINED,
just_mark_vector, true);
sc->is_unspecified_symbol =
b_defun("unspecified?", is_unspecified, 0, T_UNSPECIFIED,
just_mark_vector, true);
sc->is_c_object_symbol =
b_defun("c-object?", is_c_object, 0, T_C_OBJECT, mark_vector_1,
false);
sc->is_subvector_symbol =
b_defun("subvector?", is_subvector, 0, T_FREE, mark_vector_1,
false);
sc->is_weak_hash_table_symbol =
b_defun("weak-hash-table?", is_weak_hash_table, 0, T_FREE,
mark_vector_1, false);
sc->is_goto_symbol =
b_defun("goto?", is_goto, 0, T_GOTO, mark_vector_1, true);
/* these are for signatures */
sc->not_symbol = defun("not", not, 1, 0, false);
sc->is_integer_or_real_at_end_symbol =
make_symbol(sc, "integer:real?");
sc->is_integer_or_any_at_end_symbol = make_symbol(sc, "integer:any?");
sc->pl_p = s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol);
sc->pl_tl = s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */
sc->pl_bc =
s7_make_signature(sc, 2, sc->is_boolean_symbol,
sc->is_char_symbol);
sc->pl_bn =
s7_make_signature(sc, 2, sc->is_boolean_symbol,
sc->is_number_symbol);
sc->pl_nn =
s7_make_signature(sc, 2, sc->is_number_symbol,
sc->is_number_symbol);
sc->pl_sf =
s7_make_signature(sc, 3, sc->T, sc->is_string_symbol,
s7_make_signature(sc, 2, sc->is_procedure_symbol,
sc->is_macro_symbol));
sc->pcl_bt =
s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->T);
sc->pcl_bc =
s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol,
sc->is_char_symbol);
sc->pcl_bs =
s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol,
sc->is_string_symbol);
sc->pcl_i =
s7_make_circular_signature(sc, 0, 1, sc->is_integer_symbol);
sc->pcl_r = s7_make_circular_signature(sc, 0, 1, sc->is_real_symbol);
sc->pcl_f =
s7_make_circular_signature(sc, 0, 1, sc->is_rational_symbol);
sc->pcl_n = s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol);
sc->pcl_s = s7_make_circular_signature(sc, 0, 1, sc->is_string_symbol);
sc->pcl_v = s7_make_circular_signature(sc, 0, 1, sc->is_vector_symbol);
sc->pcl_c = s7_make_circular_signature(sc, 0, 1, sc->is_char_symbol);
sc->pcl_e =
s7_make_circular_signature(sc, 0, 1,
s7_make_signature(sc, 4,
sc->is_let_symbol,
sc->is_procedure_symbol,
sc->is_macro_symbol,
sc->is_c_object_symbol));
sc->values_symbol = make_symbol(sc, "values");
sc->is_bignum_symbol = defun("bignum?", is_bignum, 1, 0, false);
sc->bignum_symbol = defun("bignum", bignum, 1, 1, false);
sc->gensym_symbol = defun("gensym", gensym, 0, 1, false);
sc->symbol_table_symbol =
defun("symbol-table", symbol_table, 0, 0, false);
sc->symbol_to_string_symbol =
defun("symbol->string", symbol_to_string, 1, 0, false);
sc->string_to_symbol_symbol =
defun("string->symbol", string_to_symbol, 1, 0, false);
sc->symbol_symbol = defun("symbol", symbol, 1, 0, true);
sc->symbol_to_value_symbol =
defun("symbol->value", symbol_to_value, 1, 1, false);
sc->symbol_to_dynamic_value_symbol =
defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0,
false);
sc->immutable_symbol = defun("immutable!", immutable, 1, 0, false);
sc->is_immutable_symbol =
defun("immutable?", is_immutable, 1, 0, false);
sc->is_constant_symbol = defun("constant?", is_constant, 1, 0, false);
sc->string_to_keyword_symbol =
defun("string->keyword", string_to_keyword, 1, 0, false);
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);
set_func_is_definer(sc->curlet_symbol);
sc->unlet_symbol = defun("unlet", unlet, 0, 0, false);
set_local_slot(sc->unlet_symbol, global_slot(sc->unlet_symbol)); /* for set_locals */
set_immutable(sc->unlet_symbol);
/* unlet (and with-let) don't actually need to be immutable, but s7.html says they are... */
sc->is_funclet_symbol = defun("funclet?", is_funclet, 1, 0, false);
sc->sublet_symbol = defun("sublet", sublet, 1, 0, true);
sc->varlet_symbol = semisafe_defun("varlet", varlet, 1, 0, true);
set_func_is_definer(sc->varlet_symbol);
sc->cutlet_symbol = semisafe_defun("cutlet", cutlet, 1, 0, true);
set_func_is_definer(sc->cutlet_symbol);
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);
set_immutable(sc->let_ref_symbol); /* 16-Sep-19 */
sc->let_set_symbol = defun("let-set!", let_set, 3, 0, false);
set_immutable(sc->let_set_symbol);
sc->let_ref_fallback_symbol = make_symbol(sc, "let-ref-fallback");
sc->let_set_fallback_symbol = make_symbol(sc, "let-set-fallback"); /* was let-set!-fallback until 9-Oct-17 */
sc->make_iterator_symbol =
defun("make-iterator", make_iterator, 1, 1, false);
sc->iterate_symbol = defun("iterate", iterate, 1, 0, false);
sc->iterator_sequence_symbol =
defun("iterator-sequence", iterator_sequence, 1, 0, false);
sc->iterator_is_at_end_symbol =
defun("iterator-at-end?", iterator_is_at_end, 1, 0, false);
sc->is_provided_symbol = defun("provided?", is_provided, 1, 0, false);
sc->provide_symbol = semisafe_defun("provide", provide, 1, 0, false); /* can add *features* to curlet */
set_func_is_definer(sc->provide_symbol);
sc->is_defined_symbol = defun("defined?", is_defined, 1, 2, false);
sc->c_object_type_symbol =
defun("c-object-type", c_object_type, 1, 0, false);
sc->c_pointer_symbol = defun("c-pointer", c_pointer, 1, 4, false);
sc->c_pointer_info_symbol =
defun("c-pointer-info", c_pointer_info, 1, 0, false);
sc->c_pointer_type_symbol =
defun("c-pointer-type", c_pointer_type, 1, 0, false);
sc->c_pointer_weak1_symbol =
defun("c-pointer-weak1", c_pointer_weak1, 1, 0, false);
sc->c_pointer_weak2_symbol =
defun("c-pointer-weak2", c_pointer_weak2, 1, 0, false);
sc->c_pointer_to_list_symbol =
defun("c-pointer->list", c_pointer_to_list, 1, 0, false);
sc->port_file_symbol = defun("port-file", port_file, 1, 0, false);
sc->port_position_symbol =
defun("port-position", port_position, 1, 0, false);
sc->port_line_number_symbol =
defun("port-line-number", port_line_number, 0, 1, false);
sc->port_filename_symbol =
defun("port-filename", port_filename, 0, 1, false);
sc->pair_line_number_symbol =
defun("pair-line-number", pair_line_number, 1, 0, false);
sc->pair_filename_symbol =
defun("pair-filename", pair_filename, 1, 0, false);
sc->is_port_closed_symbol =
defun("port-closed?", is_port_closed, 1, 0, false);
sc->current_input_port_symbol =
defun("current-input-port", current_input_port, 0, 0, false);
sc->current_output_port_symbol =
defun("current-output-port", current_output_port, 0, 0, false);
sc->current_error_port_symbol =
defun("current-error-port", current_error_port, 0, 0, false);
sc->set_current_error_port_symbol =
defun("set-current-error-port", set_current_error_port, 1, 0,
false);
#if (!WITH_PURE_S7)
sc->let_to_list_symbol = defun("let->list", let_to_list, 1, 0, false);
sc->set_current_input_port_symbol =
defun("set-current-input-port", set_current_input_port, 1, 0,
false);
sc->set_current_output_port_symbol =
defun("set-current-output-port", set_current_output_port, 1, 0,
false);
sc->is_char_ready_symbol = defun("char-ready?", is_char_ready, 0, 1, false); /* the least-used scheme function */
#endif
sc->close_input_port_symbol =
defun("close-input-port", close_input_port, 1, 0, false);
sc->close_output_port_symbol =
defun("close-output-port", close_output_port, 1, 0, false);
sc->flush_output_port_symbol =
defun("flush-output-port", flush_output_port, 0, 1, false);
sc->open_input_file_symbol =
defun("open-input-file", open_input_file, 1, 1, false);
sc->open_output_file_symbol =
defun("open-output-file", open_output_file, 1, 1, false);
sc->open_input_string_symbol =
defun("open-input-string", open_input_string, 1, 0, false);
sc->open_output_string_symbol =
defun("open-output-string", open_output_string, 0, 0, false);
sc->get_output_string_symbol =
defun("get-output-string", get_output_string, 1, 1, false);
sc->get_output_string_uncopied =
s7_make_function(sc, "get-output-string",
g_get_output_string_uncopied, 1, 1, false, NULL);
sc->open_input_function_symbol =
defun("open-input-function", open_input_function, 1, 0, false);
sc->open_output_function_symbol =
defun("open-output-function", open_output_function, 1, 0, false);
sc->closed_input_function =
s7_make_function(sc, "closed-input-function",
g_closed_input_function_port, 2, 0, false,
"input-function error"),
sc->closed_output_function =
s7_make_function(sc, "closed-output-function",
g_closed_output_function_port, 1, 0, false,
"output-function error"), sc->newline_symbol =
defun("newline", newline, 0, 1, false);
sc->write_symbol = defun("write", write, 1, 1, false);
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 = semisafe_defun("read", read, 0, 1, false);
/* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence
* (not embedded in OP_SAFE_C_opSq for example) -- that is, it pushes OP_READ_INTERNAL, then returns
* expecting continue (goto top-of-eval-loop), which would be nonsense if arg=fn|x_proc(read) -> fn|x_proc(arg).
* a safe procedure leaves its argument list alone, does not push anything on the stack,
* and leaves sc->code|args unscathed (fx_call assumes that is the case). The stack part can
* be hidden: if a c_function calls s7_apply_function (lambda passed as arg as in some clm gens)
* then is called with args that use fx*, and the lambda func does the same, the two calls
* can step on each other.
*/
sc->call_with_input_string_symbol = semisafe_defun("call-with-input-string", call_with_input_string, 2, 0, false); /* body unsafe if func=read */
sc->call_with_input_file_symbol =
semisafe_defun("call-with-input-file", call_with_input_file, 2, 0,
false);
sc->with_input_from_string_symbol =
semisafe_defun("with-input-from-string", with_input_from_string, 2,
0, false);
sc->with_input_from_file_symbol =
semisafe_defun("with-input-from-file", with_input_from_file, 2, 0,
false);
sc->call_with_output_string_symbol =
semisafe_defun("call-with-output-string", call_with_output_string,
1, 0, false);
sc->call_with_output_file_symbol =
semisafe_defun("call-with-output-file", call_with_output_file, 2,
0, false);
sc->with_output_to_string_symbol =
semisafe_defun("with-output-to-string", with_output_to_string, 1,
0, false);
sc->with_output_to_file_symbol =
semisafe_defun("with-output-to-file", with_output_to_file, 2, 0,
false);
#if WITH_SYSTEM_EXTRAS
sc->is_directory_symbol =
defun("directory?", is_directory, 1, 0, false);
sc->file_exists_symbol =
defun("file-exists?", file_exists, 1, 0, false);
sc->delete_file_symbol =
defun("delete-file", delete_file, 1, 0, false);
sc->getenv_symbol = defun("getenv", getenv, 1, 0, false);
sc->system_symbol = defun("system", system, 1, 1, false);
#if (!MS_WINDOWS)
sc->directory_to_list_symbol =
defun("directory->list", directory_to_list, 1, 0, false);
sc->file_mtime_symbol = defun("file-mtime", file_mtime, 1, 0, false);
#endif
#endif
sc->real_part_symbol = defun("real-part", real_part, 1, 0, false);
sc->imag_part_symbol = defun("imag-part", imag_part, 1, 0, false);
sc->numerator_symbol = defun("numerator", numerator, 1, 0, false);
sc->denominator_symbol =
defun("denominator", denominator, 1, 0, false);
sc->is_even_symbol = defun("even?", is_even, 1, 0, false);
sc->is_odd_symbol = defun("odd?", is_odd, 1, 0, false);
sc->is_zero_symbol = defun("zero?", is_zero, 1, 0, false);
sc->is_positive_symbol = defun("positive?", is_positive, 1, 0, false);
sc->is_negative_symbol = defun("negative?", is_negative, 1, 0, false);
sc->is_infinite_symbol = defun("infinite?", is_infinite, 1, 0, false);
sc->is_nan_symbol = defun("nan?", is_nan, 1, 0, false);
sc->complex_symbol = defun("complex", complex, 2, 0, false);
sc->add_symbol = defun("+", add, 0, 0, true);
set_all_integer_and_float(sc->add_symbol);
sc->subtract_symbol = defun("-", subtract, 1, 0, true);
set_all_integer_and_float(sc->subtract_symbol);
sc->multiply_symbol = defun("*", multiply, 0, 0, true);
set_all_integer_and_float(sc->multiply_symbol);
sc->divide_symbol = defun("/", divide, 1, 0, true);
set_all_float(sc->divide_symbol);
sc->min_symbol = defun("min", min, 1, 0, true);
set_all_integer_and_float(sc->min_symbol);
sc->max_symbol = defun("max", max, 1, 0, true);
set_all_integer_and_float(sc->max_symbol);
sc->quotient_symbol = defun("quotient", quotient, 2, 0, false);
set_all_integer(sc->quotient_symbol);
sc->remainder_symbol = defun("remainder", remainder, 2, 0, false);
set_all_integer(sc->remainder_symbol);
sc->modulo_symbol = defun("modulo", modulo, 2, 0, false);
set_all_integer(sc->modulo_symbol);
sc->num_eq_symbol = defun("=", num_eq, 2, 0, true);
sc->lt_symbol = defun("<", less, 2, 0, true);
sc->gt_symbol = defun(">", greater, 2, 0, true);
sc->leq_symbol = defun("<=", less_or_equal, 2, 0, true);
sc->geq_symbol = defun(">=", greater_or_equal, 2, 0, true);
sc->gcd_symbol = defun("gcd", gcd, 0, 0, true);
sc->lcm_symbol = defun("lcm", lcm, 0, 0, true);
sc->rationalize_symbol =
defun("rationalize", rationalize, 1, 1, false);
sc->random_symbol = defun("random", random, 1, 1, false);
set_all_integer_and_float(sc->random_symbol);
sc->random_state_symbol =
defun("random-state", random_state, 1, 1, false);
sc->expt_symbol = defun("expt", expt, 2, 0, false);
sc->log_symbol = defun("log", log, 1, 1, false);
sc->ash_symbol = defun("ash", ash, 2, 0, false);
sc->exp_symbol = defun("exp", exp, 1, 0, false);
set_all_float(sc->exp_symbol);
sc->abs_symbol = defun("abs", abs, 1, 0, false);
set_all_integer_and_float(sc->abs_symbol);
sc->magnitude_symbol = defun("magnitude", magnitude, 1, 0, false);
set_all_integer_and_float(sc->magnitude_symbol);
sc->angle_symbol = defun("angle", angle, 1, 0, false);
sc->sin_symbol = defun("sin", sin, 1, 0, false);
set_all_float(sc->sin_symbol);
sc->cos_symbol = defun("cos", cos, 1, 0, false);
set_all_float(sc->cos_symbol);
sc->tan_symbol = defun("tan", tan, 1, 0, false);
set_all_float(sc->tan_symbol);
sc->sinh_symbol = defun("sinh", sinh, 1, 0, false);
set_all_float(sc->sinh_symbol);
sc->cosh_symbol = defun("cosh", cosh, 1, 0, false);
set_all_float(sc->cosh_symbol);
sc->tanh_symbol = defun("tanh", tanh, 1, 0, false);
set_all_float(sc->tanh_symbol);
sc->asin_symbol = defun("asin", asin, 1, 0, false);
sc->acos_symbol = defun("acos", acos, 1, 0, false);
sc->atan_symbol = defun("atan", atan, 1, 1, false);
sc->asinh_symbol = defun("asinh", asinh, 1, 0, false);
sc->acosh_symbol = defun("acosh", acosh, 1, 0, false);
sc->atanh_symbol = defun("atanh", atanh, 1, 0, false);
sc->sqrt_symbol = defun("sqrt", sqrt, 1, 0, false);
sc->floor_symbol = defun("floor", floor, 1, 0, false);
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->logand_symbol = defun("logand", logand, 0, 0, true);
sc->logior_symbol = defun("logior", logior, 0, 0, true);
sc->logxor_symbol = defun("logxor", logxor, 0, 0, true);
sc->lognot_symbol = defun("lognot", lognot, 1, 0, false);
sc->logbit_symbol = defun("logbit?", logbit, 2, 0, false);
sc->integer_decode_float_symbol =
defun("integer-decode-float", integer_decode_float, 1, 0, false);
#if (!WITH_PURE_S7)
sc->integer_length_symbol =
defun("integer-length", integer_length, 1, 0, false);
sc->inexact_to_exact_symbol =
defun("inexact->exact", inexact_to_exact, 1, 0, false);
sc->exact_to_inexact_symbol =
defun("exact->inexact", exact_to_inexact, 1, 0, false);
sc->is_exact_symbol = defun("exact?", is_exact, 1, 0, false);
sc->is_inexact_symbol = defun("inexact?", is_inexact, 1, 0, false);
#endif
sc->random_state_to_list_symbol =
defun("random-state->list", random_state_to_list, 0, 1, false);
sc->number_to_string_symbol =
defun("number->string", number_to_string, 1, 1, false);
sc->string_to_number_symbol =
defun("string->number", string_to_number, 1, 1, false);
sc->char_upcase_symbol =
defun("char-upcase", char_upcase, 1, 0, false);
sc->char_downcase_symbol =
defun("char-downcase", char_downcase, 1, 0, false);
sc->char_to_integer_symbol =
defun("char->integer", char_to_integer, 1, 0, false);
sc->integer_to_char_symbol =
defun("integer->char", integer_to_char, 1, 0, false);
sc->is_char_upper_case_symbol =
defun("char-upper-case?", is_char_upper_case, 1, 0, false);
sc->is_char_lower_case_symbol =
defun("char-lower-case?", is_char_lower_case, 1, 0, false);
sc->is_char_alphabetic_symbol =
defun("char-alphabetic?", is_char_alphabetic, 1, 0, false);
sc->is_char_numeric_symbol =
defun("char-numeric?", is_char_numeric, 1, 0, false);
sc->is_char_whitespace_symbol =
defun("char-whitespace?", is_char_whitespace, 1, 0, false);
sc->char_eq_symbol = defun("char=?", chars_are_equal, 2, 0, true);
sc->char_lt_symbol = defun("char<?", chars_are_less, 2, 0, true);
sc->char_gt_symbol = defun("char>?", chars_are_greater, 2, 0, true);
sc->char_leq_symbol = defun("char<=?", chars_are_leq, 2, 0, true);
sc->char_geq_symbol = defun("char>=?", chars_are_geq, 2, 0, true);
sc->char_position_symbol =
defun("char-position", char_position, 2, 1, false);
sc->string_position_symbol =
defun("string-position", string_position, 2, 1, false);
sc->make_string_symbol =
defun("make-string", make_string, 1, 1, false);
sc->string_ref_symbol = defun("string-ref", string_ref, 2, 0, false);
sc->string_set_symbol = defun("string-set!", string_set, 3, 0, false);
sc->string_eq_symbol =
defun("string=?", strings_are_equal, 2, 0, true);
sc->string_lt_symbol = defun("string<?", strings_are_less, 2, 0, true);
sc->string_gt_symbol =
defun("string>?", strings_are_greater, 2, 0, true);
sc->string_leq_symbol =
defun("string<=?", strings_are_leq, 2, 0, true);
sc->string_geq_symbol =
defun("string>=?", strings_are_geq, 2, 0, true);
#if (!WITH_PURE_S7)
sc->char_ci_eq_symbol =
defun("char-ci=?", chars_are_ci_equal, 2, 0, true);
sc->char_ci_lt_symbol =
defun("char-ci<?", chars_are_ci_less, 2, 0, true);
sc->char_ci_gt_symbol =
defun("char-ci>?", chars_are_ci_greater, 2, 0, true);
sc->char_ci_leq_symbol =
defun("char-ci<=?", chars_are_ci_leq, 2, 0, true);
sc->char_ci_geq_symbol =
defun("char-ci>=?", chars_are_ci_geq, 2, 0, true);
sc->string_ci_eq_symbol =
defun("string-ci=?", strings_are_ci_equal, 2, 0, true);
sc->string_ci_lt_symbol =
defun("string-ci<?", strings_are_ci_less, 2, 0, true);
sc->string_ci_gt_symbol =
defun("string-ci>?", strings_are_ci_greater, 2, 0, true);
sc->string_ci_leq_symbol =
defun("string-ci<=?", strings_are_ci_leq, 2, 0, true);
sc->string_ci_geq_symbol =
defun("string-ci>=?", strings_are_ci_geq, 2, 0, true);
sc->string_fill_symbol =
defun("string-fill!", string_fill, 2, 2, false);
sc->list_to_string_symbol =
defun("list->string", list_to_string, 1, 0, false);
sc->string_length_symbol =
defun("string-length", string_length, 1, 0, false);
sc->string_to_list_symbol =
defun("string->list", string_to_list, 1, 2, false);
#endif
sc->string_copy_symbol =
defun("string-copy", string_copy, 1, 3, false);
sc->string_downcase_symbol =
defun("string-downcase", string_downcase, 1, 0, false);
sc->string_upcase_symbol =
defun("string-upcase", string_upcase, 1, 0, false);
sc->string_append_symbol =
defun("string-append", string_append, 0, 0, true);
sc->substring_symbol = defun("substring", substring, 2, 1, false);
sc->string_symbol = defun("string", string, 0, 0, true);
sc->object_to_string_symbol =
defun("object->string", object_to_string, 1, 2, false);
sc->format_symbol = defun("format", format, 2, 0, true);
sc->object_to_let_symbol =
defun("object->let", object_to_let, 1, 0, false);
sc->cons_symbol = defun("cons", cons, 2, 0, false);
sc->car_symbol = defun("car", car, 1, 0, false);
sc->cdr_symbol = defun("cdr", cdr, 1, 0, false);
sc->set_car_symbol = defun("set-car!", set_car, 2, 0, false);
sc->set_cdr_symbol = defun("set-cdr!", set_cdr, 2, 0, false);
sc->caar_symbol = defun("caar", caar, 1, 0, false);
sc->cadr_symbol = defun("cadr", cadr, 1, 0, false);
sc->cdar_symbol = defun("cdar", cdar, 1, 0, false);
sc->cddr_symbol = defun("cddr", cddr, 1, 0, false);
sc->caaar_symbol = defun("caaar", caaar, 1, 0, false);
sc->caadr_symbol = defun("caadr", caadr, 1, 0, false);
sc->cadar_symbol = defun("cadar", cadar, 1, 0, false);
sc->cdaar_symbol = defun("cdaar", cdaar, 1, 0, false);
sc->caddr_symbol = defun("caddr", caddr, 1, 0, false);
sc->cdddr_symbol = defun("cdddr", cdddr, 1, 0, false);
sc->cdadr_symbol = defun("cdadr", cdadr, 1, 0, false);
sc->cddar_symbol = defun("cddar", cddar, 1, 0, false);
sc->caaaar_symbol = defun("caaaar", caaaar, 1, 0, false);
sc->caaadr_symbol = defun("caaadr", caaadr, 1, 0, false);
sc->caadar_symbol = defun("caadar", caadar, 1, 0, false);
sc->cadaar_symbol = defun("cadaar", cadaar, 1, 0, false);
sc->caaddr_symbol = defun("caaddr", caaddr, 1, 0, false);
sc->cadddr_symbol = defun("cadddr", cadddr, 1, 0, false);
sc->cadadr_symbol = defun("cadadr", cadadr, 1, 0, false);
sc->caddar_symbol = defun("caddar", caddar, 1, 0, false);
sc->cdaaar_symbol = defun("cdaaar", cdaaar, 1, 0, false);
sc->cdaadr_symbol = defun("cdaadr", cdaadr, 1, 0, false);
sc->cdadar_symbol = defun("cdadar", cdadar, 1, 0, false);
sc->cddaar_symbol = defun("cddaar", cddaar, 1, 0, false);
sc->cdaddr_symbol = defun("cdaddr", cdaddr, 1, 0, false);
sc->cddddr_symbol = defun("cddddr", cddddr, 1, 0, false);
sc->cddadr_symbol = defun("cddadr", cddadr, 1, 0, false);
sc->cdddar_symbol = defun("cdddar", cdddar, 1, 0, false);
sc->assq_symbol = defun("assq", assq, 2, 0, false);
sc->assv_symbol = defun("assv", assv, 2, 0, false);
sc->assoc_symbol = semisafe_defun("assoc", assoc, 2, 1, false);
sc->memq_symbol = defun("memq", memq, 2, 0, false);
sc->memv_symbol = defun("memv", memv, 2, 0, false);
sc->member_symbol = semisafe_defun("member", member, 2, 1, false);
sc->list_symbol = defun("list", list, 0, 0, true);
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);
/* set_is_definer(sc->copy_symbol); *//* (copy (inlet 'a 1) (curlet)), but this check needs to be smarter */
sc->fill_symbol = defun("fill!", fill, 2, 2, false);
sc->reverse_symbol = defun("reverse", reverse, 1, 0, false);
sc->reverseb_symbol = defun("reverse!", reverse_in_place, 1, 0, false);
sc->sort_symbol = unsafe_defun("sort!", sort, 2, 0, false); /* not semisafe! */
sc->append_symbol = defun("append", append, 0, 0, true);
#if (!WITH_PURE_S7)
sc->vector_append_symbol =
defun("vector-append", vector_append, 0, 0, true);
sc->list_to_vector_symbol =
defun("list->vector", list_to_vector, 1, 0, false);
sc->vector_fill_symbol =
defun("vector-fill!", vector_fill, 2, 2, false);
sc->vector_length_symbol =
defun("vector-length", vector_length, 1, 0, false);
sc->vector_to_list_symbol =
defun("vector->list", vector_to_list, 1, 2, false);
#else
sc->vector_append_symbol = sc->append_symbol;
sc->vector_fill_symbol = sc->fill_symbol;
sc->string_fill_symbol = sc->fill_symbol;
#endif
sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true);
sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true);
sc->vector_dimension_symbol =
defun("vector-dimension", vector_dimension, 2, 0, false);
sc->vector_dimensions_symbol =
defun("vector-dimensions", vector_dimensions, 1, 0, false);
sc->vector_rank_symbol =
defun("vector-rank", vector_rank, 1, 0, false);
sc->make_vector_symbol =
defun("make-vector", make_vector, 1, 2, false);
sc->vector_symbol = defun("vector", vector, 0, 0, true);
set_is_setter(sc->vector_symbol); /* like cons, I guess */
sc->subvector_symbol = defun("subvector", subvector, 1, 3, false);
sc->subvector_position_symbol =
defun("subvector-position", subvector_position, 1, 0, false);
sc->subvector_vector_symbol =
defun("subvector-vector", subvector_vector, 1, 0, false);
sc->float_vector_symbol =
defun("float-vector", float_vector, 0, 0, true);
sc->make_float_vector_symbol =
defun("make-float-vector", make_float_vector, 1, 1, false);
sc->float_vector_set_symbol =
defun("float-vector-set!", float_vector_set, 3, 0, true);
sc->float_vector_ref_symbol =
defun("float-vector-ref", float_vector_ref, 2, 0, true);
sc->int_vector_symbol = defun("int-vector", int_vector, 0, 0, true);
sc->make_int_vector_symbol =
defun("make-int-vector", make_int_vector, 1, 1, false);
sc->int_vector_set_symbol =
defun("int-vector-set!", int_vector_set, 3, 0, true);
sc->int_vector_ref_symbol =
defun("int-vector-ref", int_vector_ref, 2, 0, true);
sc->byte_vector_symbol = defun("byte-vector", byte_vector, 0, 0, true);
sc->make_byte_vector_symbol =
defun("make-byte-vector", make_byte_vector, 1, 1, false);
sc->byte_vector_ref_symbol =
defun("byte-vector-ref", byte_vector_ref, 2, 0, true);
sc->byte_vector_set_symbol =
defun("byte-vector-set!", byte_vector_set, 3, 0, true);
sc->string_to_byte_vector_symbol =
defun("string->byte-vector", string_to_byte_vector, 1, 0, false);
sc->byte_vector_to_string_symbol =
defun("byte-vector->string", byte_vector_to_string, 1, 0, false);
sc->hash_table_symbol = defun("hash-table", hash_table, 0, 0, true);
sc->make_hash_table_symbol =
defun("make-hash-table", make_hash_table, 0, 3, false);
sc->make_weak_hash_table_symbol =
defun("make-weak-hash-table", make_weak_hash_table, 0, 3, false);
sc->weak_hash_table_symbol =
defun("weak-hash-table", weak_hash_table, 0, 0, true);
sc->hash_table_ref_symbol =
defun("hash-table-ref", hash_table_ref, 2, 0, true);
sc->hash_table_set_symbol =
defun("hash-table-set!", hash_table_set, 3, 0, false);
sc->hash_table_entries_symbol =
defun("hash-table-entries", hash_table_entries, 1, 0, false);
sc->hash_code_symbol = defun("hash-code", hash_code, 1, 1, false);
sc->dummy_equal_hash_table = make_dummy_hash_table(sc);
sc->cyclic_sequences_symbol =
defun("cyclic-sequences", cyclic_sequences, 1, 0, false);
sc->call_cc_symbol = semisafe_defun("call/cc", call_cc, 1, 0, false); /* was unsafe 8-Feb-21 */
sc->call_with_current_continuation_symbol =
unsafe_defun("call-with-current-continuation", call_cc, 1, 0,
false);
sc->call_with_exit_symbol = semisafe_defun("call-with-exit", call_with_exit, 1, 0, false); /* was unsafe 8-Feb-21 */
sc->load_symbol = semisafe_defun("load", load, 1, 1, false);
sc->autoload_symbol = defun("autoload", autoload, 2, 0, false);
sc->eval_symbol = semisafe_defun("eval", eval, 1, 1, false); /* was unsafe 8-Feb-21, can affect stack */
set_func_is_definer(sc->eval_symbol);
sc->eval_string_symbol =
semisafe_defun("eval-string", eval_string, 1, 1, false);
set_func_is_definer(sc->eval_string_symbol);
sc->apply_symbol = unsafe_defun("apply", apply, 1, 0, true); /* not semisafe (note that type is reset below) */
set_func_is_definer(sc->apply_symbol);
/* yow... (apply (inlet) (f)) in do body where (f) returns '(define...) -- see s7test.scm under apply
* perhaps better: if closure returns a definer in some way set its name as a definer? even this is not fool-proof
*/
sc->for_each_symbol = semisafe_defun("for-each", for_each, 2, 0, true);
sc->map_symbol = semisafe_defun("map", map, 2, 0, true);
sc->dynamic_wind_symbol =
semisafe_defun("dynamic-wind", dynamic_wind, 3, 0, false);
sc->dynamic_unwind_symbol =
semisafe_defun("dynamic-unwind", dynamic_unwind, 2, 0, false);
sc->catch_symbol = semisafe_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);
/* not safe in catch if macro as error handler, (define-macro (m . args) `(apply ,(car args) ',(cadr args))) (catch #t (lambda () (error abs -1)) m) */
sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false);
/* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true);
/* values_symbol set above for signatures, not semisafe! */
sc->apply_values_symbol =
unsafe_defun("apply-values", apply_values, 0, 1, false);
set_immutable(sc->apply_values_symbol);
sc->list_values_symbol = defun("list-values", list_values, 0, 0, true);
set_immutable(sc->list_values_symbol);
sc->documentation_symbol =
defun("documentation", documentation, 1, 0, false);
sc->signature_symbol = defun("signature", signature, 1, 0, false);
sc->help_symbol = defun("help", help, 1, 0, false);
sc->procedure_source_symbol =
defun("procedure-source", procedure_source, 1, 0, false);
sc->funclet_symbol = defun("funclet", funclet, 1, 0, false);
sc->_function__symbol = defun("*function*", function, 0, 2, false);
sc->dilambda_symbol = defun("dilambda", dilambda, 2, 0, false);
s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1,
H_setter, Q_setter, NULL);
sc->arity_symbol = defun("arity", arity, 1, 0, false);
sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false);
sc->is_eq_symbol = defun("eq?", is_eq, 2, 0, false);
sc->is_eqv_symbol = defun("eqv?", is_eqv, 2, 0, false);
sc->is_equal_symbol = defun("equal?", is_equal, 2, 0, false);
sc->is_equivalent_symbol =
defun("equivalent?", is_equivalent, 2, 0, false);
sc->type_of_symbol = defun("type-of", type_of, 1, 0, false);
sc->gc_symbol = semisafe_defun("gc", gc, 0, 1, false);
defun("emergency-exit", emergency_exit, 0, 1, false);
sc->exit_symbol = defun("exit", exit, 0, 1, false);
#if WITH_GCC
s7_define_function(sc, "abort", g_abort, 0, 0, true,
"drop into gdb I hope");
#endif
s7_define_function(sc, "s7-optimize", g_optimize, 1, 0, false,
"short-term debugging aid");
sc->c_object_set_function =
s7_make_function(sc, "#<c-object-setter>", g_c_object_set, 1, 0,
true, "c-object setter");
/* c_function_signature(sc->c_object_set_function) = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T); */
set_scope_safe(global_value(sc->call_with_input_string_symbol));
set_scope_safe(global_value(sc->call_with_input_file_symbol));
set_scope_safe(global_value(sc->call_with_output_string_symbol));
set_scope_safe(global_value(sc->call_with_output_file_symbol));
set_scope_safe(global_value(sc->with_input_from_string_symbol));
set_scope_safe(global_value(sc->with_input_from_file_symbol));
set_scope_safe(global_value(sc->with_output_to_string_symbol));
set_scope_safe(global_value(sc->with_output_to_file_symbol));
set_maybe_safe(global_value(sc->assoc_symbol));
set_scope_safe(global_value(sc->assoc_symbol));
set_maybe_safe(global_value(sc->member_symbol));
set_scope_safe(global_value(sc->member_symbol));
set_scope_safe(global_value(sc->sort_symbol));
set_scope_safe(global_value(sc->call_with_exit_symbol));
set_scope_safe(global_value(sc->for_each_symbol));
set_maybe_safe(global_value(sc->for_each_symbol));
set_scope_safe(global_value(sc->map_symbol));
set_maybe_safe(global_value(sc->map_symbol));
set_scope_safe(global_value(sc->dynamic_wind_symbol));
set_scope_safe(global_value(sc->catch_symbol));
set_scope_safe(global_value(sc->throw_symbol));
set_scope_safe(global_value(sc->error_symbol));
set_scope_safe(global_value(sc->apply_values_symbol));
sc->tree_leaves_symbol =
defun("tree-leaves", tree_leaves, 1, 0, false);
sc->tree_memq_symbol = defun("tree-memq", tree_memq, 2, 0, false);
sc->tree_set_memq_symbol =
defun("tree-set-memq", tree_set_memq, 2, 0, false);
sc->tree_count_symbol = defun("tree-count", tree_count, 2, 1, false);
sc->tree_is_cyclic_symbol =
defun("tree-cyclic?", tree_is_cyclic, 1, 0, false);
sc->quasiquote_symbol =
s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false,
H_quasiquote);
sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 1, 0, false); /* calls dynamic-unwind */
sc->profile_out = NULL;
/* -------- *features* -------- */
sc->features_symbol =
s7_define_variable_with_documentation(sc, "*features*", sc->nil,
"list of currently available features ('complex-numbers, etc)");
s7_set_setter(sc, sc->features_symbol,
s7_make_function(sc, "#<set-*features*>", g_features_set,
2, 0, false, "*features* setter"));
/* -------- *load-path* -------- */
sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", list_1(sc, s7_make_string(sc, ".")), /* not plist! */
"*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name");
s7_set_setter(sc, sc->load_path_symbol,
s7_make_function(sc, "#<set-*load-path*>",
g_load_path_set, 2, 0, false,
"*load-path* setter"));
#ifdef CLOAD_DIR
sc->cload_directory_symbol =
s7_define_variable(sc, "*cload-directory*",
s7_make_string(sc, (char *) CLOAD_DIR));
s7_add_to_load_path(sc, (const char *) CLOAD_DIR);
#else
sc->cload_directory_symbol =
s7_define_variable(sc, "*cload-directory*", nil_string);
#endif
s7_set_setter(sc, sc->cload_directory_symbol,
s7_make_function(sc, "#<set-*cload-directory*>",
g_cload_directory_set, 2, 0, false,
"*cload-directory* setter"));
/* -------- *autoload* -------- this pretends to be a hash-table or environment, but it's actually a function */
sc->autoloader_symbol =
s7_define_typed_function(sc, "*autoload*", g_autoloader, 1, 0,
false, H_autoloader, Q_autoloader);
c_function_set_setter(global_value(sc->autoloader_symbol), global_value(sc->autoload_symbol)); /* (set! (*autoload* x) y) */
sc->libraries_symbol =
s7_define_variable_with_documentation(sc, "*libraries*", sc->nil,
"list of currently loaded libraries (libc.scm, etc)");
s7_set_setter(sc, sc->libraries_symbol,
s7_make_function(sc, "#<set-*libraries*>",
g_libraries_set, 2, 0, false,
"*libraries* setter"));
s7_autoload(sc, make_symbol(sc, "cload.scm"),
s7_make_permanent_string(sc, "cload.scm"));
s7_autoload(sc, make_symbol(sc, "lint.scm"),
s7_make_permanent_string(sc, "lint.scm"));
s7_autoload(sc, make_symbol(sc, "stuff.scm"),
s7_make_permanent_string(sc, "stuff.scm"));
s7_autoload(sc, make_symbol(sc, "mockery.scm"),
s7_make_permanent_string(sc, "mockery.scm"));
s7_autoload(sc, make_symbol(sc, "write.scm"),
s7_make_permanent_string(sc, "write.scm"));
s7_autoload(sc, make_symbol(sc, "reactive.scm"),
s7_make_permanent_string(sc, "reactive.scm"));
s7_autoload(sc, make_symbol(sc, "repl.scm"),
s7_make_permanent_string(sc, "repl.scm"));
s7_autoload(sc, make_symbol(sc, "r7rs.scm"),
s7_make_permanent_string(sc, "r7rs.scm"));
s7_autoload(sc, make_symbol(sc, "profile.scm"),
s7_make_permanent_string(sc, "profile.scm"));
s7_autoload(sc, make_symbol(sc, "debug.scm"),
s7_make_permanent_string(sc, "debug.scm"));
s7_autoload(sc, make_symbol(sc, "case.scm"),
s7_make_permanent_string(sc, "case.scm"));
s7_autoload(sc, make_symbol(sc, "libc.scm"),
s7_make_permanent_string(sc, "libc.scm"));
s7_autoload(sc, make_symbol(sc, "libm.scm"), s7_make_permanent_string(sc, "libm.scm")); /* repl.scm adds *libm* */
s7_autoload(sc, make_symbol(sc, "libdl.scm"),
s7_make_permanent_string(sc, "libdl.scm"));
s7_autoload(sc, make_symbol(sc, "libgsl.scm"), s7_make_permanent_string(sc, "libgsl.scm")); /* repl.scm adds *libgsl* */
s7_autoload(sc, make_symbol(sc, "libgdbm.scm"),
s7_make_permanent_string(sc, "libgdbm.scm"));
s7_autoload(sc, make_symbol(sc, "libutf8proc.scm"),
s7_make_permanent_string(sc, "libutf8proc.scm"));
sc->require_symbol =
s7_define_macro(sc, "require", g_require, 1, 0, true, H_require);
sc->stacktrace_defaults = s7_list(sc, 5, int_three, small_int(45), small_int(80), small_int(45), sc->T); /* assume NUM_SMALL_INTS >= NUM_CHARS == 256 */
/* -------- *#readers* -------- */
sym =
s7_define_variable_with_documentation(sc, "*#readers*", sc->nil,
"list of current reader macros");
sc->sharp_readers = global_slot(sym);
s7_set_setter(sc, sym,
s7_make_function(sc, "#<set-*#readers*>",
g_sharp_readers_set, 2, 0, false,
"*#readers* setter"));
sc->local_documentation_symbol = make_symbol(sc, "+documentation+");
sc->local_signature_symbol = make_symbol(sc, "+signature+");
sc->local_setter_symbol = make_symbol(sc, "+setter+");
sc->local_iterator_symbol = make_symbol(sc, "+iterator+");
init_features(sc);
init_setters(sc);
}
#if (!MS_WINDOWS)
static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER;
#endif
s7_scheme *s7_init(void)
{
int32_t i;
s7_scheme *sc;
static bool already_inited = false;
#if (!MS_WINDOWS)
setlocale(LC_NUMERIC, "C"); /* use decimal point in floats */
pthread_mutex_lock(&init_lock);
#endif
if (!already_inited) {
init_types();
init_ctables();
init_mark_functions();
init_display_functions();
init_length_functions();
init_equals();
init_hash_maps();
init_pows();
init_int_limits();
init_small_ints();
init_uppers();
init_chars();
init_strings();
init_fx_function();
init_catchers();
already_inited = true;
}
#if (!MS_WINDOWS)
pthread_mutex_unlock(&init_lock);
#endif
sc = (s7_scheme *) calloc(1, sizeof(s7_scheme)); /* not malloc! */
cur_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;
sc->saved_pointers =
(void **) malloc(INITIAL_SAVED_POINTERS_SIZE * sizeof(void *));
sc->saved_pointers_loc = 0;
sc->saved_pointers_size = INITIAL_SAVED_POINTERS_SIZE;
init_gc_caches(sc);
sc->permanent_cells = 0;
sc->alloc_pointer_k = ALLOC_POINTER_SIZE;
sc->alloc_pointer_cells = NULL;
sc->alloc_big_pointer_k = ALLOC_BIG_POINTER_SIZE;
sc->alloc_big_pointer_cells = NULL;
sc->alloc_function_k = ALLOC_FUNCTION_SIZE;
sc->alloc_function_cells = NULL;
sc->alloc_symbol_k = ALLOC_SYMBOL_SIZE;
sc->alloc_symbol_cells = NULL;
sc->num_to_str_size = -1;
sc->num_to_str = NULL;
init_block_lists(sc);
sc->alloc_string_k = ALLOC_STRING_SIZE;
sc->alloc_string_cells = NULL;
sc->alloc_opt_func_cells = NULL;
sc->alloc_opt_func_k = ALLOC_FUNCTION_SIZE;
sc->longjmp_ok = false;
sc->setjmp_loc = NO_SET_JUMP;
sc->max_vector_length = (1LL << 32);
sc->max_string_length = 1073741824; /* 1 << 30 */
sc->max_format_length = 10000;
sc->max_list_length = 1073741824;
sc->max_vector_dimensions = 512;
sc->strbuf_size = INITIAL_STRBUF_SIZE;
sc->strbuf = (char *) calloc(sc->strbuf_size, 1);
sc->print_width = sc->max_string_length;
sc->short_print = false;
sc->in_with_let = false;
sc->object_out_locked = false;
sc->has_openlets = true;
sc->is_expanding = true;
sc->accept_all_keyword_arguments = false;
sc->muffle_warnings = false;
sc->initial_string_port_length = 128;
sc->format_depth = -1;
sc->singletons = (s7_pointer *) calloc(256, sizeof(s7_pointer));
add_saved_pointer(sc, sc->singletons);
sc->read_line_buf = NULL;
sc->read_line_buf_size = 0;
sc->last_error_line = -1;
sc->stop_at_error = true;
sc->nil = make_unique(sc, "()", T_NIL);
sc->unused = make_unique(sc, "#<unused>", T_UNUSED);
sc->T = make_unique(sc, "#t", T_BOOLEAN);
sc->F = make_unique(sc, "#f", T_BOOLEAN);
sc->undefined = make_unique(sc, "#<undefined>", T_UNDEFINED);
sc->unspecified = make_unique(sc, "#<unspecified>", T_UNSPECIFIED);
sc->no_value = make_unique(sc, "#<unspecified>", T_UNSPECIFIED);
unique_car(sc->nil) = sc->unspecified;
unique_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_set_id(sc->nil, -1);
unique_cdr(sc->unspecified) = sc->unspecified;
sc->temp_cell_2 =
permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
sc->t1_1 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
sc->t2_2 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
sc->t2_1 = permanent_cons(sc, sc->nil, sc->t2_2, T_PAIR | T_IMMUTABLE);
sc->z2_2 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
sc->z2_1 = permanent_cons(sc, sc->nil, sc->z2_2, T_PAIR | T_IMMUTABLE);
sc->t3_3 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
sc->t3_2 = permanent_cons(sc, sc->nil, sc->t3_3, T_PAIR | T_IMMUTABLE);
sc->t3_1 = permanent_cons(sc, sc->nil, sc->t3_2, T_PAIR | T_IMMUTABLE);
sc->t4_1 = permanent_cons(sc, sc->nil, sc->t3_1, T_PAIR | T_IMMUTABLE);
sc->u1_1 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
sc->u2_2 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE);
sc->u2_1 = permanent_cons(sc, sc->nil, sc->u2_2, T_PAIR | T_IMMUTABLE);
sc->safe_lists[0] = sc->nil;
for (i = 1; i < NUM_SAFE_PRELISTS; i++)
sc->safe_lists[i] = permanent_list(sc, i);
for (i = NUM_SAFE_PRELISTS; i < NUM_SAFE_LISTS; i++)
sc->safe_lists[i] = sc->nil;
sc->current_safe_list = 0;
sc->input_port_stack_size = INPUT_PORT_STACK_INITIAL_SIZE;
sc->input_port_stack =
(s7_pointer *) malloc(sc->input_port_stack_size *
sizeof(s7_pointer));
sc->input_port_stack_loc = 0;
sc->code = sc->nil;
#if WITH_HISTORY
sc->eval_history1 = permanent_list(sc, DEFAULT_HISTORY_SIZE);
sc->eval_history2 = permanent_list(sc, DEFAULT_HISTORY_SIZE);
sc->history_pairs = permanent_list(sc, DEFAULT_HISTORY_SIZE);
sc->history_sink = permanent_list(sc, 1);
cdr(sc->history_sink) = sc->history_sink;
{
s7_pointer p1, p2, p3;
for (p3 = sc->history_pairs; is_pair(cdr(p3)); p3 = cdr(p3))
set_car(p3, permanent_list(sc, 1));
set_car(p3, permanent_list(sc, 1));
set_cdr(p3, sc->history_pairs);
for (p1 = sc->eval_history1, p2 = sc->eval_history2;
is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2));
set_cdr(p1, sc->eval_history1);
set_cdr(p2, sc->eval_history2);
sc->cur_code = sc->eval_history1;
sc->using_history1 = true;
sc->old_cur_code = sc->cur_code;
}
#else
sc->cur_code = sc->F;
#endif
sc->args = sc->nil;
sc->value = sc->nil;
sc->u = 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->rec_p1 = sc->F;
sc->rec_p2 = sc->F;
sc->begin_hook = NULL;
sc->autoload_table = sc->nil;
sc->autoload_names = NULL;
sc->autoload_names_sizes = NULL;
sc->autoloaded_already = NULL;
sc->autoload_names_loc = 0;
#if DISABLE_AUTOLOAD
sc->is_autoloading = false;
#else
sc->is_autoloading = true;
#endif
sc->rec_stack = NULL;
sc->heap_size = INITIAL_HEAP_SIZE;
if ((sc->heap_size % 32) != 0)
sc->heap_size =
32 * (int64_t) 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)); /* calloc to make sure type=0 at start? (for gc/valgrind) */
add_saved_pointer(sc, (void *) cells);
for (i = 0; i < INITIAL_HEAP_SIZE; i++) { /* LOOP_4 here is slower! */
sc->heap[i] = &cells[i];
sc->free_heap[i] = sc->heap[i];
i++;
sc->heap[i] = &cells[i];
sc->free_heap[i] = sc->heap[i];
}
sc->heap_blocks = (heap_block_t *) malloc(sizeof(heap_block_t));
sc->heap_blocks->start = (intptr_t) cells;
sc->heap_blocks->end =
(intptr_t) cells + (sc->heap_size * sizeof(s7_cell));
sc->heap_blocks->offset = 0;
sc->heap_blocks->next = NULL;
}
sc->gc_temps_size = GC_TEMPS_SIZE;
sc->gc_resize_heap_fraction = GC_RESIZE_HEAP_FRACTION;
sc->gc_resize_heap_by_4_fraction = GC_RESIZE_HEAP_BY_4_FRACTION;
sc->max_heap_size = (1LL << 62);
sc->gc_calls = 0;
sc->gc_total_time = 0;
sc->max_port_data_size = (1LL << 62);
#ifndef OUTPUT_PORT_DATA_SIZE
#define OUTPUT_PORT_DATA_SIZE 2048
#endif
sc->output_port_data_size = OUTPUT_PORT_DATA_SIZE;
/* this has to precede s7_make_* allocations */
sc->protected_setters_size = INITIAL_PROTECTED_OBJECTS_SIZE;
sc->protected_setters_loc = 0;
sc->protected_setters =
s7_make_vector(sc, INITIAL_PROTECTED_OBJECTS_SIZE);
sc->protected_setter_symbols =
s7_make_vector(sc, INITIAL_PROTECTED_OBJECTS_SIZE);
sc->protected_objects_size = INITIAL_PROTECTED_OBJECTS_SIZE;
sc->gpofl =
(s7_int *) malloc(INITIAL_PROTECTED_OBJECTS_SIZE * sizeof(s7_int));
sc->gpofl_loc = INITIAL_PROTECTED_OBJECTS_SIZE - 1;
sc->protected_objects =
s7_make_vector(sc, INITIAL_PROTECTED_OBJECTS_SIZE);
for (i = 0; i < INITIAL_PROTECTED_OBJECTS_SIZE; i++) {
vector_element(sc->protected_objects, i) = sc->unused;
vector_element(sc->protected_setters, i) = sc->unused;
vector_element(sc->protected_setter_symbols, i) = sc->unused;
sc->gpofl[i] = i;
}
sc->stack = s7_make_vector(sc, INITIAL_STACK_SIZE); /* this fills it with sc->nil */
sc->stack_start = vector_elements(sc->stack); /* stack type set below */
sc->stack_end = sc->stack_start;
sc->stack_size = INITIAL_STACK_SIZE;
sc->stack_resize_trigger =
(s7_pointer *) (sc->stack_start +
(INITIAL_STACK_SIZE - STACK_RESIZE_TRIGGER));
set_full_type(sc->stack, T_STACK);
sc->max_stack_size = (1 << 30);
stack_clear_flags(sc->stack);
initialize_op_stack(sc);
/* keep the symbol table out of the heap */
sc->symbol_table = (s7_pointer) calloc(1, sizeof(s7_cell));
set_full_type(sc->symbol_table, T_VECTOR | T_UNHEAP);
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);
{ /* sc->opts */
opt_info *os;
os = (opt_info *) calloc(OPTS_SIZE, sizeof(opt_info));
add_saved_pointer(sc, os);
for (i = 0; i < OPTS_SIZE; i++) {
opt_info *o = &os[i];
sc->opts[i] = o;
opt_set_sc(o, sc);
}
}
for (i = 0; i < NUM_TYPES; i++)
sc->prepackaged_type_names[i] =
s7_make_permanent_string(sc,
(const char *) type_name_from_type(i,
INDEFINITE_ARTICLE));
#if WITH_MULTITHREAD_CHECKS
sc->lock_count = 0;
{
pthread_mutexattr_t attr;
pthread_mutexattr_init(&attr);
pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);
pthread_mutex_init(&sc->lock, &attr);
}
#endif
sc->c_object_types = NULL;
sc->c_object_types_size = 0;
sc->num_c_object_types = 0;
sc->typnam = NULL;
sc->typnam_len = 0;
sc->default_rationalize_error = 1.0e-12;
sc->hash_table_float_epsilon = 1.0e-12;
sc->equivalent_float_epsilon = 1.0e-15;
sc->float_format_precision = WRITE_REAL_PRECISION;
sc->default_hash_table_length = 8;
sc->gensym_counter = 0;
sc->capture_let_counter = 0;
sc->continuation_counter = 0;
sc->f_class = 0;
sc->add_class = 0;
sc->num_eq_class = 0;
sc->let_number = 0;
sc->format_column = 0;
sc->format_ports = NULL;
sc->file_names = NULL;
sc->file_names_size = 0;
sc->file_names_top = -1;
sc->s7_call_line = 0;
sc->s7_call_file = NULL;
sc->s7_call_name = NULL;
sc->safety = NO_SAFETY;
sc->debug = 0;
sc->profile = 0;
sc->debug_or_profile = false;
sc->profiling_gensyms = false;
sc->profile_data = NULL;
sc->print_length = DEFAULT_PRINT_LENGTH;
sc->history_size = DEFAULT_HISTORY_SIZE;
sc->true_history_size = DEFAULT_HISTORY_SIZE;
sc->baffle_ctr = 0;
sc->syms_tag = 0;
sc->syms_tag2 = 0;
sc->class_name_symbol = make_symbol(sc, "class-name");
sc->name_symbol = make_symbol(sc, "name");
sc->trace_in_symbol = make_symbol(sc, "trace-in");
sc->size_symbol = make_symbol(sc, "size");
sc->mutable_symbol = make_symbol(sc, "mutable?");
sc->file__symbol = make_symbol(sc, "FILE*");
sc->circle_info = init_circle_info(sc);
sc->fdats = (format_data_t **) calloc(8, sizeof(format_data_t *));
sc->num_fdats = 8;
sc->plist_1 = permanent_list(sc, 1);
sc->plist_2 = permanent_list(sc, 2);
sc->plist_2_2 = cdr(sc->plist_2);
sc->plist_3 = permanent_list(sc, 3);
sc->qlist_2 = permanent_list(sc, 2);
sc->qlist_3 = permanent_list(sc, 3);
sc->clist_1 = permanent_list(sc, 1);
sc->dlist_1 = permanent_list(sc, 1);
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->undefined_identifier_warnings = false;
sc->undefined_constant_warnings = false;
sc->wrap_only = make_wrap_only(sc);
sc->unentry = (hash_entry_t *) malloc(sizeof(hash_entry_t));
hash_entry_set_value(sc->unentry, sc->F);
sc->begin_op = OP_BEGIN_NO_HOOK;
/* we used to laboriously set various other fields to null, but the calloc takes care of that */
sc->tree_pointers = NULL;
sc->tree_pointers_size = 0;
sc->tree_pointers_top = 0;
sc->rootlet = s7_make_vector(sc, INITIAL_ROOTLET_SIZE);
set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE);
sc->rootlet_entries = 0;
for (i = 0; i < INITIAL_ROOTLET_SIZE; i++)
rootlet_element(sc->rootlet, i) = sc->nil;
sc->curlet = sc->nil;
sc->shadow_rootlet = sc->nil;
sc->objstr_max_len = S7_INT64_MAX;
init_wrappers(sc);
init_standard_ports(sc);
init_rootlet(sc);
init_open_input_function_choices(sc);
{
s7_pointer p;
new_cell(sc, p, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_rng, so this shouldn't be permanent */
sc->default_rng = p;
sc->bignum_precision = DEFAULT_BIGNUM_PRECISION;
#if WITH_GMP
sc->bigints = NULL;
sc->bigrats = NULL;
sc->bigflts = NULL;
sc->bigcmps = NULL;
mpfr_set_default_prec((mp_prec_t) DEFAULT_BIGNUM_PRECISION);
mpc_set_default_precision((mp_prec_t) DEFAULT_BIGNUM_PRECISION);
mpz_inits(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL);
mpq_inits(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL);
mpfr_inits2(DEFAULT_BIGNUM_PRECISION, sc->mpfr_1, sc->mpfr_2,
sc->mpfr_3, NULL);
mpc_init(sc->mpc_1);
mpc_init(sc->mpc_2);
mpz_set_ui(sc->mpz_1, (uint64_t) my_clock());
gmp_randinit_default(random_gmp_state(p));
gmp_randseed(random_gmp_state(p), sc->mpz_1);
sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc));
set_initial_slot(sc->pi_symbol, make_permanent_slot(sc, sc->pi_symbol, big_pi(sc))); /* s7_make_slot does not handle this */
s7_provide(sc, "gmp");
#else
random_seed(p) = (uint64_t) my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */
random_carry(p) = 1675393560;
sc->pi_symbol = s7_define_constant(sc, "pi", real_pi);
#endif
}
for (i = 0; i < 10; i++)
sc->singletons[(uint8_t) '0' + i] = small_int(i);
sc->singletons[(uint8_t) '+'] = sc->add_symbol;
sc->singletons[(uint8_t) '-'] = sc->subtract_symbol;
sc->singletons[(uint8_t) '*'] = sc->multiply_symbol;
sc->singletons[(uint8_t) '/'] = sc->divide_symbol;
sc->singletons[(uint8_t) '<'] = sc->lt_symbol;
sc->singletons[(uint8_t) '>'] = sc->gt_symbol;
sc->singletons[(uint8_t) '='] = sc->num_eq_symbol;
init_choosers(sc);
init_typers(sc);
init_opt_functions(sc);
s7_set_history_enabled(sc, false);
#if S7_DEBUGGING
init_tc_rec(sc);
#endif
#if (!WITH_PURE_S7)
s7_define_variable(sc, "make-rectangular",
global_value(sc->complex_symbol));
s7_eval_c_string(sc,
"(define make-polar \n\
(let ((+signature+ '(number? real? real?))) \n\
(lambda (mag ang) \n\
(if (and (real? mag) (real? ang)) \n\
(complex (* mag (cos ang)) (* mag (sin ang))) \n\
(error 'wrong-type-arg \"make-polar arguments should be real\")))))");
s7_eval_c_string(sc,
"(define (call-with-values producer consumer) (apply consumer (list (producer))))");
/* (consumer (producer)) will work in any "normal" context. If consumer is syntax and then subsequently not syntax, there is confusion */
s7_eval_c_string(sc,
"(define-macro (multiple-value-bind vars expression . body) \n\
(list (cons 'lambda (cons 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\
(case (cdr tree) ((())) (else => traverse))) \n\
(if (memq tree '(and or not else)) tree \n\
(and (symbol? tree) (provided? tree))))))) \n\
(cons 'cond (map (lambda (clause) \n\
(if (pair? clause) \n\
(cons (traverse (car clause)) \n\
(case (cdr clause) ((()) '(#f)) (else))) \n\
(error 'read-error \"cond-expand: bad 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\
(when val \n\
(return (cond ((null? (cdr clause)) val) \n\
((eq? (cadr clause) '=>) ((eval (caddr clause)) val)) \n\
((null? (cddr clause)) (cadr clause)) \n\
(else (apply values (map quote (cdr clause))))))))) \n\
clauses) \n\
(values))))"); /* this is not redundant *//* map above ignores trailing cdr if improper */
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 hook-args \n\
(let ((body ())) \n\
(apply lambda* hook-args \n\
(copy '(let ((result #<unspecified>)) \n\
(let ((hook (curlet))) \n\
(for-each (lambda (hook-function) (hook-function hook)) body)\n\
result)) \n\
:readable) \n\
())))))");
s7_eval_c_string(sc,
"(define hook-functions \n\
(let ((+signature+ '(#t 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 (do ((p lst (cdr p))) \n\
((not (and (pair? p) \n\
(procedure? (car p)) \n\
(aritable? (car p) 1))) \n\
(null? p))) \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))))))");
/* -------- *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)");
/* -------- *autoload-hook* -------- */
sc->autoload_hook = s7_eval_c_string(sc, "(make-hook 'name 'file)");
s7_define_constant_with_documentation(sc, "*autoload-hook*",
sc->autoload_hook,
"*autoload-hook* functions are invoked by autoload, passing the to-be-autoloaded filename as (hook 'name) and (hook 'file))");
/* -------- *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).");
/* -------- *rootlet-redefinition-hook* -------- */
sc->rootlet_redefinition_hook =
s7_eval_c_string(sc, "(make-hook 'name 'value)");
s7_define_constant_with_documentation(sc,
"*rootlet-redefinition-hook*",
sc->rootlet_redefinition_hook,
"*rootlet-redefinition-hook* functions are called when a top-level variable's value is changed, (hook 'name 'value).");
{ /* *s7* is permanent -- 20-May-21 */
s7_pointer x, slot1, slot2;
x = alloc_pointer(sc);
set_full_type(x,
T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS |
T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK);
let_set_id(x, ++sc->let_number);
let_set_outlet(x, sc->nil);
slot1 =
make_permanent_slot(sc, sc->let_set_fallback_symbol,
s7_make_function(sc, "s7-let-set",
g_s7_let_set_fallback, 3,
0, false, "*s7* writer"));
symbol_set_local_slot(sc->let_set_fallback_symbol, sc->let_number,
slot1);
slot_set_next(slot1, slot_end(sc));
slot2 =
make_permanent_slot(sc, sc->let_ref_fallback_symbol,
s7_make_function(sc, "s7-let-ref",
g_s7_let_ref_fallback, 2,
0, false, "*s7* reader"));
symbol_set_local_slot(sc->let_ref_fallback_symbol, sc->let_number,
slot2);
slot_set_next(slot2, slot1);
let_set_slots(x, slot2);
sc->s7_let = x;
}
sc->s7_let_symbol =
s7_define_constant(sc, "*s7*", s7_openlet(sc, sc->s7_let));
set_immutable(let_slots(sc->s7_let)); /* make the *s7* let-ref|set! fallbacks immutable */
set_immutable(next_slot(let_slots(sc->s7_let)));
set_immutable(sc->s7_let);
s7_set_history_enabled(sc, true);
#if S7_DEBUGGING
s7_define_function(sc, "report-missed-calls", g_report_missed_calls, 0,
0, false, NULL);
if (!s7_type_names[0]) {
fprintf(stderr, "no type_names\n");
gdb_break();
} /* squelch very stupid warnings! */
if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0)
fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]);
if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0)
fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]);
if (NUM_OPS != 940)
fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n",
(int) sizeof(s7_cell), (int) sizeof(block_t), NUM_OPS,
(int) sizeof(opt_info));
/* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */
#endif
init_unlet(sc);
init_s7_let(sc); /* set up *s7* */
init_signatures(sc); /* depends on procedure symbols */
return (sc);
}
/* -------------------------------- s7_free -------------------------------- */
void s7_free(s7_scheme * sc)
{
/* free the memory associated with sc
* most pointers are in the saved_pointers table, but any that might be realloc'd need to be handled explicitly
* valgrind --leak-check=full --show-reachable=yes --suppressions=/home/bil/cl/free.supp repl s7test.scm
* valgrind --leak-check=full --show-reachable=yes --gen-suppressions=all --error-limit=no --log-file=raw.log repl s7test.scm
*/
s7_int i;
gc_list_t *gp;
g_gc(sc, sc->nil); /* probably not needed (my simple tests work fine if the gc call is omitted) */
gp = sc->vectors;
for (i = 0; i < gp->loc; i++)
if (block_index(unchecked_vector_block(gp->list[i])) ==
TOP_BLOCK_LIST)
free(block_data(unchecked_vector_block(gp->list[i])));
free(gp->list);
free(gp);
free(sc->multivectors->list); /* I assume vector_dimension_info won't need 131072 bytes */
free(sc->multivectors);
gp = sc->strings;
for (i = 0; i < gp->loc; i++)
if (block_index(unchecked_string_block(gp->list[i])) ==
TOP_BLOCK_LIST)
free(block_data(unchecked_string_block(gp->list[i])));
free(gp->list);
free(gp);
gp = sc->output_ports;
for (i = 0; i < gp->loc; i++) {
if ((unchecked_port_data_block(gp->list[i])) &&
(block_index(unchecked_port_data_block(gp->list[i])) ==
TOP_BLOCK_LIST))
free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */
if ((is_file_port(gp->list[i])) && (!port_is_closed(gp->list[i])))
fclose(port_file(gp->list[i]));
}
free(gp->list);
free(gp);
gp = sc->input_ports;
for (i = 0; i < gp->loc; i++)
if ((unchecked_port_data_block(gp->list[i])) &&
(block_index(unchecked_port_data_block(gp->list[i])) ==
TOP_BLOCK_LIST))
free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */
free(gp->list);
free(gp);
free(sc->input_string_ports->list); /* port_data_block is null, port_block is the const char* data, so I assume it is handled elsewhere */
free(sc->input_string_ports);
gp = sc->hash_tables;
for (i = 0; i < gp->loc; i++)
if (block_index(unchecked_hash_table_block(gp->list[i])) ==
TOP_BLOCK_LIST)
free(block_data(unchecked_hash_table_block(gp->list[i])));
free(gp->list);
free(gp);
gp = sc->c_objects;
for (i = 0; i < gp->loc; i++) {
s7_pointer s1;
s1 = gp->list[i];
if (c_object_gc_free(sc, s1))
(*(c_object_gc_free(sc, s1))) (sc, s1);
else
(*(c_object_free(sc, s1))) (c_object_value(s1));
}
free(gp->list);
free(gp);
#if WITH_GMP
/* free lists */
{
bigint *p, *np;
for (p = sc->bigints; p; p = np) {
mpz_clear(p->n);
np = p->nxt;
free(p);
}
}
{
bigrat *p, *np;
for (p = sc->bigrats; p; p = np) {
mpq_clear(p->q);
np = p->nxt;
free(p);
}
}
{
bigflt *p, *np;
for (p = sc->bigflts; p; p = np) {
mpfr_clear(p->x);
np = p->nxt;
free(p);
}
}
{
bigcmp *p, *np;
for (p = sc->bigcmps; p; p = np) {
mpc_clear(p->z);
np = p->nxt;
free(p);
}
}
/* in-use lists */
gp = sc->big_integers;
for (i = 0; i < gp->loc; i++) {
bigint *p;
p = big_integer_bgi(gp->list[i]);
mpz_clear(p->n);
free(p);
}
free(gp->list);
free(gp);
gp = sc->big_ratios;
for (i = 0; i < gp->loc; i++) {
bigrat *p;
p = big_ratio_bgr(gp->list[i]);
mpq_clear(p->q);
free(p);
}
free(gp->list);
free(gp);
gp = sc->big_reals;
for (i = 0; i < gp->loc; i++) {
bigflt *p;
p = big_real_bgf(gp->list[i]);
mpfr_clear(p->x);
free(p);
}
free(gp->list);
free(gp);
gp = sc->big_complexes;
for (i = 0; i < gp->loc; i++) {
bigcmp *p;
p = big_complex_bgc(gp->list[i]);
mpc_clear(p->z);
free(p);
}
free(gp->list);
free(gp);
gp = sc->big_random_states;
for (i = 0; i < gp->loc; i++)
gmp_randclear(random_gmp_state(gp->list[i]));
free(gp->list);
free(gp);
gmp_randclear(random_gmp_state(sc->default_rng));
/* temps */
if (sc->ratloc)
free_rat_locals(sc);
mpz_clears(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL);
mpq_clears(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL);
mpfr_clears(sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL);
mpc_clear(sc->mpc_1);
mpc_clear(sc->mpc_2);
/* I claim the leftovers (864 bytes, all from mpfr_cosh) are gmp's fault */
#endif
free(undefined_name(sc->undefined));
gp = sc->undefineds;
for (i = 0; i < gp->loc; i++)
free(undefined_name(gp->list[i]));
free(gp->list);
free(gp);
free(sc->gensyms->list);
free(sc->gensyms);
free(sc->continuations->list);
free(sc->continuations); /* stack is simple vector (handled above) */
free(sc->lambdas->list);
free(sc->lambdas);
free(sc->weak_refs->list);
free(sc->weak_refs);
free(sc->weak_hash_iterators->list);
free(sc->weak_hash_iterators);
free(sc->opt1_funcs);
free(port_port(sc->standard_output));
free(port_port(sc->standard_error));
free(port_port(sc->standard_input));
if (sc->autoload_names)
free(sc->autoload_names);
if (sc->autoload_names_sizes)
free(sc->autoload_names_sizes);
if (sc->autoloaded_already)
free(sc->autoloaded_already);
{
block_t *top;
for (top = sc->block_lists[TOP_BLOCK_LIST]; top;
top = block_next(top))
if (block_data(top))
free(block_data(top));
}
for (i = 0; i < sc->saved_pointers_loc; i++)
free(sc->saved_pointers[i]);
free(sc->saved_pointers);
{
gc_obj_t *g, *gnxt;
heap_block_t *hp, *hpnxt;
for (g = sc->permanent_lets; g; g = gnxt) {
gnxt = g->nxt;
free(g);
}
for (g = sc->permanent_objects; g; g = gnxt) {
gnxt = g->nxt;
free(g);
}
for (hp = sc->heap_blocks; hp; hp = hpnxt) {
hpnxt = hp->next;
free(hp);
}
}
free(sc->heap);
free(sc->free_heap);
free(vector_elements(sc->symbol_table)); /* alloc'd directly, not via block */
free(sc->symbol_table);
free(sc->unlet);
free(sc->setters);
free(sc->op_stack);
if (sc->tree_pointers)
free(sc->tree_pointers);
free(sc->num_to_str);
free(sc->gpofl);
if (sc->read_line_buf)
free(sc->read_line_buf);
free(sc->strbuf);
free(sc->circle_info->objs);
free(sc->circle_info->refs);
free(sc->circle_info->defined);
free(sc->circle_info);
if (sc->file_names)
free(sc->file_names);
free(sc->unentry);
free(sc->input_port_stack);
if (sc->typnam)
free(sc->typnam);
for (i = 0; i < sc->num_fdats; i++)
if (sc->fdats[i]) { /* init val is NULL */
if (sc->fdats[i]->curly_str)
free(sc->fdats[i]->curly_str);
free(sc->fdats[i]);
}
free(sc->fdats);
if (sc->profile_data) {
free(sc->profile_data->funcs);
free(sc->profile_data->excl);
free(sc->profile_data->data);
free(sc->profile_data);
}
if (sc->c_object_types) {
for (i = 0; i < sc->num_c_object_types; i++)
free(sc->c_object_types[i]);
free(sc->c_object_types);
}
free(sc);
}
/* -------------------------------- repl -------------------------------- */
#ifndef USE_SND
#define USE_SND 0
#endif
#ifndef WITH_MAIN
#define WITH_MAIN 0
#endif
#if WITH_MAIN && WITH_NOTCURSES
#define S7_MAIN 1
#include "nrepl.c"
/* gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core */
#else
static void dumb_repl(s7_scheme * sc)
{
while (true) {
char buffer[512];
fprintf(stdout, "\n> ");
if (!fgets(buffer, 512, stdin))
break; /* error or ctrl-D */
if (((buffer[0] != '\n') || (strlen(buffer) > 1))) {
char response[1024];
snprintf(response, 1024, "(write %s)", buffer);
s7_eval_c_string(sc, response);
}
}
fprintf(stdout, "\n");
if (ferror(stdin))
fprintf(stderr, "read error on stdin\n");
}
void s7_repl(s7_scheme * sc)
{
#if (!WITH_C_LOADER)
dumb_repl(sc);
#else
#if WITH_NOTCURSES
s7_load(sc, "nrepl.scm");
#else
s7_pointer old_e, e, val;
s7_int gc_loc;
bool repl_loaded = false;
/* try to get lib_s7.so from the repl's directory, and set *libc*.
* otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h
*/
e = s7_inlet(sc,
set_plist_2(sc, s7_make_symbol(sc, "init_func"),
s7_make_symbol(sc, "libc_s7_init")));
gc_loc = s7_gc_protect(sc, e);
old_e = s7_set_curlet(sc, e); /* e is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */
val = s7_load_with_environment(sc, "libc_s7.so", e);
if (val) {
s7_pointer libs;
uint64_t hash;
hash = raw_string_hash((const uint8_t *) "*libc*", 6); /* hack around an idiotic gcc 10.2.1 warning */
s7_define(sc, sc->nil,
new_symbol(sc, "*libc*", 6, hash,
hash % SYMBOL_TABLE_SIZE), e);
libs = global_slot(sc->libraries_symbol);
slot_set_value(libs,
cons(sc,
cons(sc, make_permanent_string("libc.scm"), e),
slot_value(libs)));
} else {
val = s7_load(sc, "repl.scm");
if (val)
repl_loaded = true;
}
s7_set_curlet(sc, old_e); /* restore incoming (curlet) */
s7_gc_unprotect_at(sc, gc_loc);
if (!val) /* s7_load was unable to find/load libc_s7.so or repl.scm */
dumb_repl(sc);
else {
#if S7_DEBUGGING
s7_autoload(sc, s7_make_symbol(sc, "compare-calls"),
s7_make_string(sc, "compare-calls.scm"));
s7_autoload(sc, s7_make_symbol(sc, "get-overheads"),
s7_make_string(sc, "compare-calls.scm"));
#endif
s7_provide(sc, "libc.scm");
if (!repl_loaded)
s7_load(sc, "repl.scm");
s7_eval_c_string(sc, "((*repl* 'run))");
}
#endif
#endif
}
#if WITH_MAIN && (!USE_SND)
#if (!MS_WINDOWS) && WITH_C_LOADER
static char *realdir(const char *filename)
{ /* this code courtesy Lassi Kortela 4-Nov-19 */
char *path;
char *p;
/* s7_repl wants to load libc_s7.o (for tcsetattr et al), but if it is started in a directory other than the libc_s7.so
* directory, it fails (it tries to build the library but that requires s7.h and libc.scm). So here we are trying to
* guess the libc_s7 directory from the command line program name. This can't work in general, but it works often
* enough to be worth the effort. If S7_LOAD_PATH is set, it is used instead.
*/
if (!strchr(filename, '/'))
return (NULL);
if (!(path = realpath(filename, NULL))) { /* in Windows maybe GetModuleFileName(NULL, buffer, buffer_size) */
fprintf(stderr, "%s: %s\n", strerror(errno), filename);
exit(2);
}
if (!(p = strrchr(path, '/'))) {
free(path);
fprintf(stderr, "please provide the full pathname for %s\n",
filename);
exit(2);
}
if (p > path)
*p = '\0';
else
p[1] = 0;
return (path);
}
#endif
int main(int argc, char **argv)
{
s7_scheme *sc;
sc = s7_init();
fprintf(stderr, "s7: %s\n", S7_DATE);
if (argc == 2) {
fprintf(stderr, "load %s\n", argv[1]);
if (!s7_load(sc, argv[1])) {
fprintf(stderr, "can't load %s\n", argv[1]);
return (2);
}
} else {
#if (MS_WINDOWS) || (!WITH_C_LOADER) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */
dumb_repl(sc);
#else
#ifdef S7_LOAD_PATH
s7_add_to_load_path(sc, S7_LOAD_PATH);
#else
char *dir;
dir = realdir(argv[0]);
if (dir) {
s7_add_to_load_path(sc, dir);
free(dir);
}
#endif
s7_repl(sc);
#endif
}
return (0);
}
/* in Linux: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic
* in *BSD: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm -Wl,-export-dynamic
* in OSX: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm
* (clang also needs LDFLAGS="-Wl,-export-dynamic" in Linux and "-fPIC")
* in msys2: gcc s7.c -o s7 -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib
*
* for nrepl: gcc s7.c -o repl -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm -Wl,-export-dynamic
*
* (s7.c compile time 2-Jul-21 52 secs)
* musl works, but there is some problem in libgsl.scm with gsl/gsl_blas.h I think
*/
#endif
#endif
/* --------------------------------------------------------
* gmp (8-23) 20.9 21.0 21.7 21.8
* --------------------------------------------------------
* tpeak 123 115 114 110 110
* tref 552 691 687 476 476
* tauto 785 648 642 496 496
* tshoot 1471 883 872 808 808
* index 1031 1026 1016 981 981
* tmock 7756 1177 1165 1090 1090
* tvect 1915 2456 2413 1735 1724
* s7test 4514 1873 1831 1792 1794
* texit ---- ---- 1886
* lt 2129 2123 2110 2120 2120
* tform 3245 2281 2273 2255 2258
* tmac 2429 3317 3277 2409 2409
* tread 2591 2440 2421 2415 2414
* trclo 4093 2715 2561 2458 2458
* fbench 2852 2688 2583 2475 2475
* tmat 2648 3065 3042 2530 2519
* tcopy 2745 8035 5546 2550 2550
* dup 2760 3805 3788 2565 2577
* tb 3375 2735 2681 2627 2627
* titer 2678 2865 2842 2679 2679
* tsort 3590 3105 3104 2860 2856
* tset 3100 3253 3104 3089 3089
* tload 3849 ---- ---- 3142 3142
* teq 3542 4068 4045 3570 3570
* tio 3684 3816 3752 3693 3694
* tclo 4636 4787 4735 4402 4402
* tlet 5283 7775 5640 4431 4431
* tcase 4550 4960 4793 4444 4444
* tmap 5984 8869 8774 4493 4493
* tfft 115.1 7820 7729 4787 4787
* tnum 56.7 6348 6013 5443 5441
* tstr 8059 6880 6342 5776 5776
* tgsl 25.2 8485 7802 6397 6397
* trec 8338 6936 6922 6553 6553
* tmisc 7217 8960 7699 6597 6594
* tari ---- 12.8 12.5 6973 6931
* tlist 6834 7896 7546 6865 6865
* tgc 10.1 11.9 11.1 8668 8667
* thash 35.4 11.8 11.7 9775 9775
* cb 18.8 12.2 12.2 11.1 11.1
* tgen 12.1 11.2 11.4 11.5 11.6
* tall 24.4 15.6 15.6 15.6 15.6
* calls 58.0 36.7 37.5 37.1 37.1
* sg 80.0 ---- ---- 56.1 56.1
* lg 104.5 106.6 105.0 104.4 104.4
* tbig 635.1 177.4 175.8 166.4 166.3
* --------------------------------------------------------
*
* (n)repl.scm should have some autoload function for libm and libgsl (libc also for nrepl): cload.scm has checks at end
* nrepl bug(?) in row 0 (2.3.13 is ok, 2.3.17 is broken)
* fb_annotate: bool_opt cases? and/or with bool ops (lt gt etc), cond/do tests if result
* in the vs case, can we see the bfunc and update it? In fx_tree OP_IF_B* call fx_tree directly and catch fixup
* for and/or: all branches fx->fb -> new op??
* fx_tree fb cases? trec: half fx_num_eq_t0 -> fb_num_eq_s0
* op_local_lambda _fx? [and unwrap the pointless case ((lambda () (f a b)))]
* need fx_annotate (but not tree) for lambda body, OP_F|F_A|F_AA?
* v*ref_un* from check_unchecked: -> make_integer|real?
* d_7pi??, d_dp|[pd]|pp and i_ip|[pi=i_7pi]|pp to reduce intermediate number creation, also d_pid=d_7pid and i_7pii for nr cases
* tari case for these
* b_pi_ff and check_b_types -> b_pi etc
* some opt cases check methods/errors, but others don't -- these should have the methods
* asin at top -- return ignored, so asin is pointless -- at call point we have args, so p_p_nr, p_pp_nr etc?
* then idp_nr_fixup could see if func has no_side_effects set and set call to p_p_nr etc -- will break all timing tests...
* maybe an S7_TIMING flag or *s7* field (*s7* 'timing-test?) lint has no-side-effect-functions list
* at least a bit for opt functions that have an _nr replacement
*/
Reference in a new issue View git blame Copy permalink