summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIOhannes m zmölnig <zmoelnig@umlautS.umlaeute.mur.at>2019-10-18 13:32:26 +0200
committerIOhannes m zmölnig <zmoelnig@umlautS.umlaeute.mur.at>2019-10-18 13:32:26 +0200
commite10706e0a5cc9e95c0edb626366d2760f9d19e2b (patch)
treebb91598860c2d19c4c1246a0ddd49d53594a17d6
parentf006cecce8a17e228aab1ca78242b81a5acb8090 (diff)
New upstream version 19.8
Diffstat
-rw-r--r--HISTORY.Snd1
-rw-r--r--NEWS9
-rwxr-xr-xconfigure20
-rw-r--r--configure.ac4
-rw-r--r--extsnd.html2
-rw-r--r--gtk-effects.scm2
-rw-r--r--lint.scm9
-rw-r--r--s7.c11932
-rw-r--r--s7.html64
-rw-r--r--s7test.scm452
-rw-r--r--snd-chn.c42
-rw-r--r--snd-edits.c1
-rw-r--r--snd-marks.c4
-rw-r--r--snd-motif.c7
-rw-r--r--snd-select.c4
-rw-r--r--snd-sig.c8
-rw-r--r--snd-test.scm278
-rw-r--r--snd.h6
-rw-r--r--sndclm.html4
-rw-r--r--tools/dup.scm2
-rw-r--r--tools/t101.scm2
-rw-r--r--tools/tbig.scm3
-rw-r--r--tools/tclo.scm2
-rw-r--r--tools/tcopy.scm2
-rw-r--r--tools/teq.scm2
-rwxr-xr-xtools/testsnd9
-rw-r--r--tools/tfft.scm3
-rw-r--r--tools/thash.scm7
-rw-r--r--tools/tmap.scm2
-rw-r--r--tools/tmisc.scm2
-rw-r--r--tools/tshoot.scm64
-rw-r--r--tools/tsort.scm4
-rw-r--r--tools/valcall.scm8
-rw-r--r--ws.scm2
34 files changed, 6428 insertions, 6535 deletions
diff --git a/HISTORY.Snd b/HISTORY.Snd
index ff94743..4baaf3c 100644
--- a/HISTORY.Snd
+++ b/HISTORY.Snd
@@ -1,5 +1,6 @@
Snd change log
+ 14-Oct: Snd 19.8.
2-Sep: Snd 19.7.
1-Aug: Snd 19.6.
26-Jun: Snd 19.5.
diff --git a/NEWS b/NEWS
index 0da8912..494afc1 100644
--- a/NEWS
+++ b/NEWS
@@ -1,7 +1,8 @@
-Snd 19.7:
+Snd 19.8
-in clm, Anders fixed a bug in mus.lisp.
+In Snd, Tito fixed many Snd bugs, involving left-sample and right-sample,
+ off-by-1 cases for mark-sample and selection-samples, a bug in s7_load, etc.
-checked: sbcl 1.5.6
+checked: sbcl 1.5.7
-Thanks!: Anders Vinjar, Kenneth Flak, David O'Toole \ No newline at end of file
+Thanks!: Kjetil Matheussen, David O'Toole, Tito Latini
diff --git a/configure b/configure
index 6ef4287..51e0c8e 100755
--- a/configure
+++ b/configure
@@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.69 for snd 19.7.
+# Generated by GNU Autoconf 2.69 for snd 19.8.
#
# Report bugs to <bil@ccrma.stanford.edu>.
#
@@ -580,8 +580,8 @@ MAKEFLAGS=
# Identity of this package.
PACKAGE_NAME='snd'
PACKAGE_TARNAME='ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz'
-PACKAGE_VERSION='19.7'
-PACKAGE_STRING='snd 19.7'
+PACKAGE_VERSION='19.8'
+PACKAGE_STRING='snd 19.8'
PACKAGE_BUGREPORT='bil@ccrma.stanford.edu'
PACKAGE_URL=''
@@ -1324,7 +1324,7 @@ if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures snd 19.7 to adapt to many kinds of systems.
+\`configure' configures snd 19.8 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1395,7 +1395,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of snd 19.7:";;
+ short | recursive ) echo "Configuration of snd 19.8:";;
esac
cat <<\_ACEOF
@@ -1514,7 +1514,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-snd configure 19.7
+snd configure 19.8
generated by GNU Autoconf 2.69
Copyright (C) 2012 Free Software Foundation, Inc.
@@ -1975,7 +1975,7 @@ cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by snd $as_me 19.7, which was
+It was created by snd $as_me 19.8, which was
generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
@@ -3322,7 +3322,7 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
-VERSION=19.7
+VERSION=19.8
#--------------------------------------------------------------------------------
# configuration options
@@ -6897,7 +6897,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by snd $as_me 19.7, which was
+This file was extended by snd $as_me 19.8, which was
generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -6959,7 +6959,7 @@ _ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
-snd config.status 19.7
+snd config.status 19.8
configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
diff --git a/configure.ac b/configure.ac
index 7d32c0b..7109cc7 100644
--- a/configure.ac
+++ b/configure.ac
@@ -5,7 +5,7 @@
# gmp, mpfr, and mpc deliberately have none!
-AC_INIT(snd, 19.7, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz)
+AC_INIT(snd, 19.8, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz)
AC_CONFIG_SRCDIR(snd.c)
AC_CANONICAL_HOST # needed by case $host below
@@ -24,7 +24,7 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
-VERSION=19.7
+VERSION=19.8
#--------------------------------------------------------------------------------
# configuration options
diff --git a/extsnd.html b/extsnd.html
index 973d6e0..d4c84d7 100644
--- a/extsnd.html
+++ b/extsnd.html
@@ -8088,7 +8088,7 @@ file ok:
<p>There are
other ways to get at sound file data: <a class=quiet href="#makesampler">make-sampler</a> can be given a filename,
-rather than a sound; file-&gt;float-vector in examp.scm;
+rather than a sound; file-&gt;floats in examp.scm;
and a variety of CLM-based functions such as
<a class=quiet href="sndclm.html#filetosample">file-&gt;sample</a> and
<a class=quiet href="sndclm.html#filetoarray">file-&gt;array</a>.
diff --git a/gtk-effects.scm b/gtk-effects.scm
index 436c74b..13cf08b 100644
--- a/gtk-effects.scm
+++ b/gtk-effects.scm
@@ -1,7 +1,7 @@
;;; translation of new-effects.scm to gtk/xg
(unless (provided? 'gtk4)
- (error 'gtk-error "gtk-effects-utils.scm only works in gtk4"))
+ (error 'gtk-error "gtk-effects.scm only works in gtk4"))
(provide 'snd-gtk-effects.scm)
(require snd-gtk snd-gtk-effects-utils.scm snd-xm-enved.scm snd-moog.scm snd-rubber.scm snd-dsp.scm)
diff --git a/lint.scm b/lint.scm
index 9e4e93d..faaedb4 100644
--- a/lint.scm
+++ b/lint.scm
@@ -6352,7 +6352,7 @@
(eq? (caadr tree) 'apply-values))
(list 'append (cadadr tree) (cadr (caddr tree)))
(list 'cons (cadr tree) (cadr (caddr tree))))
- (cons 'list (unlist-values (cdr tree)))))
+ (cons 'list (unlist-values (cdr tree))))) ; #_list perhaps? and #_cons #_append above?
((append)
(if (and (len=2? (cdr tree))
@@ -6726,7 +6726,6 @@
(when (and (pair? args)
(not (tree-memq (car args) (cddr func))))
(lint-format "~A is ignored, so perhaps (member #f ...)" caller (car args)))))))))))))))
-
(for-each (lambda (f)
(hash-special f sp-memx))
@@ -14444,7 +14443,7 @@
(when (pair? body)
(let ((args (cdr body)))
(case (car body)
- ((list-values list)
+ ((list-values) ; was list also briefly
(when (and (pair? args)
(quoted-symbol? (car args)))
(if (proper-list? outer-args)
@@ -22365,11 +22364,11 @@
((and (len=3? arg1) ; `((a . b) (c . d)) -> (list (cons a b) (cons c d))
(eq? (car arg1) 'append) ; `((a . (b . c))...) -> (list (cons a (cons b c)) ...)
(pair? (cadr arg1))
- (memq (caadr arg1) '(list list-values))
+ (eq? (caadr arg1) 'list-values) ; was memq+list
(len=3? arg2)
(eq? (car arg2) 'append)
(pair? (cadr arg2))
- (memq (caadr arg2) '(list list-values)))
+ (eq? (caadr arg2) 'list-values)) ; same
(let ((ca1 (cadr arg1))
(ca2 (cadr arg2)))
(let ((len1 (length ca1))
diff --git a/s7.c b/s7.c
index e7f2135..8c67cfc 100644
--- a/s7.c
+++ b/s7.c
@@ -306,8 +306,10 @@
#undef DEBUGGING
#define DEBUGGING typo!
+#define SHOW_EVAL_OPS 0
+
#ifndef OP_NAMES
- #define OP_NAMES 0
+ #define OP_NAMES SHOW_EVAL_OPS
#endif
#ifndef _GNU_SOURCE
@@ -538,6 +540,19 @@ enum {NO_SAFETY = 0, IMMUTABLE_VECTOR_SAFETY, MORE_SAFETY_WARNINGS}; /* (*s7* '
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, bool copied); /* function to read a string up to \n */
+ void (*display)(s7_scheme *sc, const char *s, s7_pointer pt);
+ void (*close_port)(s7_scheme *sc, s7_pointer p); /* close-in|output-port */
+} port_functions;
+
+typedef struct {
bool needs_free, needs_unprotect, is_closed;
port_type_t ptype;
FILE *file;
@@ -546,21 +561,10 @@ typedef struct {
uint32_t line_number, file_number;
s7_int gc_loc, filename_length;
block_t *block;
+ s7_pointer orig_str; /* GC protection for string port string */
+ const port_functions *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);
- /* a version of string ports using a pointer to the current location and a pointer to the end
- * (rather than an integer for both, indexing from the base string) was not faster.
- */
- s7_pointer orig_str; /* GC protection for string port string */
- 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, bool copied); /* function to read a string up to \n */
- void (*display)(s7_scheme *sc, const char *s, s7_pointer pt);
} 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,
@@ -627,7 +631,6 @@ typedef hash_entry_t *(*hash_check_t)(s7_scheme *sc, s7_pointer table, s7_pointe
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);
@@ -659,23 +662,16 @@ 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);
-#ifndef OPT_INFO_DEBUGGING
- #define OPT_INFO_DEBUGGING 0 /* not useful unless S7_DEBUGGING */
-#endif
-
typedef enum {OO_P, OO_I, OO_D, OO_V, OO_IV, OO_FV, OO_PV, OO_R, OO_H, OO_S, OO_BV, OO_L, OO_E, OO_AV, OO_TV} opt_type_t;
typedef struct opt_info opt_info;
-#if OPT_INFO_DEBUGGING
-typedef struct {
-#else
typedef union {
-#endif
s7_int i;
s7_double x;
s7_pointer p;
void *obj;
- s7_function cf;
+ 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);
@@ -733,13 +729,13 @@ typedef union {
s7_pointer (*fp)(opt_info *o);
} vunion;
-#define NUM_VUNIONS 12
+#define NUM_VUNIONS 15
struct opt_info {
vunion v[NUM_VUNIONS];
- int32_t size, slots;
s7_scheme *sc;
- opt_type_t types[NUM_VUNIONS];
#if S7_DEBUGGING
+ int32_t slots;
+ opt_type_t types[NUM_VUNIONS];
int32_t addrs[NUM_VUNIONS];
s7_pointer vexpr;
const char *func;
@@ -747,6 +743,8 @@ struct opt_info {
#endif
};
+#define O_WRAP (NUM_VUNIONS - 1)
+
/* -------------------------------- cell structure -------------------------------- */
@@ -967,8 +965,8 @@ typedef struct s7_cell {
struct { /* continuations */
block_t *block;
- s7_pointer stack;
- s7_pointer *stack_start, *stack_end, *op_stack;
+ s7_pointer stack, op_stack;
+ s7_pointer *stack_start, *stack_end;
} cwcc;
struct { /* call-with-exit */
@@ -1114,7 +1112,7 @@ struct s7_scheme {
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, rec_resp, rec_slot1, rec_slot2, rec_slot3;
- 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_cf;
+ 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_call;
s7_int (*rec_fi1)(opt_info *o);
s7_int (*rec_fi2)(opt_info *o);
s7_int (*rec_fi3)(opt_info *o);
@@ -1125,8 +1123,8 @@ struct s7_scheme {
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_cf;
- s7_d_dd_t rec_d_cf;
+ s7_i_ii_t rec_i_ii_f;
+ s7_d_dd_t rec_d_dd_f;
s7_pointer rec_val1, rec_val2;
int32_t rec_pc1, rec_pc2;
@@ -1168,7 +1166,7 @@ struct s7_scheme {
format_data **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;
- gc_list *strings, *vectors, *input_ports, *output_ports, *continuations, *c_objects, *hash_tables;
+ gc_list *strings, *vectors, *input_ports, *output_ports, *input_string_ports, *continuations, *c_objects, *hash_tables;
gc_list *gensyms, *unknowns, *lambdas, *multivectors, *weak_refs, *weak_hash_iterators, *lamlets;
s7_pointer *setters;
s7_int setters_size, setters_loc;
@@ -1302,15 +1300,14 @@ struct s7_scheme {
/* optimizer s7_functions */
s7_pointer add_2, add_3, add_1x, add_x1, subtract_1, subtract_2, subtract_3, subtract_s1, subtract_2f, subtract_f2, simple_char_eq,
- char_equal_2, char_greater_2, char_less_2, char_position_csi, string_equal_2, substring_to_temp, display_2,
+ char_equal_2, char_greater_2, char_less_2, char_position_csi, string_equal_2, substring_to_temp, display_2, display_f,
string_greater_2, string_less_2, symbol_to_string_uncopied,
vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, read_char_1,
fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_2i, iv_ref_3, iv_set_3, bv_ref_2, bv_ref_3, bv_set_3,
list_0, list_1, list_2, list_3, list_set_i, hash_table_ref_2, hash_table_2,
format_f, format_allg_no_column, format_just_control_string, format_as_objstr,
memq_2, memq_3, memq_4, memq_any, tree_set_memq_syms, read_line_uncopied, simple_inlet,
- lint_let_ref, lint_let_set, or_n, or_2, or_3, and_n, and_2, and_3, if_a_a, if_a_aa, if_not_a_a,
- if_not_a_aa, if_a_qq, if_a_qa, or_s, and_s, geq_2, or_s_2, and_s_2, or_s_type_2;
+ lint_let_ref, lint_let_set, geq_2, add_i_random, is_defined_in_rootlet;
#if (!WITH_GMP)
s7_pointer multiply_2, invert_1, divide_1r, divide_2, divide_by_2,
@@ -1371,7 +1368,6 @@ static void reset_opts(s7_scheme *sc)
{
int32_t k;
o = sc->opts[i];
- o->size = 0;
o->slots = 0;
for (k = 0; k < NUM_VUNIONS; k++)
{
@@ -1517,21 +1513,21 @@ static inline block_t *mallocate_block(s7_scheme *sc)
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_next(p) = NULL;
+ /* block_next(p) = NULL; */
block_index(p) = BLOCK_LIST;
return(p);
}
static inline char *alloc_permanent_string(s7_scheme *sc, size_t len)
{
- #define ALLOC_STRING_SIZE 32768
- #define ALLOC_MAX_STRING 256
+ #define ALLOC_STRING_SIZE 65536 /* 32768 -- current size is probably still too small, but the timing tests don't seem to care */
+ #define ALLOC_MAX_STRING 512 /* 256 -- sets max size of block space lost at the end (1/2 size I think), 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 (next_k > ALLOC_STRING_SIZE) /* was >= */
{
if (len >= ALLOC_MAX_STRING)
{
@@ -1543,6 +1539,7 @@ static inline char *alloc_permanent_string(s7_scheme *sc, size_t len)
#if S7_DEBUGGING
permanent_string_len += ALLOC_STRING_SIZE;
#endif
+ /* fprintf(stderr, "new heap: %ld lost\n", ALLOC_STRING_SIZE - sc->alloc_string_k); */
sc->alloc_string_cells = (char *)malloc(ALLOC_STRING_SIZE);
sc->alloc_string_k = 0;
next_k = len;
@@ -1575,7 +1572,7 @@ static inline block_t *mallocate(s7_scheme *sc, size_t bytes)
if (p)
{
sc->block_lists[index] = (block_t *)block_next(p);
- block_next(p) = NULL;
+ /* block_next(p) = NULL; */
}
else
{
@@ -1629,7 +1626,7 @@ static s7_pointer too_many_arguments_string, not_enough_arguments_string, missin
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,
+ something_applicable_string, too_many_indices_string, value_is_missing_string, no_setter_string,
format_string_1, format_string_2, format_string_3, format_string_4;
static bool t_number_p[NUM_TYPES], t_real_p[NUM_TYPES], t_rational_p[NUM_TYPES], t_big_number_p[NUM_TYPES];
@@ -1928,7 +1925,8 @@ static void init_types(void)
#define T_Ivc(P) check_ref(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL)
#define T_Nvc(P) check_ref(P, T_VECTOR, __func__, __LINE__, "sweep", NULL)
#define T_Sym(P) check_ref(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table")
- #define T_Fst(P) check_ref(P, T_C_FUNCTION_STAR, __func__, __LINE__, "sweep", NULL)
+ #define T_Fst(P) check_ref(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL)
+ #define T_Pcs(P) check_ref2(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL)
#define T_Prt(P) check_ref3(P, __func__, __LINE__) /* input|output_port */
#define T_Vec(P) check_ref4(P, __func__, __LINE__) /* any vector */
#define T_SVec(P) check_ref13(P, __func__, __LINE__) /* subvector */
@@ -1983,6 +1981,7 @@ static void init_types(void)
#define T_Fnc(P) P
#define T_Prc(P) P
#define T_Fst(P) P
+ #define T_Pcs(P) P
#define T_Slt(P) P
#define T_Sln(P) P
#define T_Sld(P) P
@@ -2158,7 +2157,6 @@ static void init_types(void)
BOLD_TEXT, s7_object_to_c_string(sc, symbol), UNBOLD_TEXT,
s7_object_to_c_string(sc, sc->cur_code));
typeflag(symbol) = (typeflag(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));
-
}
#define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__)
#else
@@ -2218,9 +2216,9 @@ static void init_types(void)
/* marks a let that is the argument to with-let */
#define T_SIMPLE_DEFAULTS T_LINE_NUMBER
-#define c_func_has_simple_defaults(p) has_type_bit(T_Fnc(p), T_SIMPLE_DEFAULTS)
-#define c_func_set_simple_defaults(p) set_type_bit(T_Fnc(p), T_SIMPLE_DEFAULTS)
-#define c_func_clear_simple_defaults(p) clear_type_bit(T_Fnc(p), T_SIMPLE_DEFAULTS)
+#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_LINE_NUMBER
@@ -2301,7 +2299,7 @@ static void init_types(void)
#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)
-/* these mark objects that have been removed from the heap or checked for that possibility */
+/* 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)
@@ -2448,6 +2446,10 @@ static void init_types(void)
#define set_slots_set(p) set_type1_bit(T_Let(p), T_SLOTS_SET)
#define clear_slots_set(p) clear_type1_bit(T_Let(p), T_SLOTS_SET)
+#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)
+
/* symbol free here */
#define T_FULL_HAS_LET_FILE (1LL << (TYPE_BITS + BIT_ROOM + 25))
#define T_HAS_LET_FILE (1 << 1)
@@ -2471,6 +2473,12 @@ static void init_types(void)
#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)
@@ -2491,6 +2499,10 @@ static void init_types(void)
#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 is_definer_or_binder(p) has_type1_bit(T_Sym(p), T_DEFINER | T_BINDER)
@@ -2511,7 +2523,7 @@ static void init_types(void)
#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) (typeflag(T_Pair(p)) & (T_SAFE_CLOSURE | T_VERY_SAFE_CLOSURE))
+#define closure_bits(p) (typeflag(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)
@@ -2537,15 +2549,12 @@ static void init_types(void)
#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_CTR3_SET T_SIMPLE_ELEMENTS
-#define ctr3_is_set(p) has_type1_bit(T_Pair(p), T_CTR3_SET)
-#define set_ctr3_is_set(p) do {set_type1_bit(T_Pair(p), T_CTR3_SET); clear_type_bit(p, T_LINE_NUMBER);} while (0)
-
#define T_SAFE_SETTER T_SIMPLE_ELEMENTS
#define is_safe_setter(p) has_type1_bit(T_Sym(p), T_SAFE_SETTER)
#define set_safe_setter(p) set_type1_bit(T_Sym(p), T_SAFE_SETTER)
@@ -2590,8 +2599,6 @@ static void init_types(void)
#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))))
-#define raw_opt1(p) ((p)->object.cons.opt1)
-
#if (!S7_DEBUGGING)
#define opt1(p, r) ((p)->object.cons.opt1)
#define set_opt1(p, x, r) (p)->object.cons.opt1 = x
@@ -2627,7 +2634,7 @@ static void init_types(void)
#define E_SET (1 << 0)
#define E_FAST (1 << 8) /* fast list in member/assoc circular list check */
#define E_CFUNC (1 << 9) /* c-function */
-#define E_CLAUSE (1 << 10) /* case clause */
+#define E_CLAUSE (1 << 10) /* case clause */
#define E_LAMBDA (1 << 11) /* lambda(*) */
#define E_SYM (1 << 12) /* symbol */
#define E_PAIR (1 << 13) /* pair */
@@ -2667,9 +2674,9 @@ static void init_types(void)
#define G_DIRECT (1 << 6) /* direct call info */
#define G_ANY (1 << 29)
#define G_LET (1 << 17) /* let or #f */
-#define G_CTR (1 << 30)
+/* #define G_CTR (1 << 30) */
#define G_BYTE 0x80000000 /* not (1LL < 31) ! */
-#define G_MASK (G_ARGLEN | G_SYM | G_AND | G_ANY | G_LET | G_CTR | G_BYTE | S_LINE | S_LEN | G_DIRECT)
+#define G_MASK (G_ARGLEN | G_SYM | G_AND | G_ANY | G_LET | G_BYTE | S_LINE | S_LEN | G_DIRECT)
#define opt3_is_set(p) (((p)->debugger_bits & G_SET) != 0)
#define set_opt3_is_set(p) (p)->debugger_bits |= G_SET
@@ -2749,15 +2756,9 @@ static void init_types(void)
#if S7_DEBUGGING
#define opt3_byte(p) opt3_byte_1(T_Pair(p), G_BYTE, __func__, __LINE__)
#define set_opt3_byte(p, x) set_opt3_byte_1(T_Pair(p), x, G_BYTE, __func__, __LINE__)
-#define opt3_ctr(p) opt3_ctr_1(T_Pair(p), G_CTR, __func__, __LINE__)
-#define set_opt3_ctr(p, x) set_opt3_ctr_1(T_Pair(p), x, G_CTR, __func__, __LINE__)
-#define increment_opt3_ctr(p) increment_opt3_ctr_1(T_Pair(p), G_CTR, __func__, __LINE__)
#else
#define opt3_byte(P) T_Pair(P)->object.cons_ext.ce.opt_type /* op_if_is_type */
#define set_opt3_byte(P, X) do {T_Pair(P)->object.cons_ext.ce.opt_type = X; clear_type_bit(P, T_LINE_NUMBER);} while (0)
-#define opt3_ctr(P) T_Pair(P)->object.cons_ext.ce.ctr
-#define set_opt3_ctr(P, X) do {T_Pair(P)->object.cons_ext.ce.ctr = X; clear_type_bit(P, T_LINE_NUMBER); set_ctr3_is_set(P);} while(0)
-#define increment_opt3_ctr(P) do {if (ctr3_is_set(P)) P->object.cons_ext.ce.ctr++; else set_opt3_ctr(P, 0);} while (0)
#endif
#define c_callee(f) ((s7_function)opt2(f, F_CALL))
@@ -3126,20 +3127,22 @@ static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p))
#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_output_function(p) port_port(p)->output_function /* these two are for function ports */
-#define port_input_function(p) port_port(p)->input_function
-#define port_original_input_string(p) port_port(p)->orig_str
-#define port_read_character(p) port_port(p)->read_character
-#define port_read_line(p) port_port(p)->read_line
-#define port_display(p) port_port(p)->display
-#define port_write_character(p) port_port(p)->write_character
-#define port_write_string(p) port_port(p)->write_string
-#define port_read_semicolon(p) port_port(p)->read_semicolon
-#define port_read_white_space(p) port_port(p)->read_white_space
-#define port_read_name(p) port_port(p)->read_name
-#define port_read_sharp(p) port_port(p)->read_sharp
#define port_gc_loc(p) port_port(p)->gc_loc
#define port_needs_unprotect(p) port_port(p)->needs_unprotect
+#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_input_function(p) port_port(p)->input_function
+
+#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->display
+#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)
@@ -3513,7 +3516,7 @@ static void try_to_call_gc(s7_scheme *sc);
#define new_cell(Sc, Obj, Type) \
do { \
- if (Sc->free_heap_top <= Sc->free_heap_trigger) {if (show_gc_stats(Sc)) fprintf(stderr, "%s[%d]: gc\n", __func__, __LINE__); try_to_call_gc(Sc);} \
+ if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \
Obj = (*(--(Sc->free_heap_top))); \
Obj->debugger_bits = 0; Obj->opt1_func = NULL; Obj->opt2_func = NULL; Obj->opt3_func = NULL; \
set_type(Obj, Type); \
@@ -3617,13 +3620,8 @@ 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);
-#if 0
- while (*tmp++) {};
- return(tmp - str - 1);
-#else
for (; *tmp; ++tmp);
return(tmp - str);
-#endif
}
static char *copy_string_with_length(const char *str, s7_int len)
@@ -3633,7 +3631,7 @@ static char *copy_string_with_length(const char *str, s7_int len)
if ((len <= 0) || (!str))
fprintf(stderr, "%s[%d]: len: %" print_s7_int ", str: %s\n", __func__, __LINE__, len, str);
#endif
- newstr = (char *)malloc((len + 1) * sizeof(char));
+ newstr = (char *)malloc(len + 1);
if (len != 0)
memcpy((void *)newstr, (void *)str, len);
newstr[len] = '\0';
@@ -3854,12 +3852,12 @@ static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointe
/* ---------------- evaluator ops ---------------- */
/* C=constant, S=symbol, A=fx-callable, Q=quote, D=list of constants, FX=list of A's */
-enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_protect used below as boundary marker (is_h_optimized etc) */
+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_D, HOP_SAFE_C_D, 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_SCC, HOP_SAFE_C_SCC, OP_SAFE_C_CSC, HOP_SAFE_C_CSC, OP_SAFE_C_CCS, HOP_SAFE_C_CCS,
OP_SAFE_C_ALL_S, HOP_SAFE_C_ALL_S,
OP_SAFE_C_opDq, HOP_SAFE_C_opDq, OP_SAFE_C_opSq, HOP_SAFE_C_opSq,
OP_SAFE_C_opSSq, HOP_SAFE_C_opSSq, OP_SAFE_C_opSCq, HOP_SAFE_C_opSCq,
@@ -3872,7 +3870,6 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_SAFE_C_C_opCSq, HOP_SAFE_C_C_opCSq, OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C,
OP_SAFE_C_S_opDq, HOP_SAFE_C_S_opDq, OP_SAFE_C_opSSq_C, HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq,
OP_SAFE_C_C_opDq, HOP_SAFE_C_C_opDq, OP_SAFE_C_opDq_S, HOP_SAFE_C_opDq_S,
- OP_SAFE_C_opDq_opDq, HOP_SAFE_C_opDq_opDq, OP_SAFE_C_opDq_C, HOP_SAFE_C_opDq_C,
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,
@@ -3887,17 +3884,18 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_SAFE_C_op_opSq_q, HOP_SAFE_C_op_opSq_q,
OP_SAFE_C_op_S_opSq_q, HOP_SAFE_C_op_S_opSq_q, OP_SAFE_C_op_opSq_S_q, HOP_SAFE_C_op_opSq_S_q,
OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS,
- OP_SAFE_C_SSSC, HOP_SAFE_C_SSSC,
- OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA,
+ OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, 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_FX, HOP_SAFE_C_FX, 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_CSA, HOP_SAFE_C_CSA, OP_SAFE_C_SCA, HOP_SAFE_C_SCA, OP_SAFE_C_CAC, HOP_SAFE_C_CAC,
+ OP_SAFE_C_CSA, HOP_SAFE_C_CSA, OP_SAFE_C_SCA, HOP_SAFE_C_SCA,
+ OP_SAFE_C_CAC, HOP_SAFE_C_CAC, /* OP_SAFE_C_CCA, HOP_SAFE_C_CCA, */
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_FX, HOP_SAFE_C_STAR_FX,
+ OP_SAFE_C_FUNCTION_STAR, HOP_SAFE_C_FUNCTION_STAR, OP_SAFE_C_FUNCTION_STAR_A, HOP_SAFE_C_FUNCTION_STAR_A,
+ OP_SAFE_C_FUNCTION_STAR_AA, HOP_SAFE_C_FUNCTION_STAR_AA, OP_SAFE_C_FUNCTION_STAR_FX, HOP_SAFE_C_FUNCTION_STAR_FX,
OP_SAFE_C_P, HOP_SAFE_C_P,
OP_THUNK, HOP_THUNK, OP_THUNK_P, HOP_THUNK_P, OP_THUNK_NIL, HOP_THUNK_NIL,
@@ -3905,15 +3903,13 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_S_P, HOP_CLOSURE_S_P,
OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_S_P, HOP_SAFE_CLOSURE_S_P, 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_S, HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC, HOP_SAFE_CLOSURE_S_TO_SC,
OP_CLOSURE_C, HOP_CLOSURE_C, OP_CLOSURE_C_P, HOP_CLOSURE_C_P,
OP_SAFE_CLOSURE_C, HOP_SAFE_CLOSURE_C, OP_SAFE_CLOSURE_C_P, HOP_SAFE_CLOSURE_C_P, OP_SAFE_CLOSURE_C_A, HOP_SAFE_CLOSURE_C_A,
-
+ OP_SAFE_CLOSURE_ID_S, HOP_SAFE_CLOSURE_ID_S,
OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_P, HOP_CLOSURE_A_P,
OP_SAFE_CLOSURE_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_A_P, HOP_SAFE_CLOSURE_A_P, OP_SAFE_CLOSURE_A_A, HOP_SAFE_CLOSURE_A_A,
-
OP_CLOSURE_P, HOP_CLOSURE_P, OP_SAFE_CLOSURE_P, HOP_SAFE_CLOSURE_P,
-
OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA,
OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, HOP_SAFE_CLOSURE_PA,
OP_CLOSURE_FA, HOP_CLOSURE_FA,
@@ -3957,7 +3953,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_SAFE_C_SSP, HOP_SAFE_C_SSP, OP_SAFE_C_FP, HOP_SAFE_C_FP,
/* end of h_opts */
- OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, OP_SAFE_IFA_SS_A, OP_MACRO_D,
+ OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, OP_opIF_A_SSq_A, OP_MACRO_D, OP_MACRO_STAR_D,
OP_S, OP_S_S, OP_S_C, OP_S_A, OP_C_FA_1, OP_S_AA,
OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A,
OP_IMPLICIT_ITERATE, OP_IMPLICIT_CONTINUATION_A, OP_IMPLICIT_VECTOR_REF_A, OP_IMPLICIT_VECTOR_REF_AA, OP_IMPLICIT_STRING_REF_A,
@@ -3965,8 +3961,8 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_IMPLICIT_S7_LET_REF, OP_IMPLICIT_VECTOR_SET_3, OP_IMPLICIT_VECTOR_SET_4,
OP_UNKNOWN, OP_UNKNOWN_ALL_S, OP_UNKNOWN_FX, OP_UNKNOWN_G, OP_UNKNOWN_GG, OP_UNKNOWN_A, OP_UNKNOWN_AA,
- OP_SYM, OP_GLOBAL_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY,
- OP_SSA_DIRECT, OP_SAFE_C_TUS,
+ OP_SYM, OP_GLOBAL_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_UNSPECIFIED,
+ OP_SSA_DIRECT, OP_HASH_INCREMENT, OP_SAFE_C_TUS,
OP_READ_INTERNAL, OP_EVAL,
OP_EVAL_ARGS, OP_EVAL_ARGS1, OP_EVAL_ARGS2, OP_EVAL_ARGS3, OP_EVAL_ARGS4, OP_EVAL_ARGS5,
@@ -3978,7 +3974,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
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_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE, OP_COND_SIMPLE_P, OP_COND1_SIMPLE_P,
+ OP_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE, OP_COND_SIMPLE_P, OP_COND1_SIMPLE_P,
OP_AND, OP_OR,
OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION, OP_DEFINE_EXPANSION_STAR,
OP_CASE,
@@ -4005,7 +4001,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
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_WITH_SETTER, OP_SET_PWS, OP_SET_LET_S, OP_SET_LET_FX, OP_SET_SAFE,
+ OP_SET_PAIR_P_1, OP_SET_FROM_SETTER, OP_SET_PWS, OP_SET_LET_S, OP_SET_LET_FX, OP_SET_SAFE,
OP_INCREMENT_1, OP_DECREMENT_1, OP_SET_CONS,
OP_INCREMENT_SS, OP_INCREMENT_SP, OP_INCREMENT_SA, OP_INCREMENT_SAA,
@@ -4027,31 +4023,34 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
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_SAFE_AA, OP_AND_PAIR_P,
- OP_AND_SAFE_P, OP_AND_SAFE_P1, OP_AND_SAFE_P2, OP_AND_SAFE_P3, OP_AND_SAFE_P_REST,
- OP_OR_P, OP_OR_P1, OP_OR_AP,
- OP_OR_SAFE_AA,
+ OP_AND_SAFE_P1, OP_AND_SAFE_P2, OP_AND_SAFE_P3, OP_AND_SAFE_P_REST, OP_AND_2, OP_AND_3, OP_AND_N, OP_AND_S_2,
+ OP_OR_P, OP_OR_P1, OP_OR_AP, OP_OR_SAFE_AA, OP_OR_2, OP_OR_3, OP_OR_N, OP_OR_S_2, OP_OR_S_TYPE_2,
OP_COND_FEED, OP_COND_FEED_1,
- OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P,
+ OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2, OP_WHEN_AND_3, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P,
+
+ OP_IF_A_CC, OP_IF_A_A, OP_IF_A_AA, OP_IF_NOT_A_A, OP_IF_NOT_A_AA,
+ OP_IF_A_A_P, OP_IF_S_P_A, OP_IF_IS_TYPE_S_P_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_PPP, OP_IF_PP, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP,
+ OP_IF_PP, OP_IF_PPP, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP,
- OP_COND_FX, OP_COND_FX_2, OP_COND_FX_P, OP_COND_FX_1P_ELSE, OP_COND_FX_2P_ELSE,
+ OP_COND_FX_FX, OP_COND_FX_FP, OP_COND_FX_FP_1, OP_COND_FX_2E, OP_COND_FX_3E,
OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, OP_SAFE_DOTIMES_STEP_P,
OP_SAFE_DO, OP_SAFE_DO_STEP, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_P, OP_DOX_NO_BODY, OP_DOX_PENDING_NO_BODY, OP_DOX_INIT,
OP_DOTIMES_P, OP_DOTIMES_STEP_P,
- OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1,
+ 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_SP_1, OP_SAFE_C_SP_MV, OP_SAFE_CONS_SP_1, OP_SAFE_MEMQ_SP_1, OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, OP_SAFE_SUBTRACT_SP_1,
+ OP_SAFE_C_SP_1, OP_SAFE_C_SP_MV, OP_SAFE_CONS_SP_1, OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, OP_SAFE_SUBTRACT_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_SAFE_CLOSURE_P_1, OP_CLOSURE_P_1, OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_FP_1, OP_SAFE_CLOSURE_FP_MV_1,
@@ -4099,7 +4098,7 @@ static const char* op_names[NUM_OPS] =
"safe_c_d", "h_safe_c_d", "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_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc", "safe_c_ccs", "h_safe_c_ccs",
"safe_c_all_s", "h_safe_c_all_s",
"safe_c_opdq", "h_safe_c_opdq", "safe_c_opsq", "h_safe_c_opsq",
"safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq",
@@ -4112,7 +4111,6 @@ static const char* op_names[NUM_OPS] =
"safe_c_c_opcsq", "h_safe_c_c_opcsq", "safe_c_opcsq_c", "h_safe_c_opcsq_c",
"safe_c_s_opdq", "h_safe_c_s_opdq", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq",
"safe_c_c_opdq", "h_safe_c_c_opdq", "safe_c_opdq_s", "h_safe_c_opdq_s",
- "safe_c_opdq_opdq", "h_safe_c_opdq_opdq", "safe_c_opdq_c", "h_safe_c_opdq_c",
"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",
@@ -4127,9 +4125,8 @@ static const char* op_names[NUM_OPS] =
"safe_c_op_opsq_q", "h_safe_c_op_opsq_q",
"safe_c_op_s_opsq_q", "h_safe_c_op_s_opsq_q", "safe_c_op_opsq_s_q", "h_safe_c_op_opsq_s_q",
"safe_c_opsq_cs", "h_safe_c_opsq_cs",
- "safe_c_sssc", "h_safe_c_sssc",
- "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa",
+ "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "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_fx", "h_safe_c_fx", "safe_c_all_ca", "h_safe_c_all_ca",
"safe_c_ssa", "h_safe_c_ssa", "safe_c_sas", "h_safe_c_sas",
@@ -4137,7 +4134,8 @@ static const char* op_names[NUM_OPS] =
"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*", "h_safe_c*", "safe_c*_a", "h_safe_c*_a", "safe_c*_aa", "h_safe_c*_aa", "safe_c*_fx", "h_safe_c*_fx",
+ "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_p", "h_thunk_p", "thunk_nil", "h_thunk_nil",
@@ -4145,13 +4143,12 @@ static const char* op_names[NUM_OPS] =
"closure_s", "h_closure_s", "closure_s_p", "h_closure_s_p",
"safe_closure_s", "h_safe_closure_s", "safe_closure_s_p", "h_safe_closure_s_p", "safe_closure_s_a", "h_safe_closure_s_a",
- "safe_closure_s_to_s", "h_safe_closure_s_to_s",
+ "safe_closure_s_to_s", "h_safe_closure_s_to_s", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc",
"closure_c", "h_closure_c", "closure_c_p", "h_closure_c_p",
"safe_closure_c", "h_safe_closure_c", "safe_closure_c_p", "h_safe_closure_c_p", "safe_closure_c_a", "h_safe_closure_c_a",
-
+ "safe_closure_id_s", "h_safe_closure_id_s",
"closure_a", "h_closure_a", "closure_a_p", "h_closure_a_p",
"safe_closure_a", "h_safe_closure_a", "safe_closure_a_p", "h_safe_closure_a_p", "safe_closure_a_a", "h_safe_closure_a_a",
-
"closure_p", "h_closure_p", "safe_closure_p", "h_safe_closure_p",
"closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa",
"safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa",
@@ -4194,7 +4191,7 @@ static const char* op_names[NUM_OPS] =
"safe_c_ps", "h_safe_c_ps", "safe_c_pc", "h_safe_c_pc",
"safe_c_ssp", "h_safe_c_ssp", "safe_c_fp", "h_safe_c_fp",
- "apply_ss", "apply_sa", "apply_sl", "safe_ifa_ss_a", "macro_d",
+ "apply_ss", "apply_sa", "apply_sl", "safe_ifa_ss_a", "macro_d", "macro*_d",
"s", "s_s", "s_c", "s_a", "c_fa_1", "s_aa",
"implicit_goto", "implicit_goto_a",
"implicit_iterate", "implicit_continuation_a", "implicit_vector_ref_a", "implicit_vector_ref_aa", "implicit_string_ref_a",
@@ -4202,8 +4199,8 @@ static const char* op_names[NUM_OPS] =
"implicit_*s7*_ref", "implicit_vector_set_3", "implicit_vector_set_4",
"unknown", "unknown_all_s", "unknown_fx", "unknown_g", "unknown_gg", "unknown_a", "unknown_aa",
- "symbol", "global-symbol", "constant", "pair_sym", "pair_pair", "pair_any",
- "ssa_direct", "safe_c_tus",
+ "symbol", "global-symbol", "constant", "pair_sym", "pair_pair", "pair_any", "unspec",
+ "ssa_direct", "hash_incrment", "safe_c_tus",
"read_internal", "eval",
"eval_args", "eval_args1", "eval_args2", "eval_args3", "eval_args4", "eval_args5",
@@ -4215,7 +4212,7 @@ static const char* op_names[NUM_OPS] =
"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",
- "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", "cond_simple_p", "cond1_simple_p",
+ "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", "cond_simple_p", "cond1_simple_p",
"and", "or",
"define_macro", "define_macro*", "define_expansion", "define_expansion*",
"case", "read_list", "read_next", "read_dot", "read_quote",
@@ -4261,31 +4258,34 @@ static const char* op_names[NUM_OPS] =
"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_safe_aa", "and_pair_p",
- "and_safe_p", "and_safe_p1", "op_and_safe_p2", "and_safe_p3", "and_safe_p_rest",
- "or_p", "or_p1", "or_ap",
- "or_safe_aa",
+ "and_safe_p1", "op_and_safe_p2", "and_safe_p3", "and_safe_p_rest", "and_2", "and_3", "and_n", "and_s_2",
+ "or_p", "or_p1", "or_ap", "or_safe_aa", "or_2", "or_3", "or_n", "or_s_2", "or_s_type_2",
"cond_feed", "cond_feed_1",
- "when_s", "when_a", "when_p", "when_and_ap", "unless_s", "unless_a", "unless_p",
+ "when_s", "when_a", "when_p", "when_and_ap", "when_and_2", "when_and_3", "unless_s", "unless_a", "unless_p",
+
+ "if_a_cc", "if_a_a", "if_a_aa", "if_not_a_a", "if_not_a_aa",
+ "if_a_a_p", "if_s_p_a", "if_is_type_s_p_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_ppp", "if_pp", "if_pr", "if_prr", "when_pp", "unless_pp",
+ "if_pp", "if_ppp", "if_pr", "if_prr", "when_pp", "unless_pp",
- "cond_fx", "cond_fx_2", "cond_fx_p", "cond_fx_1p_else", "cond_fx_2p_else",
+ "cond_fx_fx", "cond_fx_fp", "cond_fx_fp_1", "cond_fx_2e", "cond_fx_3e",
"simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_p",
"safe_do", "safe_do_step", "dox", "dox_step", "dox_step_p", "dox_no_body", "dox_pending_no_body", "dox_init",
"dotimes_p", "dotimes_step_p",
- "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1",
+ "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_sp_1", "safe_c_sp_mv", "safe_cons_sp_1", "safe_memq_sp_1", "safe_add_sp_1", "safe_multiply_sp_1", "safe_subtract_sp_1",
+ "safe_c_sp_1", "safe_c_sp_mv", "safe_cons_sp_1", "safe_add_sp_1", "safe_multiply_sp_1", "safe_subtract_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",
"safe_closure_p_1", "closure_p_1", "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_fp_1", "safe_closure_fp_mv_1",
@@ -4320,12 +4320,13 @@ static const char* op_names[NUM_OPS] =
};
#endif
+
#define in_reader(Sc) ((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE) && (is_input_port(Sc->input_port)))
#define is_safe_c_op(op) ((op >= OP_SAFE_C_D) && (op < OP_THUNK))
#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_AA))
-#define is_h_safe_c_d(P) ((is_optimized(P)) && (optimize_op(P) >= HOP_SAFE_C_D) && (optimize_op(P) < OP_SAFE_C_S) && ((optimize_op(P) & 1) != 0))
-#define is_safe_c_s(P) ((optimize_op(P) == OP_SAFE_C_S) || (optimize_op(P) == HOP_SAFE_C_S))
-#define is_h_safe_c_s(P) (optimize_op(P) == HOP_SAFE_C_S)
+#define is_h_safe_c_d(P) (optimize_op(P) == HOP_SAFE_C_D)
+#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)
static bool is_h_optimized(s7_pointer p)
{
@@ -4896,6 +4897,38 @@ static void process_multivector(s7_scheme *sc, s7_pointer s1)
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
+
+ if (port_needs_unprotect(s1))
+ {
+ s7_gc_unprotect_at(sc, port_gc_loc(s1));
+ port_needs_unprotect(s1) = false;
+ }
+ 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 process_input_port(s7_scheme *sc, s7_pointer s1)
{
if (!port_is_closed(s1))
@@ -4918,17 +4951,9 @@ static void process_input_port(s7_scheme *sc, s7_pointer s1)
}
}
}
- if (port_needs_free(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;
- }
+ if (port_needs_free(s1))
+ free_port_data(sc, s1);
+
if (port_filename(s1))
{
liberate(sc, port_filename_block(s1));
@@ -4954,11 +4979,7 @@ static void process_output_port(s7_scheme *sc, s7_pointer s1)
static void process_continuation(s7_scheme *sc, s7_pointer s1)
{
- if (continuation_op_stack(s1))
- {
- free(continuation_op_stack(s1));
- continuation_op_stack(s1) = NULL;
- }
+ continuation_op_stack(s1) = NULL;
liberate_block(sc, continuation_block(s1));
}
@@ -5032,6 +5053,9 @@ static void sweep(s7_scheme *sc)
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));
@@ -5115,6 +5139,7 @@ static void add_gensym(s7_scheme *sc, s7_pointer 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_unknown(sc, p) add_to_gc_list(sc->unknowns, p)
@@ -5142,6 +5167,7 @@ static void init_gc_caches(s7_scheme *sc)
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();
@@ -5394,12 +5420,10 @@ static void mark_stack(s7_pointer p)
static void mark_continuation(s7_pointer p)
{
- uint32_t i;
set_mark(p);
if (!is_marked(continuation_stack(p))) /* can these be cyclic? */
mark_stack_1(continuation_stack(p), continuation_stack_top(p));
- for (i = 0; i < continuation_op_loc(p); i++)
- gc_mark(continuation_op_stack(p)[i]);
+ gc_mark(continuation_op_stack(p));
}
static void mark_vector(s7_pointer p)
@@ -5781,13 +5805,13 @@ static int64_t gc(s7_scheme *sc)
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(sc->t4_1);
+ 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));
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(sc->u1_1);
+ gc_mark(car(sc->u1_1));
{
s7_pointer p;
@@ -5907,7 +5931,13 @@ static int64_t gc(s7_scheme *sc)
double secs;
gettimeofday(&t0, &z0);
secs = (t0.tv_sec - start_time.tv_sec) + 0.000001 * (t0.tv_usec - start_time.tv_usec);
- s7_warn(sc, 256, "gc freed %" print_s7_int "/%" print_s7_int " (free: %" print_pointer "), time: %f\n", sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), secs);
+#if S7_DEBUGGING
+ s7_warn(sc, 256, "%s[%d]: gc freed %" print_s7_int "/%" print_s7_int " (free: %" print_pointer "), time: %f\n",
+ func, line, sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), secs);
+#else
+ s7_warn(sc, 256, "gc freed %" print_s7_int "/%" print_s7_int " (free: %" print_pointer "), time: %f\n",
+ sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), secs);
+#endif
#else
s7_warn(sc, 128, "gc freed %" print_s7_int "/%" print_s7_int "\n", sc->gc_freed, sc->heap_size);
#endif
@@ -6287,6 +6317,8 @@ static inline void s7_remove_from_heap(s7_scheme *sc, s7_pointer x)
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:
@@ -6642,7 +6674,7 @@ static inline s7_pointer new_symbol(s7_scheme *sc, const char *name, s7_int len,
if (len > 1) /* not 0, otherwise : is a keyword */
{
- if ((name[0] == ':') || (name[len - 1] == ':'))
+ if ((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);
@@ -6658,7 +6690,8 @@ static inline s7_pointer new_symbol(s7_scheme *sc, const char *name, s7_int len,
set_local_slot(x, slot);
}
}
- typeflag(p) = T_PAIR | T_IMMUTABLE | T_UNHEAP;
+
+ typeflag(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;
@@ -8132,7 +8165,7 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_
case T_PAIR:
sym = car(p);
if (!is_symbol(sym))
- return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, a_symbol_string));
+ 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);
@@ -8143,11 +8176,11 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_
continue;
default:
- return(wrong_type_argument_with_type(sc, caller, position_of(x, bindings), p, a_symbol_string));
+ 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, position_of(x, bindings), sym, a_non_constant_symbol_string));
+ 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(slot_value(global_slot(sym)))))
return(wrong_type_argument_with_type(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic name", 20)));
@@ -8464,11 +8497,12 @@ inline s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
return(call_let_ref_fallback(sc, env, symbol));
return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string));
}
-
+
check_method_uncopied(sc, env, sc->let_ref_symbol, list_2(sc, env, 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))
@@ -8563,8 +8597,6 @@ static inline s7_pointer g_lint_let_ref(s7_scheme *sc, s7_pointer args)
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 ((is_h_safe_c_d(expr)) && (raw_opt1(expr) == sc->lint_let_ref))
- return(raw_opt1(expr));
if (optimize_op(expr) == HOP_SAFE_C_opSq_C)
{
@@ -8582,7 +8614,7 @@ static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_
return(f);
}
-static bool op_environment_c(s7_scheme *sc)
+static bool op_implicit_let_ref_c(s7_scheme *sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
@@ -8591,7 +8623,7 @@ static bool op_environment_c(s7_scheme *sc)
return(true);
}
-static bool op_environment_a(s7_scheme *sc)
+static bool op_implicit_let_ref_a(s7_scheme *sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
@@ -9258,8 +9290,7 @@ static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer e
car_p = car(p);
if (is_pair(car_p))
car_p = car(car_p);
- if ((is_symbol(car_p)) &&
- (!is_keyword(car_p)))
+ if (is_normal_symbol(car_p))
sc->w = cons(sc, add_symbol_to_list(sc, car_p), sc->w);
}
if (is_symbol(p)) /* rest arg */
@@ -9290,7 +9321,7 @@ static void clear_all_optimizations(s7_scheme *sc, s7_pointer p)
static s7_pointer make_macro(s7_scheme *sc, opcode_t op)
{
- s7_pointer cx, mac;
+ s7_pointer cx, mac, body;
uint64_t typ;
if (op == OP_DEFINE_MACRO)
@@ -9325,12 +9356,13 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op)
new_cell_no_check(sc, mac, typ);
sc->temp6 = mac;
closure_set_args(mac, cdar(sc->code));
- closure_set_body(mac, cdr(sc->code));
+ body = cdr(sc->code);
+ closure_set_body(mac, body);
closure_set_setter(mac, sc->F);
closure_set_let(mac, sc->envir);
closure_set_arity(mac, CLOSURE_ARITY_NOT_SET);
-
sc->capture_let_counter++;
+
sc->code = caar(sc->code);
if (((op == OP_DEFINE_EXPANSION) || (op == OP_DEFINE_EXPANSION_STAR)) &&
(!is_let(sc->envir)))
@@ -9340,10 +9372,18 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op)
if (is_slot(cx))
slot_set_value_with_hook(cx, mac);
else s7_make_slot(sc, sc->envir, sc->code, mac); /* was current but we've checked immutable already */
-
+
clear_symbol_list(sc); /* tracks names local to this macro */
- if (optimize(sc, closure_body(mac), 1, collect_parameters(sc, closure_args(mac), sc->nil)) == OPT_OOPS)
- clear_all_optimizations(sc, closure_body(mac));
+ if (optimize(sc, body, 1, collect_parameters(sc, closure_args(mac), sc->nil)) == OPT_OOPS)
+ clear_all_optimizations(sc, body);
+
+ if ((is_pair(car(body))) && /* a desperate kludge -- need something better here! */
+ (is_pair(cdar(body))) &&
+ (is_pair(cadar(body))) &&
+ (caadar(body) == sc->quote_symbol) &&
+ (is_symbol(cadr(cadar(body)))) &&
+ (is_definer(cadr(cadar(body)))))
+ set_is_definer(sc->code);
sc->temp6 = sc->nil;
return(mac);
@@ -9622,6 +9662,32 @@ static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, is_slot(symbol_to_slot(sc, sym))));
}
+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;
+ e = caddr(expr);
+ if ((is_pair(e)) && (is_null(cdr(e))) && (car(e) == sc->rootlet_symbol))
+ {
+ set_safe_optimize_op(expr, HOP_SAFE_C_D);
+ return(sc->is_defined_in_rootlet);
+ }
+ }
+ return(f);
+}
+
bool s7_is_defined(s7_scheme *sc, const char *name)
{
s7_pointer x;
@@ -9643,6 +9709,7 @@ static bool is_defined_b_7p(s7_scheme *sc, s7_pointer p)
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 envir, s7_pointer symbol, s7_pointer value)
{
s7_pointer x;
@@ -10101,17 +10168,18 @@ static s7_pointer copy_stack(s7_scheme *sc, s7_pointer old_v, int64_t top)
if (len < CC_INITIAL_STACK_SIZE)
len = CC_INITIAL_STACK_SIZE;
}
+
+ if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8))
+ {
+ int64_t freed_heap;
#if S7_DEBUGGING
- if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 4)) gc(sc, __func__, __LINE__);
+ freed_heap = gc(sc, __func__, __LINE__);
#else
- if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 4)) gc(sc);
+ freed_heap = gc(sc);
#endif
- /* this gc call is needed if there are lots of call/cc's -- by pure bad luck
- * we can end up hitting the end of the gc free list time after time while
- * in successive copy_stack's below, causing s7 to core up until it runs out of memory.
- * It seems like it would make more sense to use len*32 or something similar as the
- * trigger, but that was slower in my timing tests!?
- */
+ if (freed_heap < (int64_t)(sc->heap_size / 8))
+ resize_heap(sc);
+ }
new_v = make_simple_vector(sc, len);
set_type(new_v, T_STACK);
@@ -10129,7 +10197,14 @@ static s7_pointer copy_stack(s7_scheme *sc, s7_pointer old_v, int64_t top)
p = ov[i]; /* args */
if (is_pair(p)) /* args need not be a list (it can be a port or #f, etc) */
{
- nv[i] = protected_list_copy(sc, p); /* args (copy is needed -- see s7test.scm) */
+ if (is_null(cdr(p)))
+ nv[i] = list_1(sc, car(p));
+ else
+ {
+ if ((is_pair(cdr(p))) && (is_null(cddr(p))))
+ nv[i] = list_2(sc, car(p), cadr(p));
+ else nv[i] = protected_list_copy(sc, p); /* args (copy is needed -- see s7test.scm) */
+ }
set_type(nv[i], (typeflag(p) & (~T_COLLECTED))); /* carry over T_IMMUTABLE */
}
/* lst can be dotted or circular here. The circular list only happens in a case like:
@@ -10155,15 +10230,22 @@ static inline s7_pointer make_goto(s7_scheme *sc)
return(x);
}
-static s7_pointer *copy_op_stack(s7_scheme *sc)
+static s7_pointer copy_op_stack(s7_scheme *sc)
{
+ s7_pointer nv;
int32_t len;
- s7_pointer *ops;
- ops = (s7_pointer *)malloc(sc->op_stack_size * sizeof(s7_pointer));
+
len = (int32_t)(sc->op_stack_now - sc->op_stack);
+ nv = make_simple_vector(sc, len); /* not sc->op_stack_size */
if (len > 0)
- memcpy((void *)ops, (void *)(sc->op_stack), len * sizeof(s7_pointer));
- return(ops);
+ {
+ 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 . body) calls body guaranteeing that there can be no jumps into the
@@ -10238,7 +10320,7 @@ s7_pointer s7_make_continuation(s7_scheme *sc)
continuation_stack_size(x) = vector_length(continuation_stack(x)); /* copy_stack can return a smaller stack than the current one */
continuation_stack_start(x) = stack_elements(continuation_stack(x));
continuation_stack_end(x) = (s7_pointer *)(continuation_stack_start(x) + loc);
- continuation_op_stack(x) = copy_op_stack(sc); /* no heap allocation here */
+ continuation_op_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);
@@ -10249,7 +10331,7 @@ s7_pointer s7_make_continuation(s7_scheme *sc)
}
static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_pointer let);
-static void op_let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value);
+static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value);
static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c)
{
@@ -10305,7 +10387,7 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c)
break;
case OP_LET_TEMP_UNWIND:
- op_let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i));
+ let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i));
break;
case OP_LET_TEMP_S7_UNWIND:
@@ -10384,12 +10466,16 @@ static bool call_with_current_continuation(s7_scheme *sc)
{
int32_t i, top;
+ s7_pointer *src, *dst;
+
top = continuation_op_loc(c);
sc->op_stack_now = (s7_pointer *)(sc->op_stack + top);
sc->op_stack_size = continuation_op_size(c);
sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
- for (i = 0; i < top; i++)
- sc->op_stack[i] = continuation_op_stack(c)[i];
+
+ 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))
@@ -10438,7 +10524,7 @@ static void apply_continuation(s7_scheme *sc)
set_elist_1(sc, wrap_string(sc, "continuation can't jump into with-baffle", 40)));
}
-static bool op_continuation_a(s7_scheme *sc)
+static bool op_implicit_continuation_a(s7_scheme *sc)
{
s7_pointer s, code;
code = sc->code;
@@ -10529,7 +10615,7 @@ static void call_with_exit(s7_scheme *sc)
break;
case OP_LET_TEMP_UNWIND:
- op_let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i));
+ let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i));
break;
case OP_LET_TEMP_S7_UNWIND:
@@ -10652,7 +10738,7 @@ static s7_pointer op_call_with_exit_p(s7_scheme *sc)
return(NULL);
}
-static bool op_goto(s7_scheme *sc)
+static bool op_implicit_goto(s7_scheme *sc)
{
set_opt1_goto(sc->code, lookup_checked(sc, car(sc->code)));
if (!is_goto(opt1_goto(sc->code))) return(false);
@@ -10662,7 +10748,7 @@ static bool op_goto(s7_scheme *sc)
return(true);
}
-static bool op_goto_a(s7_scheme *sc)
+static bool op_implicit_goto_a(s7_scheme *sc)
{
set_opt1_goto(sc->code, lookup_checked(sc, car(sc->code)));
if (!is_goto(opt1_goto(sc->code))) return(false);
@@ -11203,8 +11289,6 @@ s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b)
s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b)
{
s7_pointer x;
- /* fprintf(stderr, "%s[%d]: %ld %ld\n", __func__, __LINE__, a, b); */
-
if (b == 0)
return(division_by_zero_error(sc, wrap_string(sc, "make-ratio", 10), set_elist_2(sc, wrap_integer1(sc, a), small_int(0))));
if (a == 0)
@@ -12131,7 +12215,7 @@ static void insert_spaces(s7_scheme *sc, char *src, s7_int width, s7_int len)
if (width >= sc->num_to_str_size)
{
sc->num_to_str_size = width + 1;
- sc->num_to_str = (char *)realloc(sc->num_to_str, sc->num_to_str_size * sizeof(char));
+ sc->num_to_str = (char *)realloc(sc->num_to_str, sc->num_to_str_size);
}
spaces = width - len;
sc->num_to_str[width] = '\0';
@@ -12155,8 +12239,8 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt
if (len > sc->num_to_str_size)
{
if (!sc->num_to_str)
- sc->num_to_str = (char *)malloc(len * sizeof(char));
- else sc->num_to_str = (char *)realloc(sc->num_to_str, len * sizeof(char));
+ sc->num_to_str = (char *)malloc(len);
+ else sc->num_to_str = (char *)realloc(sc->num_to_str, len);
sc->num_to_str_size = len;
}
@@ -12251,15 +12335,35 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt
return(sc->num_to_str);
}
-static char *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) */
+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);
+
+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(obj, radix, width, nlen, P_WRITE));
+ {
+ p = big_number_to_string_with_radix(obj, radix, width, nlen, P_WRITE);
+ b = string_to_block(sc, p, *nlen);
+ free(p);
+ return(b);
+ }
/* 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
@@ -12271,7 +12375,7 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
if (radix == 10)
{
p = number_to_string_base_10(sc, obj, width, precision, float_choice, nlen, P_WRITE);
- return(copy_string_with_length(p, *nlen));
+ return(string_to_block(sc, p, *nlen));
}
switch (type(obj))
@@ -12279,7 +12383,8 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
case T_INTEGER:
{
size_t len1;
- p = (char *)malloc((128 + width) * sizeof(char));
+ 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)
{
@@ -12291,13 +12396,15 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
*nlen = width;
}
else *nlen = len1;
- return(p);
+ return(b);
}
+
case T_RATIO:
{
size_t len1, len2;
str_len = 256 + width;
- p = (char *)malloc(str_len * sizeof(char));
+ 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);
@@ -12317,12 +12424,12 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
x = real(obj);
if (is_NaN(x))
- return(copy_string_with_length("+nan.0", *nlen = 6));
+ return(string_to_block(sc, "+nan.0", *nlen = 6));
if (is_inf(x))
{
if (x < 0.0)
- return(copy_string_with_length("-inf.0", *nlen = 6));
- return(copy_string_with_length("+inf.0", *nlen = 6));
+ return(string_to_block(sc, "-inf.0", *nlen = 6));
+ return(string_to_block(sc, "+inf.0", *nlen = 6));
}
if (x < 0.0)
@@ -12334,23 +12441,24 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
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;
- char *p1;
+ 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 */
- p1 = number_to_string_with_radix(sc, sc->real_wrapper3, radix, width, precision, float_choice, &len);
- p = (char *)malloc((len + 8) * sizeof(char));
+ 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) ? "-" : "", p1, "e", integer_to_string_no_length(sc, ep), NULL);
- free(p1);
- return(p);
+ (*nlen) = catstrs(p, len + 8, (sign) ? "-" : "", (char *)block_data(b), "e", integer_to_string_no_length(sc, ep), NULL);
+ liberate(sc, b);
+ return(b1);
}
int_part = (s7_int)floor(x);
frac_part = x - int_part;
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)
{
@@ -12366,7 +12474,8 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
if (i == 0)
d[i++] = '0';
d[i] = '\0';
- p = (char *)malloc(256 * sizeof(char));
+ b = mallocate(sc, 256);
+ p = (char *)block_data(b);
p[0] = '\0';
len = catstrs(p, 256, (sign) ? "-" : "", n, ".", d, NULL);
str_len = 256;
@@ -12375,17 +12484,20 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
default:
{
- char *n, *d;
- p = (char *)malloc(512 * sizeof(char));
+ block_t *n, *d;
+ char *dp;
real(sc->real_wrapper3) = real_part(obj);
n = number_to_string_with_radix(sc, sc->real_wrapper3, radix, 0, precision, float_choice, &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, &len);
+ dp = (char *)block_data(d);
+ b = mallocate(sc, 512);
+ p = (char *)block_data(b);
p[0] = '\0';
- len = catstrs(p, 512, n, ((d[0] == '+') || (d[0] == '-')) ? "" : "+", d, "i", NULL);
+ len = catstrs(p, 512, (char *)block_data(n), ((dp[0] == '+') || (dp[0] == '-')) ? "" : "+", dp, "i", NULL);
str_len = 512;
- free(n);
- free(d);
+ liberate(sc, n);
+ liberate(sc, d);
}
break;
}
@@ -12396,7 +12508,8 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
if (width >= str_len)
{
str_len = width + 1;
- p = (char *)realloc(p, str_len * sizeof(char));
+ b = reallocate(sc, b, str_len);
+ p = (char *)block_data(b);
}
spaces = width - len;
p[width] = '\0';
@@ -12405,13 +12518,18 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t
(*nlen) = width;
}
else (*nlen) = len;
- return(p);
+ return(b);
}
char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix)
{
s7_int nlen = 0;
- return(number_to_string_with_radix(sc, obj, radix, 0, 20, 'g', &nlen)); /* (log top 10) so we get all the digits in base 10 (??) */
+ 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)
@@ -12440,11 +12558,9 @@ static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args)
if (!s7_is_bignum(x))
#endif
{
- s7_pointer p;
- res = number_to_string_with_radix(sc, x, radix, 0, sc->float_format_precision, 'g', &nlen);
- p = make_string_with_length(sc, res, nlen);
- free(res);
- return(p);
+ 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
@@ -12457,8 +12573,19 @@ static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args)
free(res);
return(p);
}
-#endif
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_print_name(x))
+ {
+ nlen = print_name_length(x);
+ res = (char *)print_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(make_string_with_length(sc, res, nlen));
}
@@ -12486,8 +12613,8 @@ static s7_pointer number_to_string_p_i(s7_scheme *sc, s7_int p)
static s7_pointer number_to_string_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
{
s7_int nlen = 0, radix;
- char *res;
- s7_pointer p;
+ 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))
@@ -12495,10 +12622,9 @@ static s7_pointer number_to_string_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer
radix = s7_integer(p2);
if ((radix < 2) || (radix > 16))
return(out_of_range(sc, sc->number_to_string_symbol, small_int(2), p2, a_valid_radix_string));
- res = number_to_string_with_radix(sc, p1, radix, 0, sc->float_format_precision, 'g', &nlen);
- p = make_string_with_length(sc, res, nlen);
- free(res);
- return(p);
+
+ b = number_to_string_with_radix(sc, p1, radix, 0, sc->float_format_precision, 'g', &nlen);
+ return(block_to_string(sc, b, nlen));
}
@@ -12652,7 +12778,7 @@ static s7_pointer make_unknown(s7_scheme *sc, const char* name)
s7_int len;
new_cell(sc, p, T_UNDEFINED | T_IMMUTABLE);
len = safe_strlen(name);
- newstr = (char *)malloc((len + 2) * sizeof(char)); /* this is a non-permanent unknown */
+ newstr = (char *)malloc(len + 2); /* this is a non-permanent unknown */
newstr[0] = '#';
if (len > 0)
memcpy((void *)(newstr + 1), (void *)name, len);
@@ -12830,14 +12956,11 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow)
if ((multiply_overflow(lval, (s7_int)10, &lval)) ||
(add_overflow(lval, (s7_int)dig, &lval)))
{
- /* fprintf(stderr, "%d %s lval: %ld, %s %d\n", __LINE__, str, lval, tmp, digits[(uint8_t)*tmp]); */
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_int_min);
*overflow = true;
- /* fprintf(stderr, "%d set overflow\n", __LINE__); */
- /* if (lval == s7_int_min) && (digits[(uint8_t)(*tmp++)] > 9)) return(lval); */
return((negative) ? s7_int_min : s7_int_max);
break;
}
@@ -12874,7 +12997,6 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow)
if ((lval == s7_int_min) && (digits[(uint8_t)(*tmp++)] > 9))
return(lval);
*overflow = true;
- /* fprintf(stderr, "%d set overflow\n", __LINE__); */
break;
}
else lval = oval;
@@ -12882,7 +13004,6 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow)
{
if (lval == s7_int_min) return(lval);
*overflow = true;
- /* fprintf(stderr, "%d set overflow\n", __LINE__); */
break;
}
}
@@ -13574,7 +13695,6 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym
s7_int num, den;
num = string_to_integer(q, radix, &overflow);
den = string_to_integer(slash1, radix, &overflow);
- /* fprintf(stderr, "%d %s: %ld %ld\n", __LINE__, q, num, den); */
if (den == 0)
rl = NAN;
else
@@ -13671,7 +13791,6 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym
n = string_to_integer(q, radix, &overflow);
d = string_to_integer(slash1, radix, &overflow);
- /* fprintf(stderr, "%d %s: %ld %ld %d\n", __LINE__, q, n, d, overflow); */
if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */
return(small_int(0));
@@ -16771,19 +16890,19 @@ static s7_pointer g_add_1x(s7_scheme *sc, s7_pointer args)
#if (!WITH_GMP)
static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y)
{
- switch (type(x))
+ if (is_t_integer(x))
{
- case T_INTEGER:
#if HAVE_OVERFLOW_CHECKS
- {
- s7_int val;
- if (add_overflow(integer(x), y, &val))
- return(make_real(sc, (double)integer(x) + (double)y));
- return(make_integer(sc, val));
- }
+ s7_int val;
+ if (add_overflow(integer(x), y, &val))
+ return(make_real(sc, (double)integer(x) + (double)y));
+ return(make_integer(sc, val));
#else
return(make_integer(sc, integer(x) + y));
#endif
+ }
+ switch (type(x))
+ {
case T_RATIO: return(add_ratios_1(sc, numerator(x), denominator(x), y, 1));
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)));
@@ -16791,16 +16910,15 @@ static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y)
return(method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, make_integer(sc, y)), a_number_string, 1));
}
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_REAL: return(make_real(sc, real(x) + y));
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + y, imag_part(x)));
default:
return(method_or_bust_with_type(sc, x, sc->add_symbol, list_2(sc, x, make_real(sc, y)), a_number_string, 1));
@@ -16808,6 +16926,14 @@ static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y)
return(x);
}
+static s7_pointer g_add_i_random(s7_scheme *sc, s7_pointer args)
+{
+ s7_int x, y;
+ x = integer(car(args));
+ y = integer(opt3_any(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! */
+}
+
static s7_pointer g_add_2_ff(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) + real(cadr(args))));}
static s7_pointer g_add_2_ii(s7_scheme *sc, s7_pointer args)
{
@@ -17239,7 +17365,10 @@ static inline s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y
}
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, car(args), add_p_pp(sc, cadr(args), caddr(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)));}
+/* this used to be (- car (+ cadr caddr)) but that messes up (- 0+1e18i 0+1e18i 1+i) -> -1.0
+ * the current way messes up (- 0+1e18i 1+i 0+1e18i), but so does g_subtract, so at least we're internally consistent
+ */
static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x)
{
@@ -17750,7 +17879,7 @@ static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args) {return(multiply_
* how to catch this? (affects * - +)
*/
-static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n, s7_pointer args)
+static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n)
{
switch (type(x))
{
@@ -17777,9 +17906,7 @@ static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n, s7_pointer arg
case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * n, imag_part(x) * n));
default:
/* we can get here from mul_2_xi for example so the non-integer argument might not be a symbol */
- return(method_or_bust_with_type(sc, x, sc->multiply_symbol,
- (s7_is_integer(car(args))) ? list_2(sc, car(args), x) : list_2(sc, x, cadr(args)),
- a_number_string, 1));
+ return(method_or_bust_with_type(sc, x, sc->multiply_symbol, list_2(sc, x, make_integer(sc, n)), a_number_string, 1));
}
return(x);
}
@@ -17814,8 +17941,8 @@ static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args)
}
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)), args));}
-static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, cadr(args), integer(car(args)), 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))));}
@@ -22272,7 +22399,7 @@ static char *make_permanent_c_string(s7_scheme *sc, const char *str)
char *x;
s7_int len;
len = safe_strlen(str);
- x = (char *)alloc_permanent_string(sc, (len + 1) * sizeof(char));
+ x = (char *)alloc_permanent_string(sc, len + 1);
memcpy((void *)x, (void *)str, len);
x[len] = 0;
return(x);
@@ -22298,7 +22425,7 @@ s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str)
string_length(x) = len;
/* string_block(x) = mallocate_block(); */
string_block(x) = NULL;
- string_value(x) = (char *)alloc_permanent_string(sc, (len + 1) * sizeof(char));
+ string_value(x) = (char *)alloc_permanent_string(sc, len + 1);
memcpy((void *)string_value(x), (void *)str, len);
string_value(x)[len] = 0;
}
@@ -22392,6 +22519,7 @@ static void init_strings(void)
value_is_missing_string = make_permanent_string("~A argument '~A's value is missing");
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");
#if (!HAVE_COMPLEX_NUMBERS)
no_complex_numbers_string = make_permanent_string("this version of s7 does not support complex numbers");
#endif
@@ -23847,64 +23975,75 @@ 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);
-void s7_close_input_port(s7_scheme *sc, s7_pointer p)
+static void close_closed_port(s7_scheme *sc, s7_pointer port) {return;}
+
+static port_functions 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 ((is_immutable_port(p)) ||
- ((is_input_port(p)) && (port_is_closed(p))))
- {
-#if S7_DEBUGGING
- if (port_needs_free(p))
- fprintf(stderr, "closed input needs free\n");
-#endif
- return;
- }
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;
+}
- if (is_string_port(p))
+static void close_input_string(s7_scheme *sc, s7_pointer p)
+{
+ if (port_filename(p))
{
- if (port_needs_unprotect(p))
- {
- s7_gc_unprotect_at(sc, port_gc_loc(p));
- port_needs_unprotect(p) = false;
- }
+ /* for string ports, this is the original input file name */
+ liberate(sc, port_filename_block(p));
+ port_filename(p) = NULL;
}
- else
+ if (port_needs_unprotect(p))
{
- if (is_file_port(p))
- {
- if (port_file(p))
- {
- fclose(port_file(p));
- port_file(p) = NULL;
- }
- }
+ s7_gc_unprotect_at(sc, port_gc_loc(p));
+ port_needs_unprotect(p) = false;
}
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
+ if (port_needs_unprotect(p))
{
- if (port_data(p))
- {
- liberate(sc, port_data_block(p));
- port_data_block(p) = NULL;
- port_data(p) = NULL;
- port_data_size(p) = 0;
- }
- port_needs_free(p) = false;
+ s7_gc_unprotect_at(sc, port_gc_loc(p));
+ port_needs_unprotect(p) = false;
}
-
- port_read_character(p) = closed_port_read_char;
- port_read_line(p) = closed_port_read_line;
- port_write_character(p) = closed_port_write_char;
- port_write_string(p) = closed_port_write_string;
- port_display(p) = closed_port_display;
+ port_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)
@@ -23965,54 +24104,51 @@ static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args)
/* -------------------------------- close-output-port -------------------------------- */
-static void close_output_port(s7_scheme *sc, s7_pointer p)
+static void close_output_file(s7_scheme *sc, s7_pointer p)
{
- if (is_file_port(p))
+ if (port_filename(p)) /* only a file output port has a filename(?) */
{
- 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 (port_position(p) > 0)
- {
- if (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");
- }
- fflush(port_file(p));
- fclose(port_file(p));
- port_file(p) = NULL;
- }
+ liberate(sc, port_filename_block(p));
+ port_filename(p) = NULL;
+ port_filename_length(p) = 0;
}
- else
+ if (port_file(p))
{
- if (is_string_port(p))
+ if (port_position(p) > 0)
{
- if (port_data(p))
- {
- port_data(p) = NULL;
- port_data_size(p) = 0;
- }
+ if (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");
}
+ 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 S7_DEBUGGING
+ if (port_filename(p))
+ fprintf(stderr, "%s: string has a filename\n", __func__);
+#endif
+ if (port_data(p))
+ {
+ port_data(p) = NULL;
+ port_data_size(p) = 0;
}
- port_read_character(p) = closed_port_read_char;
- port_read_line(p) = closed_port_read_line;
- port_write_character(p) = closed_port_write_char;
- port_write_string(p) = closed_port_write_string;
- port_display(p) = closed_port_display;
+ port_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 ((is_immutable_port(p)) ||
- ((is_output_port(p)) && (port_is_closed(p))) ||
- (p == sc->F))
- return;
+ if ((p == sc->F) || (is_immutable_port(p))) return; /* can these happen? */
close_output_port(sc, p);
}
@@ -24028,8 +24164,7 @@ static s7_pointer g_close_output_port(s7_scheme *sc, s7_pointer args)
if (pt == sc->F) return(sc->unspecified);
return(method_or_bust_with_type_one_arg(sc, pt, sc->close_output_port_symbol, set_plist_1(sc, pt), an_output_port_string));
}
- if (!(is_immutable_port(pt)))
- s7_close_output_port(sc, pt);
+ s7_close_output_port(sc, pt);
return(sc->unspecified);
}
@@ -24088,7 +24223,7 @@ 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 * sizeof(char));
+ sc->read_line_buf = (char *)malloc(sc->read_line_buf_size);
}
if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin))
@@ -24104,7 +24239,7 @@ static s7_pointer file_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 * sizeof(char));
+ sc->read_line_buf = (char *)malloc(sc->read_line_buf_size);
}
buf = sc->read_line_buf;
@@ -24133,7 +24268,7 @@ static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol,
previous_size = sc->read_line_buf_size;
sc->read_line_buf_size *= 2;
- sc->read_line_buf = (char *)realloc(sc->read_line_buf, sc->read_line_buf_size * sizeof(char));
+ sc->read_line_buf = (char *)realloc(sc->read_line_buf, sc->read_line_buf_size);
read_size = previous_size;
previous_size -= 1;
buf = (char *)(sc->read_line_buf + previous_size);
@@ -24490,7 +24625,7 @@ static void resize_strbuf(s7_scheme *sc, s7_int needed_size)
s7_int i, old_size;
old_size = sc->strbuf_size;
while (sc->strbuf_size <= needed_size) sc->strbuf_size *= 2;
- sc->strbuf = (char *)realloc(sc->strbuf, sc->strbuf_size * sizeof(char));
+ sc->strbuf = (char *)realloc(sc->strbuf, sc->strbuf_size);
for (i = old_size; i < sc->strbuf_size; i++) sc->strbuf[i] = '\0';
}
@@ -24695,7 +24830,7 @@ static block_t *mallocate_port(s7_scheme *sc)
if (p)
{
sc->block_lists[PORT_LIST] = (block_t *)block_next(p);
- block_next(p) = NULL;
+ /* block_next(p) = NULL; */
}
else
{ /* this is mallocate without the index calc */
@@ -24707,6 +24842,15 @@ static block_t *mallocate_port(s7_scheme *sc)
return(p);
}
+static port_functions 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 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;
@@ -24723,9 +24867,6 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int ma
port_port(port) = (port_t *)block_data(b);
port_set_closed(port, false);
port_original_input_string(port) = sc->nil;
- port_write_character(port) = input_write_char;
- port_write_string(port) = input_write_string;
-
/* if we're constantly opening files, and each open saves the file name in permanent memory, we gradually core-up. */
port_filename_length(port) = safe_strlen(name);
port_set_filename(sc, port, name, port_filename_length(port));
@@ -24774,13 +24915,7 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int ma
port_position(port) = 0;
port_needs_free(port) = true;
port_needs_unprotect(port) = false;
- port_read_character(port) = string_read_char;
- port_read_line(port) = string_read_line;
- port_display(port) = input_display;
- port_read_semicolon(port) = string_read_semicolon;
- port_read_white_space(port) = terminated_string_read_white_space;
- port_read_name(port) = string_read_name;
- port_read_sharp(port) = string_read_sharp;
+ port_port(port)->pf = &input_string_functions_1;
}
else
{
@@ -24791,13 +24926,7 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int ma
port_data_size(port) = 0;
port_position(port) = 0;
port_needs_free(port) = false;
- port_read_character(port) = file_read_char;
- port_read_line(port) = file_read_line;
- port_display(port) = input_display;
- port_read_semicolon(port) = file_read_semicolon;
- port_read_white_space(port) = file_read_white_space;
- port_read_name(port) = file_read_name;
- port_read_sharp(port) = file_read_sharp; /* was string_read_sharp?? */
+ port_port(port)->pf = &input_file_functions;
}
#else
/* _stat64 is no better than the fseek/ftell route, and
@@ -24811,13 +24940,7 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int ma
port_data_block(port) = NULL;
port_data_size(port) = 0;
port_position(port) = 0;
- port_read_character(port) = file_read_char;
- port_read_line(port) = file_read_line;
- port_display(port) = input_display;
- port_read_semicolon(port) = file_read_semicolon;
- port_read_white_space(port) = file_read_white_space;
- port_read_name(port) = file_read_name;
- port_read_sharp(port) = file_read_sharp;
+ port_port(port)->pf = &input_file_functions;
#endif
s7_gc_unprotect_at(sc, port_loc);
@@ -24955,6 +25078,20 @@ static s7_pointer g_open_input_file(s7_scheme *sc, s7_pointer args)
static s7_int permanent_ports = 0;
#endif
+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 port_functions 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 port_functions stdout_functions =
+ {output_read_char, stdout_write_char, stdout_write_string, NULL, NULL, NULL, NULL, output_read_line, stdout_display, close_stdout};
+
+static port_functions stderr_functions =
+ {output_read_char, stderr_write_char, stderr_write_string, NULL, NULL, NULL, NULL, output_read_line, stderr_display, close_stderr};
+
static void make_standard_ports(s7_scheme *sc)
{
s7_pointer x;
@@ -24976,11 +25113,7 @@ static void make_standard_ports(s7_scheme *sc)
port_line_number(x) = 0;
port_file(x) = stdout;
port_needs_free(x) = false;
- port_read_character(x) = output_read_char;
- port_read_line(x) = output_read_line;
- port_display(x) = stdout_display;
- port_write_character(x) = stdout_write_char;
- port_write_string(x) = stdout_write_string;
+ port_port(x)->pf = &stdout_functions;
sc->standard_output = x;
/* standard error */
@@ -24997,11 +25130,7 @@ static void make_standard_ports(s7_scheme *sc)
port_line_number(x) = 0;
port_file(x) = stderr;
port_needs_free(x) = false;
- port_read_character(x) = output_read_char;
- port_read_line(x) = output_read_line;
- port_display(x) = stderr_display;
- port_write_character(x) = stderr_write_char;
- port_write_string(x) = stderr_write_string;
+ port_port(x)->pf = &stderr_functions;
sc->standard_error = x;
/* standard input */
@@ -25018,15 +25147,7 @@ static void make_standard_ports(s7_scheme *sc)
port_file(x) = stdin;
port_data_block(x) = NULL;
port_needs_free(x) = false;
- port_read_character(x) = file_read_char;
- port_read_line(x) = stdin_read_line;
- port_display(x) = input_display;
- port_read_semicolon(x) = file_read_semicolon;
- port_read_white_space(x) = file_read_white_space;
- port_read_name(x) = file_read_name;
- port_read_sharp(x) = file_read_sharp;
- port_write_character(x) = input_write_char;
- port_write_string(x) = input_write_string;
+ port_port(x)->pf = &stdin_functions;
sc->standard_input = x;
s7_define_constant_with_documentation(sc, "*stdin*", sc->standard_input, "*stdin* is the built-in input port, C's stdin");
@@ -25042,6 +25163,9 @@ static void make_standard_ports(s7_scheme *sc)
/* -------------------------------- open-output-file -------------------------------- */
+static port_functions 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;
@@ -25072,16 +25196,12 @@ s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode
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_read_character(x) = output_read_char;
- port_read_line(x) = output_read_line;
- port_display(x) = file_display;
- port_write_character(x) = file_write_char;
- port_write_string(x) = file_write_string;
port_position(x) = 0;
port_data_size(x) = PORT_DATA_SIZE;
block = mallocate(sc, 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);
}
@@ -25107,6 +25227,14 @@ static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer 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 port_functions 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;
@@ -25129,10 +25257,6 @@ static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_
port_line_number(x) = 0;
port_needs_free(x) = false;
port_needs_unprotect(x) = false;
- port_read_character(x) = string_read_char;
- port_read_line(x) = string_read_line;
- port_display(x) = input_display;
- port_read_semicolon(x) = string_read_semicolon;
#if S7_DEBUGGING
if (input_string[len] != '\0')
{
@@ -25140,16 +25264,12 @@ static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_
abort();
}
#endif
- port_read_white_space(x) = terminated_string_read_white_space;
- port_read_name(x) = string_read_name_no_free;
- port_read_sharp(x) = string_read_sharp;
- port_write_character(x) = input_write_char;
- port_write_string(x) = input_write_string;
- add_input_port(sc, x);
+ port_port(x)->pf = &input_string_functions;
+ add_input_string_port(sc, x);
return(x);
}
-static s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str)
+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));
@@ -25163,8 +25283,6 @@ s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string)
return(open_input_string(sc, input_string, safe_strlen(input_string)));
}
-
-/* -------------------------------- open-output-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"
@@ -25178,12 +25296,17 @@ static s7_pointer g_open_input_string(s7_scheme *sc, s7_pointer args)
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 port_functions output_string_functions =
+ {output_read_char, string_write_char, string_write_string, NULL, NULL, NULL, NULL, output_read_line, string_display, close_output_string};
+
static s7_pointer open_output_string(s7_scheme *sc, s7_int len)
{
s7_pointer x;
@@ -25204,11 +25327,7 @@ static s7_pointer open_output_string(s7_scheme *sc, s7_int len)
port_filename_block(x) = NULL;
port_filename_length(x) = 0; /* protect against (port-filename (open-output-string)) */
port_filename(x) = NULL;
- port_read_character(x) = output_read_char;
- port_read_line(x) = output_read_line;
- port_display(x) = string_display;
- port_write_character(x) = string_write_char;
- port_write_string(x) = string_write_string;
+ port_port(x)->pf = &output_string_functions;
add_output_port(sc, x);
return(x);
}
@@ -25305,6 +25424,16 @@ static s7_pointer op_get_output_string(s7_scheme *sc)
/* -------------------------------- open-input-function -------------------------------- */
+
+static void close_input_function(s7_scheme *sc, s7_pointer p)
+{
+ port_port(p)->pf = &closed_port_functions;
+ port_set_closed(p, true);
+}
+
+static port_functions input_function_functions =
+ {function_read_char, input_write_char, input_write_string, NULL, NULL, NULL, NULL, function_read_line, input_display, close_input_function};
+
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;
@@ -25324,17 +25453,22 @@ s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_schem
port_file_number(x) = 0;
port_line_number(x) = 0;
port_input_function(x) = function;
- port_read_character(x) = function_read_char;
- port_read_line(x) = function_read_line;
- port_display(x) = input_display;
- port_write_character(x) = input_write_char;
- port_write_string(x) = input_write_string;
+ port_port(x)->pf = &input_function_functions;
add_input_port(sc, x);
return(x);
}
/* -------------------------------- open-output-function -------------------------------- */
+static void close_output_function(s7_scheme *sc, s7_pointer p)
+{
+ port_port(p)->pf = &closed_port_functions;
+ port_set_closed(p, true);
+}
+
+static port_functions 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;
@@ -25349,11 +25483,7 @@ s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc
port_set_closed(x, false);
port_needs_free(x) = false;
port_output_function(x) = function;
- port_read_character(x) = output_read_char;
- port_read_line(x) = output_read_line;
- port_display(x) = function_display;
- port_write_character(x) = function_write_char;
- port_write_string(x) = function_write_string;
+ port_port(x)->pf = &output_function_functions;
add_output_port(sc, x);
return(x);
}
@@ -25887,8 +26017,13 @@ static block_t *search_load_path(s7_scheme *sc, const char *name)
block_t *b;
char *filename;
s7_pointer dir_names;
-
- b = mallocate(sc, 1024);
+ /* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: MAX_PATH_LENGTH: 1024 */
+#if MS_WINDOWS || defined(__linux__)
+ #define FILENAME_MAX 4096
+#else
+ #define FILENAME_MAX 1024
+#endif
+ b = mallocate(sc, FILENAME_MAX);
filename = (char *)block_data(b);
for (dir_names = lst; is_pair(dir_names); dir_names = cdr(dir_names))
@@ -25899,9 +26034,9 @@ static block_t *search_load_path(s7_scheme *sc, const char *name)
{
filename[0] = '\0';
if (new_dir[strlen(new_dir) - 1] == '/')
- catstrs(filename, 1024, new_dir, name, NULL);
- else catstrs(filename, 1024, new_dir, "/", name, NULL);
- if (access(filename, F_OK) == 0)
+ catstrs(filename, FILENAME_MAX, new_dir, name, NULL);
+ else catstrs(filename, FILENAME_MAX, new_dir, "/", name, NULL);
+ if (access(filename, F_OK) == 0)
return(b);
}
}
@@ -25921,7 +26056,7 @@ static block_t *full_filename(s7_scheme *sc, const char *filename)
if (filename[0] == '/')
{
len = safe_strlen(filename);
- block = mallocate(sc, len * sizeof(char));
+ block = mallocate(sc, len);
rtn = (char *)block_data(block);
memcpy((void *)rtn, (void *)filename, len);
rtn[len - 1] = '\0';
@@ -25930,7 +26065,7 @@ static block_t *full_filename(s7_scheme *sc, const char *filename)
{
char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */
len = safe_strlen(pwd) + safe_strlen(filename) + 1;
- block = mallocate(sc, len * sizeof(char));
+ block = mallocate(sc, len);
rtn = (char *)block_data(block);
if (pwd)
{
@@ -26059,6 +26194,8 @@ static FILE *open_file_with_load_path(s7_scheme *sc, const char *fname)
{
FILE *fp;
fp = fopen((const char *)block_data(b), "r");
+ if ((fp) && (hook_has_functions(sc->load_hook)))
+ s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp6 = s7_make_string(sc, (const char *)block_data(b))));
liberate(sc, b);
return(fp);
}
@@ -26068,9 +26205,6 @@ static FILE *open_file_with_load_path(s7_scheme *sc, const char *fname)
static s7_pointer read_scheme_file(s7_scheme *sc, FILE *fp, const char *fname)
{
s7_pointer port;
- if (hook_has_functions(sc->load_hook))
- s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp6 = s7_make_string(sc, fname)));
-
port = read_file(sc, fp, fname, -1, "load"); /* -1 means always read its contents into a local string */
port_file_number(port) = remember_file_name(sc, fname);
set_loader_port(port);
@@ -26101,9 +26235,16 @@ s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_poin
#if WITH_GCC
if (!fp) fp = expand_cwd(sc, filename);
#endif
- if (!fp) fp = open_file_with_load_path(sc, filename);
- if (!fp) return(NULL);
-
+ if (fp)
+ {
+ if (hook_has_functions(sc->load_hook))
+ s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp6 = s7_make_string(sc, filename)));
+ }
+ else
+ {
+ fp = open_file_with_load_path(sc, filename);
+ if (!fp) return(NULL);
+ }
port = read_scheme_file(sc, fp, filename);
sc->envir = e;
@@ -26178,8 +26319,16 @@ defaults to the rootlet. To load into the current environment instead, pass (cu
#if WITH_GCC
if (!fp) fp = expand_cwd(sc, fname);
#endif
- if (!fp) fp = open_file_with_load_path(sc, fname);
- if (!fp) return(file_error(sc, "load", "can't open", fname));
+ if (fp)
+ {
+ if (hook_has_functions(sc->load_hook))
+ s7_apply_function(sc, sc->load_hook, list_1(sc, sc->temp6 = s7_make_string(sc, fname)));
+ }
+ else
+ {
+ fp = open_file_with_load_path(sc, fname);
+ if (!fp) return(file_error(sc, "load", "can't open", fname));
+ }
read_scheme_file(sc, fp, 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 */
@@ -27345,7 +27494,7 @@ bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer obj)
return(true);
}
-static bool op_iterate(s7_scheme *sc)
+static bool op_implicit_iterate(s7_scheme *sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
@@ -29351,8 +29500,7 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port,
#endif
if (use_write != P_READABLE)
{
- if ((is_symbol(car(key_val))) &&
- (!is_keyword(car(key_val))))
+ if (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);
@@ -30069,12 +30217,12 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S
uint8_t typ;
char *buf;
- buf = (char *)malloc(1024 * sizeof(char));
+ buf = (char *)malloc(1024);
typ = unchecked_type(obj);
full_typ = typeflag(obj);
/* if debugging all of these bits are being watched, so we need to access them directly */
- snprintf(buf, 1024, "type: %s? (%d), opt_op: %d, flags: #x%" PRIx64 "%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",
+ snprintf(buf, 1024, "type: %s? (%d), opt_op: %d, flags: #x%" PRIx64 "%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",
type_name(sc, obj, NO_ARTICLE),
typ,
optimize_op(obj),
@@ -30082,7 +30230,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S
/* bit 0 (the first 8 bits are easy...) */
((full_typ & T_MULTIFORM) != 0) ? ((is_any_closure(obj)) ? (((full_typ & T_ONE_FORM) != 0) ? " clo-has-fx" : " multiform") : " ?0?") : "",
/* bit 1 */
- ((full_typ & T_SYNTACTIC) != 0) ? (((is_pair(obj)) || (is_syntax(obj)) || (is_symbol(obj))) ? " syntactic" : " ?1?") : "",
+ ((full_typ & T_SYNTACTIC) != 0) ? (((is_pair(obj)) || (is_syntax(obj)) || (is_normal_symbol(obj))) ? " syntactic" : " ?1?") : "",
/* bit 2 */
((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) ? ((is_pair(obj)) ? " simple-args|in-use" :
((is_any_closure(obj)) ? " one-form" :
@@ -30092,11 +30240,13 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S
((is_pair(obj)) ? " optimized" :
" ?3?")) : "",
/* bit 4 */
- ((full_typ & T_SAFE_CLOSURE) != 0) ? " safe-closure" : "",
+ ((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj)) || (is_pair(obj))) ? " safe-closure" :
+ " ?4?") : "",
/* bit 5 */
- ((full_typ & T_DONT_EVAL_ARGS) != 0) ? " dont-eval-args" : "",
+ ((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj)) || (is_syntax(obj))) ? " dont-eval-args" :
+ " ?5?") : "",
/* bit 6 */
- ((full_typ & T_EXPANSION) != 0) ? (((is_symbol(obj)) || (is_either_macro(obj))) ? " expansion" :
+ ((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj)) || (is_either_macro(obj))) ? " expansion" :
" ?6?") : "",
/* bit 7 */
((full_typ & T_MULTIPLE_VALUE) != 0) ? ((is_symbol(obj)) ? " matched" :
@@ -30114,12 +30264,12 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S
((is_input_port(obj)) ? " loader-port" :
((is_let(obj)) ? " with-let" :
((is_any_procedure(obj)) ? " simple-defaults" :
- (((is_symbol(obj)) || (is_slot(obj))) ? " has-setter" :
+ (((is_normal_symbol(obj)) || (is_slot(obj))) ? " has-setter" :
" ?10?"))))) : "",
/* bit 11 */
((full_typ & T_SHARED) != 0) ? " shared" : "",
/* bit 12 */
- ((full_typ & T_LOCAL) != 0) ? ((is_symbol(obj)) ? " local" :
+ ((full_typ & T_LOCAL) != 0) ? ((is_normal_symbol(obj)) ? " local" :
((is_pair(obj)) ? " high-c" :
" ?12?")) : "",
/* bit 13 */
@@ -30135,7 +30285,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S
/* bit 16 */
((full_typ & T_IMMUTABLE) != 0) ? " immutable" : "",
/* bit 17 */
- ((full_typ & T_SETTER) != 0) ? ((is_symbol(obj)) ? " setter" :
+ ((full_typ & T_SETTER) != 0) ? ((is_normal_symbol(obj)) ? " setter" :
((is_pair(obj)) ? " allow-other-keys|no-int-opt" :
(((is_hash_table(obj)) || (is_let(obj))) ? " removed" :
((is_slot(obj)) ? " has-expression" :
@@ -30162,7 +30312,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S
" ?20?") : "",
/* bit 21 */
((full_typ & T_GENSYM) != 0) ? ((is_let(obj)) ? " funclet" :
- ((is_symbol(obj)) ? " gensym" :
+ ((is_normal_symbol(obj)) ? " gensym" :
((is_string(obj)) ? " documented-symbol" :
((is_hash_table(obj)) ? " hash-chosen" :
((is_pair(obj)) ? " dotted" :
@@ -30170,57 +30320,62 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S
((is_slot(obj)) ? " has-pending-value" :
" ?21?"))))))) : "",
/* bit 22 */
- ((full_typ & T_HAS_METHODS) != 0) ? " has-methods" : "",
+ ((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 23 */
((full_typ & T_ITER_OK) != 0) ? ((is_iterator(obj)) ? " iter-ok" : " ?23?") : "",
/* bit 24+16 */
((full_typ & T_FULL_SYMCONS) != 0) ? ((is_symbol(obj)) ? " possibly-constant" :
((is_procedure(obj)) ? " has-let-arg" :
((is_let(obj)) ? " slots-set" :
- " ?24?"))) : "",
-
+ ((is_hash_table(obj)) ? " has-value-type" :
+ " ?24?")))) : "",
/* bit 25+16 */
((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" :
- " ?25?"))))) : "",
+ (((is_pair(obj)) || (is_closure_star(obj))) ? " no-defaults" :
+ " ?25?")))))) : "",
/* bit 26+16 */
- ((full_typ & T_FULL_DEFINER) != 0) ? ((is_symbol(obj)) ? " definer" :
+ ((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" :
- " ?26?")))) : "",
+ ((is_hash_table(obj)) ? " has-key-type" :
+ " ?26?"))))) : "",
/* bit 27+16 */
((full_typ & T_FULL_BINDER) != 0) ? ((is_pair(obj)) ? " tree-collected" :
((is_hash_table(obj)) ? " simple-values" :
- ((is_symbol(obj)) ? " binder" :
+ ((is_normal_symbol(obj)) ? " binder" :
" ?27?"))) : "",
/* bit 28+16 */
- ((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? " very-safe-closure" : "",
+ ((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? (((is_pair(obj)) || (is_any_closure(obj))) ? " very-safe-closure" : " ?28?") : "",
/* bit 29+16 */
- ((full_typ & T_CYCLIC) != 0) ? " cyclic" : "",
+ ((full_typ & T_CYCLIC) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || (is_any_closure(obj))) ? " cyclic" : " ?29?") : "",
/* bit 30+16 */
- ((full_typ & T_CYCLIC_SET) != 0) ? " cyclic-set" : "",
+ ((full_typ & T_CYCLIC_SET) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || (is_any_closure(obj))) ? " cyclic-set" : " ?30?") : "",
/* bit 31+16 */
((full_typ & T_KEYWORD) != 0) ? ((is_symbol(obj)) ? " keyword" : " ?31?") : "",
/* bit 32+16 */
((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) ? ((is_normal_vector(obj)) ? " simple-elements" :
((is_hash_table(obj)) ? " simple-keys" :
- ((is_pair(obj)) ? " ctr3-set" :
- ((is_symbol(obj)) ? " safe-setter" :
- ((typ >= T_C_MACRO) ? " function-simple-elements" :
- " 32?"))))) : "",
+ ((is_normal_symbol(obj)) ? " safe-setter" :
+ ((typ >= T_C_MACRO) ? " function-simple-elements" :
+ " 32?")))) : "",
/* bit 33+16 */
- ((full_typ & T_FULL_CASE_KEY) != 0) ? " case-key" : "",
+ ((full_typ & T_FULL_CASE_KEY) != 0) ? ((is_symbol(obj)) ? " case-key" : " ?33?") : "",
((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "",
/* bit 54 */
((full_typ & T_UNHEAP) != 0) ? " unheap" : "",
/* bit 55 */
- ((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "");
+ ((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "",
+
+ ((is_symbol(obj)) && (((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) || ((symbol_type(obj) & ~0xffff) != 0))) ? " bad-symbol-type" : "");
+
return(buf);
}
@@ -30232,31 +30387,33 @@ static bool has_odd_bits(s7_pointer 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))) return(true);
- if (((full_typ & T_FULL_BINDER) != 0) && ((!is_pair(obj)) && (!is_hash_table(obj)) && (!is_symbol(obj)))) return(true);
- if (((full_typ & T_SYNTACTIC) != 0) && (!is_syntax(obj)) && (!is_pair(obj)) && (!is_symbol(obj))) return(true);
+ if (((full_typ & T_KEYWORD) != 0) && ((!is_symbol(obj)) || (!is_global(obj)) || (is_gensym(obj)))) return(true);
+ if (((full_typ & T_FULL_BINDER) != 0) && ((!is_pair(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(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_EXPANSION) != 0) && (!is_symbol(obj)) && (!is_either_macro(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))) return(true);
- if (((full_typ & T_FULL_DEFINER) != 0) && (!is_symbol(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj))) return(true);
- if (((full_typ & T_FULL_SYMCONS) != 0) && (!is_symbol(obj)) && (!is_procedure(obj)) && (!is_let(obj))) return(true);
- if (((full_typ & T_LOCAL) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_FULL_SYMCONS) != 0) && (!is_symbol(obj)) && (!is_procedure(obj)) && (!is_let(obj)) && (!is_hash_table(obj))) return(true);
+ if (((full_typ & T_LOCAL) != 0) && (!is_normal_symbol(obj)) && (!is_pair(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))) 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))) return(true);
if (((full_typ & T_FULL_CASE_KEY) != 0) && (!is_symbol(obj))) return(true);
+ if (((full_typ & T_DONT_EVAL_ARGS) != 0) && (!is_any_macro(obj)) && (!is_syntax(obj))) return(true);
+ if (((full_typ & T_FULL_DEFINER) != 0) &&
+ (!is_normal_symbol(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj)) && (!is_hash_table(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_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)))
return(true);
if (((full_typ & T_SETTER) != 0) &&
- (!is_slot(obj)) && (!is_symbol(obj)) && (!is_pair(obj)) && (!is_closure(obj)) && (!is_hash_table(obj)) && (!is_let(obj)))
+ (!is_slot(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) && (!is_hash_table(obj)) && (!is_let(obj)))
return(true);
if (((full_typ & T_LINE_NUMBER) != 0) &&
(!is_pair(obj)) && (!is_input_port(obj)) && (!is_let(obj)) && (!is_any_procedure(obj)) && (!is_symbol(obj)) && (!is_slot(obj)))
@@ -30269,7 +30426,11 @@ static bool has_odd_bits(s7_pointer 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_pair(obj)) && (!is_symbol(obj)) && (unchecked_type(obj) < T_C_MACRO)))
+ ((!is_normal_vector(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(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 (is_symbol(obj))
@@ -30349,13 +30510,7 @@ static const char *check_name(int32_t typ)
s7_pointer p;
p = prepackaged_type_names[typ];
if (is_string(p)) return(string_value(p));
-
- switch (typ)
- {
- case T_C_OBJECT: return("a c-object");
- case T_INPUT_PORT: return("an input port");
- case T_OUTPUT_PORT: return("an output port");
- }
+ fprintf(stderr, "%s fell through: %d\n", __func__, typ);
}
return("unknown type!");
}
@@ -30365,7 +30520,7 @@ static char *safe_object_to_string(s7_pointer p)
uint8_t typ;
char *buf;
typ = unchecked_type(p);
- buf = (char *)malloc(128 * sizeof(char));
+ buf = (char *)malloc(128);
snprintf(buf, 128, "type: %d", typ);
return(buf);
}
@@ -30444,15 +30599,10 @@ static s7_pointer check_ref2(s7_pointer p, uint8_t expected_type, int32_t other_
static s7_pointer check_ref3(s7_pointer p, const char *func, int32_t line)
{
- if ((strcmp(func, "process_input_port") != 0) &&
- (strcmp(func, "process_output_port") != 0) &&
- (strcmp(func, "close_output_port") != 0))
- {
- uint8_t typ;
- typ = unchecked_type(p);
- if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT))
- complain("%s%s[%d]: not a port, but %s (%s)%s\n", p, func, line, typ);
- }
+ uint8_t typ;
+ 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);
}
@@ -30691,7 +30841,6 @@ static const char *opt3_role_name(uint32_t role)
if (role == G_AND) return("opt3_pair");
if (role == G_ANY) return("opt3_any");
if (role == G_LET) return("opt3_let");
- if (role == G_CTR) return("opt3_ctr");
if (role == G_BYTE) return("opt3_byte");
if (role == G_DIRECT) return("direct_opt3");
if (role == S_LEN) return("s_len");
@@ -30703,8 +30852,8 @@ static const char *opt3_role_name(uint32_t role)
static char* show_debugger_bits(int64_t bits)
{
char *bits_str;
- bits_str = (char *)malloc(512 * sizeof(char));
- 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",
+ 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",
((bits & E_SET) != 0) ? " e-set" : "",
((bits & E_FAST) != 0) ? " opt1_fast" : "",
((bits & E_CFUNC) != 0) ? " opt1_cfunc" : "",
@@ -30729,7 +30878,6 @@ static char* show_debugger_bits(int64_t bits)
((bits & G_AND) != 0) ? " opt3_pair " : "",
((bits & G_ANY) != 0) ? " opt3_any " : "",
((bits & G_LET) != 0) ? " opt3_let " : "",
- ((bits & G_CTR) != 0) ? " opt3_ctr " : "",
((bits & G_BYTE) != 0) ? " opt3_byte " : "",
((bits & G_DIRECT) != 0) ? " opt3_direct" : "",
((bits & S_NAME) != 0) ? " raw-name" : "",
@@ -30939,30 +31087,6 @@ static void set_opt3_byte_1(s7_pointer p, uint8_t x, uint32_t role, const char *
base_opt3(p, role, func, line);
}
-static int32_t opt3_ctr_1(s7_pointer p, int32_t role, const char *func, int32_t line)
-{
- check_opt3_bits(p, role, func, line);
- return(p->object.cons_ext.ce.ctr);
-}
-
-static void set_opt3_ctr_1(s7_pointer p, int32_t x, uint32_t role, const char *func, int32_t line)
-{
- clear_type_bit(p, T_LINE_NUMBER);
- p->object.cons_ext.ce.ctr = x;
- set_ctr3_is_set(p);
- base_opt3(p, role, func, line);
-}
-
-static void increment_opt3_ctr_1(s7_pointer p, uint32_t role, const char *func, int32_t line)
-{
- clear_type_bit(p, T_LINE_NUMBER);
- if (ctr3_is_set(p))
- p->object.cons_ext.ce.ctr++;
- else p->object.cons_ext.ce.ctr = 0;
- set_ctr3_is_set(p);
- base_opt3(p, role, func, line);
-}
-
/* S_LINE */
static uint32_t s_line_1(s7_pointer p, const char *func, int32_t line)
{
@@ -31907,11 +32031,7 @@ static s7_pointer open_format_port(s7_scheme *sc)
port_data(x)[0] = '\0';
port_position(x) = 0;
port_needs_free(x) = false;
- port_read_character(x) = output_read_char;
- port_read_line(x) = output_read_line;
- port_display(x) = string_display;
- port_write_character(x) = string_write_char;
- port_write_string(x) = string_write_string;
+ port_port(x)->pf = &output_string_functions;
return(x);
}
@@ -31936,7 +32056,7 @@ char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj)
object_out(sc, obj, strport, P_WRITE);
len = port_position(strport);
if (len == 0) return(NULL);
- str = (char *)malloc((len + 1) * sizeof(char));
+ str = (char *)malloc(len + 1);
memcpy((void *)str, (void *)port_data(strport), len);
str[len] = '\0';
close_format_port(sc, strport);
@@ -32095,7 +32215,7 @@ static s7_pointer newline_p_p(s7_scheme *sc, s7_pointer port)
if (!is_output_port(port))
{
if (port == sc->F) return(newline_char);
- s7_wrong_type_arg_error(sc, "newline", 1, port, "an open output port");
+ return(method_or_bust_with_type_one_arg(sc, port, sc->newline_symbol, list_1(sc, port), an_output_port_string));
}
s7_newline(sc, port);
return(newline_char);
@@ -32185,9 +32305,15 @@ static s7_pointer g_display_2(s7_scheme *sc, s7_pointer 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) return(sc->display_2);
+ if (args == 2)
+ {
+ if (caddr(expr) == sc->F) return(sc->display_f);
+ return(sc->display_2);
+ }
return(f);
}
@@ -32419,6 +32545,7 @@ static s7_int format_read_integer(s7_int *cur_i, s7_int str_len, const char *str
static void format_number(s7_scheme *sc, format_data *fdat, int32_t radix, s7_int width, s7_int precision, char float_choice, char pad, s7_pointer port)
{
char *tmp;
+ block_t *b;
s7_int nlen = 0;
if (width < 0) width = 0;
@@ -32455,11 +32582,14 @@ static void format_number(s7_scheme *sc, format_data *fdat, int32_t radix, s7_in
tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE);
else
#endif
- tmp = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen);
+ {
+ 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 (radix != 10) free(tmp);
+ if ((WITH_GMP) || (radix != 10)) liberate(sc, b);
}
else
{
@@ -32468,9 +32598,12 @@ static void format_number(s7_scheme *sc, format_data *fdat, int32_t radix, s7_in
tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE);
else
#endif
- tmp = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen);
+ {
+ 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 (radix != 10) free(tmp);
+ if ((WITH_GMP) || (radix != 10)) liberate(sc, b);
}
fdat->args = cdr(fdat->args);
fdat->ctr++;
@@ -32631,13 +32764,6 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
fdat->args = args;
fdat->orig_str = orig_str;
- /* choose whether to write to a temporary string port, or simply use the in-coming port
- * if with_result, returned string is wanted.
- * if port is sc->F, no non-string result is wanted.
- * if port is not boolean, it better be a port.
- * if we are about to goto START in eval, and main_stack_op(Sc) == OP_BEGIN1, no return string is wanted -- yow, this is not true
- */
-
if (with_result)
{
deferred_port = port;
@@ -32783,7 +32909,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
{
if (fdat->curly_str) free(fdat->curly_str);
fdat->curly_len = curly_len;
- fdat->curly_str = (char *)malloc(curly_len * sizeof(char));
+ fdat->curly_str = (char *)malloc(curly_len);
}
curly_str = fdat->curly_str;
memcpy((void *)curly_str, (void *)(str + i + 2), curly_len - 1);
@@ -33209,11 +33335,11 @@ static bool is_columnizing(const char *str)
return(false);
}
-static s7_pointer format_to_port(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, s7_pointer *next_arg, bool with_result, s7_int len)
+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, next_arg, with_result, true /* is_columnizing(str) */, len, NULL));
+ 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);
}
@@ -33403,8 +33529,8 @@ system captures the output as a string and returns it."
{
full_len += BUF_SIZE * 2;
if (str)
- str = (char *)realloc(str, full_len * sizeof(char));
- else str = (char *)malloc(full_len * sizeof(char));
+ str = (char *)realloc(str, full_len);
+ else str = (char *)malloc(full_len);
}
memcpy((void *)(str + cur_len), (void *)buf, buf_len);
cur_len += buf_len;
@@ -33539,7 +33665,7 @@ static s7_pointer permanent_list(s7_scheme *sc, s7_int len)
static void check_sig_entry(s7_scheme *sc, s7_pointer p, s7_int pos, bool circle)
{
- if ((!is_symbol(car(p))) &&
+ if ((!is_normal_symbol(car(p))) &&
(!s7_is_boolean(car(p))) &&
(!is_pair(car(p))))
{
@@ -34362,13 +34488,14 @@ static s7_pointer revappend(s7_scheme *sc, s7_pointer a, s7_pointer b)
if (is_not_null(a))
{
a = copy_list(sc, a);
- while (is_not_null(a))
+ do /* while (is_not_null(a)) */
{
q = cdr(a);
set_cdr(a, p);
p = a;
a = q;
}
+ while (is_pair(a));
}
return(p);
}
@@ -34478,8 +34605,6 @@ static s7_pointer g_is_proper_list(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, s7_is_proper_list(sc, p)));
}
-static bool is_proper_list_b_7p(s7_scheme *sc, s7_pointer p) {return(s7_is_proper_list(sc, p));}
-
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))));}
@@ -34608,7 +34733,7 @@ static s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args)
}
}
-static bool op_pair_a(s7_scheme *sc)
+static bool op_implicit_pair_a(s7_scheme *sc)
{
s7_pointer s, x;
s = lookup_checked(sc, car(sc->code));
@@ -35929,6 +36054,8 @@ static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer x)
return(sc->F); /* not reached */
}
+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. \
@@ -36018,19 +36145,37 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c
s7_pointer b;
o = sc->opts[0];
b = next_slot(let_slots(sc->envir));
- for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow))
+ if (o->v[0].fb == p_to_b)
{
- slot_set_value(b, car(x));
- sc->pc = 0;
- 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));
- sc->pc = 0;
- if (o->v[0].fb(o)) return(x);
+ 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));
+ sc->pc = 0;
+ 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));
+ sc->pc = 0;
+ 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));
+ sc->pc = 0;
+ 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));
+ sc->pc = 0;
+ if (o->v[0].fb(o)) return(x);
+ }
}
return(sc->F);
}
@@ -39663,7 +39808,7 @@ static int32_t opt_bool_sort_p(const void *v1, const void *v2, void *arg)
slot_set_value(sc->sort_v1, (*(s7_pointer *)v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *)v2));
sc->pc = 0;
- return((sc->opts[0]->v[7].fp(sc->opts[0]) == sc->F) ? 1 : -1);
+ return((sc->opts[0]->v[O_WRAP].fp(sc->opts[0]) == sc->F) ? 1 : -1);
}
static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, void *arg)
@@ -39676,7 +39821,7 @@ static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, void *arg)
sc->pc = -1;
for (i = 0; i < sc->sort_body_len - 1; i++)
{
- o = sc->opts[++sc->pc];
+ o = sc->opts[++sc->pc]; /* 1..15? */
o->v[0].fp(o);
}
o = sc->opts[++sc->pc];
@@ -39706,7 +39851,7 @@ static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2, void *arg)
sc->pc = -1;
for (i = 0; i < sc->sort_body_len - 1; i++)
{
- o = sc->opts[++sc->pc];
+ o = sc->opts[++sc->pc]; /* 1..15? */
o->v[0].fp(o);
}
o = sc->opts[++sc->pc];
@@ -39736,7 +39881,6 @@ static int32_t closure_sort_begin(const void *v1, const void *v2, void *arg)
return((sc->value != sc->F) ? -1 : 1);
}
-static bool p_to_b(opt_info *p);
static s7_b_7pp_t s7_b_7pp_function(s7_pointer f);
static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
@@ -39806,6 +39950,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
if (is_null(cdr(closure_body(lessp))))
{
if ((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.
@@ -41128,6 +41273,9 @@ s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size)
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), make_integer(sc, size * sizeof(hash_entry_t *))));
hash_table_checker(table) = hash_empty;
hash_table_mapper(table) = default_hash_map;
hash_table_entries(table) = 0;
@@ -41157,7 +41305,9 @@ 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"
+ #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))
@@ -41212,6 +41362,8 @@ static s7_pointer g_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer
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 */
}
else
@@ -41230,6 +41382,8 @@ static s7_pointer g_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer
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);
/* now a consistency check for eq-func and value type */
proc = cadr(args);
@@ -41322,7 +41476,10 @@ static s7_pointer g_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer
(c_function_call(proc) == big_num_eq))
#endif
{
- hash_table_checker(ht) = hash_number;
+ if ((is_typed_hash_table(ht)) &&
+ (hash_table_key_typer(ht) == slot_value(global_slot(sc->is_integer_symbol))))
+ hash_table_checker(ht) = hash_int;
+ else hash_table_checker(ht) = hash_number;
hash_table_mapper(ht) = number_eq_hash_map;
return(ht);
}
@@ -41595,7 +41752,7 @@ static s7_pointer hash_table_ref_p_pp(s7_scheme *sc, s7_pointer table, s7_pointe
return(hash_entry_value((*hash_table_checker(table))(sc, table, key)));
}
-static bool op_hash_table_a(s7_scheme *sc)
+static bool op_implicit_hash_table_a(s7_scheme *sc)
{
s7_pointer s;
s = lookup_checked(sc, car(sc->code));
@@ -41712,34 +41869,57 @@ static const char *hash_table_typer_name(s7_scheme *sc, s7_pointer typer)
return(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)
-{
- s7_pointer kf, vf, result = sc->T;
+#if WITH_GCC
+static inline void check_hash_types(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) __attribute__((always_inline));
+#endif
- kf = hash_table_key_typer(table);
- if (kf != sc->T)
+static inline 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 (is_c_function(kf))
- result = c_function_call(kf)(sc, set_plist_1(sc, key));
- else result = s7_apply_function(sc, kf, set_plist_1(sc, key));
+ 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));
}
- if (result == 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));
-
- vf = hash_table_value_typer(table);
- if (vf != sc->T)
+ else
+ {
+ s7_pointer kf;
+ 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
{
- if (is_c_function(vf))
- result = c_function_call(vf)(sc, set_plist_1(sc, value));
- else result = s7_apply_function(sc, vf, set_plist_1(sc, value));
+ s7_pointer vf;
+ 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));
+ }
}
- if (result == 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));
}
-inline s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
+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;
@@ -42170,7 +42350,7 @@ static s7_pointer s7_lambda(s7_scheme *sc, s7_function f, s7_int required_args,
block_t *block;
new_cell(sc, fnc, T_PAIR); /* just a place-holder */
block = mallocate(sc, sizeof(c_proc_t));
- fnc = make_function(sc, NULL, f, required_args, optional_args, rest_arg, NULL, fnc, (c_proc_t *)block_data(block));
+ fnc = make_function(sc, "#<unnamed-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);
@@ -42294,10 +42474,9 @@ static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args)
/* 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, ((is_closure_star(p)) ||
- (is_macro_star(p)) ||
- (is_bacro_star(p))) ? sc->lambda_star_symbol : sc->lambda_symbol,
- closure_args(p)), body));
+ return(append_in_place(sc,
+ list_2(sc, ((is_closure_star(p)) || (is_macro_star(p)) || (is_bacro_star(p))) ? sc->lambda_star_symbol : sc->lambda_symbol, closure_args(p)),
+ body));
}
if (!is_procedure(p))
@@ -42479,7 +42658,7 @@ s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fn
defaults[i] = cadr(arg);
s7_remove_from_heap(sc, cadr(arg));
if ((is_pair(defaults[i])) ||
- ((is_symbol(defaults[i])) && (!is_keyword(defaults[i]))))
+ (is_normal_symbol(defaults[i])))
{
c_func_clear_simple_defaults(func);
mark_function[T_C_FUNCTION_STAR] = mark_c_proc_star;
@@ -42500,8 +42679,7 @@ s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_functi
s7_pointer func;
func = s7_make_function_star(sc, name, fnc, arglist, doc);
set_type(func, typeflag(func) | T_SAFE_PROCEDURE); /* don't step on the c_func_has_simple_defaults flag */
- c_function_call_args(func) = make_list(sc, c_function_optional_args(func), sc->F);
- s7_remove_from_heap(sc, c_function_call_args(func));
+ c_function_call_args(func) = permanent_list(sc, c_function_optional_args(func));
return(func);
}
@@ -43050,9 +43228,10 @@ static void apply_c_object(s7_scheme *sc) /* -------- applicable (new-type) obj
set_car(sc->u1_1, sc->code);
set_cdr(sc->u1_1, sc->args);
sc->value = (*(c_object_ref(sc, sc->code)))(sc, sc->u1_1);
+ set_car(sc->u1_1, sc->F);
}
-static bool op_c_object_a(s7_scheme *sc)
+static bool op_implicit_c_object_a(s7_scheme *sc)
{
s7_pointer c;
c = lookup_checked(sc, car(sc->code));
@@ -43080,7 +43259,7 @@ s7_pointer s7_dilambda(s7_scheme *sc,
if (!name) return(sc->F);
len = 16 + safe_strlen(name);
- internal_set_name = (char *)malloc(len * sizeof(char));
+ internal_set_name = (char *)malloc(len);
internal_set_name[0] = '\0';
catstrs_direct(internal_set_name, "[set-", name, "]", NULL);
@@ -43732,7 +43911,6 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args)
* (set! (< 1) 2) -> #t
*/
- /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY(args)); */
if (is_symbol(p))
{
s7_pointer sym, func, slot;
@@ -43762,8 +43940,6 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args)
slot = symbol_to_slot(sc, sym);
func = cadr(args);
}
- /* fprintf(stderr, "slot: %s\n", DISPLAY(slot)); */
-
if ((!is_any_procedure(func)) && /* disallow continuation/goto here */
(func != sc->F))
return(s7_wrong_type_arg_error(sc, "set! setter", 3, func, "a function or #f"));
@@ -43780,7 +43956,6 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args)
return(func);
}
- /* fprintf(stderr, "calling slot_set_setter %s\n", DISPLAY(func)); */
slot_set_setter(slot, func);
if (func != sc->F)
{
@@ -44044,7 +44219,7 @@ static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
{
if (x == y) return(true);
- if (!is_symbol(y)) return(false); /* (equivalent? ''(1) '(1)) */
+ 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(slot_value(global_slot(x)))) &&
(is_slot(global_slot(y))) &&
@@ -44914,14 +45089,15 @@ static bool complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared
if (is_big_number(y))
return(big_num_eq(sc, set_plist_2(sc, x, y)) != sc->F);
#endif
- if (!is_number(y)) return(false);
+ if (is_t_complex(y))
+ return((floats_are_equivalent(sc, real_part(x), real_part(y))) &&
+ (floats_are_equivalent(sc, imag_part(x), imag_part(y))));
- if (is_real(y))
+ if (is_real(y))
return((fabs(imag_part(x)) <= sc->equivalent_float_epsilon) &&
(floats_are_equivalent(sc, real_part(x), s7_real(y))));
- return((floats_are_equivalent(sc, real_part(x), real_part(y))) &&
- (floats_are_equivalent(sc, imag_part(x), imag_part(y))));
+ return(false);
}
static bool rng_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci)
@@ -45047,9 +45223,6 @@ static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, s7_is_equivalent(sc, car(args), cadr(args))));
}
-static bool is_equal_b_7pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return(s7_is_equal(sc, a, b));}
-static bool is_equivalent_b_7pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return(s7_is_equivalent(sc, a, b));}
-
static s7_pointer is_equal_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((s7_is_equal(sc, a, b)) ? sc->T : sc->F);}
static s7_pointer is_equivalent_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((s7_is_equivalent(sc, a, b)) ? sc->T : sc->F);}
@@ -45380,8 +45553,8 @@ static s7_pointer copy_direct(s7_scheme *sc, s7_pointer dest, s7_pointer source,
case T_STRING:
if (is_string(dest))
- memcpy((void *)(string_value(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len * sizeof(char));
- else memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len * sizeof(char));
+ 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:
@@ -47503,7 +47676,7 @@ static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e, cha
if (new_notes_line)
{
new_note_len += (4 + notes_start_col + ((notes) ? strlen(notes) : 0));
- str = (char *)malloc(new_note_len * sizeof(char));
+ str = (char *)malloc(new_note_len);
/* str[0] = '\0'; */
catstrs_direct(str,
(notes) ? notes : "",
@@ -47518,7 +47691,7 @@ static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e, cha
else
{
new_note_len += ((notes) ? strlen(notes) : 0) + 4;
- str = (char *)malloc(new_note_len * sizeof(char));
+ str = (char *)malloc(new_note_len);
/* str[0] = '\0'; */
catstrs_direct(str,
(notes) ? notes : "",
@@ -47576,7 +47749,7 @@ static block_t *stacktrace_add_func(s7_scheme *sc, s7_pointer f, s7_pointer code
}
newlen = code_max + 8 + ((notes) ? strlen(notes) : 0);
- b = mallocate(sc, newlen * sizeof(char));
+ b = mallocate(sc, newlen);
str = (char *)block_data(b);
/* str[0] = '\0'; */
@@ -47685,7 +47858,7 @@ static s7_pointer stacktrace_1(s7_scheme *sc, s7_int frames_max, s7_int code_col
free(notes);
newlen = strlen(newstr) + 1 + ((str) ? strlen(str) : 0);
- catp = mallocate(sc, newlen * sizeof(char));
+ catp = mallocate(sc, newlen);
catstr = (char *)block_data(catp);
catstrs_direct(catstr, (str) ? str : "", newstr, NULL);
liberate(sc, newp);
@@ -47823,7 +47996,7 @@ static const char *make_type_name(s7_scheme *sc, const char *name, article_t art
if (len > sc->typnam_len)
{
if (sc->typnam) free(sc->typnam);
- sc->typnam = (char *)malloc(len * sizeof(char));
+ sc->typnam = (char *)malloc(len);
sc->typnam_len = len;
}
if (article == INDEFINITE_ARTICLE)
@@ -48628,9 +48801,14 @@ static bool catch_1_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointe
y = list_2(sc, type, info);
else
{
- if ((is_pair(error_args)) &&
- (error_body == car(error_args)))
- y = type;
+ if (is_keyword(error_body))
+ y = error_body;
+ else
+ {
+ if ((is_pair(error_args)) &&
+ (error_body == car(error_args)))
+ y = type;
+ }
}
}
else y = error_body; /* not pair or symbol */
@@ -48656,10 +48834,8 @@ static bool catch_1_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointe
*/
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);
}
}
@@ -48855,7 +49031,7 @@ static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) /* len = m
s7_pointer warning;
char *str;
- warning = make_empty_string(sc, len * sizeof(char), 0);
+ warning = make_empty_string(sc, len, 0);
string_value(warning)[0] = '\0';
str = (char *)string_value(warning);
va_start(ap, ctrl);
@@ -49038,7 +49214,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
*/
if ((!is_pair(info)) ||
(!is_string(car(info))))
- format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), NULL, false, 7);
+ 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 */
@@ -49052,10 +49228,10 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
b = mallocate(sc, len);
errstr = (char *)block_data(b);
str_len = catstrs_direct(errstr, "\n;", string_value(car(info)), NULL);
- format_to_port(sc, sc->error_port, errstr, cdr(info), NULL, false, str_len);
+ 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), NULL, false, 7); /* 7 = ctrl str len */
+ 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;
@@ -49066,10 +49242,10 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
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)),
- NULL, false, 8);
+ false, 8);
format_to_port(sc, sc->error_port, "; ~A, line ~D\n",
set_plist_2(sc, slot_value(sc->error_file), slot_value(sc->error_line)),
- NULL, false, 17);
+ false, 17);
}
else
{
@@ -49086,12 +49262,12 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
if (filename)
format_to_port(sc, sc->error_port, "\n; ~A[~D]",
set_plist_2(sc, wrap_string(sc, filename, port_filename_length(sc->input_port)),
- wrap_integer3(sc, line)), NULL, false, 10);
+ 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)), NULL, false, 11);
+ 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)
@@ -49107,7 +49283,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
if (filename)
format_to_port(sc, sc->error_port, "\n; ~A[~D]",
set_plist_2(sc, wrap_string(sc, filename, port_filename_length(sc->input_port)),
- wrap_integer3(sc, line)), NULL, false, 10);
+ wrap_integer3(sc, line)), false, 10);
}}}}
}
else
@@ -49125,7 +49301,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
s7_make_string_wrapper(sc, call_name),
s7_make_string_wrapper(sc, sc->s7_call_file),
make_integer(sc, sc->s7_call_line)),
- NULL, false, 13);
+ false, 13);
}
}
}
@@ -49152,7 +49328,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info)
{
if (is_pair(slot_value(sc->error_code)))
{
- format_to_port(sc, sc->error_port, "; ~S", set_plist_1(sc, slot_value(sc->error_code)), NULL, false, 7);
+ 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);
}
}
@@ -49230,7 +49406,7 @@ static s7_pointer read_error_1(s7_scheme *sc, const char *errmsg, bool string_er
if (slen > 0)
{
- recent_input = (char *)calloc((slen + 9), sizeof(char));
+ recent_input = (char *)calloc(slen + 9, 1);
for (i = 0; i < (slen + 8); i++) recent_input[i] = '.';
recent_input[3] = ' ';
recent_input[slen + 4] = ' ';
@@ -49442,7 +49618,7 @@ static s7_pointer missing_close_paren_error(s7_scheme *sc)
form = string_value(strp);
form_len = string_length(strp);
msg_len = form_len + 128;
- syntax_msg = (char *)malloc(msg_len * sizeof(char));
+ syntax_msg = (char *)malloc(msg_len);
snprintf(syntax_msg, msg_len, "; current form awaiting a close paren starts around line %u: %s", pair_line_number(p), form);
}
}
@@ -49689,6 +49865,7 @@ s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
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
*
@@ -49709,17 +49886,23 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic
case T_FLOAT_VECTOR:
set_car(sc->u1_1, obj);
set_cdr(sc->u1_1, indices);
- return(univect_ref(sc, sc->u1_1, sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
+ res = univect_ref(sc, sc->u1_1, sc->float_vector_ref_symbol, T_FLOAT_VECTOR);
+ set_car(sc->u1_1, sc->F);
+ return(res);
case T_INT_VECTOR:
set_car(sc->u1_1, obj);
set_cdr(sc->u1_1, indices);
- return(univect_ref(sc, sc->u1_1, sc->int_vector_ref_symbol, T_INT_VECTOR));
+ res = univect_ref(sc, sc->u1_1, sc->int_vector_ref_symbol, T_INT_VECTOR);
+ set_car(sc->u1_1, sc->F);
+ return(res);
case T_BYTE_VECTOR:
set_car(sc->u1_1, obj);
set_cdr(sc->u1_1, indices);
- return(univect_ref(sc, sc->u1_1, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
+ res = univect_ref(sc, sc->u1_1, 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)))
@@ -49746,7 +49929,9 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic
/* return((*(c_object_ref(sc, obj)))(sc, cons(sc, obj, indices))); */
set_car(sc->u1_1, obj);
set_cdr(sc->u1_1, indices);
- return((*(c_object_ref(sc, obj)))(sc, sc->u1_1));
+ res = (*(c_object_ref(sc, obj)))(sc, sc->u1_1);
+ set_car(sc->u1_1, sc->F);
+ return(res);
case T_LET:
obj = s7_let_ref(sc, obj, car(indices));
@@ -50032,8 +50217,6 @@ pass (rootlet):\n\
return(sc->nil);
}
-#define SHOW_EVAL_OPS 0
-
s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args)
{
declare_jump_info();
@@ -50224,10 +50407,6 @@ 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? */
-#if 0
- s7_load(sc, "profile.scm");
- s7_eval_c_string(sc, "(show-profile 20)");
-#endif
s7_quit(sc);
return(g_emergency_exit(sc, args));
}
@@ -50279,12 +50458,13 @@ static void check_next_let_slot_1(s7_scheme *sc, s7_pointer e, const char* func,
#endif
/* 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, arg));}
+static s7_pointer fx_c(s7_scheme *sc, s7_pointer arg) {return(arg);}
+static s7_pointer fx_unspecified(s7_scheme *sc, s7_pointer arg) {return(sc->unspecified);}
+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, arg));}
-static s7_pointer fx_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, arg));}
-static s7_pointer fx_g(s7_scheme *sc, s7_pointer arg) {return((is_global(arg)) ? slot_value(global_slot(arg)) : lookup(sc, arg));}
+static s7_pointer fx_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, arg));}
+static s7_pointer fx_g(s7_scheme *sc, s7_pointer arg) {return((is_global(arg)) ? slot_value(global_slot(arg)) : lookup(sc, arg));}
static s7_pointer fx_t(s7_scheme *sc, s7_pointer arg)
{
check_let_slots(sc, __func__, arg, arg);
@@ -50309,12 +50489,12 @@ static s7_pointer fx_U(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_c_d(s7_scheme *sc, s7_pointer arg) {return(d_call(sc, arg));}
+#if (!WITH_GMP)
static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg)
{
return(make_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_rng))));
}
-#if (!WITH_GMP)
static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, s7_int y)
{
#if S7_DEBUGGING
@@ -51127,16 +51307,6 @@ static s7_pointer fx_vector_ref_direct(s7_scheme *sc, s7_pointer arg)
check_let_slots(sc, __func__, arg, cadr(arg));
return(vector_ref_p_pi(sc, slot_value(let_slots(sc->envir)), integer(opt2_con(cdr(arg)))));
}
-
-#if 0
-static s7_pointer fx_vector_ref_a_to_a(s7_scheme *sc, s7_pointer arg)
-{
- s7_pointer body;
- body = closure_body(opt1_lambda(arg));
- check_let_slots(sc, __func__, arg, cadar(body));
- return(vector_ref_p_pi(sc, fx_call(sc, cdr(arg)), integer(opt2_con(cdar(body)))));
-}
-#endif
#endif
static s7_pointer fx_c_uc(s7_scheme *sc, s7_pointer arg) /* few hits */
@@ -51147,13 +51317,6 @@ static s7_pointer fx_c_uc(s7_scheme *sc, s7_pointer arg) /* few hits */
return(c_call(arg)(sc, sc->t2_1));
}
-#if 0
-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_any(cdr(arg))));
-}
-#endif
-
static s7_pointer fx_char_equal_tc(s7_scheme *sc, s7_pointer arg)
{
s7_pointer c;
@@ -51342,8 +51505,8 @@ static s7_pointer fx_multiply_ss(s7_scheme *sc, s7_pointer arg) {return(multiply
static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, caddr(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(caddr(arg))));}
-static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, cadr(arg)), integer(caddr(arg)), arg));}
-static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, caddr(arg)), integer(cadr(arg)), arg));}
+static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, cadr(arg)), integer(caddr(arg))));}
+static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, caddr(arg)), integer(cadr(arg))));}
static s7_pointer fx_multiply_tu(s7_scheme *sc, s7_pointer arg)
{
@@ -51352,10 +51515,8 @@ static s7_pointer fx_multiply_tu(s7_scheme *sc, s7_pointer arg)
return(multiply_p_pp(sc, slot_value(let_slots(sc->envir)), slot_value(next_slot(let_slots(sc->envir)))));
}
-static s7_pointer fx_sqr_ss(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x)
{
- s7_pointer x;
- x = lookup(sc, cadr(arg));
if (is_float(x)) return(make_real(sc, real(x) * real(x)));
switch (type(x))
@@ -51388,23 +51549,33 @@ static s7_pointer fx_sqr_ss(s7_scheme *sc, s7_pointer arg)
return(x);
}
-static s7_pointer fx_c_sqr_sqr(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_sqr_ss(s7_scheme *sc, s7_pointer arg) {return(fx_sqr_1(sc, lookup(sc, cadr(arg))));}
+static s7_pointer fx_sqr_tt(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x;
+ check_let_slots(sc, __func__, arg, cadr(arg));
+ x = slot_value(let_slots(sc->envir));
+ if (is_float(x)) return(make_real(sc, real(x) * real(x)));
+ return(fx_sqr_1(sc, x));
+}
+
+static s7_pointer fx_c_sqr_sqr(s7_scheme *sc, s7_pointer arg) /* tbig -- need t case here */
{
- set_car(sc->t2_1, fx_sqr_ss(sc, cadr(arg)));
- set_car(sc->t2_2, fx_sqr_ss(sc, caddr(arg)));
+ set_car(sc->t2_1, fx_sqr_1(sc, lookup(sc, cadr(cadr(arg)))));
+ set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg)))));
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer fx_c_s_sqr(s7_scheme *sc, s7_pointer 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_ss(sc, caddr(arg)));
+ set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg)))));
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer arg) /* fb */
{
- set_car(sc->t2_2, fx_sqr_ss(sc, caddr(arg)));
+ set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg)))));
set_car(sc->t2_1, cadr(arg));
return(c_call(arg)(sc, sc->t2_1));
}
@@ -51446,9 +51617,14 @@ static s7_pointer fx_gt_tg(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_gt_tT(s7_scheme *sc, s7_pointer arg)
{
+ s7_pointer p1, p2;
check_let_slots(sc, __func__, arg, cadr(arg));
check_outer_let_slots(sc, __func__, arg, caddr(arg));
- return(gt_p_pp(sc, slot_value(let_slots(sc->envir)), slot_value(let_slots(outlet(sc->envir)))));
+ p1 = slot_value(let_slots(sc->envir));
+ p2 = slot_value(let_slots(outlet(sc->envir)));
+ if ((is_t_integer(p1)) && (is_t_integer(p2)))
+ return(make_boolean(sc, p1 > p2));
+ return(gt_p_pp(sc, p1, p2));
}
static s7_pointer fx_gt_tu(s7_scheme *sc, s7_pointer arg)
@@ -51499,6 +51675,23 @@ 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_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); /* (< 2 1 1+i) */
+ 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)
{
check_let_slots(sc, __func__, arg, cadr(arg));
@@ -51687,25 +51880,59 @@ static s7_pointer fx_hash_table_ref_st(s7_scheme *sc, s7_pointer 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));
-
if (!is_hash_table(table))
return(g_hash_table_ref(sc, set_plist_2(sc, table, car(lst))));
-
return(hash_entry_value((*hash_table_checker(table))(sc, table, car(lst))));
}
+static inline s7_pointer fx_hash_increment_1(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer arg)
+{
+ hash_entry_t *val;
+ if (!is_hash_table(table))
+ return(((s7_p_ppp_t)opt2_direct(cdr(arg)))(sc, table, key, fx_call(sc, cdddr(arg))));
+ 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, small_int(1));
+ return(small_int(1));
+}
+
+static s7_pointer fx_hash_increment(s7_scheme *sc, s7_pointer arg)
+{
+ return(fx_hash_increment_1(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)), arg));
+}
+
static s7_pointer fx_lint_let_ref(s7_scheme *sc, s7_pointer arg)
{
s7_pointer lt, sym, y;
- lt = cdr(lookup(sc, opt2_sym(arg))); /* TODO: this is sometimes slot_value(let_slots(sc->envir)); */
+ lt = cdr(lookup(sc, opt2_sym(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_1(sc, outlet(lt), sym));
+}
+
+static s7_pointer fx_lint_let_ref_t(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer lt, sym, y;
+ check_let_slots(sc, __func__, arg, opt2_sym(arg));
+ lt = cdr(slot_value(let_slots(sc->envir)));
if (!is_let(lt))
return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 1, lt, a_let_string));
- sym = opt3_sym(cdar(closure_body(opt1_lambda(arg))));
+ sym = opt2_sym(cdr(arg));
for (y = let_slots(lt); tis_slot(y); y = next_slot(y))
if (slot_symbol(y) == sym)
return(slot_value(y));
@@ -51783,11 +52010,19 @@ static s7_pointer fx_c_css(s7_scheme *sc, s7_pointer arg)
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, cadr(arg));
+ set_car(sc->t3_1, opt3_any(cdr(arg)));
set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */
return(c_call(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));
+ set_car(sc->t3_2, opt2_con(cdr(arg))); /* caddr(arg) */
+ return(c_call(arg)(sc, sc->t3_1));
+}
+
static s7_pointer fx_c_ssc(s7_scheme *sc, s7_pointer arg)
{
set_car(sc->t3_1, lookup(sc, cadr(arg)));
@@ -51796,15 +52031,6 @@ static s7_pointer fx_c_ssc(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t3_1));
}
-static s7_pointer fx_c_sssc(s7_scheme *sc, s7_pointer arg)
-{
- set_car(sc->t4_1, lookup(sc, cadr(arg))); /* t4_1 -> t3_1 */
- set_car(sc->t3_1, lookup(sc, opt1_sym(cdr(arg)))); /* caddr(arg) */
- set_car(sc->t3_2, lookup(sc, opt3_sym(cdr(arg)))); /* cadddr(arg) */
- set_car(sc->t3_3, opt2_con(cdr(arg))); /* caddddr(arg) */
- return(c_call(arg)(sc, sc->t4_1));
-}
-
static s7_pointer fx_c_opdq(s7_scheme *sc, s7_pointer arg)
{
set_car(sc->t1_1, d_call(sc, cadr(arg)));
@@ -51836,15 +52062,6 @@ static s7_pointer fx_c_opdq_s(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer fx_c_opdq_c(s7_scheme *sc, s7_pointer arg)
-{
- s7_pointer largs;
- largs = cadr(arg);
- set_car(sc->t2_1, d_call(sc, largs));
- set_car(sc->t2_2, caddr(arg));
- return(c_call(arg)(sc, sc->t2_1));
-}
-
static inline void gc_protect_direct(s7_scheme *sc, s7_pointer val)
{
sc->stack_end[3] = (s7_pointer)OP_GC_PROTECT;
@@ -51852,19 +52069,6 @@ static inline void gc_protect_direct(s7_scheme *sc, s7_pointer val)
sc->stack_end[-2] = val;
}
-static s7_pointer fx_c_opdq_opdq(s7_scheme *sc, s7_pointer arg)
-{
- s7_pointer largs;
-
- largs = cadr(arg);
- gc_protect_direct(sc, d_call(sc, largs));
- largs = caddr(arg);
- set_car(sc->t2_2, d_call(sc, largs));
- set_car(sc->t2_1, sc->stack_end[-2]);
- sc->stack_end -= 4;
- return(c_call(arg)(sc, sc->t2_1));
-}
-
static s7_pointer fx_c_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -51988,18 +52192,6 @@ static s7_pointer fx_c_weak1_type_s(s7_scheme *sc, s7_pointer arg)
return(wrong_type_argument(sc, sc->c_pointer_weak1_symbol, 1, val, T_C_POINTER));
}
-#if 0
-static s7_pointer fx_c_weak1_type_t(s7_scheme *sc, s7_pointer arg)
-{
- s7_pointer val;
- check_let_slots(sc, __func__, arg, cadadr(arg));
- val = slot_value(let_slots(sc->envir));
- 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))));
- return(method_or_bust(sc, val, sc->c_pointer_weak1_symbol, list_1(sc, val), T_C_POINTER, 1));
-}
-#endif
-
static s7_pointer fx_not_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -52149,10 +52341,31 @@ static s7_pointer fx_c_opgsq_t_direct(s7_scheme *sc, s7_pointer arg)
s7_pointer largs;
largs = cdadr(arg);
return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc,
- ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, slot_value(global_slot(car(largs))), lookup(sc, opt2_sym(largs))),
+ ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs))),
slot_value(let_slots(sc->envir))));
}
+static s7_pointer fx_vector_ref_vector_ref_gs_t(s7_scheme *sc, s7_pointer arg) /* ugh! */
+{
+ s7_pointer p1, p2, v1, v2, largs;
+ p1 = slot_value(let_slots(sc->envir));
+ largs = cdadr(arg);
+ p2 = lookup(sc, opt2_sym(largs));
+ v1 = lookup_global(sc, car(largs));
+ if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1)))
+ {
+ s7_int i1, i2;
+ i1 = integer(p1);
+ i2 = integer(p2);
+ if ((i1 >= 0) && (i2 >= 0) && (i2 < vector_length(v1)))
+ {
+ v2 = vector_element(v1, i2);
+ if ((is_normal_vector(v2)) && (vector_rank(v2) == 1) && (i1 < vector_length(v2)))
+ return(vector_element(v2, i1));
+ }}
+ return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p2), p1));
+}
+
static s7_pointer fx_c_opscq_c(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -52220,6 +52433,15 @@ static s7_pointer fx_c_opuq_t(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+static s7_pointer fx_c_opuq_t_direct(s7_scheme *sc, s7_pointer arg)
+{
+ check_let_slots(sc, __func__, arg, caddr(arg));
+ check_next_let_slot(sc, __func__, arg, cadadr(arg));
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc,
+ ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir)))),
+ slot_value(let_slots(sc->envir))));
+}
+
static s7_pointer fx_c_opsq_cs(s7_scheme *sc, s7_pointer arg)
{
set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg); */
@@ -52310,6 +52532,25 @@ static s7_pointer fx_c_s_opssq_direct(s7_scheme *sc, s7_pointer arg)
return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)),
((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
}
+/* multiply_s_opssq_direct saved almost nothing */
+
+static s7_pointer fx_c_g_opgsq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ arg = cdr(arg);
+ largs = cdadr(arg);
+ return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup_global(sc, car(arg)),
+ ((s7_p_pp_t)opt3_direct(arg))(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
+}
+
+static s7_pointer fx_vector_ref_g_vector_ref_gs(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ arg = cdr(arg);
+ largs = cdadr(arg);
+ return(vector_ref_p_pp(sc, lookup_global(sc, car(arg)),
+ vector_ref_p_pp(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
+}
#if (!WITH_GMP)
static s7_pointer fx_num_eq_add_ss(s7_scheme *sc, s7_pointer arg)
@@ -52358,6 +52599,19 @@ static s7_pointer fx_c_s_opscq(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+static s7_pointer fx_c_t_opucq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = caddr(arg);
+ check_let_slots(sc, __func__, arg, cadr(arg));
+ check_next_let_slot(sc, __func__, arg, cadr(largs));
+ set_car(sc->t2_1, slot_value(next_slot(let_slots(sc->envir))));
+ set_car(sc->t2_2, opt2_con(cdr(largs)));
+ set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1));
+ set_car(sc->t2_1, slot_value(let_slots(sc->envir)));
+ return(c_call(arg)(sc, sc->t2_1));
+}
+
static s7_pointer fx_c_s_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -52462,17 +52716,6 @@ static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
-#if 0
-static s7_pointer fx_c_c_optq(s7_scheme *sc, s7_pointer arg)
-{
- check_let_slots(sc, __func__, arg, cadr(caddr(arg)));
- set_car(sc->t1_1, slot_value(let_slots(sc->envir)));
- set_car(sc->t2_2, c_call(caddr(arg))(sc, sc->t1_1));
- set_car(sc->t2_1, cadr(arg));
- return(c_call(arg)(sc, sc->t2_1));
-}
-#endif
-
static s7_pointer direct_c_opsq_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_double x1, x2;
@@ -52518,6 +52761,15 @@ static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+static s7_pointer fx_c_opsq_optuq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ 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, slot_value(let_slots(sc->envir)), slot_value(next_slot(let_slots(sc->envir))))));
+}
+
static s7_pointer fx_c_opssq_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -52643,6 +52895,16 @@ static s7_pointer fx_c_op_opsq_q_c(s7_scheme *sc, s7_pointer code)
return(c_call(code)(sc, sc->t2_1));
}
+static s7_pointer fx_string_ref_0_symbol_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer sym;
+ set_car(sc->t1_1, lookup(sc, cadr(opt3_any(code))));
+ sym = c_call(opt3_any(code))(sc, sc->t1_1);
+ if (is_symbol(sym))
+ return(s7_make_character(sc, symbol_name(sym)[0]));
+ return(simple_wrong_type_argument(sc, sc->symbol_to_string_symbol, car(sc->t1_1), T_SYMBOL));
+}
+
static s7_pointer fx_c_a(s7_scheme *sc, s7_pointer arg)
{
set_car(sc->t1_1, fx_call(sc, cdr(arg)));
@@ -52732,6 +52994,37 @@ static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+static s7_pointer fx_c_ca(s7_scheme *sc, s7_pointer arg)
+{
+ check_stack_size(sc);
+ set_car(sc->t2_2, fx_call(sc, cddr(arg)));
+ set_car(sc->t2_1, opt3_any(arg));
+ return(c_call(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_ac(s7_scheme *sc, s7_pointer arg)
+{
+ check_stack_size(sc);
+ set_car(sc->t2_1, fx_call(sc, cdr(arg)));
+ set_car(sc->t2_2, opt3_any(arg));
+ return(c_call(arg)(sc, sc->t2_1));
+}
+
+#if (!WITH_GMP)
+static s7_pointer fx_is_zero_remainder(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer u, t, rarg;
+ rarg = cdadr(arg);
+ check_let_slots(sc, __func__, arg, cadr(rarg));
+ check_next_let_slot(sc, __func__, arg, cadar(rarg));
+ u = ((s7_p_p_t)opt3_direct(rarg))(sc, slot_value(next_slot(let_slots(sc->envir))));
+ t = slot_value(let_slots(sc->envir));
+ if ((is_t_integer(u)) && (is_t_integer(t)))
+ return(make_boolean(sc, c_rem_int(sc, integer(u), integer(t)) == 0));
+ return(is_zero_p_p(sc, remainder_p_pp(sc, u, t)));
+}
+#endif
+
static s7_pointer fx_c_sa(s7_scheme *sc, s7_pointer arg)
{
s7_pointer a1;
@@ -52791,6 +53084,14 @@ static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer arg)
return(number_to_string_p_pp(sc, fx_call(sc, a1), fx_call(sc, a2)));
}
+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, cddr(arg)));
+ set_car(sc->t3_3, fx_call(sc, cdddr(arg)));
+ return(c_call(arg)(sc, sc->t3_1));
+}
+
static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg)
{
check_stack_size(sc);
@@ -52862,6 +53163,17 @@ static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t1_1));
}
+static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p;
+ check_stack_size(sc); /* t101 + s7test full */
+ 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, c_call(p)(sc, sc->t2_1));
+ return(c_call(arg)(sc, sc->t1_1));
+}
+
static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer code)
{
s7_pointer arg;
@@ -52915,20 +53227,36 @@ static s7_pointer fx_c_s_opaaaq(s7_scheme *sc, s7_pointer code)
static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code)
{
+ s7_pointer res;
#if S7_DEBUGGING
if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
- gc_protect_direct(sc, fx_call(sc, cdr(code)));
- sc->stack_end[-4] = fx_call(sc, cddr(code));
- sc->stack_end[-3] = fx_call(sc, cdddr(code));
- set_car(sc->t3_3, fx_call(sc, cddddr(code)));
+ res = cdr(code);
+ gc_protect_direct(sc, fx_call(sc, res));
+ sc->stack_end[-4] = fx_call(sc, cdr(res));
+ sc->stack_end[-3] = fx_call(sc, cddr(res));
+ set_car(sc->t3_3, fx_call(sc, cdddr(res)));
set_car(sc->t3_2, sc->stack_end[-3]);
set_car(sc->t3_1, sc->stack_end[-4]);
set_car(sc->t4_1, sc->stack_end[-2]);
sc->stack_end -= 4;
- return(c_call(code)(sc, sc->t4_1));
+ res = c_call(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;
+ 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, cddr(res)));
+ set_car(sc->t3_3, fx_call(sc, cdddr(res)));
+ res = c_call(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)
{
@@ -53073,35 +53401,48 @@ static s7_pointer fx_c_fx(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_if_a_a(s7_scheme *sc, s7_pointer arg)
{
if (is_true(sc, fx_call(sc, cdr(arg))))
- return(fx_call(sc, cddr(arg)));
+ return(fx_call(sc, opt1_pair(arg)));
+ return(sc->unspecified);
+}
+
+static s7_pointer fx_if_not_a_a(s7_scheme *sc, s7_pointer arg)
+{
+ if (is_false(sc, fx_call(sc, opt1_pair(arg))))
+ return(fx_call(sc, opt2_pair(arg)));
return(sc->unspecified);
}
static s7_pointer fx_if_a_aa(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer p;
- p = cdr(arg);
- if (is_true(sc, fx_call(sc, p)))
- return(fx_call(sc, cdr(p)));
- return(fx_call(sc, cddr(p)));
+ if (is_true(sc, fx_call(sc, cdr(arg))))
+ return(fx_call(sc, opt1_pair(arg)));
+ return(fx_call(sc, opt2_pair(arg)));
}
-static s7_pointer fx_and_2(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_if_not_a_aa(s7_scheme *sc, s7_pointer arg)
{
- /* arg is the full expr: (and ...) */
- s7_pointer p, val;
- p = cdr(arg);
- val = fx_call(sc, p);
- if (val == sc->F) return(val);
- return(fx_call(sc, cdr(p)));
+ if (is_false(sc, fx_call(sc, opt1_pair(arg))))
+ return(fx_call(sc, opt2_pair(arg)));
+ return(fx_call(sc, opt3_pair(arg)));
}
-static s7_pointer fx_and_s_2(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_if_a_cc(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer x;
- set_car(sc->t1_1, lookup(sc, cadadr(arg)));
- x = c_call(cadr(arg))(sc, sc->t1_1);
- if (x == sc->F) return(x);
+ if (is_true(sc, fx_call(sc, cdr(arg))))
+ return(opt1_any(arg));
+ return(opt2_any(arg));
+}
+
+static inline s7_pointer fx_and_2(s7_scheme *sc, s7_pointer arg) /* arg is the full expr: (and ...) */
+{
+ if (fx_call(sc, cdr(arg)) == sc->F) return(sc->F);
+ return(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) */
+ if (c_call(cadr(arg))(sc, sc->t1_1) == sc->F) return(sc->F);
return(c_call(caddr(arg))(sc, sc->t1_1));
}
@@ -53121,7 +53462,7 @@ static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer arg)
{
s7_pointer p, x;
x = sc->T;
- for (p = cdr(arg); is_pair(p); p = cdr(p))
+ 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))
@@ -53142,7 +53483,7 @@ static s7_pointer fx_or_2(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_or_s_2(s7_scheme *sc, s7_pointer arg)
{
s7_pointer x;
- set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg))); */
+ set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg); */
x = c_call(cadr(arg))(sc, sc->t1_1);
if (x != sc->F) return(x);
return(c_call(caddr(arg))(sc, sc->t1_1));
@@ -53207,7 +53548,7 @@ static s7_pointer fx_or_n(s7_scheme *sc, s7_pointer arg)
return(sc->F);
}
-static s7_pointer fx_thunk_a(s7_scheme *sc, s7_pointer code)
+static s7_pointer fx_safe_thunk_a(s7_scheme *sc, s7_pointer code)
{
s7_pointer f, result;
gc_protect_direct(sc, sc->envir);
@@ -53242,12 +53583,21 @@ static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code)
return(result);
}
+static s7_pointer fx_safe_closure_id_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, opt2_sym(arg)));}
+
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(c_call(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_any(cdr(arg)));
+ set_car(sc->t2_1, lookup(sc, opt2_sym(arg)));
+ return(c_call(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1));
+}
+
static s7_pointer fx_c_closure_s_a(s7_scheme *sc, s7_pointer arg)
{
s7_pointer clo_arg;
@@ -53295,13 +53645,13 @@ static s7_pointer fx_c_closure_s_d(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t1_1));
}
-static s7_pointer fx_and_2_closure_s(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is g_and_2 */
+static s7_pointer fx_and_2_closure_s(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2 */
{
s7_pointer result;
gc_protect_direct(sc, sc->envir);
sc->envir = old_frame_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);
+ 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));
sc->envir = sc->stack_end[-2];
@@ -53309,7 +53659,7 @@ static s7_pointer fx_and_2_closure_s(s7_scheme *sc, s7_pointer code) /* safe_clo
return(result);
}
-static s7_pointer fx_and_pair_closure_s(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is g_and_2 with is_pair as first clause */
+static s7_pointer fx_and_pair_closure_s(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2 with is_pair as first clause */
{
s7_pointer result;
gc_protect_direct(sc, sc->envir);
@@ -53362,6 +53712,20 @@ static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code)
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 fx_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer arg);
static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg);
@@ -53391,6 +53755,8 @@ static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg);
static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme *sc, s7_pointer arg);
static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer arg);
+static s7_pointer fx_opif_a_ssq_a(s7_scheme *sc, s7_pointer code);
+
static s7_function fx_function[NUM_OPS];
static void fx_function_init(void)
@@ -53419,7 +53785,6 @@ static void fx_function_init(void)
fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq;
fx_function[HOP_SAFE_C_S_opDq] = fx_c_s_opdq;
fx_function[HOP_SAFE_C_opDq_S] = fx_c_opdq_s;
- fx_function[HOP_SAFE_C_opDq_C] = fx_c_opdq_c;
fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq;
fx_function[HOP_SAFE_C_C_opDq] = fx_c_c_opdq;
fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c;
@@ -53435,7 +53800,6 @@ static void fx_function_init(void)
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_opDq_opDq] = fx_c_opdq_opdq;
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_opSSq_q_C] = fx_c_op_opssq_q_c;
@@ -53449,12 +53813,7 @@ static void fx_function_init(void)
fx_function[HOP_SAFE_C_op_opSSq_q_S] = fx_c_op_opssq_q_s;
fx_function[HOP_SAFE_C_op_opSSq_Sq_S] = fx_c_op_opssq_sq_s;
fx_function[HOP_SAFE_C_S_op_opSSq_opSSqq] = fx_c_s_op_opssq_opssqq;
- 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_SSA] = fx_c_ssa;
- fx_function[OP_SSA_DIRECT] = fx_c_ssa_direct;
+
fx_function[OP_SAFE_C_TUS] = fx_c_tus;
fx_function[HOP_SAFE_C_SSC] = fx_c_ssc;
fx_function[HOP_SAFE_C_SSS] = fx_c_sss;
@@ -53462,14 +53821,21 @@ static void fx_function_init(void)
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_SSSC] = fx_c_sssc;
+ fx_function[HOP_SAFE_C_CCS] = fx_c_ccs;
fx_function[HOP_SAFE_C_ALL_S] = fx_c_all_s;
- fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca;
- fx_function[HOP_SAFE_C_FX] = fx_c_fx;
fx_function[HOP_SAFE_C_A] = fx_c_a;
fx_function[HOP_SAFE_C_AA] = fx_c_aa;
+ 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_SSA] = fx_c_ssa;
+ fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca;
+ fx_function[HOP_SAFE_C_FX] = fx_c_fx;
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;
@@ -53479,13 +53845,42 @@ static void fx_function_init(void)
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_SAFE_THUNK_A] = fx_thunk_a;
+ fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a;
fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a;
- fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s;
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[OP_SSA_DIRECT] = fx_c_ssa_direct;
+ fx_function[OP_HASH_INCREMENT] = fx_hash_increment;
+
+ fx_function[HOP_SAFE_CLOSURE_ID_S] = fx_safe_closure_id_s;
+
+ 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[OP_COND_FX_FX] = fx_cond_fx_fx;
+ fx_function[OP_opIF_A_SSq_A] = fx_opif_a_ssq_a;
+ fx_function[OP_IF_A_CC] = fx_if_a_cc;
+ fx_function[OP_IF_A_A] = fx_if_a_a;
+ fx_function[OP_IF_A_AA] = fx_if_a_aa;
+ fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a;
+ fx_function[OP_IF_NOT_A_AA] = fx_if_not_a_aa;
+ fx_function[OP_OR_2] = fx_or_2;
+ 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_3] = fx_or_3;
+ fx_function[OP_OR_N] = fx_or_n;
+ fx_function[OP_AND_2] = fx_and_2;
+ fx_function[OP_AND_S_2] = fx_and_s_2;
+ fx_function[OP_AND_3] = fx_and_3;
+ fx_function[OP_AND_N] = fx_and_n;
+
+ fx_function[OP_SYM] = fx_unsafe_s; /* these 4 probably never happen */
+ fx_function[OP_GLOBAL_SYM] = fx_g;
+ fx_function[OP_CON] = fx_c;
+ fx_function[OP_UNSPECIFIED] = fx_unspecified;
+
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;
@@ -53540,18 +53935,6 @@ static bool is_code_constant(s7_scheme *sc, s7_pointer p)
return(is_constant(sc, p));
}
-static s7_pointer g_if_a_a(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_if_a_aa(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_and_2(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_and_s_2(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_and_3(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_and_n(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_or_2(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_or_s_2(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_or_s_type_2(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_or_3(s7_scheme *sc, s7_pointer args);
-static s7_pointer g_or_n(s7_scheme *sc, s7_pointer args);
-
static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code);
static s7_p_p_t s7_p_p_function(s7_pointer f);
@@ -53563,532 +53946,546 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
s7_pointer arg;
arg = car(holder);
/* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, DISPLAY(arg), op_names[optimize_op(arg)]); */
- if (is_pair(arg))
+
+ if (!is_pair(arg))
{
- if (is_optimized(arg))
+ if (is_symbol(arg))
{
- switch (optimize_op(arg))
+ if ((is_keyword(arg)) ||
+ ((arg == sc->else_symbol) &&
+ (is_global(arg))))
+ return(fx_c);
+#if S7_DEBUGGING
+ if ((is_global(arg)) && (!checker(sc, arg, e))) fprintf(stderr, "%s global: %d\n", DISPLAY(arg), checker(sc, arg, e));
+#endif
+ if (is_global(arg))
+ return(fx_g);
+ if (checker(sc, arg, e))
+ return(fx_s);
+ return(fx_unsafe_s);
+ }
+ return(fx_c);
+ }
+
+ if (is_optimized(arg))
+ {
+ switch (optimize_op(arg))
+ {
+ case HOP_SAFE_C_D:
+#if (!WITH_GMP)
+ if (c_callee(arg) == g_random_i) return(fx_random_i);
+#endif
+ return(fx_c_d);
+
+ case OP_OR_2:
+ if (c_callee(cddr(arg)) == fx_and_2) return(fx_or_and_2);
+ if (c_callee(cddr(arg)) == fx_and_3) return(fx_or_and_3);
+ return(fx_or_2);
+
+ case HOP_SAFE_C_S:
+ 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 (is_global(car(arg))) /* guard against (op arg) where arg is a let with an op method */
{
- case HOP_SAFE_C_D:
- if (c_callee(arg) == g_if_a_aa) return(fx_if_a_aa);
- if (c_callee(arg) == g_if_a_a) return(fx_if_a_a);
- if (c_callee(arg) == g_and_2) return(fx_and_2);
- if (c_callee(arg) == g_and_3) return(fx_and_3);
- if (c_callee(arg) == g_and_n) return(fx_and_n);
- if (c_callee(arg) == g_or_2)
- {
- if (c_callee(cddr(arg)) == fx_and_2) return(fx_or_and_2);
- if (c_callee(cddr(arg)) == fx_and_3) return(fx_or_and_3);
- return(fx_or_2);
- }
- if (c_callee(arg) == g_or_3) return(fx_or_3);
- if (c_callee(arg) == g_or_n) return(fx_or_n);
- if (c_callee(arg) == g_or_s_2) return(fx_or_s_2);
- if (c_callee(arg) == g_or_s_type_2) return(fx_or_s_type_2);
- if (c_callee(arg) == g_and_s_2) return(fx_and_s_2);
- if (c_callee(arg) == g_random_i) return(fx_random_i);
- return(fx_c_d);
-
- case HOP_SAFE_C_S:
- 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 (is_global(car(arg))) /* guard against (op arg) where arg is a let with an op method */
+ uint8_t typ;
+ 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_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);
+ typ = symbol_type(car(arg));
+ if (typ > 0)
{
- uint8_t typ;
- 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_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);
- typ = symbol_type(car(arg));
- if (typ > 0)
- {
- set_opt3_byte(cdr(arg), typ);
- return(fx_is_type_s);
- }
+ set_opt3_byte(cdr(arg), typ);
+ return(fx_is_type_s);
}
- if (symbol_id(car(arg)) == 0)
+ }
+ if (symbol_id(car(arg)) == 0)
+ {
+ /* 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(slot_value(global_slot(car(arg)))))) == 0) /* yow! */
{
- /* 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(slot_value(global_slot(car(arg)))))) == 0) /* yow! */
+ s7_p_p_t f;
+ f = s7_p_p_function(slot_value(global_slot(car(arg))));
+ if (f)
{
- s7_p_p_t f;
- f = s7_p_p_function(slot_value(global_slot(car(arg))));
- if (f)
- {
- set_direct_opt(arg);
- set_opt2_direct(cdr(arg), (s7_pointer)f);
- if (f == iterate_p_p)
- return(fx_iterate_p_p);
- return(fx_o_p_p_s);
- }
+ set_direct_opt(arg);
+ set_opt2_direct(cdr(arg), (s7_pointer)f);
+ if (f == iterate_p_p)
+ return(fx_iterate_p_p);
+ return(fx_o_p_p_s);
}
}
- if (is_global(cadr(arg))) return(fx_c_g);
- return(fx_c_s);
-
- case HOP_SAFE_C_SS:
- if (c_callee(arg) == g_cons) return(fx_cons_ss);
+ }
+ if (is_global(cadr(arg))) return(fx_c_g);
+ return(fx_c_s);
+
+ case HOP_SAFE_C_SS:
+ if (c_callee(arg) == g_cons) return(fx_cons_ss);
#if (!WITH_GMP)
- if (car(arg) == sc->num_eq_symbol) return(fx_num_eq_ss);
- if (c_callee(arg) == g_geq_2) return(fx_geq_ss);
- if (c_callee(arg) == g_greater_2) return(fx_gt_ss);
- if (c_callee(arg) == g_leq_2) return(fx_leq_ss);
- if (c_callee(arg) == g_less_2) return(fx_lt_ss);
- if ((car(arg) == sc->multiply_symbol) && (cadr(arg) == caddr(arg))) return(fx_sqr_ss);
- if (c_callee(arg) == g_multiply_2) return(fx_multiply_ss);
-#endif
- if (c_callee(arg) == g_is_eq) return(fx_is_eq_ss);
- if (c_callee(arg) == g_add_2) return(fx_add_ss);
- if (c_callee(arg) == g_subtract_2) return(fx_subtract_ss);
-
- if ((c_callee(arg) == g_hash_table_ref_2) && (is_symbol(car(arg))) && (is_symbol(cadr(arg))))
- return(fx_hash_table_ref_ss);
- return(fx_c_ss);
-
- case HOP_SAFE_C_SSA:
- if (s7_p_ppp_function(slot_value(global_slot(car(arg)))))
- {
- set_direct_opt(arg);
- set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(slot_value(global_slot(car(arg))))));
- return(fx_c_ssa_direct);
- }
- return(fx_c_ssa);
-
- case HOP_SAFE_C_AAA:
- if ((c_callee(cdr(arg)) == fx_g) && (c_callee(cdddr(arg)) == fx_c)) return(fx_c_gac);
- return(fx_c_aaa);
-
- case HOP_SAFE_C_S_opSSq:
+ if (car(arg) == sc->num_eq_symbol) return(fx_num_eq_ss);
+ if (c_callee(arg) == g_geq_2) return(fx_geq_ss);
+ if (c_callee(arg) == g_greater_2) return(fx_gt_ss);
+ if (c_callee(arg) == g_leq_2) return(fx_leq_ss);
+ if (c_callee(arg) == g_less_2) return((is_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss);
+ if ((car(arg) == sc->multiply_symbol) && (cadr(arg) == caddr(arg))) return(fx_sqr_ss);
+ if (c_callee(arg) == g_multiply_2) return(fx_multiply_ss);
+#endif
+ if (c_callee(arg) == g_is_eq) return(fx_is_eq_ss);
+ if (c_callee(arg) == g_add_2) return(fx_add_ss);
+ if (c_callee(arg) == g_subtract_2) return(fx_subtract_ss);
+
+ if ((c_callee(arg) == g_hash_table_ref_2) && (is_symbol(car(arg))) && (is_symbol(cadr(arg))))
+ return(fx_hash_table_ref_ss);
+ return(fx_c_ss);
+
#if (!WITH_GMP)
- {
- s7_pointer s2;
- s2 = caddr(arg);
- if ((car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2)))
- return(fx_c_s_sqr);
-
- if ((car(arg) == sc->num_eq_symbol) && (car(s2) == sc->add_symbol))
- return(fx_num_eq_add_ss);
- }
+ case HOP_SAFE_C_SSS:
+ if ((c_callee(arg) == g_less) && (is_global(cadr(arg))) && (is_global(cadddr(arg)))) return(fx_lt_gsg);
+ return(fx_c_sss);
#endif
- if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
- (s7_p_pp_function(slot_value(global_slot(caaddr(arg))))))
- {
-#if 0
- fprintf(stderr, "%s %d, %s %d, %s %d\n",
- DISPLAY(cadr(caddr(arg))), is_global(cadr(caddr(arg))),
- DISPLAY(caddr(caddr(arg))), is_global(caddr(caddr(arg))),
- DISPLAY(cadr(arg)), is_global(cadr(arg)));
- /* op_g_opgTq or opg_opgtq or op_g_opgsq */
-#endif
- set_direct_opt(arg);
- set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
- set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg))))));
- /* fprintf(stderr, "fx_c_s_opssq_direct: %s\n", DISPLAY(arg)); */
- return(fx_c_s_opssq_direct);
- }
- return(fx_c_s_opssq);
+
+ case HOP_SAFE_C_SSA:
+ if (s7_p_ppp_function(slot_value(global_slot(car(arg)))))
+ {
+ set_direct_opt(arg);
+ set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(slot_value(global_slot(car(arg))))));
+ return(fx_c_ssa_direct);
+ }
+ return(fx_c_ssa);
+
+ case HOP_SAFE_C_AAA:
+ if ((c_callee(cdr(arg)) == fx_g) && (c_callee(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;
+ if (is_null(p)) return(fx_c_4g);
+ return(fx_c_4a);
+ }
- case HOP_SAFE_C_opSSq_S:
- if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
- (s7_p_pp_function(slot_value(global_slot(caadr(arg))))))
+ case HOP_SAFE_C_S_opSSq:
+#if (!WITH_GMP)
+ {
+ s7_pointer s2;
+ s2 = caddr(arg);
+ if ((car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2)))
+ return(fx_c_s_sqr);
+
+ if ((car(arg) == sc->num_eq_symbol) && (car(s2) == sc->add_symbol))
+ return(fx_num_eq_add_ss);
+ }
+#endif
+ if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
+ (s7_p_pp_function(slot_value(global_slot(caaddr(arg))))))
+ {
+ set_direct_opt(arg);
+ set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg))))));
+ /* tbig: (* wr (vector-ref|float-vector-ref|int-vector-ref|hash-table-ref|let-ref rl j))
+ * (+ ii (* pw mmax))
+ * b: (vref s (vref...)) (-|+ s (* s s))
+ */
+ if ((is_global(cadr(arg))) && (is_global(cadr(caddr(arg)))))
{
-#if 0
- fprintf(stderr, "%s %d, %s %d, %s %d\n",
- DISPLAY(cadr(cadr(arg))), is_global(cadr(cadr(arg))),
- DISPLAY(caddr(cadr(arg))), is_global(caddr(cadr(arg))),
- DISPLAY(caddr(arg)), is_global(caddr(arg)));
-#endif
- /* op_c_opgsq_t */
- /* also gt_tT gt_tg */
-
- set_direct_opt(arg);
- set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
- set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(arg))))));
- return(fx_c_opssq_s_direct);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) &&
+ (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp))
+ return(fx_vector_ref_g_vector_ref_gs);
+ return(fx_c_g_opgsq_direct);
}
- return(fx_c_opssq_s);
-
+ /* if (opt2_direct(cdr(arg)) == (s7_pointer)multiply_p_pp) return(fx_multiply_s_opssq_direct); */ /* very small gain */
+ return(fx_c_s_opssq_direct);
+ }
+ return(fx_c_s_opssq);
+
+ case HOP_SAFE_C_opSSq_S:
+ if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
+ (s7_p_pp_function(slot_value(global_slot(caadr(arg))))))
+ {
+ /* op_c_opgsq_t */
+ set_direct_opt(arg);
+ set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(arg))))));
+ return(fx_c_opssq_s_direct);
+ }
+ return(fx_c_opssq_s);
+
#if (!WITH_GMP)
- case HOP_SAFE_C_opSSq_opSSq:
- {
- s7_pointer s1, s2;
- s1 = cadr(arg);
- s2 = caddr(arg);
- if ((car(s1) == sc->multiply_symbol) && (cadr(s1) == caddr(s1)) &&
- (car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2)))
- return(fx_c_sqr_sqr);
- return(fx_c_opssq_opssq);
- }
+ case HOP_SAFE_C_opSSq_opSSq:
+ {
+ s7_pointer s1, s2;
+ s1 = cadr(arg);
+ s2 = caddr(arg);
+ if ((car(s1) == sc->multiply_symbol) && (cadr(s1) == caddr(s1)) &&
+ (car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2)))
+ return(fx_c_sqr_sqr);
+ return(fx_c_opssq_opssq);
+ }
#endif
- case HOP_SAFE_C_opSq:
- if (is_global(caadr(arg)))
+ case HOP_SAFE_C_opSq:
+ if (is_global(caadr(arg)))
+ {
+ if (car(arg) == sc->is_pair_symbol) /* h_safe so no need to check pair? */
{
- if (car(arg) == sc->is_pair_symbol) /* h_safe so no need to check pair? */
+ if (caadr(arg) == sc->car_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);
- }
+ set_opt2_sym(cdr(arg), cadadr(arg));
+ return(fx_is_pair_car_s);
}
- if (car(arg) == sc->is_null_symbol)
+ if (caadr(arg) == sc->cdr_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);
- }
+ set_opt2_sym(cdr(arg), cadadr(arg));
+ return(fx_is_pair_cdr_s);
}
-
- if (car(arg) == sc->is_symbol_symbol)
+ if (caadr(arg) == sc->cadr_symbol)
{
- if (caadr(arg) == sc->cadr_symbol)
- {
- set_opt2_sym(cdr(arg), cadadr(arg));
- return(fx_is_symbol_cadr_s);
- }
+ set_opt2_sym(cdr(arg), cadadr(arg));
+ return(fx_is_pair_cadr_s);
}
-
- if (car(arg) == sc->not_symbol)
+ if (caadr(arg) == sc->cddr_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);
+ set_opt2_sym(cdr(arg), cadadr(arg));
+ return(fx_is_pair_cddr_s);
}
}
- if (is_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */
- { /* other possibility: fx_c_a */
- uint8_t typ;
- typ = symbol_type(car(arg));
- if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */
+ if (car(arg) == sc->is_null_symbol)
+ {
+ if (caadr(arg) == sc->cdr_symbol)
{
set_opt2_sym(cdr(arg), cadadr(arg));
- set_opt3_byte(cdr(arg), typ);
- if (c_callee(cadr(arg)) == (s7_function)g_c_pointer_weak1)
- return(fx_c_weak1_type_s);
- if (caadr(arg) == sc->car_symbol) /* trclo: symbol? integer?, trec: symbol?, lt: symbol? integer? string? */
- return(fx_is_type_car_s);
- return(fx_is_type_opsq);
+ 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);
}
}
- /* this should follow the is_type* check above */
- if (caadr(arg) == sc->car_symbol)
- {
- set_opt2_sym(cdr(arg), cadadr(arg));
- return(fx_c_car_s);
- }
- if (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 (!WITH_GMP)
- if (car(arg) == sc->add_symbol)
+
+ if (car(arg) == sc->is_symbol_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 (caadr(arg) == sc->cadr_symbol)
+ {
+ set_opt2_sym(cdr(arg), cadadr(arg));
+ return(fx_is_symbol_cadr_s);
+ }
}
- if (car(arg) == sc->subtract_symbol)
+
+ if (car(arg) == sc->not_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 (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 (car(arg) == sc->multiply_symbol)
+ }
+ if (is_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */
+ { /* other possibility: fx_c_a */
+ uint8_t typ;
+ typ = symbol_type(car(arg));
+ if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */
{
- if (is_t_real(caddr(arg))) return(fx_multiply_sf);
- if (is_t_integer(caddr(arg))) return(fx_multiply_si);
+ set_opt2_sym(cdr(arg), cadadr(arg));
+ set_opt3_byte(cdr(arg), typ);
+ if (c_callee(cadr(arg)) == (s7_function)g_c_pointer_weak1)
+ return(fx_c_weak1_type_s);
+ if (caadr(arg) == sc->car_symbol) /* trclo: symbol? integer?, trec: symbol?, lt: symbol? integer? string? */
+ return(fx_is_type_car_s);
+ return(fx_is_type_opsq);
}
- if ((car(arg) == sc->num_eq_symbol) && (is_t_integer(caddr(arg)))) return(fx_num_eq_si);
+ }
+ /* this should follow the is_type* check above */
+ if (caadr(arg) == sc->car_symbol)
+ {
+ set_opt2_sym(cdr(arg), cadadr(arg));
+ return(fx_c_car_s);
+ }
+ if (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 (!WITH_GMP)
+ 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 ((car(arg) == sc->num_eq_symbol) && (is_t_integer(caddr(arg)))) return(fx_num_eq_si);
#endif
- if ((c_callee(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2);
- if ((c_callee(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc);
- return(fx_c_sc);
-
- case HOP_SAFE_C_CS:
+ if ((c_callee(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2);
+ if ((c_callee(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc);
+ return(fx_c_sc);
+
+ case HOP_SAFE_C_CS:
#if (!WITH_GMP)
- 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->multiply_symbol)
- {
- if (is_t_real(cadr(arg))) return(fx_multiply_fs);
- if (is_t_integer(cadr(arg))) return(fx_multiply_is);
- }
+ 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->multiply_symbol)
+ {
+ if (is_t_real(cadr(arg))) return(fx_multiply_fs);
+ if (is_t_integer(cadr(arg))) return(fx_multiply_is);
+ }
#endif
- return(fx_c_cs);
-
- case HOP_SAFE_C_S_opSq:
- if (car(caddr(arg)) == sc->car_symbol)
+ return(fx_c_cs);
+
+ case HOP_SAFE_C_S_opSq:
+ if (car(caddr(arg)) == sc->car_symbol)
+ {
+ if (car(arg) == sc->hash_table_ref_symbol)
{
- if (car(arg) == sc->hash_table_ref_symbol)
- {
- set_opt2_sym(cdr(arg), cadr(caddr(arg)));
- return(fx_hash_table_ref_car);
- }
set_opt2_sym(cdr(arg), cadr(caddr(arg)));
- if (car(arg) == sc->add_symbol)
- return(fx_add_s_car_s);
- return(fx_c_s_car_s);
+ return(fx_hash_table_ref_car);
}
-
- if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
- (s7_p_p_function(slot_value(global_slot(caaddr(arg))))))
- {
- set_direct_opt(arg);
- set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
- set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caaddr(arg))))));
- return(fx_c_s_opsq_direct);
- }
-#if 0
- if (!s7_p_pp_function(slot_value(global_slot(car(arg)))))
- fprintf(stderr, "no p_pp: %s in %s\n", DISPLAY(car(arg)), DISPLAY(arg));
- if (!s7_p_p_function(slot_value(global_slot(caaddr(arg)))))
- fprintf(stderr, "no p_p: %s in %s\n", DISPLAY(caaddr(arg)), DISPLAY(arg));
-#endif
- return(fx_c_s_opsq);
-
- case HOP_SAFE_C_opSq_C:
- if ((car(arg) == sc->memq_symbol) &&
- (car(cadr(arg)) == sc->car_symbol) &&
- (is_proper_quote(sc, caddr(arg))) &&
- (is_pair(cadr(caddr(arg)))))
- {
- if (s7_list_length(sc, opt2_con(cdr(arg))) == 2)
- return(fx_memq_car_s_2);
- return(fx_memq_car_s);
- }
-
- if (car(arg) == sc->is_eq_symbol)
- {
- if (((caadr(arg) == sc->car_symbol) || (caadr(arg) == sc->caar_symbol)) &&
- (is_proper_quote(sc, caddr(arg))))
- {
- set_opt3_sym(cdr(arg), cadadr(arg));
- set_opt2_con(cdr(arg), cadr(caddr(arg)));
- return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_q : fx_is_eq_caar_q);
- }
- }
-#if (!WITH_GMP)
- if (((car(arg) == sc->lt_symbol) || (car(arg) == sc->num_eq_symbol)) &&
- (is_t_integer(caddr(arg))) &&
- (caadr(arg) == sc->length_symbol))
+ set_opt2_sym(cdr(arg), cadr(caddr(arg)));
+ if (car(arg) == sc->add_symbol)
+ return(fx_add_s_car_s);
+ return(fx_c_s_car_s);
+ }
+
+ if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
+ (s7_p_p_function(slot_value(global_slot(caaddr(arg))))))
+ {
+ set_direct_opt(arg);
+ set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caaddr(arg))))));
+ return(fx_c_s_opsq_direct);
+ }
+ return(fx_c_s_opsq);
+
+ case HOP_SAFE_C_opSq_C:
+ if ((car(arg) == sc->memq_symbol) &&
+ (car(cadr(arg)) == sc->car_symbol) &&
+ (is_proper_quote(sc, caddr(arg))) &&
+ (is_pair(cadr(caddr(arg)))))
+ {
+ if (s7_list_length(sc, opt2_con(cdr(arg))) == 2)
+ return(fx_memq_car_s_2);
+ return(fx_memq_car_s);
+ }
+
+ if (car(arg) == sc->is_eq_symbol)
+ {
+ if (((caadr(arg) == sc->car_symbol) || (caadr(arg) == sc->caar_symbol)) &&
+ (is_proper_quote(sc, caddr(arg))))
{
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_opt2_con(cdr(arg), cadr(caddr(arg)));
+ return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_q : fx_is_eq_caar_q);
}
+ }
+#if (!WITH_GMP)
+ if (((car(arg) == sc->lt_symbol) || (car(arg) == sc->num_eq_symbol)) &&
+ (is_t_integer(caddr(arg))) &&
+ (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);
+ }
#endif
- return(fx_c_opsq_c);
-
- case HOP_SAFE_C_opSCq:
- if (car(arg) == sc->not_symbol)
+ return(fx_c_opsq_c);
+
+ case HOP_SAFE_C_opSCq:
+ if (car(arg) == sc->not_symbol)
+ {
+ if (c_callee(cadr(arg)) == g_is_eq)
{
- if (c_callee(cadr(arg)) == g_is_eq)
- {
- set_opt2_sym(cdr(arg), cadr(cadr(arg)));
- set_opt3_any(cdr(arg), (is_pair(caddr(cadr(arg)))) ? cadr(caddr(cadr(arg))) : caddr(cadr(arg)));
- return(fx_not_is_eq_sq);
- }
- return(fx_c_opscq);
+ set_opt2_sym(cdr(arg), cadr(cadr(arg)));
+ set_opt3_any(cdr(arg), (is_pair(caddr(cadr(arg)))) ? cadr(caddr(cadr(arg))) : caddr(cadr(arg)));
+ return(fx_not_is_eq_sq);
}
return(fx_c_opscq);
-
- case HOP_SAFE_C_opSSq:
- if (car(arg) == sc->not_symbol)
+ }
+ return(fx_c_opscq);
+
+ case HOP_SAFE_C_opSSq:
+ if (car(arg) == sc->not_symbol)
+ {
+ if (c_callee(cadr(arg)) == g_is_eq)
{
- if (c_callee(cadr(arg)) == g_is_eq)
- {
- set_opt2_sym(cdr(arg), cadr(cadr(arg)));
- set_opt3_sym(cdr(arg), caddr(cadr(arg)));
- return(fx_not_is_eq_ss);
- }
- return(fx_not_opssq);
+ set_opt2_sym(cdr(arg), cadr(cadr(arg)));
+ set_opt3_sym(cdr(arg), caddr(cadr(arg)));
+ return(fx_not_is_eq_ss);
}
- return(fx_c_opssq);
-
- case HOP_SAFE_C_C_opSSq:
+ return(fx_not_opssq);
+ }
+ return(fx_c_opssq);
+
+ case HOP_SAFE_C_C_opSSq:
#if (!WITH_GMP)
- {
- s7_pointer s2;
- s2 = caddr(arg);
- if ((car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2)))
- return(fx_c_c_sqr);
- }
+ {
+ s7_pointer s2;
+ s2 = caddr(arg);
+ if ((car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2)))
+ return(fx_c_c_sqr);
+ }
#endif
- if (has_direct_opt(arg)) return(direct_c_c_opssq);
- return(fx_c_c_opssq);
+ if (has_direct_opt(arg)) return(direct_c_c_opssq);
+ return(fx_c_c_opssq);
- case HOP_SAFE_C_opSq_opSq:
- if (has_direct_opt(arg)) return(direct_c_opsq_opsq);
- return(fx_c_opsq_opsq);
-
- case HOP_SAFE_C_op_opSq_q:
- if ((car(arg) == sc->not_symbol) && /* (not (eq? (car s) 's)) */
- (c_callee(cadr(arg)) == g_is_eq) &&
- (c_callee(cadadr(arg)) == g_car) &&
- (is_symbol(cadr(cadadr(arg)))) &&
- (is_proper_quote(sc, caddr(cadr(arg)))))
- {
- set_opt2_sym(cdr(arg), cadr(cadr(cadr(arg))));
- set_opt3_any(cdr(arg), cadr(caddr(cadr(arg))));
- return(fx_not_is_eq_car_q);
- }
- return(fx_c_op_opsq_q);
-
- case HOP_SAFE_C_S_op_S_opSSqq:
- if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
- (s7_p_pp_function(slot_value(global_slot(caaddr(arg))))) &&
- (s7_p_pp_function(slot_value(global_slot(caaddr(caddr(arg)))))))
- {
- set_direct_opt(arg);
- set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
- set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg))))));
- set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(caddr(arg)))))));
- return(fx_c_s_op_s_opssqq_direct);
- }
- return(fx_c_s_op_s_opssqq);
+ case HOP_SAFE_C_opSq_opSq:
+ if (has_direct_opt(arg)) return(direct_c_opsq_opsq);
+ return(fx_c_opsq_opsq);
+
+ case HOP_SAFE_C_op_opSq_q:
+ if ((car(arg) == sc->not_symbol) && /* (not (eq? (car s) 's)) */
+ (c_callee(cadr(arg)) == g_is_eq) &&
+ (c_callee(cadadr(arg)) == g_car) &&
+ (is_symbol(cadr(cadadr(arg)))) &&
+ (is_proper_quote(sc, caddr(cadr(arg)))))
+ {
+ set_opt2_sym(cdr(arg), cadr(cadr(cadr(arg))));
+ set_opt3_any(cdr(arg), cadr(caddr(cadr(arg))));
+ return(fx_not_is_eq_car_q);
+ }
+ return(fx_c_op_opsq_q);
+
+ case HOP_SAFE_C_S_op_S_opSSqq:
+ if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
+ (s7_p_pp_function(slot_value(global_slot(caaddr(arg))))) &&
+ (s7_p_pp_function(slot_value(global_slot(caaddr(caddr(arg)))))))
+ {
+ set_direct_opt(arg);
+ set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
+ set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg))))));
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(caddr(arg)))))));
+ return(fx_c_s_op_s_opssqq_direct);
+ }
+ return(fx_c_s_op_s_opssqq);
+
+ case HOP_SAFE_C_op_opSSq_q_S:
+ if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
+ (s7_p_p_function(slot_value(global_slot(caadr(arg))))) &&
+ (s7_p_pp_function(slot_value(global_slot(car(cadr(cadr(arg))))))))
+ {
+ set_direct_opt(arg);
+ set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
+ set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(arg))))));
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(cadr(arg)))))));
+ return(fx_c_op_opssq_q_s_direct);
+ }
+ return(fx_c_op_opssq_q_s);
- case HOP_SAFE_C_op_opSSq_q_S:
- if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
- (s7_p_p_function(slot_value(global_slot(caadr(arg))))) &&
- (s7_p_pp_function(slot_value(global_slot(car(cadr(cadr(arg))))))))
- {
- set_direct_opt(arg);
- set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
- set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(arg))))));
- set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(cadr(arg)))))));
- return(fx_c_op_opssq_q_s_direct);
- }
- return(fx_c_op_opssq_q_s);
-
- case HOP_SAFE_C_A:
- if (car(arg) == sc->not_symbol) return(fx_not_a);
- if (c_callee(cdr(arg)) == fx_safe_closure_s_d) return(fx_c_closure_s_d);
- if (c_callee(cdr(arg)) == fx_safe_closure_s_a) return(fx_c_closure_s_a);
- return(fx_c_a);
-
- 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 (c_callee(arg) == g_add_2) return(fx_add_aa);
- if (c_callee(arg) == g_subtract_2) return(fx_subtract_aa);
- if (c_callee(arg) == g_number_to_string) return(fx_number_to_string_aa);
+ case HOP_SAFE_C_op_opSq_q_C:
+ if ((c_callee(arg) == g_string_ref) && (integer(caddr(arg)) == 0) && (c_callee(cadr(arg)) == g_symbol_to_string_uncopied))
+ {
+ set_opt3_any(arg, cadadr(arg));
+ return(fx_string_ref_0_symbol_a);
+ }
+ return(fx_c_op_opsq_q_c);
+
+ case HOP_SAFE_C_A:
+ if (car(arg) == sc->not_symbol) return(fx_not_a);
+ if (c_callee(cdr(arg)) == fx_safe_closure_s_d) return(fx_c_closure_s_d);
+ if (c_callee(cdr(arg)) == fx_safe_closure_s_a) return(fx_c_closure_s_a);
+ return(fx_c_a);
+
+ 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 (c_callee(arg) == g_add_2) return(fx_add_aa);
+ if (c_callee(arg) == g_subtract_2) return(fx_subtract_aa);
+ if (c_callee(arg) == g_number_to_string) return(fx_number_to_string_aa);
#if WITH_GMP
- if (c_callee(cdr(arg)) == fx_s) return(fx_c_sa);
+ if (c_callee(cdr(arg)) == fx_s) return(fx_c_sa);
#else
- if (c_callee(cdr(arg)) == fx_s) return((c_callee(arg) == g_multiply_2) ? fx_multiply_sa : fx_c_sa); /* watch out for fx_unsafe_s here */
- if (c_callee(arg) == g_multiply_2) return(fx_multiply_aa);
+ if (c_callee(cdr(arg)) == fx_s) return((c_callee(arg) == g_multiply_2) ? fx_multiply_sa : fx_c_sa); /* watch out for fx_unsafe_s here */
+ if (c_callee(arg) == g_multiply_2) return(fx_multiply_aa);
#endif
- if (c_callee(cddr(arg)) == fx_s) return(fx_c_as);
- return(fx_c_aa);
+ if (c_callee(cddr(arg)) == fx_s) return(fx_c_as);
+ return(fx_c_aa);
- case HOP_SAFE_CLOSURE_S_A:
+ case HOP_SAFE_C_opAAq:
+ if (c_callee(cdadr(arg)) == fx_s) return(fx_c_opsaq);
+ return(fx_c_opaaq);
+
+ case HOP_SAFE_CLOSURE_S_A:
+ {
+ s7_pointer body;
+ body = car(closure_body(opt1_lambda(arg)));
+ if (is_pair(body))
{
- s7_pointer body;
- body = car(closure_body(opt1_lambda(arg)));
- if (is_pair(body))
+ if (optimize_op(body) == OP_AND_2)
{
- if (is_h_safe_c_d(body))
- {
- if (c_callee(body) == g_and_2)
- {
- if ((caadr(body) == sc->is_pair_symbol) &&
- (symbol_id(sc->is_pair_symbol) == 0) &&
- (cadadr(body) == car(closure_args(opt1_lambda(arg)))))
- return(fx_and_pair_closure_s);
- return(fx_and_2_closure_s);
- }
- return(fx_safe_closure_s_d);
- }
- if (optimize_op(body) == HOP_SAFE_C_opSq_C)
+ if ((caadr(body) == sc->is_pair_symbol) &&
+ (symbol_id(sc->is_pair_symbol) == 0) &&
+ (cadadr(body) == car(closure_args(opt1_lambda(arg)))))
+ return(fx_and_pair_closure_s);
+ return(fx_and_2_closure_s);
+ }
+
+ if (is_h_safe_c_d(body))
+ return(fx_safe_closure_s_d);
+
+ if (optimize_op(body) == HOP_SAFE_C_opSq_C)
+ {
+ if ((c_callee(body) == g_lint_let_ref) &&
+ (cadadr(body) == car(closure_args(opt1_lambda(arg)))))
{
- /* fprintf(stderr, "%s %d %s\n", DISPLAY(body), (c_callee(body) == g_lint_let_ref), DISPLAY(closure_args(opt1_lambda(arg)))); */
- if ((c_callee(body) == g_lint_let_ref) &&
- (cadadr(body) == car(closure_args(opt1_lambda(arg)))))
- return(fx_lint_let_ref);
+ set_opt2_sym(cdr(arg), cadr(caddr(body)));
+ return(fx_lint_let_ref); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */
}
}
- return(fx_safe_closure_s_a);
}
-
- 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)
- {
- check_quote(sc, arg);
- return(fx_q);
+ return(fx_safe_closure_s_a);
+ }
+
+ 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)]);
}
- return(NULL);
- }
- if (is_symbol(arg))
+ } /* is_optimized */
+ if (car(arg) == sc->quote_symbol)
{
- if ((is_keyword(arg)) ||
- ((arg == sc->else_symbol) &&
- (is_global(arg))))
- return(fx_c);
-#if S7_DEBUGGING
- if ((is_global(arg)) && (!checker(sc, arg, e))) fprintf(stderr, "%s global: %d\n", DISPLAY(arg), checker(sc, arg, e));
-#endif
- if (is_global(arg))
- return(fx_g);
- if (checker(sc, arg, e))
- return(fx_s);
- return(fx_unsafe_s);
+ check_quote(sc, arg);
+ return(fx_q);
}
- return(fx_c);
+ return(NULL);
}
#if 0
@@ -54124,7 +54521,7 @@ static bool fx_tree_out2(s7_scheme *sc, s7_pointer tree, s7_pointer v1, s7_point
static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2)
{
s7_pointer p;
- /* fprintf(stderr, "%s[%d] %s %s %d %s: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), fx_name(sc, tree), DISPLAY(tree)); */
+ /* fprintf(stderr, "%s[%d] %s %s %d: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), DISPLAY(tree)); */
p = car(tree);
if (is_symbol(p))
{
@@ -54179,7 +54576,7 @@ static s7_b_7p_t s7_b_7p_function(s7_pointer f);
#if 0
static void tree_globals(s7_scheme *sc, s7_pointer tree, s7_pointer orig)
{
- if ((is_symbol(tree)) && (!is_keyword(tree)))
+ if (is_normal_symbol(tree))
{
if (is_global(tree)) fprintf(stderr, "%s in %s\n", DISPLAY(tree), DISPLAY_80(orig));
}
@@ -54200,8 +54597,8 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
/* extending this to a third variable did not get many hits */
s7_pointer p;
- /* fprintf(stderr, "%s[%d] %s %s %s\n", __func__, __LINE__, DISPLAY(tree), DISPLAY(var1), (var2) ? DISPLAY(var2) : ""); */
- /* fprintf(stderr, "%s[%d] %s %s %d %s: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), fx_name(sc, tree), DISPLAY(tree)); */
+ /* fprintf(stderr, "%s[%d] %s %s %s, fx: %d\n", __func__, __LINE__, DISPLAY(tree), DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree)); */
+ /* fprintf(stderr, "%s[%d] %s %s %d %s: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), fx_name(sc, tree), DISPLAY(tree)); */
#if S7_DEBUGGING
/* tree_globals(sc, tree, tree); */
@@ -54222,11 +54619,6 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
}
return(false);
}
-#if 0
- if ((c_callee(tree) == fx_sqr_ss) &&
- ((s7_tree_memq(sc, var1, p)) || (s7_tree_memq(sc, var2, p))))
- fprintf(stderr, "%s %s %s\n", DISPLAY(var1), (var2) ? DISPLAY(var2) : "", DISPLAY_80(p));
-#endif
if ((is_pair(p)) && (is_pair(cdr(p))))
{
@@ -54286,6 +54678,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
if (c_callee(tree) == fx_safe_closure_s_d) return(with_c_call(tree, fx_safe_closure_t_d));
if (c_callee(tree) == fx_length_s) return(with_c_call(tree, fx_length_t));
if ((c_callee(tree) == fx_c_s_opsq_direct) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_opuq_direct));
+ if ((c_callee(tree) == fx_c_s_opscq) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_opucq));
#if (!WITH_GMP)
if (c_callee(tree) == fx_num_eq_ss)
{
@@ -54301,7 +54694,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
if (c_callee(tree) == fx_lt_ss) return(with_c_call(tree, fx_lt_tu));
if (c_callee(tree) == fx_leq_ss) return(with_c_call(tree, fx_leq_tu));
if (c_callee(tree) == fx_geq_ss) return(with_c_call(tree, fx_geq_tu));
- if (c_callee(tree) == fx_c_sss) {set_optimize_op(p, OP_SAFE_C_TUS); return(with_c_call(tree, fx_c_tus));}
+ if (c_callee(tree) == fx_c_sss) {set_safe_optimize_op(p, OP_SAFE_C_TUS); return(with_c_call(tree, fx_c_tus));}
}
else
{
@@ -54311,9 +54704,11 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
}
if (c_callee(tree) == fx_num_eq_si) return(with_c_call(tree, fx_num_eq_ti));
if (c_callee(tree) == fx_gt_ss) return(with_c_call(tree, (is_global(caddr(p))) ? fx_gt_tg : fx_gt_ts));
+ if (c_callee(tree) == fx_sqr_ss) return(with_c_call(tree, fx_sqr_tt));
#endif
if (c_callee(tree) == fx_cons_ss) return(with_c_call(tree, fx_cons_ts));
if ((c_callee(tree) == fx_c_s_car_s) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_car_u));
+ if (c_callee(tree) == fx_lint_let_ref) return(with_c_call(tree, fx_lint_let_ref_t));
}
else
{
@@ -54350,7 +54745,6 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
{
if (c_callee(tree) == fx_c_opssq)
{
- /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(p)); */
if (caddr(cadr(p)) == var1)
{
if ((is_global(car(p))) && (is_global(caadr(p))) &&
@@ -54368,74 +54762,93 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
}
if ((c_callee(tree) == fx_c_opssq_c) && (caddr(cadr(p)) == var1)) return(with_c_call(tree, fx_c_opstq_c));
- if ((is_pair(cdadr(p))) && (cadadr(p) == var1))
+ if (is_pair(cdadr(p)))
{
- /* fprintf(stderr, "%d: %s %s\n", __LINE__, DISPLAY(var1), DISPLAY(p)); */
- if ((c_callee(tree) == fx_c_opsq_c) || (c_callee(tree) == fx_c_optq_c))
+ if (cadadr(p) == var1)
{
- if (c_callee(p) != g_lint_let_ref) /* don't step on opt3_sym */
+ if ((c_callee(tree) == fx_c_opsq_c) || (c_callee(tree) == fx_c_optq_c))
+ {
+ if (c_callee(p) != g_lint_let_ref) /* don't step on opt3_sym */
+ {
+ if ((is_global(car(p))) && (is_global(caadr(p))) &&
+ (s7_p_pp_function(slot_value(global_slot(car(p))))) &&
+ (s7_p_p_function(slot_value(global_slot(caadr(p))))))
+ {
+ set_direct_opt(p);
+ if (c_callee(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(slot_value(global_slot(car(p))))));
+ set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p))))));
+ set_c_call(tree, fx_c_optq_c_direct);
+ }
+ else set_c_call(tree, fx_c_optq_c);
+ }
+ return(true);
+ }
+ if (c_callee(tree) == fx_is_pair_car_s) return(with_c_call(tree, fx_is_pair_car_t));
+ if (c_callee(tree) == fx_is_pair_cdr_s) return(with_c_call(tree, fx_is_pair_cdr_t));
+ if (c_callee(tree) == fx_is_pair_cadr_s) return(with_c_call(tree, fx_is_pair_cadr_t));
+ if (c_callee(tree) == fx_is_symbol_cadr_s) return(with_c_call(tree, fx_is_symbol_cadr_t));
+ if (c_callee(tree) == fx_is_pair_cddr_s) return(with_c_call(tree, fx_is_pair_cddr_t));
+ if (c_callee(tree) == fx_is_null_cdr_s) return(with_c_call(tree, fx_is_null_cdr_t));
+ if (c_callee(tree) == fx_is_null_cddr_s) return(with_c_call(tree, fx_is_null_cddr_t));
+ if (c_callee(tree) == fx_not_is_pair_s) return(with_c_call(tree, fx_not_is_pair_t));
+ if (c_callee(tree) == fx_not_is_null_s) return(with_c_call(tree, fx_not_is_null_t));
+ if (c_callee(tree) == fx_not_is_symbol_s) return(with_c_call(tree, fx_not_is_symbol_t));
+ if (c_callee(tree) == fx_is_type_car_s) return(with_c_call(tree, fx_is_type_car_t));
+ if (c_callee(tree) == fx_c_opsq)
{
if ((is_global(car(p))) && (is_global(caadr(p))) &&
- (s7_p_pp_function(slot_value(global_slot(car(p))))) &&
+ (s7_p_p_function(slot_value(global_slot(car(p))))) &&
(s7_p_p_function(slot_value(global_slot(caadr(p))))))
{
set_direct_opt(p);
- if (c_callee(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(slot_value(global_slot(car(p))))));
+ set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p))))));
set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p))))));
- set_c_call(tree, fx_c_optq_c_direct);
+ set_c_call(tree, fx_c_optq_direct);
}
- else set_c_call(tree, fx_c_optq_c);
+ else set_c_call(tree, fx_c_optq);
+ return(true);
}
- return(true);
+ if (c_callee(tree) == fx_is_type_opsq) return(with_c_call(tree, fx_is_type_optq));
+ if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_t));
+ if (c_callee(tree) == fx_c_cdr_s) return(with_c_call(tree, fx_c_cdr_t));
+ if (c_callee(tree) == fx_is_eq_car_q) return(with_c_call(tree, fx_is_eq_car_t_q));
+
+ if ((c_callee(tree) == fx_c_opsq_cs) && (cadddr(p) == var2)) {set_c_call(tree, fx_c_optq_cu); return(true);}
+ if (c_callee(tree) == fx_c_opsq_s) return(with_c_call(tree, fx_c_optq_s));
}
- if (c_callee(tree) == fx_is_pair_car_s) return(with_c_call(tree, fx_is_pair_car_t));
- if (c_callee(tree) == fx_is_pair_cdr_s) return(with_c_call(tree, fx_is_pair_cdr_t));
- if (c_callee(tree) == fx_is_pair_cadr_s) return(with_c_call(tree, fx_is_pair_cadr_t));
- if (c_callee(tree) == fx_is_symbol_cadr_s) return(with_c_call(tree, fx_is_symbol_cadr_t));
- if (c_callee(tree) == fx_is_pair_cddr_s) return(with_c_call(tree, fx_is_pair_cddr_t));
- if (c_callee(tree) == fx_is_null_cdr_s) return(with_c_call(tree, fx_is_null_cdr_t));
- if (c_callee(tree) == fx_is_null_cddr_s) return(with_c_call(tree, fx_is_null_cddr_t));
- if (c_callee(tree) == fx_not_is_pair_s) return(with_c_call(tree, fx_not_is_pair_t));
- if (c_callee(tree) == fx_not_is_null_s) return(with_c_call(tree, fx_not_is_null_t));
- if (c_callee(tree) == fx_not_is_symbol_s) return(with_c_call(tree, fx_not_is_symbol_t));
- if (c_callee(tree) == fx_is_type_car_s) return(with_c_call(tree, fx_is_type_car_t));
- if (c_callee(tree) == fx_c_opsq)
+
+ if (cadadr(p) == var2)
{
- if ((is_global(car(p))) && (is_global(caadr(p))) &&
- (s7_p_p_function(slot_value(global_slot(car(p))))) &&
- (s7_p_p_function(slot_value(global_slot(caadr(p))))))
+ if (c_callee(tree) == fx_not_is_null_s) return(with_c_call(tree, fx_not_is_null_u));
+#if (!WITH_GMP)
+ if ((c_callee(tree) == fx_not_opssq) && (caddr(cadr(p)) == var1))
{
- set_direct_opt(p);
- set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p))))));
- set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p))))));
- set_c_call(tree, fx_c_optq_direct);
+ if (c_callee(cadr(p)) == g_less_2) set_c_call(tree, fx_not_lt_ut); else set_c_call(tree, fx_not_oputq);
+ return(true);
}
- else set_c_call(tree, fx_c_optq);
- return(true);
+#endif
+ if ((c_callee(tree) == fx_c_opsq_s) && (caddr(p) == var1))
+ {
+ if ((is_global(car(p))) && (is_global(caadr(p))) &&
+ (s7_p_pp_function(slot_value(global_slot(car(p))))) &&
+ (s7_p_p_function(slot_value(global_slot(caadr(p))))))
+ {
+ set_direct_opt(p);
+ set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p))))));
+ set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p))))));
+ set_c_call(tree, fx_c_opuq_t_direct);
+ }
+ else return(with_c_call(tree, fx_c_opuq_t));
+ }
+ if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_u));
}
- if (c_callee(tree) == fx_is_type_opsq) return(with_c_call(tree, fx_is_type_optq));
- if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_t));
- if (c_callee(tree) == fx_c_cdr_s) return(with_c_call(tree, fx_c_cdr_t));
- if (c_callee(tree) == fx_is_eq_car_q) return(with_c_call(tree, fx_is_eq_car_t_q));
-
- if ((c_callee(tree) == fx_c_opsq_cs) && (cadddr(p) == var2)) {set_c_call(tree, fx_c_optq_cu); return(true);}
- if (c_callee(tree) == fx_c_opsq_s) return(with_c_call(tree, fx_c_optq_s));
- }
-
- if ((is_pair(cdadr(p))) && (cadadr(p) == var2))
- {
- if (c_callee(tree) == fx_not_is_null_s) return(with_c_call(tree, fx_not_is_null_u));
#if (!WITH_GMP)
- if ((c_callee(tree) == fx_not_opssq) && (caddr(cadr(p)) == var1))
- {
- if (c_callee(cadr(p)) == g_less_2) set_c_call(tree, fx_not_lt_ut); else set_c_call(tree, fx_not_oputq);
- return(true);
- }
+ if ((c_callee(tree) == fx_c_ac) && (c_callee(p) == g_num_eq_xi) && (caddr(p) == small_int(0)) &&
+ (c_callee(cdr(p)) == fx_c_opuq_t_direct) && (caadr(p) == sc->remainder_symbol))
+ return(with_c_call(tree, fx_is_zero_remainder));
#endif
- if ((c_callee(tree) == fx_c_opsq_s) && (caddr(p) == var1)) return(with_c_call(tree, fx_c_opuq_t));
- if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_u));
}
}
}
@@ -54460,15 +54873,32 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
if (c_callee(tree) == fx_c_ss) return(with_c_call(tree, (is_global(cadr(p))) ? fx_c_gt : fx_c_st));
if (c_callee(tree) == fx_hash_table_ref_ss) return(with_c_call(tree, fx_hash_table_ref_st));
if ((c_callee(tree) == fx_c_opssq_s_direct) && (is_global(cadr(cadr(p)))))
- return(with_c_call(tree, fx_c_opgsq_t_direct));
+ {
+ if ((opt2_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) &&
+ (opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp))
+ return(with_c_call(tree, fx_vector_ref_vector_ref_gs_t));
+ return(with_c_call(tree, fx_c_opgsq_t_direct));
+ }
}
-#if 0
- if ((is_pair(caddr(p))) && (is_pair(cdr(caddr(p)))) && (var1 == cadr(caddr(p))))
+
+ if (is_pair(caddr(p)))
{
- /* lots of opsq_opsq here */
- /* if (c_callee(tree) == fx_c_c_opsq) {set_c_call(tree, fx_c_c_optq); return(true);} */
+ if ((c_callee(tree) == fx_c_opsq_opssq) && (cadr(caddr(p)) == var1) && (caddr(caddr(p)) == var2))
+ {
+ if ((is_global(car(p))) && (is_global(caadr(p))) && (is_global(caaddr(p))) &&
+ (s7_p_pp_function(slot_value(global_slot(car(p))))) &&
+ (s7_p_p_function(slot_value(global_slot(caadr(p))))) &&
+ (s7_p_pp_function(slot_value(global_slot(caaddr(p))))))
+ {
+ set_direct_opt(p);
+ set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p))))));
+ set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p))))));
+ set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(p))))));
+ set_c_call(tree, fx_c_opsq_optuq_direct);
+ return(true);
+ }
+ }
}
-#endif
if (caddr(p) == var2)
{
if (c_callee(tree) == fx_c_cs) return(with_c_call(tree, fx_c_cu));
@@ -54478,11 +54908,12 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
return(false);
}
+/* #define fx_tree(Sc, Tree, Var1, Var2) fx_tree_1(Sc, Tree, Var1, Var2, __func__, __LINE__) */
static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2)
{
#if 0
if (is_pair(tree))
- fprintf(stderr, "%s[%d]: %s %s %d %s %s\n", __func__, __LINE__,
+ fprintf(stderr, "%s[%d]: %s %s %d %s %s\n", func, line,
DISPLAY_80(tree), (is_optimized(tree)) ? op_names[optimize_op(tree)] : "unopt",
has_fx(tree), /* (has_fx(tree)) ? fx_name(sc, tree) : "", */
DISPLAY(var1), (var2) ? DISPLAY(var2) : "");
@@ -54765,14 +55196,8 @@ static void s7_set_p_dd_function(s7_pointer f, s7_p_dd_t df) {add_opt_func(f, o_
#endif
static s7_p_dd_t s7_p_dd_function(s7_pointer f) {return((s7_p_dd_t)opt_func(f, o_p_dd));}
-#define oo_slots(p) p->slots
-#define oo_size(p) p->size
-
#if S7_DEBUGGING
-#if OPT_INFO_DEBUGGING
- static const char *oo_types[15] = {"OO_P", "OO_I", "OO_D", "OO_V", "OO_IV", "OO_FV", "OO_PV", "OO_R", "OO_H", "OO_S", "OO_BV", "OO_L", "OO_E", "OO_AV", "OO_TV"};
-#endif
-
+#define oo_slots(p) p->slots
#define oo_func(p) p->func
#define oo_line(p) p->line
@@ -54793,16 +55218,7 @@ static bool check_slot_type(s7_scheme *sc, s7_pointer slot, opt_info *o, int32_t
val = slot_value(slot);
if (!s7_is_valid(sc, val)) return(false);
if ((oo_to_s7[recorded_val_type] & (1 << type(val))) == 0)
- {
-#if OPT_INFO_DEBUGGING
- fprintf(stderr, "%s[%d] -> %s[%d]: %s (slot %d) wants %s but got %s, expr: %s\n",
- oo_func(o), oo_line(o), func, line,
- symbol_name(slot_symbol(slot)), i, oo_types[recorded_val_type],
- DISPLAY(g_type_of(sc, set_plist_1(sc, val))),
- DISPLAY(o->vexpr));
-#endif
- return(false);
- }
+ return(false);
if (!already_warned)
{
if ((recorded_val_type == OO_TV) && (!is_typed_vector(val)))
@@ -54818,175 +55234,54 @@ static bool check_slot_type(s7_scheme *sc, s7_pointer slot, opt_info *o, int32_t
#define oo_check(Sc, O) oo_check_1(Sc, O, __func__, __LINE__)
static void oo_check_1(s7_scheme *sc, opt_info *o, const char *func, int32_t line)
{
- int32_t i, slots, size;
- size = oo_size(o);
- if ((size <= 0) || (size > NUM_VUNIONS))
- fprintf(stderr, "%s[%d]: oo_size: %d (%s[%d]\n", func, line, size, oo_func(o), oo_line(o));
+ int32_t i, slots;
slots = oo_slots(o);
- if ((slots < 0) || (slots >= size))
- fprintf(stderr, "%s[%d]: oo_slots: %d, size: %d\n", func, line, slots, size);
+ if ((slots < 0) || (slots > NUM_VUNIONS))
+ fprintf(stderr, "%s[%d]: oo_slots: %d\n", func, line, slots);
for (i = 0; i < slots; i++)
{
s7_pointer slot = NULL;
int32_t p_addr, obj_addr;
p_addr = o->addrs[i] & 0xf;
obj_addr = (o->addrs[i] >> 4) & 0xf;
- if (p_addr >= size)
- fprintf(stderr, "%s[%d]: v[%d].p but size = %d\n", func, line, p_addr, size);
+ slot = o->v[p_addr].p;
+ if (!slot)
+ fprintf(stderr, "%s[%d]: v[%d].p is null\n", func, line, p_addr);
else
{
- slot = o->v[p_addr].p;
- if (!slot)
- fprintf(stderr, "%s[%d]: v[%d].p is null\n", func, line, p_addr);
+ if (!s7_is_valid(sc, slot))
+ fprintf(stderr, "%s[%d]: v[%d].p is not valid\n", func, line, p_addr);
else
{
- if (!s7_is_valid(sc, slot))
- fprintf(stderr, "%s[%d]: v[%d].p is not valid\n", func, line, p_addr);
- else
- {
- if (!is_slot(slot))
- fprintf(stderr, "%s[%d]: v[%d].p is not a slot\n", func, line, p_addr);
- else check_slot_type(sc, slot, o, i, func, line);
- }
+ if (!is_slot(slot))
+ fprintf(stderr, "%s[%d]: v[%d].p is not a slot\n", func, line, p_addr);
+ else check_slot_type(sc, slot, o, i, func, line);
}
}
if ((slot) && (obj_addr > 0))
{
- if (obj_addr >= size)
- fprintf(stderr, "%s[%d]: v[%d].obj but size = %d\n", func, line, obj_addr, size);
+ s7_pointer obj;
+ obj = slot_value(slot);
+ if (!obj)
+ fprintf(stderr, "%s[%d]: v[%d].obj is null\n", func, line, obj_addr);
else
{
- s7_pointer obj;
- obj = slot_value(slot);
- if (!obj)
- fprintf(stderr, "%s[%d]: v[%d].obj is null\n", func, line, obj_addr);
+ if (!s7_is_valid(sc, obj))
+ fprintf(stderr, "%s[%d]: v[%d].obj is not valid\n", func, line, obj_addr);
else
{
- if (!s7_is_valid(sc, obj))
- fprintf(stderr, "%s[%d]: v[%d].obj is not valid\n", func, line, obj_addr);
+ if (!is_c_object(obj))
+ fprintf(stderr, "%s[%d]: v[%d].obj is not a c_object\n", func, line, obj_addr);
else
{
- if (!is_c_object(obj))
- fprintf(stderr, "%s[%d]: v[%d].obj is not a c_object\n", func, line, obj_addr);
- else
- {
- void *value;
- value = o->v[obj_addr].obj;
- if (value != c_object_value(obj))
- fprintf(stderr, "%s[%d]: c_object value does not match\n", func, line);
- }}}}}}
-}
-
-#define OPT_EXTREME_DEBUGGING 0
-#if OPT_EXTREME_DEBUGGING
-static const char *opt_name(void *f);
-
-static void print_opt_1(s7_scheme *sc, opt_info *p, bool show_place)
-{
- int i, slot;
- bool happy = false, place_out = false;
- for (slot = 0; slot < OPTS_SIZE; slot++)
- if (p == p->sc->opts[slot])
- break;
- for (i = 0; i < oo_size(p); i++)
- {
- const char *fname;
- fname = opt_name(p->v[i].obj);
- if (fname)
- {
- if (!place_out)
- {
- place_out = true;
- happy = true;
- if (show_place)
- fprintf(stderr, "%s[%d]: %d\t", oo_func(p), oo_line(p), slot);
- else fprintf(stderr, "%d:\t", slot);
- }
- fprintf(stderr, " v[%d]: %s", i, fname);
- }
- }
- fprintf(stderr, "\n");
- if (!happy)
- {
- if (show_place)
- fprintf(stderr, "%s[%d] (%d): unknown\n", oo_func(p), oo_line(p), slot);
- else fprintf(stderr, "%d: unknown\n", slot);
- }
-}
-
-#define print_opt(Sc, O) print_opt_1(Sc, O, true)
-#define trace_opt(Sc, O) print_opt_1(Sc, O, false)
-
-static void print_opts(s7_scheme *sc)
-{
- int32_t i;
- for (i = 0; i < sc->pc; i++)
- {
- opt_info *o;
- int32_t k;
- o = sc->opts[i];
- fprintf(stderr, "[%d]: ", i);
- for (k = 0; k < oo_size(o); k++)
- {
- if (o->v[k].obj)
- {
- const char *fname;
- fname = opt_name(o->v[k].obj);
- if (fname)
- fprintf(stderr, "v[%d].%s ", k, fname);
- }
- }
- fprintf(stderr, "\n");
- }
+ void *value;
+ value = o->v[obj_addr].obj;
+ if (value != c_object_value(obj))
+ fprintf(stderr, "%s[%d]: c_object value does not match\n", func, line);
+ }}}}}
}
-static void oo_save_func(opt_info *p, const char *func, int line)
-{
- oo_func(p) = func;
- oo_line(p) = line;
- print_opt(cur_sc, p);
- oo_check(cur_sc, p);
-}
-#else
#define oo_save_func(p, func, line) do {oo_func(p) = func; oo_line(p) = line; oo_check(cur_sc, p);} while (0)
-#endif
-
-#define oo_rc(Sc, O, Size, Slots) oo_rc_1(Sc, O, Size, Slots, __func__, __LINE__)
-static void oo_rc_1(s7_scheme *sc, opt_info *o, int size, int slots, const char *func, int32_t line)
-{
- int32_t i;
- if ((oo_size(o) < size) || (oo_size(o) >= NUM_VUNIONS))
- fprintf(stderr, "%s[%d]: o[%s[%d]] size: %d, desired: %d\n", func, line, oo_func(o), oo_line(o), oo_size(o), size);
- if ((oo_slots(o) < slots) || (oo_slots(o) >= NUM_VUNIONS))
- fprintf(stderr, "%s[%d]: o[%s[%d]] slots: %d, desired: %d\n", func, line, oo_func(o), oo_line(o), oo_slots(o), slots);
- for (i = 0; i < slots; i++)
- {
- int32_t p_addr;
- s7_pointer slot;
- p_addr = o->addrs[i] & 0xf;
- slot = o->v[p_addr].p;
- if (!slot)
- fprintf(stderr, "%s[%d]: o[%s[%d]] slot[%d, p_addr: %d] is null\n", func, line, oo_func(o), oo_line(o), i, p_addr);
- if (tis_slot(slot))
- check_slot_type(sc, slot, o, i, func, line);
- else fprintf(stderr, "%s[%d]: slot: %s\n", func, line, DISPLAY(slot));
- }
-#if OPT_EXTREME_DEBUGGING
- trace_opt(cur_sc, o);
-#endif
-}
-
-static void oo_clear(opt_info *o)
-{
-#if OPT_INFO_DEBUGGING
- memset((void *)o, 0, sizeof(opt_info));
- o->sc = cur_sc;
-#else
- int32_t i;
- for (i = oo_size(o); i < NUM_VUNIONS; i++)
- o->v[i].p = NULL;
-#endif
-}
static void check_oo_type(opt_type_t typ, int slot, int num, const char *func, int line)
{
@@ -54995,8 +55290,6 @@ static void check_oo_type(opt_type_t typ, int slot, int num, const char *func, i
#else
#define oo_check(sc, p)
-#define oo_rc(sc, p, size, slots)
-#define oo_clear(p)
#define oo_func(p)
#define oo_line(p)
@@ -55008,82 +55301,74 @@ static void oo_store_slot(opt_info *p, int offset, int32_t slot, opt_type_t type
{
#if S7_DEBUGGING
p->addrs[offset] = slot;
-#endif
p->types[offset] = type;
+#endif
}
-#define oo_set_type_0(P, Size) oo_set_type_0_0(P, Size, __func__, __LINE__)
-static bool oo_set_type_0_0(opt_info *p, int size, const char *func, int line)
+#define oo_set_type_0(P) oo_set_type_0_0(P, __func__, __LINE__)
+static bool oo_set_type_0_0(opt_info *p, const char *func, int line)
{
+#if S7_DEBUGGING
oo_slots(p) = 0;
- oo_size(p) = size;
+#endif
oo_save_func(p, func, line);
return(true);
}
-#define oo_set_type_1(P, Size, Slot, Type) oo_set_type_1_1(P, Size, Slot, Type, __func__, __LINE__)
-static bool oo_set_type_1_1(opt_info *p, int size, int slot1, opt_type_t type1, const char *func, int line)
+#define oo_set_type_1(P, Slot, Type) oo_set_type_1_1(P, Slot, Type, __func__, __LINE__)
+static bool oo_set_type_1_1(opt_info *p, int slot1, opt_type_t type1, const char *func, int line)
{
check_oo_type(type1, slot1, 1, func, line);
+#if S7_DEBUGGING
oo_slots(p) = 1;
- oo_size(p) = size;
+#endif
oo_store_slot(p, 0, slot1, type1);
oo_save_func(p, func, line);
return(true);
}
-#define oo_set_type_2(P, Size, Slot1, Slot2, Type1, Type2) oo_set_type_2_2(P, Size, Slot1, Slot2, Type1, Type2, __func__, __LINE__)
-static bool oo_set_type_2_2(opt_info *p, int size, int slot1, int slot2, opt_type_t type1, opt_type_t type2, const char *func, int line)
+#define oo_set_type_2(P, Slot1, Slot2, Type1, Type2) oo_set_type_2_2(P, Slot1, Slot2, Type1, Type2, __func__, __LINE__)
+static bool oo_set_type_2_2(opt_info *p, int slot1, int slot2, opt_type_t type1, opt_type_t type2, const char *func, int line)
{
check_oo_type(type1, slot1, 1, func, line);
check_oo_type(type2, slot2, 2, func, line);
+#if S7_DEBUGGING
oo_slots(p) = 2;
- oo_size(p) = size;
+#endif
oo_store_slot(p, 0, slot1, type1);
oo_store_slot(p, 1, slot2, type2);
oo_save_func(p, func, line);
return(true);
}
-#define oo_set_type_3(P, Size, Slot1, Slot2, Slot3, Type1, Type2, Type3) oo_set_type_3_1(P, Size, Slot1, Slot2, Slot3, Type1, Type2, Type3, __func__, __LINE__)
-static bool oo_set_type_3_1(opt_info *p, int size, int slot1, int slot2, int slot3, opt_type_t type1, opt_type_t type2, opt_type_t type3, const char *func, int line)
+#define oo_set_type_3(P, Slot1, Slot2, Slot3, Type1, Type2, Type3) oo_set_type_3_1(P, Slot1, Slot2, Slot3, Type1, Type2, Type3, __func__, __LINE__)
+static bool oo_set_type_3_1(opt_info *p, int slot1, int slot2, int slot3, opt_type_t type1, opt_type_t type2, opt_type_t type3, const char *func, int line)
{
- check_oo_type(type1, slot1, 1, func, line);
- check_oo_type(type2, slot2, 2, func, line);
+ oo_set_type_2(p, slot1, slot2, type1, type2);
check_oo_type(type3, slot3, 3, func, line);
+#if S7_DEBUGGING
oo_slots(p) = 3;
- oo_size(p) = size;
- oo_store_slot(p, 0, slot1, type1);
- oo_store_slot(p, 1, slot2, type2);
+#endif
oo_store_slot(p, 2, slot3, type3);
oo_save_func(p, func, line);
return(true);
}
-#define oo_set_type_4(P, Size, Slot1, Slot2, Slot3, Slot4, Type1, Type2, Type3, Type4) \
- oo_set_type_4_1(P, Size, Slot1, Slot2, Slot3, Slot4, Type1, Type2, Type3, Type4, __func__, __LINE__)
-static bool oo_set_type_4_1(opt_info *p, int size, int slot1, int slot2, int slot3, int slot4,
+#define oo_set_type_4(P, Slot1, Slot2, Slot3, Slot4, Type1, Type2, Type3, Type4) \
+ oo_set_type_4_1(P, Slot1, Slot2, Slot3, Slot4, Type1, Type2, Type3, Type4, __func__, __LINE__)
+static bool oo_set_type_4_1(opt_info *p, int slot1, int slot2, int slot3, int slot4,
opt_type_t type1, opt_type_t type2, opt_type_t type3, opt_type_t type4, const char *func, int line)
{
- check_oo_type(type1, slot1, 1, func, line);
- check_oo_type(type2, slot2, 2, func, line);
- check_oo_type(type3, slot3, 3, func, line);
+ oo_set_type_3(p, slot1, slot2, slot3, type1, type2, type3);
check_oo_type(type4, slot4, 4, func, line);
+#if S7_DEBUGGING
oo_slots(p) = 4;
- oo_size(p) = size;
- oo_store_slot(p, 0, slot1, type1);
- oo_store_slot(p, 1, slot2, type2);
- oo_store_slot(p, 2, slot3, type3);
+#endif
oo_store_slot(p, 3, slot4, type4);
oo_save_func(p, func, line);
return(true);
}
-static void oo_resize(opt_info *o, int32_t new_size)
-{
- oo_size(o) = new_size;
-}
-
#if S7_DEBUGGING
#define alloc_opo(Sc, Expr) alloc_opo_2(Sc, Expr, __func__, __LINE__)
static opt_info *alloc_opo_2(s7_scheme *sc, s7_pointer expr, const char *func, int line)
@@ -55108,8 +55393,7 @@ static opt_info *alloc_opo_1(s7_scheme *sc)
}
#endif
o = sc->opts[sc->pc++];
- oo_clear(o);
- o->v[7].fd = NULL;
+ o->v[O_WRAP].fd = NULL; /* see bool_optimize -- this is a kludge */
#if S7_DEBUGGING
o->vexpr = expr;
o->func = func;
@@ -55248,12 +55532,12 @@ static s7_pointer opt_wrap_int(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; re
static s7_pointer opt_wrap_cell(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return( sc->opts[0]->v[0].fp(sc->opts[0]));}
static s7_pointer opt_wrap_bool(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return(( sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);}
-static s7_pointer b_to_p(opt_info *o) {return((o->v[7].fb(o)) ? o->sc->T : o->sc->F);}
-static bool p_to_b(opt_info *o) {return(o->v[7].fp(o) != o->sc->F);}
-static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, o->v[7].fd(o)));}
-static s7_pointer d_to_p_nr(opt_info *o) {o->v[7].fd(o); return(NULL);}
-static s7_pointer i_to_p(opt_info *o) {return(make_integer(o->sc, o->v[7].fi(o)));}
-static s7_pointer i_to_p_nr(opt_info *o) {o->v[7].fi(o); return(NULL);}
+/* static s7_pointer b_to_p(opt_info *o) {return((o->v[O_WRAP].fb(o)) ? o->sc->T : o->sc->F);} */
+static bool p_to_b(opt_info *o) {return(o->v[O_WRAP].fp(o) != o->sc->F);}
+static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, 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(o->sc, 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 -------------------------------- */
@@ -55261,8 +55545,8 @@ static s7_pointer i_to_p_nr(opt_info *o) {o->v[7].fi(o); return(NULL);}
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) {oo_rc(o->sc, o, 2, 0); return(o->v[1].i);}
-static s7_int opt_i_s(opt_info *o) {oo_rc(o->sc, o, 2, 1); return(integer(slot_value(o->v[1].p)));}
+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)
{
@@ -55273,7 +55557,7 @@ static bool opt_int_not_pair(s7_scheme *sc, s7_pointer car_x)
opc = alloc_opo(sc, car_x);
opc->v[1].i = integer(car_x);
opc->v[0].fi = opt_i_c;
- return(oo_set_type_0(opc, 2));
+ return(oo_set_type_0(opc));
}
p = opt_integer_symbol(sc, car_x);
if (p)
@@ -55281,36 +55565,23 @@ static bool opt_int_not_pair(s7_scheme *sc, s7_pointer car_x)
opc = alloc_opo(sc, car_x);
opc->v[1].p = p;
opc->v[0].fi = opt_i_s;
- return(oo_set_type_1(opc, 2, 1, OO_I));
+ return(oo_set_type_1(opc, 1, OO_I));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- i_i|d|p -------- */
-static s7_int opt_i_i_c(opt_info *o) {oo_rc(o->sc, o, 3, 0); return(o->v[2].i_i_f(o->v[1].i));}
-static s7_int opt_i_i_s(opt_info *o) {oo_rc(o->sc, o, 3, 1); return(o->v[2].i_i_f(integer(slot_value(o->v[1].p))));}
-static s7_int opt_i_i_f(opt_info *o) {opt_info *o1; o1 = o->sc->opts[++(o->sc->pc)]; oo_rc(o->sc, o, 3, 0); return(o->v[2].i_i_f(o1->v[0].fi(o1)));}
-static s7_int opt_i_7i_c(opt_info *o) {oo_rc(o->sc, o, 3, 0); return(o->v[2].i_7i_f(o->sc, o->v[1].i));}
-static s7_int opt_i_7i_s(opt_info *o) {oo_rc(o->sc, o, 3, 1); return(o->v[2].i_7i_f(o->sc, integer(slot_value(o->v[1].p))));}
-static s7_int opt_i_7i_f(opt_info *o) {opt_info *o1; o1 = o->sc->opts[++(o->sc->pc)]; oo_rc(o->sc, o, 3, 0); return(o->v[2].i_7i_f(o->sc, o1->v[0].fi(o1)));}
-static s7_int opt_i_d_c(opt_info *o) {oo_rc(o->sc, o, 3, 0); return(o->v[2].i_7d_f(o->sc, o->v[1].x));}
-static s7_int opt_i_d_s(opt_info *o) {oo_rc(o->sc, o, 3, 1); return(o->v[2].i_7d_f(o->sc, real(slot_value(o->v[1].p))));}
-
-static s7_int opt_i_7d_f(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 3, 0);
- return(o->v[2].i_7d_f(o->sc, o1->v[0].fd(o1)));
-}
-
-static s7_int opt_i_7p_f(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 3, 0);
- return(o->v[2].i_7p_f(o->sc, o1->v[0].fp(o1)));
-}
+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(o->sc, o->v[1].i));}
+static s7_int opt_i_7i_s(opt_info *o) {return(o->v[2].i_7i_f(o->sc, integer(slot_value(o->v[1].p))));}
+static s7_int opt_i_d_c(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[1].x));}
+static s7_int opt_i_d_s(opt_info *o) {return(o->v[2].i_7d_f(o->sc, real(slot_value(o->v[1].p))));}
+
+static s7_int opt_i_i_f(opt_info *o) {o->sc->pc++; 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) {o->sc->pc++; return(o->v[2].i_7i_f(o->sc, o->v[4].fi(o->v[3].o1)));}
+static s7_int opt_i_7d_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_7d_f(o->sc, o->v[4].fd(o->v[3].o1)));}
+static s7_int opt_i_7p_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -55320,7 +55591,9 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
s7_i_7p_t ipf;
s7_pointer p;
int32_t start;
+
start = sc->pc;
+ opc->v[3].o1 = sc->opts[start];
func = s7_i_i_function(s_func);
if (!func)
@@ -55333,26 +55606,21 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (is_opt_int(cadr(car_x)))
{
opc->v[1].i = integer(cadr(car_x));
- if (func)
- opc->v[0].fi = opt_i_i_c;
- else opc->v[0].fi = opt_i_7i_c;
- return(oo_set_type_0(opc, 3));
+ opc->v[0].fi = (func) ? opt_i_i_c : opt_i_7i_c;
+ return(oo_set_type_0(opc));
}
p = opt_integer_symbol(sc, cadr(car_x));
if (p)
{
opc->v[1].p = p;
- if (func)
- opc->v[0].fi = opt_i_i_s;
- else opc->v[0].fi = opt_i_7i_s;
- return(oo_set_type_1(opc, 3, 1, OO_I));
+ opc->v[0].fi = (func) ? opt_i_i_s : opt_i_7i_s;
+ return(oo_set_type_1(opc, 1, OO_I));
}
if (int_optimize(sc, cdr(car_x)))
{
- if (func)
- opc->v[0].fi = opt_i_i_f;
- else opc->v[0].fi = opt_i_7i_f;
- return(oo_set_type_0(opc, 3));
+ opc->v[4].fi = sc->opts[start]->v[0].fi;
+ opc->v[0].fi = (func) ? opt_i_i_f : opt_i_7i_f;
+ return(oo_set_type_0(opc));
}
pc_fallback(sc, start);
}
@@ -55364,19 +55632,20 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[1].x = s7_number_to_real(sc, cadr(car_x));
opc->v[0].fi = opt_i_d_c;
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
p = opt_float_symbol(sc, cadr(car_x));
if (p)
{
opc->v[1].p = p;
opc->v[0].fi = opt_i_d_s;
- return(oo_set_type_1(opc, 3, 1, OO_D));
+ return(oo_set_type_1(opc, 1, OO_D));
}
if (float_optimize(sc, cdr(car_x)))
{
opc->v[0].fi = opt_i_7d_f;
- return(oo_set_type_0(opc, 3));
+ opc->v[4].fd = sc->opts[start]->v[0].fd;
+ return(oo_set_type_0(opc));
}
pc_fallback(sc, start);
}
@@ -55387,7 +55656,8 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (cell_optimize(sc, cdr(car_x)))
{
opc->v[0].fi = opt_i_7p_f;
- return(oo_set_type_0(opc, 3));
+ opc->v[4].fp = sc->opts[start]->v[0].fp;
+ return(oo_set_type_0(opc));
}
pc_fallback(sc, start);
}
@@ -55397,25 +55667,9 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- i_pi -------- */
-static s7_int opt_i_7pi_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));
-}
-
-static s7_int ivref_7pi_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(int_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));
-}
-
-static s7_int opt_i_7pi_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), o1->v[0].fi(o1)));
-}
+static s7_int opt_i_7pi_ss(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_int ivref_7pi_ss(opt_info *o) {return(int_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_7pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7pi_f(o->sc, 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)
{
@@ -55457,12 +55711,14 @@ static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[0].fi = ivref_7pi_ss;
opc->v[3].i_7pi_f = int_vector_ref_unchecked;
}
- return(oo_set_type_2(opc, 4, 1, 2, OO_P, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_I));
}
+ opc->v[4].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x)))
{
opc->v[0].fi = opt_i_7pi_sf;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[5].fi = opc->v[4].o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, OO_P));
}
pc_fallback(sc, start);
}
@@ -55472,100 +55728,35 @@ static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- i_ii -------- */
-static s7_int opt_i_ii_cc(opt_info *o) {oo_rc(o->sc, o, 4, 0); 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) {oo_rc(o->sc, o, 4, 1); 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) {oo_rc(o->sc, o, 4, 1); return(o->v[1].i * integer(slot_value(o->v[2].p)));}
-static s7_int opt_i_ii_sc(opt_info *o) {oo_rc(o->sc, o, 4, 1); 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) {oo_rc(o->sc, o, 4, 1); return(integer(slot_value(o->v[1].p)) + o->v[2].i);}
-static s7_int opt_i_ii_sc_sub(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(integer(slot_value(o->v[1].p)) - o->v[2].i);}
-static s7_int opt_i_ii_ss(opt_info *o) {oo_rc(o->sc, o, 4, 2); 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) {oo_rc(o->sc, o, 4, 2); 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) {oo_rc(o->sc, o, 4, 2); return(make_integer(o->sc, integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p))));}
-
-static s7_int opt_i_ii_cf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].i_ii_f(o->v[1].i, o1->v[0].fi(o1)));
-}
-
-static s7_int opt_i_ii_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o1->v[0].fi(o1)));
-}
-
-static s7_int opt_i_ii_sf_add(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(integer(slot_value(o->v[1].p)) + o1->v[0].fi(o1));
-}
+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);}
+static s7_int opt_i_ii_sc_sub(opt_info *o) {return(integer(slot_value(o->v[1].p)) - o->v[2].i);}
+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(o->sc, integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_ii_cf(opt_info *o) {o->sc->pc++; 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_sf(opt_info *o) {o->sc->pc++; 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) {o->sc->pc++; 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)
{
- opt_info *o1;
- s7_int i1;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].i_ii_f(i1, o1->v[0].fi(o1)));
-}
-
-static s7_int opt_i_ii_fc(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].i_ii_f(o1->v[0].fi(o1), o->v[2].i));
-}
-
-static s7_int opt_i_ii_fc_add(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o1->v[0].fi(o1) + o->v[2].i);
-}
-
-static s7_pointer opt_p_ii_fc_add(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(make_integer(o->sc, o1->v[0].fi(o1) + o->v[2].i));
-}
-
-static s7_int opt_i_7ii_fc(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].i_7ii_f(o->sc, o1->v[0].fi(o1), o->v[2].i));
-}
-
-static s7_int opt_i_ii_fco(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].i_ii_f(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));
-}
-
-static s7_int opt_i_ii_fco_add(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))) + o->v[5].i);
+ s7_int i1, i2;
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[3].i_ii_f(i1, i2));
}
-static s7_int opt_i_7ii_fco(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].i_7ii_f(o->sc, o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));
-}
+static s7_int opt_i_ii_fc(opt_info *o) {o->sc->pc++; 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) {o->sc->pc++; return(o->v[11].fi(o->v[10].o1) + o->v[2].i);}
+static s7_int opt_i_7ii_fc(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, 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(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));}
+static s7_int opt_i_ii_fco_add(opt_info *o){return(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))) + o->v[5].i);}
+static s7_int opt_i_7ii_fco(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[4].i_7pi_f(o->sc, 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)
{
@@ -55581,51 +55772,37 @@ static bool i_ii_fc_combinable(s7_scheme *sc, opt_info *opc, s7_i_ii_t func)
opc->v[1].p = o1->v[1].p;
opc->v[2].p = o1->v[2].p;
if (func)
- {
- if (opc->v[3].i_ii_f == add_i_ii)
- opc->v[0].fi = opt_i_ii_fco_add;
- else opc->v[0].fi = opt_i_ii_fco;
- }
+ opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_fco_add : opt_i_ii_fco;
else opc->v[0].fi = opt_i_7ii_fco;
backup_pc(sc);
- return(oo_set_type_2(opc, 6, 1, 2, OO_P, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_I));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
}
-static s7_int opt_i_7ii_cc(opt_info *o) {oo_rc(o->sc, o, 4, 0); return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[2].i));}
-static s7_int opt_i_7ii_cs(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(o->v[3].i_7ii_f(o->sc, o->v[1].i, integer(slot_value(o->v[2].p))));}
-static s7_int opt_i_7ii_sc(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));}
-static s7_int opt_i_7ii_ss(opt_info *o) {oo_rc(o->sc, o, 4, 2); return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
-
-static s7_int opt_i_7ii_cf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4,0);
- return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o1->v[0].fi(o1)));
-}
-
-static s7_int opt_i_7ii_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o1->v[0].fi(o1)));
-}
+static s7_int opt_i_7ii_cc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, 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(o->sc, 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(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));}
+static s7_int opt_i_7ii_ss(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_7ii_cf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_7ii_sf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, 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)
{
- opt_info *o1;
- s7_int i1;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].i_7ii_f(o->sc, i1, o1->v[0].fi(o1)));
+ s7_int i1, i2;
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[3].i_7ii_f(o->sc, 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(o->sc->default_rng)));}
+static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc->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;
@@ -55648,7 +55825,7 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (ifunc)
opc->v[3].i_ii_f = ifunc;
else opc->v[3].i_7ii_f = ifunc7;
- oo_set_type_0(opc, 4);
+ oo_set_type_0(opc);
if (is_opt_int(arg1))
{
@@ -55659,7 +55836,7 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (ifunc)
opc->v[0].fi = opt_i_ii_cc;
else opc->v[0].fi = opt_i_7ii_cc;
- return(oo_set_type_0(opc, 4));
+ return(oo_set_type_0(opc));
}
p = opt_integer_symbol(sc, arg2);
if (p)
@@ -55672,14 +55849,28 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
else opc->v[0].fi = opt_i_ii_cs;
}
else opc->v[0].fi = opt_i_7ii_cs;
- return(oo_set_type_1(opc, 4, 2, OO_I));
+ return(oo_set_type_1(opc, 2, OO_I));
}
+ 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;
+ {
+ 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 (!WITH_GMP)
+ 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);
+ }
+#endif
+ }
else opc->v[0].fi = opt_i_7ii_cf;
- return(oo_set_type_0(opc, 4));
+ opc->v[5].fi = opc->v[4].o1->v[0].fi;
+ return(oo_set_type_0(opc));
}
pc_fallback(sc, start);
}
@@ -55733,11 +55924,7 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
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 OPT_INFO_DEBUGGING
- if ((!ifunc) && (opc->v[3].i_7ii_f == quotient_i_7ii))
-#else
if (opc->v[3].i_7ii_f == quotient_i_7ii)
-#endif
{
opc->v[3].i_ii_f = quotient_i_ii_direct;
opc->v[0].fi = opt_i_ii_sc;
@@ -55746,17 +55933,13 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
if (opc->v[2].i > 1)
{
-#if OPT_INFO_DEBUGGING
- if ((!ifunc) && (opc->v[3].i_7ii_f == remainder_i_7ii))
-#else
if (opc->v[3].i_7ii_f == remainder_i_7ii)
-#endif
{
opc->v[3].i_ii_f = remainder_i_ii_direct;
opc->v[0].fi = opt_i_ii_sc;
}}}}}}
#endif
- return(oo_set_type_1(opc, 4, 1, OO_I));
+ return(oo_set_type_1(opc, 1, OO_I));
} /* opt_int arg2 */
p = opt_integer_symbol(sc, arg2);
if (p)
@@ -55769,18 +55952,16 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
else opc->v[0].fi = opt_i_ii_ss;
}
else opc->v[0].fi = opt_i_7ii_ss;
- return(oo_set_type_2(opc, 4, 1, 2, OO_I, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_I, OO_I));
}
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)
- {
- if (opc->v[3].i_ii_f == add_i_ii)
- opc->v[0].fi = opt_i_ii_sf_add;
- else opc->v[0].fi = opt_i_ii_sf;
- }
+ 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(oo_set_type_1(opc, 4, 1, OO_I));
+ return(oo_set_type_1(opc, 1, OO_I));
}
pc_fallback(sc, start);
}
@@ -55789,15 +55970,30 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (is_opt_int(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;
- else opc->v[0].fi = opt_i_ii_fc;
+ {
+ opc->v[0].fi = opt_i_ii_fc_add;
+ return(oo_set_type_0(opc));
+ }
+ opc->v[0].fi = opt_i_ii_fc;
+#if (!WITH_GMP)
+ 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);
+ }
+#endif
}
else opc->v[0].fi = opt_i_7ii_fc;
#if (!WITH_GMP)
@@ -55829,35 +56025,34 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
else
{
- if ((int_optimize(sc, cdr(car_x))) &&
- (int_optimize(sc, cddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cdr(car_x)))
{
- if (ifunc)
- opc->v[0].fi = opt_i_ii_ff;
- else opc->v[0].fi = opt_i_7ii_ff;
- oo_check(sc, opc);
- return(true);
- }
- pc_fallback(sc, start);
- }}}}
- }
+ 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;
+ oo_check(sc, opc);
+ return(true);
+ }
+ pc_fallback(sc, start);
+ }}}}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- i_iii -------- */
static s7_int opt_i_iii_fff(opt_info *o)
{
- opt_info *o1;
- s7_int i1, i2;
- s7_scheme *sc;
- sc = o->sc;
- o1 = sc->opts[++sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- i2 = o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].i_iii_f(i1, i2, o1->v[0].fi(o1)));
+ s7_int i1, i2, i3;
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ o->sc->pc++;
+ 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)
@@ -55868,14 +56063,22 @@ static bool i_iii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
int32_t start;
start = sc->pc;
- if ((int_optimize(sc, cdr(car_x))) &&
- (int_optimize(sc, cddr(car_x))) &&
- (int_optimize(sc, cdddr(car_x))))
+ opc->v[10].o1 = sc->opts[start];
+ if (int_optimize(sc, cdr(car_x)))
{
- opc->v[3].i_iii_f = ifunc;
- opc->v[0].fi = opt_i_iii_fff;
- return(oo_set_type_0(opc, 4));
- }
+ 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(oo_set_type_0(opc));
+ }}}
pc_fallback(sc, start);
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -55885,68 +56088,58 @@ static bool i_iii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- i_7pii -------- */
static s7_int opt_i_7pii_ssf(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fi(o1)));
+ o->sc->pc++;
+ return(o->v[3].i_7pii_f(o->sc, 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)
{
- oo_rc(o->sc, o, 5, 2);
return(o->v[3].i_7pii_f(o->sc, 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)
{
- oo_rc(o->sc, o, 5, 3);
return(o->v[4].i_7pii_f(o->sc, 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_7pii_sff(opt_info *o)
{
- opt_info *o1, *o2;
- s7_int i1;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o2 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), i1, o2->v[0].fi(o2)));
+ s7_int i1, i2;
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2));
}
/* -------- i_7piii -------- */
static s7_int opt_i_7piii_sssf(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 3);
- return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o1->v[0].fi(o1)));
+ o->sc->pc++;
+ return(o->v[5].i_7piii_f(o->sc, 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_7piii_sssc(opt_info *o)
{
- oo_rc(o->sc, o, 6, 3);
return(o->v[5].i_7piii_f(o->sc, 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)
{
- oo_rc(o->sc, o, 6, 3);
return(o->v[5].i_7piii_f(o->sc, 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)
{
- opt_info *o1;
- s7_int i1, i2;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- i2 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 1);
- return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), i1, i2, o1->v[0].fi(o1)));
+ s7_int i1, i2, i3;
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ o->sc->pc++;
+ i3 = o->v[5].fi(o->v[4].o1);
+ return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), i1, i2, i3));
}
static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, opt_type_t otype, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp)
@@ -55964,30 +56157,40 @@ static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, opt_type_t otype, s7_
{
opc->v[0].fi = opt_i_7piii_sssc;
opc->v[4].i = integer(car(valp));
- return(oo_set_type_3(opc, 6, 1, 2, 3, otype, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, otype, OO_I, OO_I));
}
slot = opt_integer_symbol(sc, car(valp));
if (slot)
{
opc->v[4].p = slot;
opc->v[0].fi = opt_i_7piii_ssss;
- return(oo_set_type_4(opc, 6, 1, 2, 3, 4, otype, OO_I, OO_I, OO_I));
+ return(oo_set_type_4(opc, 1, 2, 3, 4, otype, OO_I, OO_I, OO_I));
}
+ 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;
- return(oo_set_type_3(opc, 6, 1, 2, 3, otype, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, otype, OO_I, OO_I));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
}
- if ((int_optimize(sc, indexp1)) &&
- (int_optimize(sc, indexp2)) &&
- (int_optimize(sc, valp)))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, indexp1))
{
- opc->v[0].fi = opt_i_7piii_sfff;
- return(oo_set_type_1(opc, 6, 1, otype));
- }
+ 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[5].fi = opc->v[4].o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, otype));
+ }}}
return(return_false(sc, indexp1, __func__, __LINE__));
}
@@ -56016,6 +56219,8 @@ static bool opt_int_vector_set(s7_scheme *sc, opt_type_t v_type, opt_info *opc,
slot = opt_integer_symbol(sc, car(indexp1));
if (slot)
{
+ int32_t start;
+ start = sc->pc;
opc->v[2].p = slot;
if ((is_step_end(opc->v[2].p)) &&
(denominator(slot_value(opc->v[2].p)) <= vector_length(vect)))
@@ -56026,20 +56231,28 @@ static bool opt_int_vector_set(s7_scheme *sc, opt_type_t v_type, opt_info *opc,
{
opc->v[4].i = integer(car(valp));
opc->v[0].fi = opt_i_7pii_ssc;
- return(oo_set_type_2(opc, 5, 1, 2, otype, OO_I));
+ return(oo_set_type_2(opc, 1, 2, otype, OO_I));
}
if (int_optimize(sc, valp))
{
opc->v[0].fi = opt_i_7pii_ssf;
- return(oo_set_type_2(opc, 4, 1, 2, otype, OO_I));
+ opc->v[4].o1 = sc->opts[start];
+ opc->v[5].fi = sc->opts[start]->v[0].fi;
+ return(oo_set_type_2(opc, 1, 2, otype, OO_I));
}
return(return_false(sc, NULL, __func__, __LINE__));
}
- if ((int_optimize(sc, indexp1)) &&
- (int_optimize(sc, valp)))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, indexp1))
{
- opc->v[0].fi = opt_i_7pii_sff;
- return(oo_set_type_1(opc, 4, 1, otype));
+ 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(oo_set_type_1(opc, 1, otype));
+ }
}
return(return_false(sc, NULL, __func__, __LINE__));
}
@@ -56095,22 +56308,30 @@ static bool i_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe
opc->v[3].p = p;
opc->v[4].i_7pii_f = pfunc;
opc->v[0].fi = opt_i_7pii_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_P, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_P, OO_I, OO_I));
}
if (int_optimize(sc, cdddr(car_x)))
{
opc->v[3].i_7pii_f = pfunc;
opc->v[0].fi = opt_i_7pii_ssf;
- return(oo_set_type_2(opc, 4, 1, 2, OO_P, OO_I));
+ opc->v[4].o1 = sc->opts[start];
+ opc->v[5].fi = sc->opts[start]->v[0].fi;
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_I));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
- if ((int_optimize(sc, cddr(car_x))) &&
- (int_optimize(sc, cdddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cddr(car_x)))
{
- opc->v[3].i_7pii_f = pfunc;
- opc->v[0].fi = opt_i_7pii_sff;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ 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(oo_set_type_1(opc, 1, OO_P));
+ }
}
pc_fallback(sc, start);
}
@@ -56151,11 +56372,11 @@ static s7_int opt_i_add_any_f(opt_info *o)
{
s7_int sum = 0;
int32_t i;
- oo_rc(o->sc, o, 2, 0);
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = o->v[i + 2].o1;
+ o->sc->pc++;
sum += o1->v[0].fi(o1);
}
return(sum);
@@ -56163,82 +56384,68 @@ static s7_int opt_i_add_any_f(opt_info *o)
static s7_int opt_i_add2(opt_info *o)
{
- opt_info *o1;
s7_int sum;
- o1 = o->sc->opts[++o->sc->pc];
- sum = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- return(sum + o1->v[0].fi(o1));
+ o->sc->pc++;
+ sum = o->v[6].fi(o->v[2].o1);
+ o->sc->pc++;
+ return(sum + o->v[7].fi(o->v[3].o1));
}
static s7_int opt_i_mul2(opt_info *o)
{
- opt_info *o1;
s7_int sum;
- o1 = o->sc->opts[++o->sc->pc];
- sum = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- return(sum * o1->v[0].fi(o1));
+ o->sc->pc++;
+ sum = o->v[6].fi(o->v[2].o1);
+ o->sc->pc++;
+ return(sum * o->v[7].fi(o->v[3].o1));
}
static s7_int opt_i_add3(opt_info *o)
{
- opt_info *o1;
s7_int sum;
- s7_scheme *sc;
- sc = o->sc;
- o1 = sc->opts[++sc->pc];
- sum = o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- sum += o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- return(sum + o1->v[0].fi(o1));
+ o->sc->pc++;
+ sum = o->v[6].fi(o->v[2].o1);
+ o->sc->pc++;
+ sum += o->v[7].fi(o->v[3].o1);
+ o->sc->pc++;
+ return(sum + o->v[8].fi(o->v[4].o1));
}
static s7_int opt_i_mul3(opt_info *o)
{
- opt_info *o1;
s7_int sum;
- s7_scheme *sc;
- sc = o->sc;
- o1 = sc->opts[++sc->pc];
- sum = o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- sum *= o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- return(sum * o1->v[0].fi(o1));
+ o->sc->pc++;
+ sum = o->v[6].fi(o->v[2].o1);
+ o->sc->pc++;
+ sum *= o->v[7].fi(o->v[3].o1);
+ o->sc->pc++;
+ return(sum * o->v[8].fi(o->v[4].o1));
}
static s7_int opt_i_add4(opt_info *o)
{
- opt_info *o1;
s7_int sum;
- s7_scheme *sc;
- sc = o->sc;
- o1 = sc->opts[++sc->pc];
- sum = o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- sum += o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- sum += o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- return(sum + o1->v[0].fi(o1));
+ o->sc->pc++;
+ sum = o->v[6].fi(o->v[2].o1);
+ o->sc->pc++;
+ sum += o->v[7].fi(o->v[3].o1);
+ o->sc->pc++;
+ sum += o->v[8].fi(o->v[4].o1);
+ o->sc->pc++;
+ return(sum + o->v[9].fi(o->v[5].o1));
}
static s7_int opt_i_mul4(opt_info *o)
{
- opt_info *o1;
s7_int sum;
- s7_scheme *sc;
- sc = o->sc;
- o1 = sc->opts[++sc->pc];
- sum = o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- sum *= o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- sum *= o1->v[0].fi(o1);
- o1 = sc->opts[++sc->pc];
- return(sum * o1->v[0].fi(o1));
+ o->sc->pc++;
+ sum = o->v[6].fi(o->v[2].o1);
+ o->sc->pc++;
+ sum *= o->v[7].fi(o->v[3].o1);
+ o->sc->pc++;
+ sum *= o->v[8].fi(o->v[4].o1);
+ o->sc->pc++;
+ return(sum * o->v[9].fi(o->v[5].o1));
}
static s7_int opt_i_multiply_any_f(opt_info *o)
@@ -56248,7 +56455,8 @@ static s7_int opt_i_multiply_any_f(opt_info *o)
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = o->v[i + 2].o1;
+ o->sc->pc++;
sum *= o1->v[0].fi(o1);
}
return(sum);
@@ -56260,12 +56468,21 @@ static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x)
int32_t cur_len, start;
start = sc->pc;
head = car(car_x);
- for (cur_len = 0, p = cdr(car_x); is_pair(p); p = cdr(p), cur_len++)
- if (!int_optimize(sc, p))
- break;
+ for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++)
+ {
+ opc->v[2 + cur_len].o1 = sc->opts[sc->pc];
+ if (!int_optimize(sc, p))
+ break;
+ }
if (is_null(p))
{
+ int32_t i;
opc->v[1].i = cur_len;
+ if (cur_len <= 4)
+ {
+ 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
@@ -56280,7 +56497,7 @@ static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x)
}
}
/* all v[1].i = cur_len */
- return(oo_set_type_0(opc, 2));
+ return(oo_set_type_0(opc));
}
pc_fallback(sc, start);
return(return_false(sc, car_x, __func__, __LINE__));
@@ -56290,22 +56507,18 @@ static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x)
/* -------- set_i_i -------- */
static s7_int opt_set_i_i_f(opt_info *o)
{
- opt_info *o1;
s7_int x;
- oo_rc(o->sc, o, 2, 1);
- o1 = o->sc->opts[++o->sc->pc];
- x = o1->v[0].fi(o1);
+ o->sc->pc++;
+ x = o->v[3].fi(o->v[2].o1);
slot_set_value(o->v[1].p, make_integer(o->sc, x));
return(x);
}
-static s7_int opt_set_i_i_fm(opt_info *o)
+static s7_int opt_set_i_i_fm(opt_info *o) /* when is this called? */
{
- opt_info *o1;
s7_int x;
- oo_rc(o->sc, o, 2, 1);
- o1 = o->sc->opts[++o->sc->pc];
- x = o1->v[0].fi(o1);
+ o->sc->pc++;
+ x = o->v[3].fi(o->v[2].o1);
integer(slot_value(o->v[1].p)) = x;
return(x);
}
@@ -56313,7 +56526,6 @@ static s7_int opt_set_i_i_fm(opt_info *o)
static s7_int opt_set_i_i_fo(opt_info *o)
{
s7_int x;
- oo_rc(o->sc, o, 5, 2);
x = integer(slot_value(o->v[3].p)) + o->v[2].i;
slot_set_value(o->v[1].p, make_integer(o->sc, x));
return(x);
@@ -56333,7 +56545,7 @@ static bool set_i_i_f_combinable(s7_scheme *sc, opt_info *opc)
opc->v[2].i = o1->v[2].i;
opc->v[0].fi = opt_set_i_i_fo;
backup_pc(sc);
- return(oo_set_type_2(opc, 5, 1, 3, OO_I, OO_I)); /* ii_sc v[1].p is a slot */
+ return(oo_set_type_2(opc, 1, 3, OO_I, OO_I)); /* ii_sc v[1].p is a slot */
}
}
return(return_false(sc, NULL, __func__, __LINE__));
@@ -56356,17 +56568,20 @@ static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
if ((is_slot(settee)) &&
(!is_immutable(settee)))
{
+ opt_info *o1;
+ 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);
-
if (is_mutable_integer(slot_value(opc->v[1].p)))
opc->v[0].fi = opt_set_i_i_fm;
else opc->v[0].fi = opt_set_i_i_f;
- return(oo_set_type_1(opc, 2, 1, OO_P)); /* or OO_I? */
+ opc->v[2].o1 = o1;
+ opc->v[3].fi = o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, OO_P)); /* or OO_I? */
}
}
}
@@ -56417,14 +56632,15 @@ static bool i_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_unchecked : byte_vector_ref_unchecked;
/* opc->v[0].fi = ivref_7pi_ss; */ /* this causes a huge slowdown in dup.scm?? */
}
- return(oo_set_type_2(opc, 4, 1, 2, (int_case) ? OO_IV : OO_BV, OO_I));
-
+ return(oo_set_type_2(opc, 1, 2, (int_case) ? OO_IV : OO_BV, OO_I));
}
+ opc->v[4].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(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;
- return(oo_set_type_1(opc, 4, 1, (int_case) ? OO_IV : OO_BV));
+ opc->v[5].fi = opc->v[4].o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, (int_case) ? OO_IV : OO_BV));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -56446,27 +56662,39 @@ static bool i_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
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;
- return(oo_set_type_3(opc, 5, 1, 2, 3, (int_case) ? OO_IV : OO_BV, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, (int_case) ? OO_IV : OO_BV, OO_I, OO_I));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
- if ((int_optimize(sc, cdr(car_x))) &&
- (int_optimize(sc, cddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cdr(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;
- return(oo_set_type_1(opc, 5, 1, (int_case) ? OO_IV : OO_BV));
- }}}
+ 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(oo_set_type_1(opc, 1, (int_case) ? OO_IV : OO_BV));
+ }}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* ------------------------------------- float opts ------------------------------------------- */
-static s7_double opt_d_c(opt_info *o) {oo_rc(o->sc, o, 2, 0); return(o->v[1].x);}
-static s7_double opt_D_s(opt_info *o) {oo_rc(o->sc, o, 2, 1); return(s7_number_to_real(o->sc, slot_value(o->v[1].p)));}
-static s7_double opt_d_s(opt_info *o) {oo_rc(o->sc, o, 2, 1); return(real(slot_value(o->v[1].p)));}
+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;
+ x = slot_value(o->v[1].p);
+ if (is_t_integer(x)) return((s7_double)(integer(x)));
+ return(s7_number_to_real(o->sc, x));
+}
static bool opt_float_not_pair(s7_scheme *sc, s7_pointer car_x)
{
@@ -56480,7 +56708,7 @@ static bool opt_float_not_pair(s7_scheme *sc, s7_pointer car_x)
opc = alloc_opo(sc, car_x);
opc->v[1].x = s7_number_to_real(sc, car_x);
opc->v[0].fd = opt_d_c;
- return(oo_set_type_0(opc, 2));
+ return(oo_set_type_0(opc));
}
p = opt_real_symbol(sc, car_x);
if (p)
@@ -56490,13 +56718,13 @@ static bool opt_float_not_pair(s7_scheme *sc, s7_pointer car_x)
opc = alloc_opo(sc, car_x);
opc->v[1].p = p;
opc->v[0].fd = (is_float(slot_value(p))) ? opt_d_s : opt_D_s;
- return(oo_set_type_1(opc, 2, 1, OO_R));
+ return(oo_set_type_1(opc, 1, OO_R));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- d -------- */
-static s7_double opt_d_f(opt_info *o) {oo_rc(o->sc, o, 2, 1); return(o->v[1].d_f());}
+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)
{
@@ -56513,45 +56741,12 @@ static bool d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func)
}
/* -------- d_d -------- */
-static s7_double opt_d_d_c(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].d_d_f(o->v[1].x));
-}
-
-static s7_double opt_d_d_s(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_d_f(real(slot_value(o->v[1].p))));
-}
-
-static s7_double opt_d_d_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_d_f(o1->v[0].fd(o1)));
-}
-
-static s7_double opt_d_7d_c(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].d_7d_f(o->sc, o->v[1].x));
-}
-
-static s7_double opt_d_7d_s(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_7d_f(o->sc, real(slot_value(o->v[1].p))));
-}
-
-static s7_double opt_d_7d_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_7d_f(o->sc, o1->v[0].fd(o1)));
-}
+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_7d_c(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[1].x));}
+static s7_double opt_d_7d_s(opt_info *o) {return(o->v[3].d_7d_f(o->sc, real(slot_value(o->v[1].p))));}
+static s7_double opt_d_d_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_7d_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_7d_f(o->sc, o->v[5].fd(o->v[4].o1)));}
static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -56576,27 +56771,23 @@ static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
(car(car_x) == sc->cos_symbol)))
return(return_false(sc, car_x, __func__, __LINE__));
opc->v[1].x = s7_number_to_real(sc, cadr(car_x));
- if (func)
- opc->v[0].fd = opt_d_d_c;
- else opc->v[0].fd = opt_d_7d_c;
- return(oo_set_type_0(opc, 4));
+ opc->v[0].fd = (func) ? opt_d_d_c : opt_d_7d_c;
+ return(oo_set_type_0(opc));
}
p = opt_float_symbol(sc, cadr(car_x));
if ((p) &&
(!has_methods(slot_value(p))))
{
opc->v[1].p = p;
- if (func)
- opc->v[0].fd = opt_d_d_s;
- else opc->v[0].fd = opt_d_7d_s;
- return(oo_set_type_1(opc, 4, 1, OO_D));
+ opc->v[0].fd = (func) ? opt_d_d_s : opt_d_7d_s;
+ return(oo_set_type_1(opc, 1, OO_D));
}
+ opc->v[4].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x)))
{
- if (func)
- opc->v[0].fd = opt_d_d_f;
- else opc->v[0].fd = opt_d_7d_f;
- return(oo_set_type_0(opc, 4));
+ opc->v[0].fd = (func) ? opt_d_d_f : opt_d_7d_f;
+ opc->v[5].fd = opc->v[4].o1->v[0].fd;
+ return(oo_set_type_0(opc));
}
pc_fallback(sc, start);
}
@@ -56604,11 +56795,7 @@ static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
}
/* -------- d_v -------- */
-static s7_double opt_d_v(opt_info *o)
-{
- oo_rc(o->sc, o, 6, 0);
- return(o->v[3].d_v_f(o->v[5].obj));
-}
+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)
{
@@ -56630,25 +56817,14 @@ static bool d_v_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
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(oo_set_type_1(opc, 6, 1 + (5 << 4), OO_V));
+ return(oo_set_type_1(opc, 1 + (5 << 4), OO_V));
}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- d_p -------- */
-static s7_double opt_d_p_s(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_p_f(slot_value(o->v[1].p)));
-}
-
-static s7_double opt_d_p_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_p_f(o1->v[0].fp(o1)));
-}
+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) {o->sc->pc++; 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)
{
@@ -56667,14 +56843,16 @@ static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
{
opc->v[1].p = slot;
opc->v[0].fd = opt_d_p_s;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
+ opc->v[4].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x)))
{
opc->v[0].fd = opt_d_p_f;
- return(oo_set_type_0(opc, 4));
+ opc->v[5].fp = opc->v[4].o1->v[0].fp;
+ return(oo_set_type_0(opc));
}
pc_fallback(sc, start);
}
@@ -56683,35 +56861,17 @@ static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
/* -------- d_7pi -------- */
-static s7_double opt_d_7pi_sc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));
-}
-
-static s7_double opt_d_7pi_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));
-}
-
-static s7_double opt_d_7pi_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o1->v[0].fi(o1)));
-}
+static s7_double opt_d_7pi_sc(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, 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(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_double opt_d_7pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1)));}
static s7_double opt_d_7pi_ff(opt_info *o)
{
- opt_info *o1;
s7_pointer seq;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- seq = o1->v[0].fp(o1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_7pi_f(o->sc, seq, o1->v[0].fi(o1)));
+ o->sc->pc++;
+ seq = o->v[5].fp(o->v[4].o1);
+ o->sc->pc++;
+ return(o->v[3].d_7pi_f(o->sc, seq, o->v[9].fi(o->v[8].o1)));
}
static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp);
@@ -56746,7 +56906,7 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].i = integer(arg2);
opc->v[0].fd = opt_d_7pi_sc;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
p = opt_integer_symbol(sc, arg2);
if (p)
@@ -56758,16 +56918,18 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
(denominator(slot_value(opc->v[2].p)) <= vector_length(slot_value(opc->v[1].p))))
{
opc->v[3].d_7pi_f = float_vector_ref_unchecked;
- return(oo_set_type_2(opc, 4, 1, 2, OO_FV, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_FV, OO_I));
}
- return(oo_set_type_2(opc, 4, 1, 2, OO_P, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_I));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
if (int_optimize(sc, cddr(car_x)))
{
opc->v[0].fd = opt_d_7pi_sf;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[10].o1 = sc->opts[start];
+ opc->v[11].fi = opc->v[10].o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, OO_P));
}
pc_fallback(sc, start);
return(return_false(sc, car_x, __func__, __LINE__));
@@ -56778,11 +56940,19 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
(vector_rank(cadr(car_x)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */
return(return_false(sc, car_x, __func__, __LINE__));
- if ((cell_optimize(sc, cdr(car_x))) &&
- (int_optimize(sc, cddr(car_x))))
+ if (cell_optimize(sc, cdr(car_x)))
{
- opc->v[0].fd = opt_d_7pi_ff;
- return(oo_set_type_0(opc, 4));
+ opt_info *o2;
+ 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(oo_set_type_0(opc));
+ }
}
pc_fallback(sc, start);
}
@@ -56790,11 +56960,7 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- d_ip -------- */
-static s7_double opt_d_ip_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].d_ip_f(integer(slot_value(o->v[1].p)), slot_value(o->v[2].p)));
-}
+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)
{
@@ -56814,25 +56980,14 @@ static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
/* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */
opc->v[0].fd = opt_d_ip_ss;
- return(oo_set_type_2(opc, 4, 1, 2, OO_I, OO_P));
+ return(oo_set_type_2(opc, 1, 2, OO_I, OO_P));
}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- d_pd -------- */
-static s7_double opt_d_pd_sf(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_pd_f(slot_value(o->v[1].p), o1->v[0].fd(o1)));
-}
-
-static s7_double opt_d_pd_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].d_pd_f(slot_value(o->v[1].p), real(slot_value(o->v[2].p))));
-}
+static s7_double opt_d_pd_sf(opt_info *o) {o->sc->pc++; 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)
{
@@ -56855,12 +57010,14 @@ static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].p = p;
opc->v[0].fd = opt_d_pd_ss;
- return(oo_set_type_2(opc, 4, 1, 2, OO_P, OO_D));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_D));
}
+ opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cddr(car_x)))
{
opc->v[0].fd = opt_d_pd_sf;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[11].fd = opc->v[10].o1->v[0].fd;
+ return(oo_set_type_1(opc, 1, OO_P));
}
pc_fallback(sc, start);
}
@@ -56869,36 +57026,14 @@ static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- d_vd -------- */
-static s7_double opt_d_vd_c(opt_info *o)
-{
- oo_rc(o->sc, o, 6, 0);
- 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)
-{
- oo_rc(o->sc, o, 6, 1);
- 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)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 6, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_vd_f(o->v[5].obj, o1->v[0].fd(o1)));
-}
-
-static s7_double opt_d_vd_o(opt_info *o)
-{
- oo_rc(o->sc, o, 6, 0);
- 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_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) {o->sc->pc++; 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)
{
opt_info *o1;
- oo_rc(o->sc, o, 6, 1);
o->sc->pc += 2;
o1 = o->sc->opts[o->sc->pc];
return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)) * o1->v[0].fd(o1)));
@@ -56907,30 +57042,19 @@ static s7_double opt_d_vd_o1_mul(opt_info *o)
static s7_double opt_d_vd_o1(opt_info *o)
{
opt_info *o1;
- oo_rc(o->sc, o, 6, 1);
o->sc->pc += 2;
o1 = o->sc->opts[o->sc->pc];
return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(real(slot_value(o->v[2].p)), o1->v[0].fd(o1))));
}
-static s7_double opt_d_vd_o2(opt_info *o)
-{
- oo_rc(o->sc, o, 7, 1); /* v[1].p = v6 obj slot */
- 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)
-{
- oo_rc(o->sc, o, 7, 1);
- 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_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)
{
opt_info *o1;
o->sc->pc += 2;
o1 = o->sc->opts[o->sc->pc];
- oo_rc(o->sc, o, 6, 0);
return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].d_vd_f(o->v[4].obj, o1->v[0].fd(o1))));
}
@@ -56950,7 +57074,7 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start)
opc->v[4].d_v_f = o1->v[3].d_v_f;
opc->v[0].fd = opt_d_vd_o;
backup_pc(sc);
- return(oo_set_type_2(opc, 7, 1 + (5 << 4), 2 + (6 << 4), OO_V, OO_V));
+ return(oo_set_type_2(opc, 1 + (5 << 4), 2 + (6 << 4), OO_V, OO_V));
}
if (o1->v[0].fd == opt_d_vd_s)
{
@@ -56962,7 +57086,7 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start)
opc->v[7].p = o1->v[1].p;
opc->v[0].fd = opt_d_vd_o2;
backup_pc(sc);
- return(oo_set_type_3(opc, 8, 1 + (6 << 4), 3, 7 + (2 << 4), OO_V, OO_D, OO_V));
+ return(oo_set_type_3(opc, 1 + (6 << 4), 3, 7 + (2 << 4), OO_V, OO_D, OO_V));
}
if (o1->v[0].fd == opt_d_dd_cs)
{
@@ -56971,7 +57095,7 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start)
opc->v[2].p = o1->v[1].p;
opc->v[0].fd = opt_d_vd_o3;
backup_pc(sc);
- return(oo_set_type_2(opc, 7, 1 + (5 << 4), 2, OO_V, OO_D));
+ return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_D));
}
if ((o1->v[0].fd == opt_d_dd_sf_mul) || (o1->v[0].fd == opt_d_dd_sf))
{
@@ -56980,7 +57104,7 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start)
if (o1->v[0].fd == opt_d_dd_sf_mul)
opc->v[0].fd = opt_d_vd_o1_mul;
else opc->v[0].fd = opt_d_vd_o1;
- return(oo_set_type_2(opc, 6, 1 + (5 << 4), 2, OO_V, OO_D));
+ return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_D));
}
if (o1->v[0].fd == opt_d_vd_f)
{
@@ -56988,7 +57112,7 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start)
opc->v[4].obj = o1->v[5].obj;
opc->v[6].p = o1->v[1].p;
opc->v[0].fd = opt_d_vd_ff;
- return(oo_set_type_2(opc, 7, 1 + (5 << 4), 6 + ((4 << 4)), OO_V, OO_V));
+ return(oo_set_type_2(opc, 1 + (5 << 4), 6 + ((4 << 4)), OO_V, OO_V));
}
return(return_false(sc, NULL, __func__, __LINE__));
}
@@ -57024,7 +57148,7 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].x = s7_number_to_real(sc, arg2);
opc->v[0].fd = opt_d_vd_c;
- return(oo_set_type_1(opc, 6, 1 + (5 << 4), OO_V));
+ return(oo_set_type_1(opc, 1 + (5 << 4), OO_V));
}
opc->v[2].p = symbol_to_slot(sc, arg2);
if (is_slot(opc->v[2].p))
@@ -57032,14 +57156,16 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (is_float(slot_value(opc->v[2].p)))
{
opc->v[0].fd = opt_d_vd_s;
- return(oo_set_type_2(opc, 6, 1 + (5 << 4), 2, OO_V, OO_D));
+ return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_D));
}
if (float_optimize(sc, cddr(car_x)))
{
if (d_vd_f_combinable(sc, start))
return(true);
opc->v[0].fd = opt_d_vd_f;
- return(oo_set_type_2(opc, 6, 1 + (5 << 4), 2, OO_V, OO_P));
+ opc->v[8].o1 = sc->opts[start];
+ opc->v[9].fd = sc->opts[start]->v[0].fd;
+ return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_P));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -57053,7 +57179,9 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (d_vd_f_combinable(sc, start))
return(true);
opc->v[0].fd = opt_d_vd_f;
- return(oo_set_type_1(opc, 6, 1 + (5 << 4), OO_V));
+ opc->v[8].o1 = sc->opts[start];
+ opc->v[9].fd = sc->opts[start]->v[0].fd;
+ return(oo_set_type_1(opc, 1 + (5 << 4), OO_V));
}
pc_fallback(sc, start);
}}}}
@@ -57062,31 +57190,10 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- d_id -------- */
-static s7_double opt_d_id_sf(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o1->v[0].fd(o1)));
-}
-
-static s7_double opt_d_id_sc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[2].x));
-}
-
-static s7_double opt_d_id_sfo(opt_info *o)
-{
- oo_rc(o->sc, o, 7, 2);
- 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_sfo1(opt_info *o)
-{
- oo_rc(o->sc, o, 6, 1);
- 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_sf(opt_info *o) {o->sc->pc++; 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 bool d_id_sf_combinable(s7_scheme *sc, opt_info *opc)
{
@@ -57104,7 +57211,7 @@ static bool d_id_sf_combinable(s7_scheme *sc, opt_info *opc)
opc->v[3].p = o1->v[2].p;
opc->v[0].fd = opt_d_id_sfo;
backup_pc(sc);
- return(oo_set_type_3(opc, 7, 1, 2 + (6 << 4), 3, OO_I, OO_V, OO_D));
+ return(oo_set_type_3(opc, 1, 2 + (6 << 4), 3, OO_I, OO_V, OO_D));
}
if (o1->v[0].fd == opt_d_v)
{
@@ -57113,7 +57220,7 @@ static bool d_id_sf_combinable(s7_scheme *sc, opt_info *opc)
opc->v[5].d_v_f = o1->v[3].d_v_f;
opc->v[0].fd = opt_d_id_sfo1;
backup_pc(sc);
- return(oo_set_type_2(opc, 7, 1, 6 + (2 << 4), OO_I, OO_V));
+ return(oo_set_type_2(opc, 1, 6 + (2 << 4), OO_I, OO_V));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
@@ -57137,14 +57244,16 @@ static bool d_id_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[0].fd = opt_d_id_sc;
opc->v[2].x = real(caddr(car_x));
- return(oo_set_type_1(opc, 4, 1, OO_I));
+ return(oo_set_type_1(opc, 1, OO_I));
}
if (float_optimize(sc, cddr(car_x)))
{
if (d_id_sf_combinable(sc, opc))
return(true);
opc->v[0].fd = opt_d_id_sf;
- return(oo_set_type_1(opc, 4, 1, OO_I));
+ opc->v[4].o1 = sc->opts[start];
+ opc->v[5].fd = sc->opts[start]->v[0].fd;
+ return(oo_set_type_1(opc, 1, OO_I));
}
pc_fallback(sc, start);
}
@@ -57154,135 +57263,46 @@ static bool d_id_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- d_dd -------- */
-static s7_double opt_d_dd_cc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 0);
- 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)
-{
- oo_rc(o->sc, o, 4, 1);
- 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)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));
-}
-
-static s7_double opt_d_dd_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- 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_mul(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- 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)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_dd_f(o->v[1].x, o1->v[0].fd(o1)));
-}
-
-static s7_double opt_d_dd_fc(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_dd_f(o1->v[0].fd(o1), o->v[2].x));
-}
+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_fc_add(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fd(o1) + o->v[2].x);
-}
-
-static s7_double opt_d_dd_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o1->v[0].fd(o1)));
-}
-
-static s7_double opt_d_dd_sf_mul(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(real(slot_value(o->v[1].p)) * o1->v[0].fd(o1));
-}
-
-
-static s7_double opt_d_7dd_cc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[2].x));
-}
+static s7_double opt_d_dd_cf(opt_info *o) {o->sc->pc++; 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_fc(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));}
-static s7_double opt_d_7dd_cs(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_7dd_f(o->sc, o->v[2].x, real(slot_value(o->v[1].p))));
-}
-
-static s7_double opt_d_7dd_sc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[2].x));
-}
-
-static s7_double opt_d_7dd_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));
-}
+#if (!WITH_GMP)
+static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc->default_rng) - o->v[2].x);}
+#endif
-static s7_double opt_d_7dd_cf(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o1->v[0].fd(o1)));
-}
+static s7_double opt_d_dd_fc_add(opt_info *o) {o->sc->pc++; return(o->v[5].fd(o->v[4].o1) + o->v[2].x);}
+static s7_double opt_d_dd_fc_subtract(opt_info *o) {o->sc->pc++; return(o->v[5].fd(o->v[4].o1) - o->v[2].x);}
+static s7_double opt_d_dd_sf(opt_info *o) {o->sc->pc++; 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) {o->sc->pc++; return(real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));}
-static s7_double opt_d_7dd_fc(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_7dd_f(o->sc, o1->v[0].fd(o1), o->v[2].x));
-}
+static s7_double opt_d_7dd_cc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, 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(o->sc, 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(o->sc, 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(o->sc, real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));}
+static s7_double opt_d_7dd_cf(opt_info *o) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_7dd_fc(opt_info *o) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), o->v[2].x));}
static s7_double opt_d_7dd_sf(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o1->v[0].fd(o1)));
+ o->sc->pc++;
+ return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));
}
-
static s7_double opt_d_dd_sfo(opt_info *o)
{
- oo_rc(o->sc, o, 6, 3);
return(o->v[4].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p)))));
}
static s7_double opt_d_7dd_sfo(opt_info *o)
{
- oo_rc(o->sc, o, 6, 3);
return(o->v[4].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p)))));
}
@@ -57309,45 +57329,23 @@ static bool d_dd_sf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
opc->v[3].p = o1->v[2].p;
opc->v[5].d_7pi_f = o1->v[3].d_7pi_f;
backup_pc(sc);
- return(oo_set_type_3(opc, 6, 1, 2, 3, OO_D, OO_P, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_D, OO_P, OO_I));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
}
-static s7_double opt_d_dd_fs(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_dd_f(o1->v[0].fd(o1), real(slot_value(o->v[1].p))));
-}
-
-static s7_double opt_d_dd_fs_mul(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fd(o1) * real(slot_value(o->v[1].p)));
-}
-
-static s7_double opt_d_7dd_fs(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_7dd_f(o->sc, o1->v[0].fd(o1), real(slot_value(o->v[1].p))));
-}
+static s7_double opt_d_dd_fs(opt_info *o) {o->sc->pc++; 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) {o->sc->pc++; 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) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));}
static s7_double opt_d_dd_fso(opt_info *o)
{
- oo_rc(o->sc, o, 5, 3);
return(o->v[4].d_dd_f(o->v[5].d_7pi_f(o->sc, 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)
{
- oo_rc(o->sc, o, 5, 3);
return(o->v[4].d_7dd_f(o->sc, o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p))));
}
@@ -57374,7 +57372,7 @@ static bool d_dd_fs_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
opc->v[3].p = o1->v[2].p;
opc->v[5].d_7pi_f = o1->v[3].d_7pi_f;
backup_pc(sc);
- return(oo_set_type_3(opc, 6, 1, 2, 3, OO_D, OO_P, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_D, OO_P, OO_I));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
@@ -57382,57 +57380,67 @@ static bool d_dd_fs_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
static s7_double opt_d_dd_ff(opt_info *o)
{
- opt_info *o1, *o2;
s7_double x1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[0].fd(o1);
- o2 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_dd_f(x1, o2->v[0].fd(o2)));
+ o->sc->pc++;
+ x1 = o->v[9].fd(o->v[8].o1);
+ o->sc->pc++;
+ 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)
{
- opt_info *o1, *o2;
s7_double x1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[0].fd(o1);
- o2 = o->sc->opts[++o->sc->pc];
- return(x1 * o2->v[0].fd(o2));
+ o->sc->pc++;
+ x1 = o->v[9].fd(o->v[8].o1);
+ o->sc->pc++;
+ return(x1 * o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_dd_ff_add(opt_info *o)
{
- opt_info *o1, *o2;
s7_double x1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[0].fd(o1);
- o2 = o->sc->opts[++o->sc->pc];
- return(x1 + o2->v[0].fd(o2));
+ o->sc->pc++;
+ x1 = o->v[5].fd(o->v[4].o1);
+ o->sc->pc++;
+ 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;
+ o->sc->pc++;
+ x1 = o->v[5].fd(o->v[4].o1);
+ o->sc->pc += 2;
+ x2 = o->v[9].fd(o->v[8].o1);
+ o->sc->pc++;
+ 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;
+ o->sc->pc++;
+ x1 = o->v[5].fd(o->v[4].o1);
+ o->sc->pc += 2;
+ return(x1 + float_vector_ref_d_7pi(o->sc, 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)
{
- opt_info *o1, *o2;
s7_double x1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[0].fd(o1);
- o2 = o->sc->opts[++o->sc->pc];
- return(x1 - o2->v[0].fd(o2));
+ o->sc->pc++;
+ x1 = o->v[5].fd(o->v[4].o1);
+ o->sc->pc++;
+ return(x1 - o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_7dd_ff(opt_info *o)
{
- opt_info *o1, *o2;
s7_double x1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[0].fd(o1);
- o2 = o->sc->opts[++o->sc->pc];
- return(o->v[3].d_7dd_f(o->sc, x1, o2->v[0].fd(o2)));
+ o->sc->pc++;
+ x1 = o->v[9].fd(o->v[8].o1);
+ o->sc->pc++;
+ return(o->v[3].d_7dd_f(o->sc, x1, o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_o1(opt_info *o)
@@ -57441,7 +57449,6 @@ 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);
o2 = o->sc->opts[o->sc->pc += 2];
- oo_rc(o->sc, o, 4, 1);
return(o->v[3].d_dd_f(x1, o2->v[0].fd(o2)));
}
@@ -57449,65 +57456,55 @@ static s7_double opt_d_dd_ff_mul1(opt_info *o)
{
opt_info *o2;
o2 = o->sc->opts[o->sc->pc += 2];
- oo_rc(o->sc, o, 4, 1);
return(o->v[2].d_v_f(o->v[1].obj) * o2->v[0].fd(o2));
}
static s7_double opt_d_dd_ff_o2(opt_info *o)
{
s7_double x1;
- oo_rc(o->sc, o, 6, 2);
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)
{
- oo_rc(o->sc, o, 6, 2);
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;
- oo_rc(o->sc, o, 7, 3);
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)
{
- opt_info *o1, *o2;
s7_double x1, x2;
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[4].d_dd_f(o1->v[5].d_7pi_f(o->sc, slot_value(o1->v[2].p), integer(slot_value(o1->v[3].p))), real(slot_value(o1->v[1].p))); /* dd_fso */
- o2 = o->sc->opts[++o->sc->pc];
- x2 = o2->v[4].d_dd_f(o2->v[5].d_7pi_f(o->sc, slot_value(o2->v[2].p), integer(slot_value(o2->v[3].p))), real(slot_value(o2->v[1].p))); /* dd_fso */
- oo_rc(o->sc, o, 4, 0);
+ o->sc->pc++;
+ x1 = o->v[3+4].d_dd_f(o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))), real(slot_value(o->v[3+1].p))); /* dd_fso */
+ o->sc->pc++;
+ x2 = o->v[8+4].d_dd_f(o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))), real(slot_value(o->v[8+1].p))); /* dd_fso */
return(o->v[3].d_dd_f(x1, x2));
}
static s7_double opt_d_mm_fff(opt_info *o)
{
- opt_info *o1, *o2;
s7_double x1, x2;
- o1 = o->sc->opts[++o->sc->pc];
- x1 = float_vector_ref_d_7pi(o->sc, slot_value(o1->v[2].p), integer(slot_value(o1->v[3].p))) * real(slot_value(o1->v[1].p));
- o2 = o->sc->opts[++o->sc->pc];
- x2 = float_vector_ref_d_7pi(o->sc, slot_value(o2->v[2].p), integer(slot_value(o2->v[3].p))) * real(slot_value(o2->v[1].p));
- oo_rc(o->sc, o, 4, 0);
+ o->sc->pc++;
+ x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))) * real(slot_value(o->v[3+1].p));
+ o->sc->pc++;
+ x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))) * real(slot_value(o->v[8+1].p));
return(o->v[3].d_dd_f(x1, x2));
}
-static s7_double opt_d_dd_fff_rev(opt_info *o)
+static s7_double opt_d_dd_fff_rev(opt_info *o) /* faster with o->sc? */
{
- opt_info *o1, *o2;
s7_double x1, x2;
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[4].d_dd_f(real(slot_value(o1->v[1].p)), o1->v[5].d_7pi_f(o->sc, slot_value(o1->v[2].p), integer(slot_value(o1->v[3].p))));
- o2 = o->sc->opts[++o->sc->pc];
- x2 = o2->v[4].d_dd_f(real(slot_value(o2->v[1].p)), o2->v[5].d_7pi_f(o->sc, slot_value(o2->v[2].p), integer(slot_value(o2->v[3].p))));
- oo_rc(o->sc, o, 4, 0);
+ o->sc->pc++;
+ x1 = o->v[3+4].d_dd_f(real(slot_value(o->v[3+1].p)), o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))));
+ o->sc->pc++;
+ x2 = o->v[8+4].d_dd_f(real(slot_value(o->v[8+1].p)), o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))));
return(o->v[3].d_dd_f(x1, x2));
}
@@ -57515,26 +57512,22 @@ 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);
- oo_rc(o->sc, o, 8, 3);
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)
{
- oo_rc(o->sc, o, 8, 3);
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 bool d_dd_ff_combinable(s7_scheme *sc, int32_t start)
+static bool d_dd_ff_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
{
- opt_info *opc, *o1;
- opc = sc->opts[start - 1];
- o1 = sc->opts[start];
+ opt_info *o1, *o2;
+ o1 = opc->v[8].o1;
+ o2 = opc->v[10].o1;
if (o1->v[0].fd == opt_d_v)
{
- opt_info *o2;
/* opc->v[3] is in use */
- o2 = sc->opts[start + 1];
if ((o2->v[0].fd == opt_d_v) &&
(sc->pc == start + 2))
{
@@ -57548,7 +57541,7 @@ static bool d_dd_ff_combinable(s7_scheme *sc, int32_t start)
opc->v[0].fd = opt_d_dd_ff_mul2;
else opc->v[0].fd = opt_d_dd_ff_o2;
sc->pc -= 2;
- return(oo_set_type_2(opc, 8, 6 + (1 << 4), 7 + (2 << 4), OO_V, OO_V));
+ return(oo_set_type_2(opc, 6 + (1 << 4), 7 + (2 << 4), OO_V, OO_V));
}
if ((o2->v[0].fd == opt_d_vd_s) &&
(sc->pc == start + 2))
@@ -57563,7 +57556,7 @@ static bool d_dd_ff_combinable(s7_scheme *sc, int32_t start)
opc->v[3].p = o2->v[2].p;
opc->v[0].fd = opt_d_dd_ff_o3;
sc->pc -= 2;
- return(oo_set_type_3(opc, 9, 3, 7 + (1 << 4), 8 + (2 << 4), OO_D, OO_V, OO_V));
+ return(oo_set_type_3(opc, 3, 7 + (1 << 4), 8 + (2 << 4), OO_D, OO_V, OO_V));
}
if ((o2->v[0].fd == opt_d_vd_o) &&
(sc->pc == start + 2))
@@ -57581,7 +57574,7 @@ static bool d_dd_ff_combinable(s7_scheme *sc, int32_t start)
opc->v[0].fd = opt_d_dd_ff_mul4;
else opc->v[0].fd = opt_d_dd_ff_o4;
sc->pc -= 2;
- return(oo_set_type_3(opc, 11, 8 + (1 << 4), 9 + (5 << 4), 10 + (6 << 4), OO_V, OO_V, OO_V));
+ return(oo_set_type_3(opc, 8 + (1 << 4), 9 + (5 << 4), 10 + (6 << 4), OO_V, OO_V, OO_V));
}
opc->v[1].obj = o1->v[5].obj;
opc->v[4].p = o1->v[1].p;
@@ -57589,28 +57582,34 @@ static bool d_dd_ff_combinable(s7_scheme *sc, int32_t start)
if (opc->v[3].d_dd_f == multiply_d_dd)
opc->v[0].fd = opt_d_dd_ff_mul1;
else opc->v[0].fd = opt_d_dd_ff_o1;
- return(oo_set_type_1(opc, 5, 4 + (1 << 4), OO_V));
+ return(oo_set_type_1(opc, 4 + (1 << 4), OO_V));
}
if (o1->v[0].fd == opt_d_dd_fso)
{
- opt_info *o2;
- o2 = sc->opts[start + 1];
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;
+ opc->v[0].fd = opt_d_mm_fff; /* a placeholder (never called) */
else opc->v[0].fd = opt_d_dd_fff;
- return(oo_set_type_0(opc, 4));
+ 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 = o1->v[1].p;
+ opc->v[8+2].p = o1->v[2].p;
+ opc->v[8+3].p = o1->v[3].p;
+ opc->v[8+4].d_dd_f = o1->v[4].d_dd_f;
+ opc->v[8+5].d_7pi_f = o1->v[5].d_7pi_f;
+ return(oo_set_type_0(opc));
}
}
if (o1->v[0].fd == opt_d_dd_sfo)
{
- opt_info *o2;
- o2 = sc->opts[start + 1];
if (o2->v[0].fd == opt_d_dd_sfo)
{
if ((o1->v[4].d_dd_f == multiply_d_dd) &&
@@ -57619,37 +57618,28 @@ static bool d_dd_ff_combinable(s7_scheme *sc, int32_t start)
(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(oo_set_type_0(opc, 4));
+ 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 = o1->v[1].p;
+ opc->v[8+2].p = o1->v[2].p;
+ opc->v[8+3].p = o1->v[3].p;
+ opc->v[8+4].d_dd_f = o1->v[4].d_dd_f;
+ opc->v[8+5].d_7pi_f = o1->v[5].d_7pi_f;
+ return(oo_set_type_0(opc));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
}
-static s7_double opt_d_dd_cfo(opt_info *o)
-{
- oo_rc(o->sc, o, 5, 0);
- 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)
-{
- oo_rc(o->sc, o, 5, 0);
- return(o->v[3].d_7dd_f(o->sc, o->v[2].x, o->v[4].d_v_f(o->v[1].obj)));
-}
-
-static s7_double opt_d_dd_cfo1(opt_info *o)
-{
- oo_rc(o->sc, o, 7, 2);
- 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)
-{
- oo_rc(o->sc, o, 7, 2);
- return(o->v[3].d_7dd_f(o->sc, 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_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(o->sc, 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(o->sc, 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_cf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
+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]))
@@ -57662,11 +57652,9 @@ static bool d_dd_cf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
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;
- if (func)
- opc->v[0].fd = opt_d_dd_cfo;
- else opc->v[0].fd = opt_d_7dd_cfo;
+ opc->v[0].fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo;
backup_pc(sc);
- return(oo_set_type_1(opc, 7, 6 + (1 << 4), OO_V));
+ return(oo_set_type_1(opc, 6 + (1 << 4), OO_V));
}
if (o1->v[0].fd == opt_d_vd_s)
{
@@ -57675,11 +57663,9 @@ static bool d_dd_cf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
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;
- if (func)
- opc->v[0].fd = opt_d_dd_cfo1;
- else opc->v[0].fd = opt_d_7dd_cfo1;
+ opc->v[0].fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1;
backup_pc(sc);
- return(oo_set_type_2(opc, 7, 1 + (6 << 4), 2, OO_V, OO_D));
+ return(oo_set_type_2(opc, 1 + (6 << 4), 2, OO_V, OO_D));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
@@ -57695,6 +57681,7 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
s7_pointer arg1, arg2, slot;
int32_t start;
+ opt_info *o1;
start = sc->pc;
arg1 = cadr(car_x);
arg2 = caddr(car_x);
@@ -57711,30 +57698,26 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
return(return_false(sc, car_x, __func__, __LINE__));
opc->v[1].x = s7_number_to_real(sc, arg1);
opc->v[2].x = s7_number_to_real(sc, arg2);
- if (func)
- opc->v[0].fd = opt_d_dd_cc;
- else opc->v[0].fd = opt_d_7dd_cc;
- return(oo_set_type_0(opc, 4));
+ opc->v[0].fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc;
+ return(oo_set_type_0(opc));
}
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? */
- if (func)
- opc->v[0].fd = opt_d_dd_cs;
- else opc->v[0].fd = opt_d_7dd_cs;
- return(oo_set_type_1(opc, 4, 1, OO_D));
+ opc->v[0].fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs;
+ return(oo_set_type_1(opc, 1, OO_D));
}
if (float_optimize(sc, cddr(car_x)))
{
opc->v[1].x = s7_number_to_real(sc, arg1);
- if (d_dd_cf_combinable(sc, opc, func))
+ if (d_dd_call_combinable(sc, opc, func))
return(true);
- if (func)
- opc->v[0].fd = opt_d_dd_cf;
- else opc->v[0].fd = opt_d_7dd_cf;
- return(oo_set_type_0(opc, 4));
+ 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;
+ return(oo_set_type_0(opc));
}
pc_fallback(sc, start);
return(return_false(sc, car_x, __func__, __LINE__));
@@ -57749,9 +57732,9 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].x = s7_number_to_real(sc, arg2);
if (func)
- opc->v[0].fd = opt_d_dd_sc;
+ 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(oo_set_type_1(opc, 4, 1, OO_D));
+ return(oo_set_type_1(opc, 1, OO_D));
}
slot = opt_float_symbol(sc, arg2);
if (slot)
@@ -57761,42 +57744,62 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
if (func == multiply_d_dd)
opc->v[0].fd = opt_d_dd_ss_mul;
- else opc->v[0].fd = opt_d_dd_ss;
+ 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(oo_set_type_2(opc, 4, 1, 2, OO_R, OO_D));
+ return(oo_set_type_2(opc, 1, 2, OO_R, OO_D));
}
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)
- {
- if (func == multiply_d_dd)
- opc->v[0].fd = opt_d_dd_sf_mul;
- else opc->v[0].fd = opt_d_dd_sf;
- }
+ opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_sf_mul : opt_d_dd_sf;
else opc->v[0].fd = opt_d_7dd_sf;
- return(oo_set_type_1(opc, 4, 1, OO_D));
+ return(oo_set_type_1(opc, 1, OO_D));
}
pc_fallback(sc, start);
return(return_false(sc, car_x, __func__, __LINE__));
}
/* arg1 = float expr or non-float */
+ o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x)))
{
+ int32_t start2;
+ start2 = sc->pc;
if (is_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 = opt_d_dd_fc_add;
+ {
+ opc->v[0].fd = opt_d_dd_fc_add; /* opt_i_7i_c o->v[2].i_7i_f = random_i_7i else as below except add_i_ii in opt_i_ii_cf = (+ i1 (random i2)) */
+ return(oo_set_type_0(opc));
+ }
+ 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 (!WITH_GMP)
+ 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);
+ }
+#endif
+ }
else opc->v[0].fd = opt_d_dd_fc;
}
else opc->v[0].fd = opt_d_7dd_fc;
- return(oo_set_type_0(opc, 4));
+ return(oo_set_type_0(opc));
}
slot = opt_float_symbol(sc, arg2);
if (slot)
@@ -57804,37 +57807,84 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
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 = opt_d_dd_fs;
if (func == multiply_d_dd)
opc->v[0].fd = opt_d_dd_fs_mul;
+ else opc->v[0].fd = opt_d_dd_fs;
}
else opc->v[0].fd = opt_d_7dd_fs;
- return(oo_set_type_1(opc, 4, 1, OO_D));
+ return(oo_set_type_1(opc, 1, OO_D));
}
+ 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, start))
+ if (d_dd_ff_combinable(sc, opc, start))
return(true);
opc->v[0].fd = opt_d_dd_ff;
if (func == multiply_d_dd)
- opc->v[0].fd = opt_d_dd_ff_mul;
+ {
+ opc->v[0].fd = opt_d_dd_ff_mul;
+ return(oo_set_type_0(opc));
+ }
else
{
+ opt_info *o2;
+ o2 = sc->opts[start2]; /* this is opc->v[10].o1 */
if (func == add_d_dd)
- opc->v[0].fd = opt_d_dd_ff_add;
+ {
+ 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(oo_set_type_0(opc));
+ }
+ 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(oo_set_type_0(opc));
+ }
else
{
if (func == subtract_d_dd)
- opc->v[0].fd = opt_d_dd_ff_sub;
+ {
+ 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(oo_set_type_0(opc));
+ }
}
}
}
else opc->v[0].fd = opt_d_7dd_ff;
- return(oo_set_type_0(opc, 4));
+ return(oo_set_type_0(opc));
}
}
pc_fallback(sc, start);
@@ -57845,42 +57895,35 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- d_ddd -------- */
static s7_double opt_d_ddd_sss(opt_info *o)
{
- oo_rc(o->sc, o, 5, 3);
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)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 5, 2);
- return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), o1->v[0].fd(o1)));
+ o->sc->pc++;
+ 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)
{
- opt_info *o1;
- s7_double x1;
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[0].fd(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 5, 1);
- return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), x1, o1->v[0].fd(o1)));
+ s7_double x1, x2;
+ o->sc->pc++;
+ x1 = o->v[11].fd(o->v[10].o1);
+ o->sc->pc++;
+ 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)
{
- opt_info *o1, *o2, *o3;
- s7_double x1, x2;
- s7_scheme *sc;
- sc = o->sc;
- o1 = sc->opts[++sc->pc];
- x1 = o1->v[0].fd(o1); /* this could involve nested funcs, incrementing pc internally */
- o2 = sc->opts[++sc->pc];
- x2 = o2->v[0].fd(o2);
- o3 = sc->opts[++sc->pc];
- oo_rc(o->sc, o, 5, 0);
- return(o->v[4].d_ddd_f(x1, x2, o3->v[0].fd(o3)));
+ s7_double x1, x2, x3;
+ o->sc->pc++;
+ x1 = o->v[11].fd(o->v[10].o1);
+ o->sc->pc++;
+ x2 = o->v[9].fd(o->v[8].o1);
+ o->sc->pc++;
+ 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)
@@ -57889,21 +57932,18 @@ static s7_double opt_d_ddd_fff1(opt_info *o)
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);
- oo_rc(o->sc, o, 8, 3);
return(o->v[7].d_ddd_f(x1, x2, x3));
}
static s7_double opt_d_ddd_fff2(opt_info *o)
{
- opt_info *o2, *o3;
- s7_double x1, x2;
+ s7_double x1, x2, x3;
x1 = o->v[1].d_v_f(o->v[2].obj);
o->sc->pc += 2;
- o2 = o->sc->opts[o->sc->pc];
- x2 = o2->v[0].fd(o2);
- o3 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 8, 1);
- return(o->v[7].d_ddd_f(x1, x2, o3->v[0].fd(o3)));
+ x2 = o->v[9].fd(o->v[12].o1);
+ o->sc->pc++;
+ 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)
@@ -57911,6 +57951,7 @@ static bool d_ddd_fff_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
if (sc->opts[start]->v[0].fd == opt_d_v)
{
opt_info *o1;
+ 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;
@@ -57929,10 +57970,12 @@ static bool d_ddd_fff_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
opc->v[6].obj = o1->v[5].obj;
opc->v[10].p = o1->v[1].p;
sc->pc -= 3;
- return(oo_set_type_3(opc, 11, 8 + (2 << 4), 9 + (4 << 4), 10 + (6 << 4), OO_V, OO_V, OO_V));
+ return(oo_set_type_3(opc, 8 + (2 << 4), 9 + (4 << 4), 10 + (6 << 4), OO_V, OO_V, OO_V));
}
opc->v[0].fd = opt_d_ddd_fff2;
- return(oo_set_type_1(opc, 9, 8 + (2 << 4), OO_V));
+ opc->v[9].fd = opc->v[12].o1->v[0].fd;
+ opc->v[6].fd = opc->v[5].o1->v[0].fd;
+ return(oo_set_type_1(opc, 8 + (2 << 4), OO_V));
}
return(return_false(sc, NULL, __func__, __LINE__));
}
@@ -57951,6 +57994,7 @@ static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
start = sc->pc;
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;
@@ -57965,36 +58009,45 @@ static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[3].p = slot;
opc->v[0].fd = opt_d_ddd_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_D, OO_D, OO_D));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_D, OO_D, OO_D));
}
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(oo_set_type_2(opc, 5, 1, 2, OO_D, OO_D));
+ return(oo_set_type_2(opc, 1, 2, OO_D, OO_D));
}
pc_fallback(sc, start);
}
- if ((float_optimize(sc, cddr(car_x))) &&
- (float_optimize(sc, cdddr(car_x))))
+ if (float_optimize(sc, cddr(car_x)))
{
- opc->v[0].fd = opt_d_ddd_sff;
- return(oo_set_type_1(opc, 5, 1, OO_D));
+ 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(oo_set_type_1(opc, 1, OO_D));
+ }
}
pc_fallback(sc, start);
}
- if ((float_optimize(sc, cdr(car_x))) &&
- (float_optimize(sc, cddr(car_x))) &&
- (float_optimize(sc, cdddr(car_x))))
+ if (float_optimize(sc, cdr(car_x)))
{
- if (d_ddd_fff_combinable(sc, opc, start))
- return(true);
- opc->v[0].fd = opt_d_ddd_fff;
- /* (* (env pulsef) (blackman pulse2) (polywave gen (rand-interp rnd)))
- * (* (env e)...) is common = opt_d_v: v3 v5 -> opc
- * (+ k (* 2 alpha) -2.0) (* scl ang ang) (- n k 1)
- */
- return(oo_set_type_0(opc, 5));
- }
+ 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(oo_set_type_0(opc));
+ }}}
pc_fallback(sc, start);
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -58003,53 +58056,43 @@ static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- d_7pid -------- */
static s7_double opt_d_7pid_ssf(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 5, 2);
- return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fd(o1)));
+ o->sc->pc++;
+ return(o->v[4].d_7pid_f(o->sc, 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)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 5, 2);
- o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fd(o1));
+ o->sc->pc++;
+ o->v[4].d_7pid_f(o->sc, 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)
{
- oo_rc(o->sc, o, 5, 3);
return(o->v[4].d_7pid_f(o->sc, 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)
{
- oo_rc(o->sc, o, 5, 2);
return(o->v[4].d_7pid_f(o->sc, 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)
{
- opt_info *o1;
s7_int pos;
- o1 = o->sc->opts[++o->sc->pc];
- pos = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 5, 1);
- return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), pos, o1->v[0].fd(o1)));
+ o->sc->pc++;
+ pos = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ return(o->v[4].d_7pid_f(o->sc, 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)
{
- oo_rc(o->sc, o, 6, 3);
return(o->v[4].d_7pid_f(o->sc, 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)
{
- oo_rc(o->sc, o, 7, 4);
return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[3].d_7pi_f(o->sc, slot_value(o->v[5].p),
@@ -58060,7 +58103,6 @@ static s7_double opt_d_7pid_ssfo(opt_info *o)
{
s7_pointer fv;
fv = slot_value(o->v[1].p);
- oo_rc(o->sc, o, 9, 4);
return(o->v[4].d_7pid_f(o->sc, fv, integer(slot_value(o->v[2].p)),
o->v[6].d_dd_f(o->v[5].d_7pi_f(o->sc, fv, integer(slot_value(o->v[3].p))), real(slot_value(o->v[8].p)))));
}
@@ -58072,7 +58114,6 @@ static s7_double opt_d_7pid_ssfo_fv(opt_info *o)
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;
- oo_rc(o->sc, o, 7, 4);
return(val);
}
@@ -58081,7 +58122,6 @@ static s7_pointer opt_d_7pid_ssfo_fv_nr(opt_info *o)
s7_double *els;
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)));
- oo_rc(o->sc, o, 9, 4);
return(NULL);
}
@@ -58090,7 +58130,6 @@ static s7_pointer opt_d_7pid_ssfo_fv_add_nr(opt_info *o)
s7_double *els;
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));
- oo_rc(o->sc, o, 9, 4);
return(NULL);
}
@@ -58099,7 +58138,6 @@ static s7_pointer opt_d_7pid_ssfo_fv_sub_nr(opt_info *o)
s7_double *els;
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));
- oo_rc(o->sc, o, 9, 4);
return(NULL);
}
@@ -58117,7 +58155,7 @@ static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc)
opc->v[5].d_v_f = o1->v[3].d_v_f;
opc->v[0].fd = opt_d_7pid_sso;
backup_pc(sc);
- return(oo_set_type_3(opc, 7, 1, 2, 6 + (3 << 4), OO_P, OO_I, OO_V));
+ return(oo_set_type_3(opc, 1, 2, 6 + (3 << 4), OO_P, OO_I, OO_V));
}
if (o1->v[0].fd == opt_d_7pi_ss)
{
@@ -58126,7 +58164,7 @@ static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc)
opc->v[6].p = o1->v[2].p;
opc->v[0].fd = opt_d_7pid_ss_ss;
backup_pc(sc);
- return(oo_set_type_4(opc, 7, 1, 2, 5, 6, OO_P, OO_I, OO_P, OO_I));
+ return(oo_set_type_4(opc, 1, 2, 5, 6, OO_P, OO_I, OO_P, OO_I));
}
if ((o1->v[0].fd == opt_d_dd_fso) &&
(opc->v[1].p == o1->v[2].p))
@@ -58145,9 +58183,9 @@ static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc)
(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 */
- oo_set_type_4(opc, 9, 1, 2, 3, 8, OO_FV, OO_I, OO_I, OO_D);
+ oo_set_type_4(opc, 1, 2, 3, 8, OO_FV, OO_I, OO_I, OO_D);
}
- else oo_set_type_4(opc, 9, 1, 2, 3, 8, OO_P, OO_I, OO_I, OO_D);
+ else oo_set_type_4(opc, 1, 2, 3, 8, OO_P, OO_I, OO_I, OO_D);
backup_pc(sc);
return(true);
}
@@ -58158,37 +58196,30 @@ static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc)
/* -------- d_7piid -------- */
static s7_double opt_d_7piid_sssf(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 3);
- return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o1->v[0].fd(o1)));
+ o->sc->pc++;
+ return(o->v[5].d_7piid_f(o->sc, 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)
{
- oo_rc(o->sc, o, 6, 3);
return(o->v[5].d_7piid_f(o->sc, 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)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 2);
- return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p)), o1->v[0].fd(o1)));
+ o->sc->pc++;
+ return(o->v[5].d_7piid_f(o->sc, 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)
{
- opt_info *o1;
s7_int i1, i2;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- i2 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 1);
- return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), i1, i2, o1->v[0].fd(o1)));
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ o->sc->pc++;
+ return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), i1, i2, o->v[4].fd(o->v[3].o1)));
}
static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp)
@@ -58200,9 +58231,12 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_
(!is_immutable(slot_value(settee))))
{
s7_pointer slot;
+ int32_t start;
opc->v[1].p = settee;
+ start = sc->pc;
if (is_float_vector(slot_value(settee)))
{
+ opc->v[10].o1 = sc->opts[start];
if ((!indexp2) &&
(vector_rank(slot_value(settee)) == 1))
{
@@ -58219,29 +58253,36 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_
{
opc->v[3].p = slot;
opc->v[0].fd = opt_d_7pid_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_FV, OO_I, OO_D));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_FV, OO_I, OO_D));
}
if (is_real(car(valp)))
{
opc->v[3].x = s7_real(car(valp));
opc->v[0].fd = opt_d_7pid_ssc;
- return(oo_set_type_2(opc, 5, 1, 2, OO_FV, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_FV, OO_I));
}
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(oo_set_type_2(opc, 5, 1, 2, OO_FV, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_FV, OO_I));
}
+ pc_fallback(sc, start);
}
- if ((int_optimize(sc, indexp1)) &&
- (float_optimize(sc, valp)))
+ if (int_optimize(sc, indexp1))
{
- opc->v[0].fd = opt_d_7pid_sff;
- return(oo_set_type_1(opc, 5, 1, OO_FV));
+ 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(oo_set_type_1(opc, 1, OO_FV));
+ }
}
- return(return_false(sc, NULL, __func__, __LINE__));
+ return(return_false(sc, NULL, __func__, __LINE__));
}
if ((indexp2) &&
@@ -58258,7 +58299,8 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_
{
opc->v[0].fd = opt_d_7piid_scsf;
opc->v[2].i = integer(car(indexp1));
- return(oo_set_type_2(opc, 6, 1, 3, OO_FV, OO_I));
+ opc->v[11].fd = opc->v[10].o1->v[0].fd;
+ return(oo_set_type_2(opc, 1, 3, OO_FV, OO_I));
}
return(return_false(sc, NULL, __func__, __LINE__));
}
@@ -58270,46 +58312,53 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_
{
opc->v[0].fd = opt_d_7piid_sssc;
opc->v[4].x = s7_real(car(valp));
- return(oo_set_type_3(opc, 6, 1, 2, 3, OO_FV, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_FV, OO_I, OO_I));
}
+ opc->v[8].o1 = sc->opts[sc->pc];
if (float_optimize(sc, valp))
{
opc->v[0].fd = opt_d_7piid_sssf;
- return(oo_set_type_3(opc, 6, 1, 2, 3, OO_FV, OO_I, OO_I));
+ opc->v[9].fd = opc->v[8].o1->v[0].fd;
+ return(oo_set_type_3(opc, 1, 2, 3, OO_FV, OO_I, OO_I));
}
+ pc_fallback(sc, start);
}
- if ((int_optimize(sc, indexp1)) &&
- (int_optimize(sc, indexp2)) &&
- (float_optimize(sc, valp)))
+ }
+ if (int_optimize(sc, indexp1))
+ {
+ opc->v[8].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, indexp2))
{
- opc->v[0].fd = opt_d_7piid_sfff;
- return(oo_set_type_1(opc, 6, 1, OO_FV));
- }}}}
- }
+ 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(oo_set_type_1(opc, 1, OO_FV));
+ }}}}}}
return(return_false(sc, NULL, __func__, __LINE__));
}
static s7_double opt_d_7pii_sss(opt_info *o)
{
- oo_rc(o->sc, o, 5, 3);
return(o->v[4].d_7pii_f(o->sc, 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_scs(opt_info *o)
{
- oo_rc(o->sc, o, 5, 2);
return(o->v[4].d_7pii_f(o->sc, 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)
{
- opt_info *o1;
- s7_int i1;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 5, 1);
- return(o->v[4].d_7pii_f(o->sc, slot_value(o->v[1].p), i1, o1->v[0].fi(o1)));
+ s7_int i1, i2;
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[4].d_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2));
}
static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
@@ -58344,20 +58393,26 @@ static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe
{
opc->v[2].p = slot;
opc->v[0].fd = opt_d_7pii_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_P, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_P, OO_I, OO_I));
}
if (is_t_integer(caddr(car_x)))
{
opc->v[2].i = integer(caddr(car_x));
opc->v[0].fd = opt_d_7pii_scs;
- return(oo_set_type_2(opc, 5, 1, 3, OO_P, OO_I));
+ return(oo_set_type_2(opc, 1, 3, OO_P, OO_I));
}
}
- if ((int_optimize(sc, cddr(car_x))) &&
- (int_optimize(sc, cdddr(car_x))))
+ opc->v[10].o1 = sc->opts[start];
+ if (int_optimize(sc, cddr(car_x)))
{
- opc->v[0].fd = opt_d_7pii_sff;
- return(oo_set_type_1(opc, 5, 1, OO_P));
+ 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(oo_set_type_1(opc, 1, OO_P));
+ }
}
pc_fallback(sc, start);
}
@@ -58383,6 +58438,7 @@ static bool d_7pid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe
return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), NULL, cdddr(car_x)));
opc->v[1].p = symbol_to_slot(sc, cadr(car_x));
+ opc->v[10].o1 = sc->opts[start];
if (is_slot(opc->v[1].p))
{
slot = opt_integer_symbol(sc, caddr(car_x));
@@ -58394,22 +58450,28 @@ static bool d_7pid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe
{
opc->v[3].p = slot;
opc->v[0].fd = opt_d_7pid_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_P, OO_I, OO_D));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_P, OO_I, OO_D));
}
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(oo_set_type_2(opc, 5, 1, 2, OO_P, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_I));
}
pc_fallback(sc, start);
}
- if ((int_optimize(sc, cddr(car_x))) &&
- (float_optimize(sc, cdddr(car_x))))
+ if (int_optimize(sc, cddr(car_x)))
{
- opc->v[0].fd = opt_d_7pid_sff;
- return(oo_set_type_1(opc, 5, 1, OO_P));
+ 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(oo_set_type_1(opc, 1, OO_P));
+ }
}
pc_fallback(sc, start);
}
@@ -58434,28 +58496,23 @@ static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point
/* -------- d_vid -------- */
static s7_double opt_d_vid_ssf(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 2);
- return(o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), o1->v[0].fd(o1)));
+ o->sc->pc++;
+ 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 */
+ /* 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;
s7_scheme *sc;
sc = o->sc;
-
o1 = sc->opts[sc->pc + 1];
o2 = sc->opts[sc->pc + 3];
o3 = sc->opts[sc->pc += 5];
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);
-
- oo_rc(o->sc, o, 6, 2);
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,
@@ -58485,6 +58542,7 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
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))))
@@ -58492,6 +58550,7 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
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)
{
@@ -58504,10 +58563,10 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
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;
+ opc->v[0].fd = opt_fmv; /* a placeholder -- see below */
}
}
- return(oo_set_type_2(opc, 6, 1 + (5 << 4), 2, OO_V, OO_I));
+ return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_I));
}
}
pc_fallback(sc, start);
@@ -58518,13 +58577,12 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- d_vdd -------- */
static s7_double opt_d_vdd_ff(opt_info *o)
{
- opt_info *o1, *o2;
- s7_double x1;
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[0].fd(o1);
- o2 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 1);
- return(o->v[4].d_vdd_f(o->v[5].obj, x1, o2->v[0].fd(o2)));
+ s7_double x1, x2;
+ o->sc->pc++;
+ x1 = o->v[11].fd(o->v[10].o1);
+ o->sc->pc++;
+ 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)
@@ -58544,13 +58602,19 @@ static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
int32_t start;
start = sc->pc;
- if ((float_optimize(sc, cddr(car_x))) &&
- (float_optimize(sc, cdddr(car_x))))
+ opc->v[10].o1 = sc->opts[start];
+ if (float_optimize(sc, cddr(car_x)))
{
- 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(oo_set_type_1(opc, 6, 1 + (5 << 4), OO_V));
+ 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(oo_set_type_1(opc, 1 + (5 << 4), OO_V));
+ }
}
pc_fallback(sc, start);
}}}
@@ -58561,19 +58625,16 @@ static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- d_dddd -------- */
static s7_double opt_d_dddd_ffff(opt_info *o)
{
- opt_info *o1, *o2, *o3, *o4;
- s7_double x1, x2, x3;
- s7_scheme *sc;
- sc = o->sc;
- o1 = sc->opts[++sc->pc];
- x1 = o1->v[0].fd(o1);
- o2 = sc->opts[++sc->pc];
- x2 = o2->v[0].fd(o2);
- o3 = sc->opts[++sc->pc];
- x3 = o3->v[0].fd(o3);
- o4 = sc->opts[++sc->pc];
- oo_rc(o->sc, o, 1, 0);
- return(o->v[1].d_dddd_f(x1, x2, x3, o4->v[0].fd(o4)));
+ s7_double x1, x2, x3, x4;
+ o->sc->pc++;
+ x1 = o->v[11].fd(o->v[10].o1);
+ o->sc->pc++;
+ x2 = o->v[9].fd(o->v[8].o1);
+ o->sc->pc++;
+ x3 = o->v[5].fd(o->v[4].o1);
+ o->sc->pc++;
+ 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)
@@ -58582,16 +58643,26 @@ static bool d_dddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe
f = s7_d_dddd_function(s_func);
if (f)
{
- if ((float_optimize(sc, cdr(car_x))) &&
- (float_optimize(sc, cddr(car_x))) &&
- (float_optimize(sc, cdddr(car_x))) &&
- (float_optimize(sc, cddddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (float_optimize(sc, cdr(car_x)))
{
- opc->v[1].d_dddd_f = f;
- opc->v[0].fd = opt_d_dddd_ffff;
- return(oo_set_type_0(opc, 2));
- }
- }
+ 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(oo_set_type_0(opc));
+ }}}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -58600,43 +58671,25 @@ static s7_double opt_d_add_any_f(opt_info *o)
{
s7_double sum = 0.0;
int32_t i;
- oo_rc(o->sc, o, 2, 0);
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = o->v[i + 2].o1;
+ o->sc->pc++;
sum += o1->v[0].fd(o1);
}
return(sum);
}
-static s7_double opt_d_subtract_any_f(opt_info *o)
-{
- opt_info *o1;
- s7_double sum;
- int32_t i;
- s7_scheme *sc;
- sc = o->sc;
- oo_rc(o->sc, o, 2, 0);
- o1 = sc->opts[++sc->pc];
- sum = o1->v[0].fd(o1);
- for (i = 1; i < o->v[1].i; i++)
- {
- o1 = sc->opts[++sc->pc];
- 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;
- oo_rc(o->sc, o, 2, 0);
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = o->v[i + 2].o1;
+ o->sc->pc++;
sum *= o1->v[0].fd(o1);
}
return(sum);
@@ -58653,31 +58706,19 @@ static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x, int32_t
{
s7_pointer p;
int32_t cur_len;
- for (cur_len = 0, p = cdr(car_x); is_pair(p); p = cdr(p), cur_len++)
- if (!float_optimize(sc, p))
- break;
+
+ for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++)
+ {
+ opc->v[2 + cur_len].o1 = sc->opts[sc->pc];
+ if (!float_optimize(sc, p))
+ break;
+ }
+
if (is_null(p))
{
- /* since 2|3|4-arg case is split out above, can cur_len ever be 2? */
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(oo_set_type_0(opc, 2));
- }
- }
- else
- {
- if (head == sc->subtract_symbol)
- {
- s7_pointer p;
- opc->v[1].i = (len - 1);
- for (p = cdr(car_x); is_pair(p); p = cdr(p))
- if (!float_optimize(sc, p))
- break;
- if (is_null(p))
- {
- opc->v[0].fd = opt_d_subtract_any_f;
- return(oo_set_type_0(opc, 2));
- }
+ return(oo_set_type_0(opc));
}
}
pc_fallback(sc, start);
@@ -58688,22 +58729,18 @@ static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x, int32_t
/* -------- d_syntax -------- */
static s7_double opt_set_d_d_f(opt_info *o)
{
- opt_info *o1;
s7_double x;
- o1 = o->sc->opts[++o->sc->pc];
- x = o1->v[0].fd(o1);
- oo_rc(o->sc, o, 2, 1);
+ o->sc->pc++;
+ x = o->v[3].fd(o->v[2].o1);
slot_set_value(o->v[1].p, make_real(o->sc, x));
return(x);
}
static s7_double opt_set_d_d_fm(opt_info *o)
{
- opt_info *o1;
s7_double x;
- o1 = o->sc->opts[++o->sc->pc];
- x = o1->v[0].fd(o1);
- oo_rc(o->sc, o, 2, 1);
+ o->sc->pc++;
+ x = o->v[3].fd(o->v[2].o1);
real(slot_value(o->v[1].p)) = x;
return(x);
}
@@ -58725,6 +58762,8 @@ static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
if ((is_slot(settee)) &&
(!is_immutable(settee)))
{
+ opt_info *o1;
+ o1 = sc->opts[sc->pc];
opc->v[1].p = settee;
if ((!is_t_integer(caddr(car_x))) &&
(is_float(slot_value(settee))) &&
@@ -58733,7 +58772,9 @@ static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
if (is_mutable_number(slot_value(opc->v[1].p)))
opc->v[0].fd = opt_set_d_d_fm;
else opc->v[0].fd = opt_set_d_d_f;
- return(oo_set_type_1(opc, 2, 1, OO_R));
+ opc->v[2].o1 = o1;
+ opc->v[3].fd = o1->v[0].fd;
+ return(oo_set_type_1(opc, 1, OO_R));
}
}
}
@@ -58778,12 +58819,14 @@ static bool d_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
if ((is_step_end(opc->v[2].p)) &&
(denominator(slot_value(opc->v[2].p)) <= vector_length(slot_value(opc->v[1].p))))
opc->v[3].d_7pi_f = float_vector_ref_unchecked;
- return(oo_set_type_2(opc, 4, 1, 2, OO_FV, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_FV, OO_I));
}
+ 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(oo_set_type_1(opc, 4, 1, OO_FV));
+ return(oo_set_type_1(opc, 1, OO_FV));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -58803,14 +58846,20 @@ static bool d_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
opc->v[3].p = slot;
opc->v[0].fd = opt_d_7pii_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_FV, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_FV, OO_I, OO_I));
}
}
- if ((int_optimize(sc, cdr(car_x))) &&
- (int_optimize(sc, cddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cdr(car_x)))
{
- opc->v[0].fd = opt_d_7pii_sff;
- return(oo_set_type_1(opc, 5, 1, OO_FV));
+ 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(oo_set_type_1(opc, 1, OO_FV));
+ }
}
}
}
@@ -58835,12 +58884,14 @@ static bool d_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
opc->v[0].fd = opt_d_7pi_ss;
opc->v[2].p = slot;
- return(oo_set_type_2(opc, 5, 1 + (4 << 4), 2, OO_V, OO_I));
+ return(oo_set_type_2(opc, 1 + (4 << 4), 2, OO_V, OO_I));
}
+ 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(oo_set_type_1(opc, 5, 1 + (4 << 4), OO_V));
+ return(oo_set_type_1(opc, 1 + (4 << 4), OO_V));
}}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -58849,7 +58900,7 @@ static bool d_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
/* -------------------------------- bool opts -------------------------------- */
static bool opt_b_t(opt_info *o) {return(true);}
static bool opt_b_f(opt_info *o) {return(false);}
-static bool opt_b_s(opt_info *o) {oo_rc(o->sc, o, 2, 1); return(slot_value(o->v[1].p) != o->sc->F);}
+static bool opt_b_s(opt_info *o) {return(slot_value(o->v[1].p) != o->sc->F);}
static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x)
{
@@ -58861,7 +58912,7 @@ static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x)
return(return_false(sc, car_x, __func__, __LINE__)); /* i.e. use cell_optimize */
opc = alloc_opo(sc, car_x);
opc->v[0].fb = ((car_x == sc->F) ? opt_b_f : opt_b_t);
- return(oo_set_type_0(opc, 1));
+ return(oo_set_type_0(opc));
}
p = opt_simple_symbol(sc, car_x);
if ((p) &&
@@ -58870,74 +58921,26 @@ static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x)
opc = alloc_opo(sc, car_x);
opc->v[1].p = p;
opc->v[0].fb = opt_b_s;
- return(oo_set_type_1(opc, 2, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- b_idp -------- */
-static bool opt_b_i_s(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 1);
- return(o->v[2].b_i_f(integer(slot_value(o->v[1].p))));
-}
-
-static bool opt_b_i_f(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 3, 0);
- return(o->v[2].b_i_f(o1->v[0].fi(o1)));
-}
-
-static bool opt_b_d_s(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 1);
- return(o->v[2].b_d_f(real(slot_value(o->v[1].p))));
-}
-
-static bool opt_b_d_f(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 3, 0);
- return(o->v[2].b_d_f(o1->v[0].fd(o1)));
-}
-
-static bool opt_b_p_s(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 1);
- return(o->v[2].b_p_f(slot_value(o->v[1].p)));
-}
-
-static bool opt_b_p_f(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 3, 0);
- return(o->v[2].b_p_f(o1->v[0].fp(o1)));
-}
-
-static bool opt_b_7p_s(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 1);
- return(o->v[2].b_7p_f(o->sc, slot_value(o->v[1].p)));
-}
-
-static bool opt_b_7p_f(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 3, 0);
- return(o->v[2].b_7p_f(o->sc, o1->v[0].fp(o1)));
-}
+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) {o->sc->pc++; 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) {o->sc->pc++; 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) {o->sc->pc++; 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(o->sc, slot_value(o->v[1].p)));}
+static bool opt_b_7p_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
#if (!WITH_GMP)
static bool opt_zero_mod(opt_info *o)
{
s7_int x;
x = integer(slot_value(o->v[1].p));
- oo_rc(o->sc, o, 3, 1);
return((x % o->v[2].i) == 0);
}
#endif
@@ -58963,8 +58966,9 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin
{
opc->v[1].p = symbol_to_slot(sc, cadr(car_x));
opc->v[0].fb = opt_b_i_s;
- return(oo_set_type_1(opc, 3, 1, OO_I));
+ return(oo_set_type_1(opc, 1, OO_I));
}
+ opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x)))
{
#if (!WITH_GMP)
@@ -58978,11 +58982,12 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin
opc->v[1].p = o1->v[1].p;
opc->v[2].i = o1->v[2].i;
backup_pc(sc);
- return(oo_set_type_1(opc, 3, 1, OO_I));
+ return(oo_set_type_1(opc, 1, OO_I));
}
#endif
opc->v[0].fb = opt_b_i_f;
- return(oo_set_type_0(opc, 3));
+ opc->v[11].fi = opc->v[10].o1->v[0].fi;
+ return(oo_set_type_0(opc));
}
}
}
@@ -58999,12 +59004,14 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin
{
opc->v[1].p = symbol_to_slot(sc, cadr(car_x));
opc->v[0].fb = opt_b_d_s;
- return(oo_set_type_1(opc, 3, 1, OO_D));
+ return(oo_set_type_1(opc, 1, OO_D));
}
+ opc->v[10].o1 = sc->opts[sc->pc];
if (float_optimize(sc, cdr(car_x)))
{
opc->v[0].fb = opt_b_d_f;
- return(oo_set_type_0(opc, 3));
+ opc->v[11].fd = opc->v[10].o1->v[0].fd;
+ return(oo_set_type_0(opc));
}
}
}
@@ -59034,11 +59041,13 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin
opc->v[0].fb = opt_b_p_s;
}
}
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
+ opc->v[3].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x)))
{
opc->v[0].fb = (bpf) ? opt_b_p_f : opt_b_7p_f;
+ opc->v[4].fp = opc->v[3].o1->v[0].fp;
if (arg_type == sc->is_char_symbol)
{
bpf = s7_b_p_direct_function(s_func);
@@ -59048,7 +59057,7 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin
opc->v[0].fb = opt_b_p_f;
}
}
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -59126,105 +59135,34 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp)
static bool opt_b_pp_ff(opt_info *o)
{
- opt_info *o1;
s7_pointer p1;
- o1 = o->sc->opts[++o->sc->pc];
- p1 = o1->v[0].fp(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].b_pp_f(p1, o1->v[0].fp(o1)));
-}
-
-static bool opt_b_pp_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_pp_f(slot_value(o->v[1].p), o1->v[0].fp(o1)));
-}
-
-static bool opt_b_pp_fs(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_pp_f(o1->v[0].fp(o1), slot_value(o->v[1].p)));
-}
-
-static bool opt_b_pp_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- 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)
-{
- oo_rc(o->sc, o, 4, 1);
- 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)
-{
- oo_rc(o->sc, o, 5, 2);
- return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));
+ o->sc->pc++;
+ p1 = o->v[9].fp(o->v[8].o1);
+ o->sc->pc++;
+ 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)
{
- opt_info *o1;
s7_pointer p1;
- o1 = o->sc->opts[++o->sc->pc];
- p1 = o1->v[0].fp(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].b_7pp_f(o->sc, p1, o1->v[0].fp(o1)));
-}
-
-static bool opt_b_7pp_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o1->v[0].fp(o1)));
-}
-
-static bool opt_b_7pp_fs(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_7pp_f(o->sc, o1->v[0].fp(o1), slot_value(o->v[1].p)));
-}
-
-static bool opt_b_7pp_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));
-}
-
-static bool opt_lt_b_7pp_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));
-}
-
-static bool opt_b_7pp_sc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));
-}
-
-static bool opt_b_7pp_sfo(opt_info *o)
-{
- oo_rc(o->sc, o, 5, 2);
- return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));
-}
-
-static bool opt_is_equal_sfo(opt_info *o)
-{
- oo_rc(o->sc, o, 5, 2);
- return(is_equal_b_7pp(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));
-}
+ o->sc->pc++;
+ p1 = o->v[9].fp(o->v[8].o1);
+ o->sc->pc++;
+ return(o->v[3].b_7pp_f(o->sc, p1, o->v[11].fp(o->v[10].o1)));
+}
+
+static bool opt_b_pp_sf(opt_info *o) {o->sc->pc++; 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) {o->sc->pc++; 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(o->sc, slot_value(o->v[2].p))));}
+static bool opt_b_7pp_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));}
+static bool opt_b_7pp_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_7pp_f(o->sc, 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(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static bool opt_lt_b_7pp_ss(opt_info *o) {return(lt_b_7pp(o->sc, 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(o->sc, 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(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));}
+static bool opt_is_equal_sfo(opt_info *o) {return(s7_is_equal(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));}
static s7_pointer opt_p_p_s(opt_info *o);
@@ -59239,9 +59177,9 @@ static bool b_pp_sf_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case)
{
opc->v[2].p = o1->v[1].p;
opc->v[4].p_p_f = o1->v[2].p_p_f;
- opc->v[0].fb = (bpf_case) ? opt_b_pp_sfo : ((opc->v[3].b_7pp_f == is_equal_b_7pp) ? opt_is_equal_sfo : opt_b_7pp_sfo);
+ opc->v[0].fb = (bpf_case) ? opt_b_pp_sfo : ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_is_equal_sfo : opt_b_7pp_sfo);
backup_pc(sc);
- return(oo_set_type_2(opc, 5, 1, 2, OO_P, OO_P));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_P));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
@@ -59251,7 +59189,6 @@ static bool opt_b_pp_ffo(opt_info *o)
{
s7_pointer b1;
b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p));
- oo_rc(o->sc, o, 6, 2);
return(o->v[3].b_pp_f(b1, o->v[5].p_p_f(o->sc, slot_value(o->v[2].p))));
}
@@ -59259,7 +59196,6 @@ static bool opt_b_7pp_ffo(opt_info *o)
{
s7_pointer b1;
b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p));
- oo_rc(o->sc, o, 6, 2);
return(o->v[3].b_7pp_f(o->sc, b1, o->v[5].p_p_f(o->sc, slot_value(o->v[2].p))));
}
@@ -59280,7 +59216,7 @@ static bool b_pp_ff_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case)
opc->v[5].p_p_f = o2->v[2].p_p_f;
opc->v[0].fb = (bpf_case) ? opt_b_pp_ffo : opt_b_7pp_ffo;
sc->pc -= 2;
- return(oo_set_type_2(opc, 6, 1, 2, OO_P, OO_P));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_P));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
@@ -59289,6 +59225,7 @@ static bool b_pp_ff_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case)
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;
+ opt_info *o1;
cur_index = sc->pc;
/* v[3] is set when we get here */
@@ -59301,7 +59238,7 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
(opc->v[2].p))
{
opc->v[0].fb = (bpf_case) ? opt_b_pp_ss : ((opc->v[3].b_7pp_f == lt_b_7pp) ? opt_lt_b_7pp_ss : opt_b_7pp_ss);
- return(oo_set_type_2(opc, 4, 1, 2, OO_P, OO_P));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_P));
}
}
if (is_symbol(arg1))
@@ -59314,14 +59251,16 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].p = arg2;
opc->v[0].fb = (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
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;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
oo_check(sc, opc);
return(true);
@@ -59333,40 +59272,48 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
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 = symbol_to_slot(sc, arg2);
if ((!is_slot(opc->v[1].p)) ||
(has_methods(slot_value(opc->v[1].p))))
return(return_false(sc, car_x, __func__, __LINE__));
+ 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;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
/* return(return_false(sc, car_x, __func__, __LINE__)); */
pc_fallback(sc, cur_index);
}
}
- if ((cell_optimize(sc, cdr(car_x))) &&
- (cell_optimize(sc, cddr(car_x))))
+ o1 = sc->opts[sc->pc];
+ if (cell_optimize(sc, cdr(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;
- if (s7_b_pp_direct_function(s_func))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (cell_optimize(sc, cddr(car_x)))
{
- s7_pointer call_sig, 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 = opt_b_pp_ff;
- opc->v[3].b_pp_f = s7_b_pp_direct_function(s_func);
- return(oo_set_type_0(opc, 4));
+ 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;
+ if (s7_b_pp_direct_function(s_func))
+ {
+ s7_pointer call_sig, 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 = opt_b_pp_ff;
+ opc->v[3].b_pp_f = s7_b_pp_direct_function(s_func);
+ }
}
+ return(oo_set_type_0(opc));
}
- return(oo_set_type_0(opc, 4));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -59374,10 +59321,8 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- b_pi -------- */
static bool opt_b_pi_fs(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 3, 1);
- return(o->v[2].b_pi_f(o->sc, o1->v[0].fp(o1), integer(slot_value(o->v[1].p))));
+ o->sc->pc++;
+ return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));
}
static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg2)
@@ -59387,11 +59332,13 @@ static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (bpif)
{
opc->v[1].p = symbol_to_slot(sc, arg2); /* slot checked in opt_arg_type */
+ opc->v[10].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x)))
{
opc->v[2].b_pi_f = bpif;
opc->v[0].fb = opt_b_pi_fs;
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ opc->v[11].fp = opc->v[10].o1->v[0].fp;
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -59399,51 +59346,27 @@ static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- b_dd -------- */
-static bool opt_b_dd_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- 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(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)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));
-}
+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)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o1->v[0].fd(o1)));
-}
-
-static bool opt_b_dd_fs(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_dd_f(o1->v[0].fd(o1), real(slot_value(o->v[1].p))));
-}
-
-static bool opt_b_dd_fc(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].b_dd_f(o1->v[0].fd(o1), o->v[1].x));
-}
+static bool opt_b_dd_sf(opt_info *o) {o->sc->pc++; 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) {o->sc->pc++; 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_fc(opt_info *o) {o->sc->pc++; 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)
{
- opt_info *o1;
- s7_double x1;
- o1 = o->sc->opts[++o->sc->pc];
- x1 = o1->v[0].fd(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].b_dd_f(x1, o1->v[0].fd(o1)));
+ s7_double x1, x2;
+ o->sc->pc++;
+ x1 = o->v[11].fd(o->v[10].o1);
+ o->sc->pc++;
+ 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)
@@ -59455,47 +59378,52 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (bif)
{
opc->v[3].b_dd_f = bif;
-
if (is_symbol(arg1))
{
opc->v[1].p = symbol_to_slot(sc, arg1);
if (is_symbol(arg2))
{
opc->v[2].p = symbol_to_slot(sc, arg2);
- opc->v[0].fb = opt_b_dd_ss;
- return(oo_set_type_2(opc, 4, 1, 2, OO_D, OO_D));
+ 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(oo_set_type_2(opc, 1, 2, OO_D, OO_D));
}
if (is_real(arg2))
{
opc->v[2].x = s7_number_to_real(sc, arg2);
- opc->v[0].fb = opt_b_dd_sc;
- return(oo_set_type_1(opc, 4, 1, OO_D));
+ 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(oo_set_type_1(opc, 1, OO_D));
}
+ 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(oo_set_type_1(opc, 4, 1, OO_D));
+ return(oo_set_type_1(opc, 1, OO_D));
}
}
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 = symbol_to_slot(sc, arg2);
opc->v[0].fb = opt_b_dd_fs;
- return(oo_set_type_1(opc, 4, 1, OO_D));
+ return(oo_set_type_1(opc, 1, OO_D));
}
if (is_real(arg2))
{
opc->v[1].x = s7_number_to_real(sc, arg2);
opc->v[0].fb = opt_b_dd_fc;
- return(oo_set_type_0(opc, 4));
+ return(oo_set_type_0(opc));
}
+ 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(oo_set_type_0(opc, 4));
+ return(oo_set_type_0(opc));
}
}
}
@@ -59505,51 +59433,30 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- b_ii -------- */
-static bool opt_b_ii_ss(opt_info *o) {oo_rc(o->sc, o, 4, 2); 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) {oo_rc(o->sc, o, 4, 2); 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) {oo_rc(o->sc, o, 4, 2); 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) {oo_rc(o->sc, o, 4, 2); 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) {oo_rc(o->sc, o, 4, 2); 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) {oo_rc(o->sc, o, 4, 2); return(integer(slot_value(o->v[1].p)) == integer(slot_value(o->v[2].p)));}
-static bool opt_b_ii_sc(opt_info *o) {oo_rc(o->sc, o, 4, 1); 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) {oo_rc(o->sc, o, 4, 1); return(integer(slot_value(o->v[1].p)) < o->v[2].i);}
-static bool opt_b_ii_sc_geq(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(integer(slot_value(o->v[1].p)) >= o->v[2].i);}
-static bool opt_b_ii_sc_eq(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(integer(slot_value(o->v[1].p)) == o->v[2].i);}
+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_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_ff(opt_info *o)
{
- opt_info *o1;
- s7_int i1;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].b_ii_f(i1, o1->v[0].fi(o1)));
-}
-
-static bool opt_b_ii_fs(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_ii_f(o1->v[0].fi(o1), integer(slot_value(o->v[2].p))));
-}
-
-static bool opt_b_ii_fc(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].b_ii_f(o1->v[0].fi(o1), o->v[2].i));
+ s7_int i1, i2;
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[3].b_ii_f(i1, i2));
}
-static bool opt_b_ii_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o1->v[0].fi(o1)));
-}
+static bool opt_b_ii_fs(opt_info *o) {o->sc->pc++; 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_fc(opt_info *o) {o->sc->pc++; return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));}
+static bool opt_b_ii_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[11].fi(o->v[10].o1)));}
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)
{
@@ -59587,44 +59494,53 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
}
}
- return(oo_set_type_2(opc, 4, 1, 2, OO_I, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_I, OO_I));
}
if (is_opt_int(arg2))
{
opc->v[2].i = integer(arg2);
opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_sc_lt : ((bif == geq_b_ii) ? opt_b_ii_sc_geq : ((bif == num_eq_b_ii) ? opt_b_ii_sc_eq : opt_b_ii_sc));
- return(oo_set_type_1(opc, 4, 1, OO_I));
+ return(oo_set_type_1(opc, 1, OO_I));
}
+ opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x)))
{
opc->v[0].fb = opt_b_ii_sf;
- return(oo_set_type_1(opc, 4, 1, OO_I));
+ opc->v[11].fi = opc->v[10].o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, OO_I));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
if (is_symbol(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;
opc->v[2].p = symbol_to_slot(sc, arg2);
opc->v[0].fb = opt_b_ii_fs;
- return(oo_set_type_1(opc, 4, 2, OO_I));
+ return(oo_set_type_1(opc, 2, OO_I));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
- if ((is_opt_int(arg2)) &&
- (int_optimize(sc, cdr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cdr(car_x)))
{
- opc->v[2].i = integer(arg2);
- opc->v[0].fb = opt_b_ii_fc;
- return(oo_set_type_0(opc, 4));
+ opc->v[11].fi = opc->v[10].o1->v[0].fi;
+ if (is_opt_int(arg2))
+ {
+ opc->v[2].i = integer(arg2);
+ opc->v[0].fb = opt_b_ii_fc;
+ return(oo_set_type_0(opc));
+ }
+ 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(oo_set_type_0(opc));
+ }
}
- if ((int_optimize(sc, cdr(car_x))) &&
- (int_optimize(sc, cddr(car_x))))
- {
- opc->v[0].fb = opt_b_ii_ff;
- return(oo_set_type_0(opc, 4));
- }
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -59632,29 +59548,22 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- b_or|and -------- */
static bool opt_and_bb(opt_info *o)
{
- opt_info *o1;
- s7_scheme *sc;
- sc = o->sc;
- oo_rc(sc, o, 2, 0);
- o1 = sc->opts[++sc->pc];
- if (o1->v[0].fb(o1))
+ o->sc->pc++;
+ if (o->v[3].fb(o->v[2].o1))
{
- o1 = sc->opts[++sc->pc];
- return(o1->v[0].fb(o1));
+ o->sc->pc++;
+ return(o->v[11].fb(o->v[10].o1));
}
- sc->pc = o->v[1].i;
+ o->sc->pc = o->v[1].i;
return(false);
}
static bool opt_and_bb1(opt_info *o)
{
- oo_rc(o->sc, o, 8, 0);
- if (o->v[7].fb(o))
+ if (o->v[5].fb(o))
{
- opt_info *o1;
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o1->v[0].fb(o1));
+ return(o->v[11].fb(o->v[10].o1));
}
o->sc->pc = o->v[4].i;
return(false);
@@ -59663,11 +59572,11 @@ static bool opt_and_bb1(opt_info *o)
static bool opt_and_any_b(opt_info *o)
{
int32_t i;
- oo_rc(o->sc, o, 3, 0);
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ o->sc->pc++;
+ o1 = o->v[i + 3].o1;
if (!o1->v[0].fb(o1))
{
o->sc->pc = o->v[2].i;
@@ -59679,40 +59588,35 @@ static bool opt_and_any_b(opt_info *o)
static bool opt_or_bb(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 2, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[0].fb(o1))
+ o->sc->pc++;
+ if (o->v[3].fb(o->v[2].o1))
{
o->sc->pc = o->v[1].i;
return(true);
}
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fb(o1));
+ o->sc->pc++;
+ return(o->v[11].fb(o->v[10].o1));
}
static bool opt_or_bb1(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 8, 0);
- if (o->v[7].fb(o))
+ if (o->v[5].fb(o))
{
o->sc->pc = o->v[4].i;
return(true);
}
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o1->v[0].fb(o1));
+ return(o->v[11].fb(o->v[10].o1));
}
static bool opt_or_any_b(opt_info *o)
{
int32_t i;
- oo_rc(o->sc, o, 3, 0);
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ o->sc->pc++;
+ o1 = o->v[i + 3].o1;
if (o1->v[0].fb(o1))
{
o->sc->pc = o->v[2].i;
@@ -59726,52 +59630,58 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i
{
opt_info *opc;
s7_pointer p;
+ int32_t i;
opc = alloc_opo(sc, car_x);
if (len == 3)
{
opt_info *o1;
o1 = sc->opts[sc->pc];
- if ((bool_optimize_nw(sc, cdr(car_x))) &&
- (bool_optimize_nw(sc, cddr(car_x))))
- {
- if ((o1->v[0].fb == opt_b_dd_ss) ||
- (o1->v[0].fb == opt_b_ii_ss) ||
- (o1->v[0].fb == opt_b_ii_ss_lt) || (o1->v[0].fb == opt_b_ii_ss_gt) || (o1->v[0].fb == opt_b_ii_ss_leq) || (o1->v[0].fb == opt_b_ii_ss_geq) ||
- (o1->v[0].fb == opt_b_pp_ss) ||
- (o1->v[0].fb == opt_b_7pp_ss) ||
- (o1->v[0].fb == opt_lt_b_7pp_ss))
- {
- opc->v[4].i = sc->pc - 1;
- opc->v[7].fb = o1->v[0].fb;
- opc->v[0].fb = (is_and) ? opt_and_bb1 : opt_or_bb1;
- opc->v[1].p = o1->v[1].p;
- opc->v[2].p = o1->v[2].p;
-#if OPT_INFO_DEBUGGING
- if (o1->v[0].fb == opt_b_dd_ss) opc->v[3].b_dd_f = o1->v[3].b_dd_f; else
- if (o1->v[0].fb == opt_b_pp_ss) opc->v[3].b_pp_f = o1->v[3].b_pp_f; else
- if ((o1->v[0].fb == opt_b_7pp_ss) || (o1->v[0].fb == opt_lt_b_7pp_ss)) opc->v[3].b_7pp_f = o1->v[3].b_7pp_f; else
- opc->v[3].b_ii_f = o1->v[3].b_ii_f;
-#else
- opc->v[3].p = o1->v[3].p; /* this works only in the union vunion case (it's actually supposed to be b_dd_f etc) */
-#endif
- return(oo_set_type_2(opc, 8, 1, 2, OO_P, OO_P));
+ if (bool_optimize_nw(sc, cdr(car_x)))
+ {
+ opt_info *o2;
+ 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;
+ if ((o1->v[0].fb == opt_b_dd_ss) ||
+ (o1->v[0].fb == opt_b_dd_ss_lt) || (o1->v[0].fb == opt_b_dd_ss_gt) ||
+ (o1->v[0].fb == opt_b_ii_ss) ||
+ (o1->v[0].fb == opt_b_ii_ss_lt) || (o1->v[0].fb == opt_b_ii_ss_gt) || (o1->v[0].fb == opt_b_ii_ss_leq) || (o1->v[0].fb == opt_b_ii_ss_geq) ||
+ (o1->v[0].fb == opt_b_pp_ss) ||
+ (o1->v[0].fb == opt_b_7pp_ss) ||
+ (o1->v[0].fb == opt_lt_b_7pp_ss))
+ {
+ opc->v[4].i = sc->pc - 1;
+ opc->v[5].fb = o1->v[0].fb;
+ opc->v[0].fb = (is_and) ? opt_and_bb1 : opt_or_bb1;
+ opc->v[1].p = o1->v[1].p;
+ opc->v[2].p = o1->v[2].p;
+ opc->v[3].p = o1->v[3].p;
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_P));
+ }
+ opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb;
+ opc->v[1].i = sc->pc - 1;
+ opc->v[2].o1 = o1;
+ opc->v[3].fb = o1->v[0].fb;
+ return(oo_set_type_0(opc));
}
- opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb;
- opc->v[1].i = sc->pc - 1;
- return(oo_set_type_0(opc, 2));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
opc->v[1].i = (len - 1);
- for (p = cdr(car_x); is_pair(p); p = cdr(p))
- if (!bool_optimize_nw(sc, p))
- break;
+ 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))
{
opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b;
opc->v[2].i = sc->pc - 1;
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -59782,8 +59692,8 @@ static bool opt_b_or(s7_scheme *sc, s7_pointer car_x, int32_t len) {return(opt_
/* ---------------------------------------- cell opts ---------------------------------------- */
-static s7_pointer opt_p_c(opt_info *o) {oo_rc(o->sc, o, 2, 0); return(o->v[1].p);}
-static s7_pointer opt_p_s(opt_info *o) {oo_rc(o->sc, o, 2, 0); return(slot_value(o->v[1].p));}
+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)
{
@@ -59794,7 +59704,7 @@ static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer car_x)
opc = alloc_opo(sc, car_x);
opc->v[1].p = car_x;
opc->v[0].fp = opt_p_c;
- return(oo_set_type_0(opc, 2));
+ return(oo_set_type_0(opc));
}
p = opt_simple_symbol(sc, car_x);
if (p)
@@ -59802,7 +59712,7 @@ static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer car_x)
opc = alloc_opo(sc, car_x);
opc->v[1].p = p;
opc->v[0].fp = opt_p_s;
- return(oo_set_type_1(opc, 2, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -59813,8 +59723,8 @@ static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer car_x)
#define cf_call(Sc, Car_x, S_func, Num) \
(((is_optimized(Car_x)) && (is_opt_safe(Car_x))) ? c_callee(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) {oo_rc(o->sc, o, 2, 0); return(o->v[1].p_f(o->sc));}
-static s7_pointer opt_p_cf(opt_info *o) {oo_rc(o->sc, o, 2, 0); return(o->v[1].cf(o->sc, o->sc->nil));}
+static s7_pointer opt_p_f(opt_info *o) {return(o->v[1].p_f(o->sc));}
+static s7_pointer opt_p_call(opt_info *o) {return(o->v[1].call(o->sc, o->sc->nil));}
static bool p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -59824,39 +59734,27 @@ static bool p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car
{
opc->v[1].p_f = func;
opc->v[0].fp = opt_p_f;
- return(oo_set_type_0(opc, 2));
+ return(oo_set_type_0(opc));
}
if ((is_safe_procedure(s_func)) &&
(c_function_required_args(s_func) == 0))
{
- opc->v[1].cf = cf_call(sc, car_x, s_func, 0);
- opc->v[0].fp = opt_p_cf;
- return(oo_set_type_0(opc, 2));
+ opc->v[1].call = cf_call(sc, car_x, s_func, 0);
+ opc->v[0].fp = opt_p_call;
+ return(oo_set_type_0(opc));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- p_p -------- */
-static s7_pointer opt_p_p_c(opt_info *o) {oo_rc(o->sc, o, 3, 0); return(o->v[2].p_p_f(o->sc, o->v[1].p));}
-static s7_pointer opt_p_i_c(opt_info *o) {oo_rc(o->sc, o, 3, 0); return(make_integer(o->sc, o->v[2].i_i_f(o->v[1].i)));}
-static s7_pointer opt_p_7i_c(opt_info *o) {oo_rc(o->sc, o, 3, 0); return(make_integer(o->sc, o->v[2].i_7i_f(o->sc, o->v[1].i)));}
-static s7_pointer opt_p_d_c(opt_info *o) {oo_rc(o->sc, o, 3, 0); return(make_real(o->sc, o->v[2].d_d_f(o->v[1].x)));}
-static s7_pointer opt_p_7d_c(opt_info *o) {oo_rc(o->sc, o, 3, 0); return(make_real(o->sc, o->v[2].d_7d_f(o->sc, o->v[1].x)));}
-static s7_pointer opt_p_p_s(opt_info *o) {oo_rc(o->sc, o, 3, 1); return(o->v[2].p_p_f(o->sc, slot_value(o->v[1].p)));}
-
-static s7_pointer opt_p_p_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 3, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[2].p_p_f(o->sc, o1->v[0].fp(o1)));
-}
-
-static s7_pointer opt_p_p_f1(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[2].p_p_f(o->sc, o->v[3].p_p_f(o->sc, slot_value(o->v[1].p))));
-}
+static s7_pointer opt_p_p_c(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[1].p));}
+static s7_pointer opt_p_i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_i_f(o->v[1].i)));}
+static s7_pointer opt_p_7i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_7i_f(o->sc, o->v[1].i)));}
+static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_d_f(o->v[1].x)));}
+static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_7d_f(o->sc, o->v[1].x)));}
+static s7_pointer opt_p_p_s(opt_info *o) {return(o->v[2].p_p_f(o->sc, slot_value(o->v[1].p)));}
+static s7_pointer opt_p_p_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_p_f(o->sc, 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(o->sc, o->v[3].p_p_f(o->sc, slot_value(o->v[1].p))));}
static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc)
{
@@ -59871,31 +59769,15 @@ static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc)
opc->v[1].p = o1->v[1].p;
opc->v[0].fp = opt_p_p_f1;
backup_pc(sc);
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
}
-static s7_pointer opt_p_cf_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 3, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[2].cf(o->sc, set_plist_1(o->sc, o1->v[0].fp(o1))));
-}
-
-static s7_pointer opt_p_cf_s(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 1);
- return(o->v[2].cf(o->sc, set_plist_1(o->sc, slot_value(o->v[1].p))));
-}
-
-static s7_pointer opt_p_cf_c(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 0);
- return(o->v[2].cf(o->sc, set_plist_1(o->sc, o->v[1].p)));
-}
+static s7_pointer opt_p_call_f(opt_info *o) {o->sc->pc++; return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[5].fp(o->v[4].o1))));}
+static s7_pointer opt_p_call_s(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, slot_value(o->v[1].p))));}
+static s7_pointer opt_p_call_c(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[1].p)));}
static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -59912,14 +59794,14 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
{
opc->v[2].i_i_f = iif;
opc->v[0].fp = opt_p_i_c;
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
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(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
}
if (is_float(cadr(car_x)))
@@ -59932,19 +59814,20 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
{
opc->v[2].d_d_f = ddf;
opc->v[0].fp = opt_p_d_c;
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
d7df = s7_d_7d_function(s_func);
if (d7df)
{
opc->v[2].d_7d_f = d7df;
opc->v[0].fp = opt_p_7d_c;
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
}
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) &&
(is_optimized(car_x)) &&
@@ -59957,20 +59840,23 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
if (!opc->v[1].p)
return(return_false(sc, car_x, __func__, __LINE__));
opc->v[0].fp = opt_p_p_s;
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
if (!is_pair(cadr(car_x)))
{
opc->v[1].p = cadr(car_x);
opc->v[0].fp = opt_p_p_c;
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
+ 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;
- return(oo_set_type_0(opc, 3));
+ opc->v[3].o1 = o1;
+ opc->v[4].fp = o1->v[0].fp;
+ return(oo_set_type_0(opc));
}
oo_check(sc, opc);
return(true);
@@ -59982,47 +59868,40 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
(c_function_all_args(s_func) >= 1))
{
s7_pointer slot;
- opc->v[2].cf = cf_call(sc, car_x, s_func, 1);
+ 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_cf_s;
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ opc->v[0].fp = opt_p_call_s;
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
else
{
+ opt_info *o1;
if (!is_pair(cadr(car_x)))
{
opc->v[1].p = cadr(car_x);
- opc->v[0].fp = opt_p_cf_c;
- return(oo_set_type_0(opc, 3));
+ opc->v[0].fp = opt_p_call_c;
+ return(oo_set_type_0(opc));
}
+ o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x)))
{
- opc->v[0].fp = opt_p_cf_f;
- return(oo_set_type_0(opc, 3));
+ opc->v[0].fp = opt_p_call_f;
+ opc->v[4].o1 = o1;
+ opc->v[5].fp = o1->v[0].fp;
+ return(oo_set_type_0(opc));
}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- p_i -------- */
-static s7_pointer opt_p_i_s(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 1);
- return(o->v[2].p_i_f(o->sc, integer(slot_value(o->v[1].p))));
-}
-
-static s7_pointer opt_p_i_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 3, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[2].p_i_f(o->sc, o1->v[0].fi(o1)));
-}
+static s7_pointer opt_p_i_s(opt_info *o) {return(o->v[2].p_i_f(o->sc, integer(slot_value(o->v[1].p))));}
+static s7_pointer opt_p_i_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_i_f(o->sc, 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)
{
@@ -60037,13 +59916,15 @@ static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
opc->v[1].p = p;
opc->v[2].p_i_f = ifunc;
opc->v[0].fp = opt_p_i_s;
- return(oo_set_type_1(opc, 3, 1, OO_I));
+ return(oo_set_type_1(opc, 1, OO_I));
}
if (int_optimize(sc, cdr(car_x)))
{
opc->v[2].p_i_f = ifunc;
opc->v[0].fp = opt_p_i_f;
- return(oo_set_type_0(opc, 3));
+ opc->v[3].o1 = sc->opts[pstart];
+ opc->v[4].fi = sc->opts[pstart]->v[0].fi;
+ return(oo_set_type_0(opc));
}
}
pc_fallback(sc, pstart);
@@ -60051,29 +59932,16 @@ static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
}
/* -------- p_ii -------- */
-static s7_pointer opt_p_ii_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].p_ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));
-}
-
-static s7_pointer opt_p_ii_fs(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_ii_f(o->sc, o1->v[0].fi(o1), integer(slot_value(o->v[2].p))));
-}
+static s7_pointer opt_p_ii_ss(opt_info *o) {return(o->v[3].p_ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_ii_fs(opt_info *o) {o->sc->pc++; return(o->v[3].p_ii_f(o->sc, o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));}
static s7_pointer opt_p_ii_ff(opt_info *o)
{
- opt_info *o1;
s7_int i1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_ii_f(o->sc, i1, o1->v[0].fi(o1)));
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ return(o->v[3].p_ii_f(o->sc, 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)
@@ -60094,24 +59962,32 @@ static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[2].p = p2;
opc->v[3].p_ii_f = ifunc;
opc->v[0].fp = opt_p_ii_ss;
- return(oo_set_type_2(opc, 4, 1, 2, OO_I, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_I, OO_I));
}
+ 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(oo_set_type_1(opc, 4, 2, OO_I));
+ return(oo_set_type_1(opc, 2, OO_I));
}
pc_fallback(sc, pstart);
return(return_false(sc, car_x, __func__, __LINE__));
}
- if ((int_optimize(sc, cdr(car_x))) &&
- (int_optimize(sc, cddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cdr(car_x)))
{
- opc->v[3].p_ii_f = ifunc;
- opc->v[0].fp = opt_p_ii_ff;
- return(oo_set_type_0(opc, 4));
+ 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 = opt_p_ii_ff;
+ return(oo_set_type_0(opc));
+ }
}
}
pc_fallback(sc, pstart);
@@ -60119,19 +59995,8 @@ static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- p_d -------- */
-static s7_pointer opt_p_d_s(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 1);
- return(o->v[2].p_d_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), "p_d")));
-}
-
-static s7_pointer opt_p_d_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 3, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[2].p_d_f(o->sc, o1->v[0].fd(o1)));
-}
+static s7_pointer opt_p_d_s(opt_info *o) {return(o->v[2].p_d_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), "p_d")));}
+static s7_pointer opt_p_d_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_d_f(o->sc, 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)
{
@@ -60140,21 +60005,25 @@ static bool p_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
if (ifunc)
{
s7_pointer p;
+ opt_info *o1;
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(oo_set_type_1(opc, 3, 1, OO_R));
+ return(oo_set_type_1(opc, 1, OO_R));
}
if ((is_number(cadr(car_x))) && (!is_float(cadr(car_x))))
return(return_false(sc, car_x, __func__, __LINE__));
+ 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;
- return(oo_set_type_0(opc, 3));
+ opc->v[3].o1 = o1;
+ opc->v[4].fd = o1->v[0].fd;
+ return(oo_set_type_0(opc));
}
}
pc_fallback(sc, pstart);
@@ -60162,17 +60031,8 @@ static bool p_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
}
/* -------- p_dd -------- */
-static s7_pointer opt_p_dd_sc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].p_dd_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), "p_dd"), o->v[2].x));
-}
-
-static s7_pointer opt_p_dd_cs(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].p_dd_f(o->sc, o->v[2].x, real_to_double(o->sc, slot_value(o->v[1].p), "p_dd")));
-}
+static s7_pointer opt_p_dd_sc(opt_info *o) {return(o->v[3].p_dd_f(o->sc, real_to_double(o->sc, 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(o->sc, o->v[2].x, real_to_double(o->sc, slot_value(o->v[1].p), "p_dd")));}
static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
{
@@ -60192,7 +60052,7 @@ static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[1].p = slot;
opc->v[3].p_dd_f = ifunc;
opc->v[0].fp = opt_p_dd_sc;
- return(oo_set_type_1(opc, 4, 1, OO_R));
+ return(oo_set_type_1(opc, 1, OO_R));
}
}
if (is_float(arg1))
@@ -60204,7 +60064,7 @@ static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[1].p = slot;
opc->v[3].p_dd_f = ifunc;
opc->v[0].fp = opt_p_dd_cs;
- return(oo_set_type_1(opc, 4, 1, OO_R));
+ return(oo_set_type_1(opc, 1, OO_R));
}
}
}
@@ -60213,33 +60073,10 @@ static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- p_pi -------- */
-static s7_pointer opt_p_pi_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));
-}
-
-static s7_pointer opt_p_pi_sc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));
-}
-
-static s7_pointer opt_p_pi_sf(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o1->v[0].fi(o1)));
-}
-
-static s7_pointer opt_p_pi_fc(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_pi_f(o->sc, o1->v[0].fp(o1), o->v[2].i));
-}
+static s7_pointer opt_p_pi_ss(opt_info *o) {return(o->v[3].p_pi_f(o->sc, 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(o->sc, slot_value(o->v[1].p), o->v[2].i));}
+static s7_pointer opt_p_pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+static s7_pointer opt_p_pi_fc(opt_info *o) {o->sc->pc++; return(o->v[3].p_pi_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].i));}
static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sig, s7_pointer car_x)
{
@@ -60248,6 +60085,7 @@ static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (func)
{
s7_pointer obj = NULL, slot1, checker = NULL;
+ opt_info *o1;
/* here we know cadr is a symbol */
slot1 = opt_simple_symbol(sc, cadr(car_x));
@@ -60290,50 +60128,49 @@ static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
case T_VECTOR:
if (denominator(slot_value(slot1)) <= vector_length(obj))
opc->v[3].p_pi_f = vector_ref_unchecked;
- return(oo_set_type_2(opc, 4, 1, 2, OO_PV, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_PV, OO_I));
case T_INT_VECTOR:
if (denominator(slot_value(slot1)) <= vector_length(obj))
opc->v[3].p_pi_f = int_vector_ref_unchecked_p;
- return(oo_set_type_2(opc, 4, 1, 2, OO_IV, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_IV, OO_I));
case T_FLOAT_VECTOR:
if (denominator(slot_value(slot1)) <= vector_length(obj))
opc->v[3].p_pi_f = float_vector_ref_unchecked_p;
- return(oo_set_type_2(opc, 4, 1, 2, OO_FV, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_FV, OO_I));
case T_STRING:
if (denominator(slot_value(slot1)) <= string_length(obj))
opc->v[3].p_pi_f = string_ref_unchecked;
- return(oo_set_type_2(opc, 4, 1, 2, OO_S, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_S, OO_I));
case T_BYTE_VECTOR:
if (denominator(slot_value(slot1)) <= string_length(obj))
opc->v[3].p_pi_f = byte_vector_ref_unchecked_p;
- return(oo_set_type_2(opc, 4, 1, 2, OO_BV, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_BV, OO_I));
}
- return(oo_set_type_2(opc, 4, 1, 2, OO_P, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_I));
}
if (is_t_integer(caddr(car_x)))
{
opc->v[2].i = integer(caddr(car_x));
opc->v[0].fp = opt_p_pi_sc;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
+ o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x)))
{
opc->v[0].fp = opt_p_pi_sf;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[4].o1 = o1;
+ opc->v[5].fi = o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
return(return_false(sc, car_x, __func__, __LINE__));
}
-static s7_pointer opt_p_pi_fco(opt_info *o)
-{
- oo_rc(o->sc, o, 5, 1);
- return(o->v[3].p_pi_f(o->sc, o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)), o->v[2].i));
-}
+static s7_pointer opt_p_pi_fco(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)), o->v[2].i));}
static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc)
{
@@ -60348,70 +60185,28 @@ static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc)
opc->v[1].p = o1->v[1].p;
opc->v[0].fp = opt_p_pi_fco;
backup_pc(sc);
- return(oo_set_type_1(opc, 5, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
}
/* -------- p_pp -------- */
-static s7_pointer opt_p_pp_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));
-}
-
-static s7_pointer opt_p_pp_sc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));
-}
-
-static s7_pointer opt_p_pp_cs(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].p_pp_f(o->sc, o->v[2].p, slot_value(o->v[1].p)));
-}
-
-static s7_pointer opt_p_pp_sf(opt_info *o)
-{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o1->v[0].fp(o1)));
-}
-
-static s7_pointer opt_p_pp_fs(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_pp_f(o->sc, o1->v[0].fp(o1), slot_value(o->v[1].p)));
-}
-
-static s7_pointer opt_p_pp_fc(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_pp_f(o->sc, o1->v[0].fp(o1), o->v[2].p));
-}
-
-static s7_pointer opt_p_pp_cc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 0);
- return(o->v[3].p_pp_f(o->sc, o->v[1].p, o->v[2].p));
-}
+static s7_pointer opt_p_pp_ss(opt_info *o) {return(o->v[3].p_pp_f(o->sc, 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(o->sc, 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(o->sc, o->v[2].p, slot_value(o->v[1].p)));}
+static s7_pointer opt_p_pp_sf(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_fs(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));}
+static s7_pointer opt_p_pp_fc(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, 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(o->sc, o->v[1].p, o->v[2].p));}
static s7_pointer opt_p_pp_ff(opt_info *o)
{
- opt_info *o1;
s7_pointer p1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- p1 = o1->v[0].fp(o1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_pp_f(o->sc, p1, o1->v[0].fp(o1)));
+ o->sc->pc++;
+ p1 = o->v[11].fp(o->v[10].o1);
+ o->sc->pc++;
+ return(o->v[3].p_pp_f(o->sc, 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)
@@ -60459,7 +60254,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (opc->v[2].p)
{
opc->v[0].fp = opt_p_pp_ss;
- return(oo_set_type_2(opc, 4, 1, 2, OO_P, OO_P));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_P));
}
pc_fallback(sc, pstart);
return(return_false(sc, car_x, __func__, __LINE__));
@@ -60469,16 +60264,20 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x));
opc->v[0].fp = opt_p_pp_sc;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
if (cell_optimize(sc, cddr(car_x)))
{
opc->v[0].fp = opt_p_pp_sf;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[4].o1 = sc->opts[pstart];
+ opc->v[5].fp = sc->opts[pstart]->v[0].fp;
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
else
{
+ opt_info *o1;
+ o1 = sc->opts[sc->pc];
if ((!is_pair(cadr(car_x))) ||
(is_proper_quote(sc, cadr(car_x))))
{
@@ -60489,7 +60288,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x));
opc->v[0].fp = opt_p_pp_cc;
- return(oo_set_type_0(opc, 4));
+ return(oo_set_type_0(opc));
}
if (is_symbol(caddr(car_x)))
{
@@ -60498,7 +60297,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (opc->v[1].p)
{
opc->v[0].fp = opt_p_pp_cs;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
pc_fallback(sc, pstart);
return(return_false(sc, car_x, __func__, __LINE__));
@@ -60512,7 +60311,9 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (opc->v[1].p)
{
opc->v[0].fp = opt_p_pp_fs;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[4].o1 = o1;
+ opc->v[5].fp = o1->v[0].fp;
+ return(oo_set_type_1(opc, 1, OO_P));
}
pc_fallback(sc, pstart);
return(return_false(sc, car_x, __func__, __LINE__));
@@ -60531,7 +60332,9 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (!p_pi_fc_combinable(sc, opc))
{
opc->v[0].fp = opt_p_pi_fc;
- return(oo_set_type_0(opc, 4));
+ opc->v[4].o1 = o1;
+ opc->v[5].fp = o1->v[0].fp;
+ return(oo_set_type_0(opc));
}
oo_check(sc, opc);
return(true);
@@ -60539,12 +60342,18 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x));
opc->v[0].fp = opt_p_pp_fc;
- return(oo_set_type_0(opc, 4));
+ opc->v[4].o1 = o1;
+ opc->v[5].fp = o1->v[0].fp;
+ return(oo_set_type_0(opc));
}
+ 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(oo_set_type_0(opc, 4));
+ return(oo_set_type_0(opc));
}
}
}
@@ -60553,60 +60362,44 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
return(return_false(sc, car_x, __func__, __LINE__));
}
-/* -------- p_cf_pp -------- */
-static s7_pointer opt_p_cf_ff(opt_info *o)
+/* -------- p_call_pp -------- */
+static s7_pointer opt_p_call_ff(opt_info *o)
{
- opt_info *o1;
s7_pointer po2;
s7_scheme *sc;
-
sc = o->sc;
#if S7_DEBUGGING
if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
- oo_rc(sc, o, 4, 0);
- o1 = sc->opts[++sc->pc];
- gc_protect_direct(sc, o1->v[0].fp(o1));
- o1 = sc->opts[++sc->pc];
- po2 = o1->v[0].fp(o1);
- po2 = o->v[3].cf(sc, set_plist_2(sc, sc->stack_end[-2], po2));
+ sc->pc++;
+ gc_protect_direct(sc, o->v[11].fp(o->v[10].o1));
+ sc->pc++;
+ po2 = o->v[9].fp(o->v[8].o1);
+ po2 = o->v[3].call(sc, set_plist_2(sc, sc->stack_end[-2], po2));
sc->stack_end -= 4;
return(po2);
}
-static s7_pointer opt_p_cf_fs(opt_info *o)
+static s7_pointer opt_p_call_fs(opt_info *o)
{
- opt_info *o1;
s7_pointer po1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- po1 = o1->v[0].fp(o1);
- return(o->v[3].cf(o->sc, set_plist_2(o->sc, po1, slot_value(o->v[1].p))));
+ o->sc->pc++;
+ po1 = o->v[11].fp(o->v[10].o1);
+ return(o->v[3].call(o->sc, set_plist_2(o->sc, po1, slot_value(o->v[1].p))));
}
-static s7_pointer opt_p_cf_sf(opt_info *o)
+static s7_pointer opt_p_call_sf(opt_info *o)
{
- opt_info *o1;
s7_pointer po1;
- o1 = o->sc->opts[++o->sc->pc];
- po1 = o1->v[0].fp(o1);
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].cf(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), po1)));
+ o->sc->pc++;
+ po1 = o->v[11].fp(o->v[10].o1);
+ return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), po1)));
}
-static s7_pointer opt_p_cf_sc(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 1);
- return(o->v[3].cf(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), o->v[2].p)));
-}
+static s7_pointer opt_p_call_sc(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, 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(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p))));}
-static s7_pointer opt_p_cf_ss(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].cf(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p))));
-}
-
-static bool p_cf_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
+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) &&
@@ -60615,7 +60408,7 @@ static bool p_cf_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point
/* if optimized, we want to use the current c_call (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].cf = cf_call(sc, car_x, s_func, 2);
+ opc->v[3].call = cf_call(sc, car_x, s_func, 2);
if (is_symbol(cadr(car_x)))
{
opc->v[1].p = symbol_to_slot(sc, cadr(car_x));
@@ -60627,8 +60420,8 @@ static bool p_cf_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point
opc->v[2].p = opt_simple_symbol(sc, caddr(car_x));
if (opc->v[2].p)
{
- opc->v[0].fp = opt_p_cf_ss;
- return(oo_set_type_2(opc, 4, 1, 2, OO_P, OO_P));
+ opc->v[0].fp = opt_p_call_ss;
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_P));
}
pc_fallback(sc, pstart);
return(return_false(sc, car_x, __func__, __LINE__));
@@ -60636,13 +60429,15 @@ static bool p_cf_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point
if (!is_pair(caddr(car_x)))
{
opc->v[2].p = caddr(car_x);
- opc->v[0].fp = opt_p_cf_sc;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[0].fp = opt_p_call_sc;
+ return(oo_set_type_1(opc, 1, OO_P));
}
if (cell_optimize(sc, cddr(car_x)))
{
- opc->v[0].fp = opt_p_cf_sf;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ 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(oo_set_type_1(opc, 1, OO_P));
}
}
else
@@ -60651,23 +60446,27 @@ static bool p_cf_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point
return(return_false(sc, car_x, __func__, __LINE__));
}
}
+ 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_cf_fs;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[0].fp = opt_p_call_fs;
+ return(oo_set_type_1(opc, 1, OO_P));
}
pc_fallback(sc, pstart);
return(return_false(sc, car_x, __func__, __LINE__));
}
+ opc->v[8].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x)))
{
- opc->v[0].fp = opt_p_cf_ff;
- return(oo_set_type_0(opc, 4));
+ opc->v[9].fp = opc->v[8].o1->v[0].fp;
+ opc->v[0].fp = opt_p_call_ff;
+ return(oo_set_type_0(opc));
}
}
}
@@ -60680,44 +60479,36 @@ static bool p_cf_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point
static s7_pointer opt_p_pip_ssf(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 2);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fp(o1)));
+ o->sc->pc++;
+ return(o->v[3].p_pip_f(o->sc, 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)
{
- oo_rc(o->sc, o, 5, 3);
return(o->v[4].p_pip_f(o->sc, 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)
{
- oo_rc(o->sc, o, 5, 2);
return(o->v[3].p_pip_f(o->sc, 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)
{
- oo_rc(o->sc, o, 6, 2);
return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].p_p_f(o->sc, o->v[4].p)));
}
static s7_pointer opt_p_pip_sff(opt_info *o)
{
- opt_info *o1, *o2;
s7_int i1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o2 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), i1, o2->v[0].fp(o2)));
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ return(o->v[3].p_pip_f(o->sc, 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)
{
- oo_rc(o->sc, o, 7, 4);
return(o->v[5].p_pip_f(o->sc, slot_value(o->v[1].p),
integer(slot_value(o->v[2].p)),
o->v[6].p_pi_f(o->sc, slot_value(o->v[3].p),
@@ -60726,10 +60517,8 @@ static s7_pointer opt_p_pip_sso(opt_info *o)
static s7_pointer opt_p_pip_ssf1(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 5, 2);
- o1 = o->sc->opts[o->sc->pc += 2];
- return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p_p_f(o->sc, o1->v[0].fp(o1))));
+ o->sc->pc += 2;
+ return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p_p_f(o->sc, o->v[6].fp(o->v[5].o1))));
}
static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
@@ -60741,16 +60530,22 @@ static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
o1 = sc->opts[sc->pc - 1];
if (o1->v[0].fp == opt_p_pi_ss) /* ref for set! as in (set! (var ind) ...) for example */
{
+#if S7_DEBUGGING
opt_type_t ref_type, set_type;
ref_type = o1->types[0];
set_type = opc->types[0];
+#endif
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(oo_set_type_4(opc, 7, 1, 2, 3, 4, set_type, OO_I, ref_type, OO_I));
+#if S7_DEBUGGING
+ return(oo_set_type_4(opc, 1, 2, 3, 4, set_type, OO_I, ref_type, OO_I));
+#else
+ return(true);
+#endif
}
if (o1->v[0].fp == opt_p_p_c)
{
@@ -60758,7 +60553,7 @@ static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
opc->v[4].p = o1->v[1].p;
backup_pc(sc);
opc->v[0].fp = opt_p_pip_c;
- return(oo_set_type_2(opc, 6, 1, 2, OO_P, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_I));
}
}
@@ -60766,8 +60561,10 @@ static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
if (o1->v[0].fp == opt_p_p_f)
{
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(oo_set_type_2(opc, 5, 1, 2, OO_P, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_I));
}
return(return_false(sc, NULL, __func__, __LINE__));
}
@@ -60889,7 +60686,7 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
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(oo_set_type_3(opc, 5, 1, 2, 3, op2, OO_I, OO_P));
+ return(oo_set_type_3(opc, 1, 2, 3, op2, OO_I, OO_P));
}
}
else
@@ -60901,7 +60698,7 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[4].p = cadddr(car_x);
else opc->v[4].p = cadr(cadddr(car_x));
opc->v[0].fp = opt_p_pip_ssc;
- return(oo_set_type_2(opc, 5, 1, 2, op2, OO_I));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_I));
}
}
if (cell_optimize(sc, cdddr(car_x)))
@@ -60909,19 +60706,25 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (p_pip_ssf_combinable(sc, opc, start))
return(true);
opc->v[0].fp = opt_p_pip_ssf;
- return(oo_set_type_2(opc, 4, 1, 2, op2, OO_I));
+ opc->v[4].o1 = sc->opts[start];
+ opc->v[5].fp = sc->opts[start]->v[0].fp;
+ return(oo_set_type_2(opc, 1, 2, op2, OO_I));
}
}
}
else /* not symbol caddr */
{
- if ((int_optimize(sc, cddr(car_x))) &&
- (cell_optimize(sc, cdddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cddr(car_x)))
{
- opc->v[0].fp = opt_p_pip_sff;
- if ((obj) && (is_normal_vector(obj)))
- return(oo_set_type_1(opc, 4, 1, op2));
- return(oo_set_type_1(opc, 4, 1, op2));
+ opc->v[8].o1 = sc->opts[sc->pc];
+ if (cell_optimize(sc, cdddr(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(oo_set_type_1(opc, 1, op2));
+ }
}
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -60930,29 +60733,69 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- p_piip -------- */
static s7_pointer opt_p_piip_sssf(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 3);
- return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o1->v[0].fp(o1)));
+ o->sc->pc++;
+ return(o->v[5].p_piip_f(o->sc, 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 opt_p_piip_sssc(opt_info *o)
{
- oo_rc(o->sc, o, 6, 3);
return(o->v[5].p_piip_f(o->sc, 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)
{
- opt_info *o1;
s7_int i1, i2;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- i2 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 6, 1);
- return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), i1, i2, o1->v[0].fp(o1)));
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
+ o->sc->pc++;
+ return(o->v[5].p_piip_f(o->sc, 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)
+ {
+ 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))
+ {
+ opc->v[11].fp = opc->v[10].o1->v[0].fp;
+ opc->v[0].fp = opt_p_piip_sssf;
+ return(oo_set_type_3(opc, 1, 2, 3, (is_typed_vector(obj)) ? OO_TV : OO_PV, OO_I, OO_I));
+ }
+ return(return_false(sc, car_x, __func__, __LINE__));
+ }
+ opc->v[0].fp = opt_p_piip_sssc;
+ opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp);
+ return(oo_set_type_3(opc, 1, 2, 3, (is_typed_vector(obj)) ? OO_TV : OO_PV, OO_I, OO_I));
+ }
+ 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(oo_set_type_1(opc, 1, (is_typed_vector(obj)) ? OO_TV : OO_PV));
+ }}}}
+ return(return_false(sc, car_x, __func__, __LINE__));
}
static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
@@ -60973,61 +60816,27 @@ static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe
if ((is_any_vector(obj)) && /* vector_set_p_piip calls vector_setter(obj) */
(vector_rank(obj) == 2))
{
- s7_pointer indexp1, indexp2, valp, slot;
- indexp1 = cddr(car_x);
- indexp2 = cdddr(car_x);
- valp = cddddr(car_x);
opc->v[1].p = slot1;
opc->v[5].p_piip_f = vector_set_p_piip;
- 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_symbol(car(valp))) ||
- (is_unquoted_pair(car(valp))))
- {
- if (cell_optimize(sc, valp))
- {
- opc->v[0].fp = opt_p_piip_sssf;
- return(oo_set_type_3(opc, 6, 1, 2, 3, OO_P, OO_I, OO_I));
- }
- return(return_false(sc, car_x, __func__, __LINE__));
- }
- opc->v[0].fp = opt_p_piip_sssc;
- opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp);
- return(oo_set_type_3(opc, 6, 1, 2, 3, OO_P, OO_I, OO_I));
- }
- }
- if ((int_optimize(sc, indexp1)) &&
- (int_optimize(sc, indexp2)) &&
- (cell_optimize(sc, valp)))
- {
- opc->v[0].fp = opt_p_piip_sfff;
- return(oo_set_type_1(opc, 6, 1, (is_typed_vector(obj)) ? OO_TV : OO_PV));
- }}}
+ return(p_piip_to_sx(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x), obj));
+ }
+ }
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- p_pii -------- */
static s7_pointer opt_p_pii_sss(opt_info *o)
{
- oo_rc(o->sc, o, 5, 3);
return(o->v[4].p_pii_f(o->sc, 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)
{
- opt_info *o1;
s7_int i1, i2;
- o1 = o->sc->opts[++o->sc->pc];
- i1 = o1->v[0].fi(o1);
- o1 = o->sc->opts[++o->sc->pc];
- i2 = o1->v[0].fi(o1);
- oo_rc(o->sc, o, 5, 1);
+ o->sc->pc++;
+ i1 = o->v[11].fi(o->v[10].o1);
+ o->sc->pc++;
+ i2 = o->v[9].fi(o->v[8].o1);
return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), i1, i2));
}
@@ -61062,25 +60871,28 @@ static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].p = slot;
opc->v[0].fp = opt_p_pii_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_P, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_P, OO_I, OO_I));
}
}
- if ((int_optimize(sc, indexp1)) &&
- (int_optimize(sc, indexp2)))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, indexp1))
{
- opc->v[0].fp = opt_p_pii_sff;
- return(oo_set_type_1(opc, 5, 1, OO_PV));
- }}}
+ 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(oo_set_type_1(opc, 1, OO_PV));
+ }}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- p_ppi -------- */
static s7_pointer opt_p_ppi_psf(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_ppi_f(o->sc, o->v[2].p, slot_value(o->v[1].p), o1->v[0].fi(o1)));
+ o->sc->pc++;
+ return(o->v[3].p_ppi_f(o->sc, 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)
@@ -61103,7 +60915,9 @@ static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[2].p = cadr(car_x);
opc->v[1].p = slot;
opc->v[0].fp = opt_p_ppi_psf;
- return(oo_set_type_1(opc, 4, 1, OO_P));
+ opc->v[4].o1 = sc->opts[start];
+ opc->v[5].fi = sc->opts[start]->v[0].fi;
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
pc_fallback(sc, start);
@@ -61112,67 +60926,36 @@ static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- p_ppp -------- */
-static s7_pointer opt_p_ppp_ssf(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 2);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o1->v[0].fp(o1)));
-}
-
-static s7_pointer opt_p_ppp_sfs(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 2);
- o1 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o1->v[0].fp(o1), slot_value(o->v[2].p)));
-}
-
-static s7_pointer opt_p_ppp_scs(opt_info *o)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));
-}
+static s7_pointer opt_p_ppp_ssf(opt_info *o) {o->sc->pc++; return(o->v[3].p_ppp_f(o->sc, 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_increment(opt_info *o) {o->sc->pc = o->v[4].i; return(fx_hash_increment_1(o->sc, 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) {o->sc->pc++; return(o->v[3].p_ppp_f(o->sc, 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(o->sc, 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(o->sc, 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(o->sc, 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)
{
- opt_info *o1, *o2;
s7_pointer po1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[++o->sc->pc];
- po1 = o1->v[0].fp(o1);
- o2 = o->sc->opts[++o->sc->pc];
- return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), po1, o2->v[0].fp(o2)));
-}
-
-static s7_pointer opt_p_ppp_sss(opt_info *o)
-{
- oo_rc(o->sc, o, 5, 3);
- return(o->v[4].p_ppp_f(o->sc, 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)
-{
- oo_rc(o->sc, o, 4, 2);
- return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[4].p));
+ o->sc->pc++;
+ po1 = o->v[11].fp(o->v[10].o1);
+ o->sc->pc++;
+ return(o->v[3].p_ppp_f(o->sc, 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)
{
- opt_info *o1;
s7_pointer res;
s7_scheme *sc;
sc = o->sc;
#if S7_DEBUGGING
if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
- oo_rc(sc, o, 4, 0);
- o1 = sc->opts[++sc->pc];
- gc_protect_direct(sc, T_Pos(o1->v[0].fp(o1)));
- o1 = sc->opts[++sc->pc];
- sc->stack_end[-4] = T_Pos(o1->v[0].fp(o1));
- o1 = sc->opts[++sc->pc];
- res = o->v[3].p_ppp_f(sc, sc->stack_end[-2], sc->stack_end[-4], o1->v[0].fp(o1));
+ sc->pc++;
+ gc_protect_direct(sc, T_Pos(o->v[11].fp(o->v[10].o1)));
+ sc->pc++;
+ sc->stack_end[-4] = T_Pos(o->v[9].fp(o->v[8].o1));
+ sc->pc++;
+ res = o->v[3].p_ppp_f(sc, sc->stack_end[-2], sc->stack_end[-4], o->v[5].fp(o->v[4].o1));
sc->stack_end -= 4;
return(res);
}
@@ -61202,6 +60985,8 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (is_symbol(arg1)) /* dealt with at the top -> p1 */
{
s7_pointer slot, obj;
+ opt_info *o1;
+
slot = symbol_to_slot(sc, arg1);
if ((!is_slot(slot)) ||
(has_methods(slot_value(slot))))
@@ -61249,7 +61034,7 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[4].p_ppp_f = opc->v[3].p_ppp_f;
opc->v[3].p = slot;
opc->v[0].fp = opt_p_ppp_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, op2, OO_P, OO_P));
+ return(oo_set_type_3(opc, 1, 2, 3, op2, OO_P, OO_P));
}
}
else
@@ -61262,13 +61047,22 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[4].p = arg3;
else opc->v[4].p = cadr(arg3);
opc->v[0].fp = opt_p_ppp_ssc;
- return(oo_set_type_2(opc, 5, 1, 2, op2, OO_P));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
}
+ if (optimize_op(car_x) == OP_HASH_INCREMENT)
+ {
+ opc->v[0].fp = opt_p_ppp_hash_increment;
+ opc->v[4].i = sc->pc - 1;
+ opc->v[5].p = car_x;
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
+ }
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(oo_set_type_2(opc, 4, 1, 2, op2, OO_P));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
pc_fallback(sc, start);
}
@@ -61289,11 +61083,14 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
opc->v[3].p_ppp_f = let_set_1;
else return(return_false(sc, car_x, __func__, __LINE__));
}
- return(oo_set_type_2(opc, 5, 1, 2, op2, OO_P));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
}
+ o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x)))
{
+ opt_info *o2;
+ o2 = sc->opts[sc->pc];
if (is_symbol(arg3))
{
s7_pointer val_slot;
@@ -61302,68 +61099,76 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
{
opc->v[2].p = val_slot;
opc->v[0].fp = opt_p_ppp_sfs;
- return(oo_set_type_2(opc, 4, 1, 2, op2, OO_P));
+ opc->v[4].o1 = o1;
+ opc->v[5].fp = o1->v[0].fp;
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
}
if (cell_optimize(sc, cdddr(car_x)))
{
opc->v[0].fp = opt_p_ppp_sff;
- return(oo_set_type_1(opc, 4, 1, op2));
+ 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(oo_set_type_1(opc, 1, op2));
}
}
}
else
{
- if ((cell_optimize(sc, cdr(car_x))) &&
- (cell_optimize(sc, cddr(car_x))) &&
- (cell_optimize(sc, cdddr(car_x))))
+ opc->v[10].o1 = sc->opts[start];
+ if (cell_optimize(sc, cdr(car_x)))
{
- opc->v[0].fp = opt_p_ppp_fff;
- return(oo_set_type_0(opc, 4));
- }
- }
+ 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(oo_set_type_0(opc));
+ }}}}
pc_fallback(sc, start);
}
return(return_false(sc, car_x, __func__, __LINE__));
}
-/* -------- p_cf_ppp -------- */
-static s7_pointer opt_p_cf_sss(opt_info *o)
+/* -------- p_call_ppp -------- */
+static s7_pointer opt_p_call_sss(opt_info *o)
{
- oo_rc(o->sc, o, 5, 3);
- return(o->v[4].cf(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p))));
+ return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p))));
}
-static s7_pointer opt_p_cf_ssf(opt_info *o)
+static s7_pointer opt_p_call_ssf(opt_info *o)
{
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- oo_rc(o->sc, o, 5, 2);
- return(o->v[4].cf(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o1->v[0].fp(o1))));
+ o->sc->pc++;
+ return(o->v[4].call(o->sc, set_plist_3(o->sc, 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_cf_ppp(opt_info *o)
+static s7_pointer opt_p_call_ppp(opt_info *o)
{
- opt_info *o1;
- s7_pointer po3;
+ s7_pointer res;
s7_scheme *sc;
sc = o->sc;
+ sc->pc++;
#if S7_DEBUGGING
if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
- o1 = sc->opts[++sc->pc];
- oo_rc(sc, o, 3, 0);
- gc_protect_direct(sc, o1->v[0].fp(o1));
- o1 = sc->opts[++sc->pc];
- sc->stack_end[-4] = o1->v[0].fp(o1);
- o1 = sc->opts[++sc->pc];
- po3 = o1->v[0].fp(o1);
- po3 = o->v[2].cf(sc, set_plist_3(sc, sc->stack_end[-2], sc->stack_end[-4], po3));
+ gc_protect_direct(sc, o->v[4].fp(o->v[3].o1));
+ sc->pc++;
+ sc->stack_end[-4] = o->v[6].fp(o->v[5].o1);
+ sc->pc++;
+ res = o->v[11].fp(o->v[10].o1); /* not combinable into next */
+ res = o->v[2].call(sc, set_plist_3(sc, sc->stack_end[-2], sc->stack_end[-4], res));
sc->stack_end -= 4;
- return(po3);
+ return(res);
}
-static bool p_cf_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
int32_t start;
start = sc->pc;
@@ -61373,6 +61178,8 @@ static bool p_cf_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin
(c_function_all_args(s_func) >= 3))
{
s7_pointer slot, arg;
+ opt_info *o1;
+ o1 = sc->opts[sc->pc];
arg = cadr(car_x);
if (is_symbol(arg))
{
@@ -61394,26 +61201,42 @@ static bool p_cf_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin
if (slot)
{
opc->v[3].p = slot;
- opc->v[4].cf = cf_call(sc, car_x, s_func, 3);
- opc->v[0].fp = opt_p_cf_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_P, OO_P, OO_P));
+ opc->v[4].call = cf_call(sc, car_x, s_func, 3);
+ opc->v[0].fp = opt_p_call_sss;
+ return(oo_set_type_3(opc, 1, 2, 3, OO_P, OO_P, OO_P));
}
}
else
{
if (cell_optimize(sc, cdddr(car_x)))
{
- opc->v[4].cf = cf_call(sc, car_x, s_func, 3);
- opc->v[0].fp = opt_p_cf_ssf;
- return(oo_set_type_2(opc, 5, 1, 2, OO_P, OO_P));
+ opc->v[4].call = cf_call(sc, car_x, s_func, 3);
+ opc->v[0].fp = opt_p_call_ssf;
+ opc->v[5].o1 = o1;
+ opc->v[6].fp = o1->v[0].fp;
+ return(oo_set_type_2(opc, 1, 2, OO_P, OO_P));
}}}}}}
- if ((cell_optimize(sc, cdr(car_x))) &&
- (cell_optimize(sc, cddr(car_x))) &&
- (cell_optimize(sc, cdddr(car_x))))
+ if (cell_optimize(sc, cdr(car_x)))
{
- opc->v[2].cf = cf_call(sc, car_x, s_func, 3);
- opc->v[0].fp = opt_p_cf_ppp;
- return(oo_set_type_0(opc, 3));
+ opt_info *o2;
+ o2 = sc->opts[sc->pc];
+ if (cell_optimize(sc, cddr(car_x)))
+ {
+ opt_info *o3;
+ 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(oo_set_type_0(opc));
+ }
+ }
}
}
pc_fallback(sc, start);
@@ -61421,24 +61244,23 @@ static bool p_cf_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin
}
-/* -------- p_cf_any -------- */
-static s7_pointer opt_p_cf_any(opt_info *o)
+/* -------- p_call_any -------- */
+static s7_pointer opt_p_call_any(opt_info *o)
{
s7_pointer arg, val;
int32_t i;
s7_scheme *sc;
sc = o->sc;
- oo_rc(sc, o, 3, 0);
val = safe_list_if_possible(sc, o->v[1].i);
if (in_heap(val))
gc_protect_direct(sc, val);
for (i = 0, arg = val; i < o->v[1].i; i++, arg = cdr(arg))
{
opt_info *o1;
- o1 = sc->opts[++sc->pc];
+ o1 = sc->opts[++sc->pc]; /* 3..15 */
set_car(arg, o1->v[0].fp(o1));
}
- arg = o->v[2].cf(sc, val);
+ arg = o->v[2].call(sc, val);
if (in_heap(val))
sc->stack_end -= 4;
else
@@ -61449,7 +61271,7 @@ static s7_pointer opt_p_cf_any(opt_info *o)
return(arg);
}
-static bool p_cf_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t len)
+static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t len)
{
if ((is_safe_procedure(s_func)) &&
(c_function_required_args(s_func) <= (len - 1)) &&
@@ -61462,9 +61284,9 @@ static bool p_cf_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin
break;
if (is_null(p))
{
- opc->v[0].fp = opt_p_cf_any;
- opc->v[2].cf = cf_call(sc, car_x, s_func, len - 1);
- return(oo_set_type_0(opc, 3));
+ opc->v[0].fp = opt_p_call_any;
+ opc->v[2].call = cf_call(sc, car_x, s_func, len - 1);
+ return(oo_set_type_0(opc));
}
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -61473,11 +61295,7 @@ static bool p_cf_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin
/* -------- p_fx_any -------- */
-static s7_pointer opt_p_fx_any(opt_info *o)
-{
- oo_rc(o->sc, o, 3, 0);
- return(o->v[1].cf(o->sc, o->v[2].p));
-}
+static s7_pointer opt_p_fx_any(opt_info *o) {return(o->v[1].call(o->sc, o->v[2].p));}
static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer x)
{
@@ -61488,9 +61306,9 @@ static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin
if (f)
{
opc->v[0].fp = opt_p_fx_any;
- opc->v[1].cf = f;
+ opc->v[1].call = f;
opc->v[2].p = car(x);
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
return(return_false(sc, x, __func__, __LINE__));
}
@@ -61511,8 +61329,10 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len)
if (is_sequence(obj))
{
opt_info *opc;
+ int32_t start;
opc = alloc_opo(sc, car_x);
opc->v[1].p = s_slot;
+ start = sc->pc;
if (len == 2)
{
opt_type_t op2 = OO_P;
@@ -61599,12 +61419,12 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len)
break;
}
}
- return(oo_set_type_2(opc, 4, 1, 2, op2, OO_I));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_I));
}
return(return_false(sc, car_x, __func__, __LINE__)); /* I think this reflects that a non-int index is an error for list-ref et al */
}
opc->v[0].fp = opt_p_pp_ss;
- return(oo_set_type_2(opc, 4, 1, 2, op2, OO_P));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
}
else
@@ -61612,23 +61432,29 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len)
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(oo_set_type_1(opc, 4, 1, op2));
+ return(oo_set_type_1(opc, 1, op2));
}
+ o1 = sc->opts[sc->pc];
if (int_optimize(sc, cdr(car_x)))
{
opc->v[0].fp = opt_p_pi_sf;
- return(oo_set_type_1(opc, 4, 1, op2));
+ opc->v[4].o1 = o1;
+ opc->v[5].fi = o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, op2));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
if (cell_optimize(sc, cdr(car_x)))
{
opc->v[0].fp = opt_p_pp_sf;
- return(oo_set_type_1(opc, 4, 1, op2));
+ opc->v[4].o1 = sc->opts[start];
+ opc->v[5].fp = sc->opts[start]->v[0].fp;
+ return(oo_set_type_1(opc, 1, op2));
}
}
} /* len==2 */
@@ -61637,18 +61463,22 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len)
if (len > 2)
{
s7_pointer p;
- int32_t start;
- start = sc->pc;
if ((is_normal_vector(obj)) &&
(len == 3) && (vector_rank(obj) == 2))
{
- if ((int_optimize(sc, cdr(car_x))) &&
- (int_optimize(sc, cddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cdr(car_x)))
{
- opc->v[0].fp = opt_p_pii_sff;
- /* opc->v[1].p set above */
- opc->v[4].p_pii_f = vector_ref_p_pii_direct;
- return(oo_set_type_1(opc, 5, 1, OO_P));
+ 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(oo_set_type_1(opc, 1, OO_P));
+ }
}
pc_fallback(sc, start);
}
@@ -61659,18 +61489,18 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len)
break;
if (is_null(p))
{
- opc->v[0].fp = opt_p_cf_any;
+ 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].cf = g_list_ref; break;
- case T_HASH_TABLE: opc->v[2].cf = g_hash_table_ref; break;
- /* case T_LET: opc->v[2].cf = g_let_ref; break; */ /* this doesn't handle implicit indices via g_let_ref! apply_let */
- case T_INT_VECTOR: opc->v[2].cf = g_int_vector_ref; break;
- case T_FLOAT_VECTOR: opc->v[2].cf = g_float_vector_ref; break;
- case T_VECTOR: opc->v[2].cf = g_vector_ref; break;
+ 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_FLOAT_VECTOR: opc->v[2].call = g_float_vector_ref; break;
+ case T_VECTOR: opc->v[2].call = g_vector_ref; break;
default: return(return_false(sc, car_x, __func__, __LINE__));
}
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}}}
} /* obj is sequence */
}
@@ -61686,17 +61516,15 @@ static bool opt_cell_quote(s7_scheme *sc, s7_pointer car_x)
opc = alloc_opo(sc, car_x);
opc->v[1].p = cadr(car_x);
opc->v[0].fp = opt_p_c;
- return(oo_set_type_0(opc, 2));
+ return(oo_set_type_0(opc));
}
/* -------- cell_set -------- */
static s7_pointer opt_set_p_p_f(opt_info *o)
{
- opt_info *o1;
s7_pointer x;
- oo_rc(o->sc, o, 2, 1);
- o1 = o->sc->opts[++o->sc->pc];
- x = o1->v[0].fp(o1);
+ o->sc->pc++;
+ x = o->v[4].fp(o->v[3].o1);
slot_set_value(o->v[1].p, x);
return(x);
}
@@ -61704,7 +61532,6 @@ static s7_pointer opt_set_p_p_f(opt_info *o)
static s7_pointer opt_set_p_i_s(opt_info *o)
{
s7_pointer val;
- oo_rc(o->sc, o, 3, 2);
val = slot_value(o->v[2].p);
if (is_mutable_integer(val))
val = make_integer(o->sc, integer(val));
@@ -61714,11 +61541,9 @@ static s7_pointer opt_set_p_i_s(opt_info *o)
static s7_pointer opt_set_p_i_f(opt_info *o)
{
- opt_info *o1;
s7_pointer x;
- oo_rc(o->sc, o, 2, 1);
- o1 = o->sc->opts[++o->sc->pc];
- x = make_integer(o->sc, o1->v[0].fi(o1));
+ o->sc->pc++;
+ x = make_integer(o->sc, o->v[6].fi(o->v[5].o1));
slot_set_value(o->v[1].p, x);
return(x);
}
@@ -61726,7 +61551,6 @@ static s7_pointer opt_set_p_i_f(opt_info *o)
static s7_pointer opt_set_p_d_s(opt_info *o)
{
s7_pointer val;
- oo_rc(o->sc, o, 3, 2);
val = slot_value(o->v[2].p);
if (is_mutable_number(val))
val = make_real(o->sc, real(val));
@@ -61736,48 +61560,33 @@ static s7_pointer opt_set_p_d_s(opt_info *o)
static s7_pointer opt_set_p_d_f(opt_info *o)
{
- opt_info *o1;
s7_pointer x;
- oo_rc(o->sc, o, 2, 1);
- o1 = o->sc->opts[++o->sc->pc];
- x = make_real(o->sc, o1->v[0].fd(o1));
+ o->sc->pc++;
+ x = make_real(o->sc, 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_mm_add(opt_info *o)
{
- opt_info *o1, *o2;
s7_double x1, x2;
- oo_rc(o->sc, o, 3, 1);
-
- o1 = o->sc->opts[o->sc->pc += 2];
- x1 = float_vector_ref_d_7pi(o->sc, slot_value(o1->v[2].p), integer(slot_value(o1->v[3].p))) * real(slot_value(o1->v[1].p));
- o2 = o->sc->opts[++o->sc->pc];
- x2 = float_vector_ref_d_7pi(o->sc, slot_value(o2->v[2].p), integer(slot_value(o2->v[3].p))) * real(slot_value(o2->v[1].p));
-
+ x1 = float_vector_ref_d_7pi(o->sc, 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(o->sc, 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(o->sc, x1 + x2));
return(slot_value(o->v[1].p));
}
static s7_pointer opt_set_p_d_f_mm_subtract(opt_info *o)
{
- opt_info *o1, *o2;
s7_double x1, x2;
- oo_rc(o->sc, o, 3, 1);
-
- o1 = o->sc->opts[o->sc->pc += 2];
- x1 = float_vector_ref_d_7pi(o->sc, slot_value(o1->v[2].p), integer(slot_value(o1->v[3].p))) * real(slot_value(o1->v[1].p));
- o2 = o->sc->opts[++o->sc->pc];
- x2 = float_vector_ref_d_7pi(o->sc, slot_value(o2->v[2].p), integer(slot_value(o2->v[3].p))) * real(slot_value(o2->v[1].p));
-
+ x1 = float_vector_ref_d_7pi(o->sc, 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(o->sc, 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(o->sc, x1 - x2));
return(slot_value(o->v[1].p));
}
static s7_pointer opt_set_p_c(opt_info *o)
{
- oo_rc(o->sc, o, 3, 1);
slot_set_value(o->v[1].p, o->v[2].p);
return(o->v[2].p);
}
@@ -61786,7 +61595,6 @@ static s7_pointer opt_set_p_i_fo(opt_info *o)
{
s7_pointer x;
s7_int i;
- oo_rc(o->sc, o, 4, 3);
i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)));
x = make_integer(o->sc, i);
slot_set_value(o->v[1].p, x);
@@ -61797,7 +61605,6 @@ static s7_pointer opt_set_p_i_fo_add(opt_info *o)
{
s7_pointer x;
s7_int i;
- oo_rc(o->sc, o, 4, 3);
i = integer(slot_value(o->v[2].p)) + integer(slot_value(o->v[3].p));
x = make_integer(o->sc, i);
slot_set_value(o->v[1].p, x);
@@ -61808,7 +61615,6 @@ static s7_pointer opt_set_p_i_fo1(opt_info *o)
{
s7_pointer x;
s7_int i;
- oo_rc(o->sc, o, 4, 2);
i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), o->v[3].i);
x = make_integer(o->sc, i);
slot_set_value(o->v[1].p, x);
@@ -61819,7 +61625,6 @@ static s7_pointer opt_set_p_i_fo1_add(opt_info *o)
{
s7_pointer x;
s7_int i;
- oo_rc(o->sc, o, 4, 2);
i = integer(slot_value(o->v[2].p)) + o->v[3].i;
x = make_integer(o->sc, i);
slot_set_value(o->v[1].p, x);
@@ -61843,7 +61648,7 @@ static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc)
opc->v[0].fp = opt_set_p_i_fo_add;
else opc->v[0].fp = opt_set_p_i_fo;
backup_pc(sc);
- return(oo_set_type_3(opc, 5, 1, 2, 3, OO_I, OO_I, OO_I));
+ return(oo_set_type_3(opc, 1, 2, 3, OO_I, OO_I, OO_I));
}
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))
{
@@ -61854,7 +61659,7 @@ static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc)
opc->v[0].fp = opt_set_p_i_fo1_add;
else opc->v[0].fp = opt_set_p_i_fo1;
backup_pc(sc);
- return(oo_set_type_2(opc, 5, 1, 2, OO_I, OO_I));
+ return(oo_set_type_2(opc, 1, 2, OO_I, OO_I));
}
}
return(return_false(sc, NULL, __func__, __LINE__));
@@ -61870,8 +61675,16 @@ static bool set_p_d_f_combinable(s7_scheme *sc, opt_info *opc)
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[2].d_dd_f = o1->v[3].d_dd_f; */
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);
}
}
@@ -61926,7 +61739,9 @@ static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer
if (cell_optimize(sc, cddr(car_x)))
{
opc->v[0].fp = opt_set_p_p_f;
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ opc->v[3].o1 = sc->opts[start_pc];
+ opc->v[4].fp = sc->opts[start_pc]->v[0].fp;
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
}
@@ -61970,17 +61785,20 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
{
opc->v[2].p = val_slot;
opc->v[0].fp = opt_set_p_i_s;
- return(oo_set_type_2(opc, 3, 1, 2, OO_I, OO_I));
+ fprintf(stderr, "expr: %s\n", DISPLAY(car_x));
+ return(oo_set_type_2(opc, 1, 2, OO_I, OO_I));
}
}
else
{
+ opc->v[5].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x)))
{
if (!set_p_i_f_combinable(sc, opc))
{
opc->v[0].fp = opt_set_p_i_f;
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ opc->v[6].fi = opc->v[5].o1->v[0].fi;
+ return(oo_set_type_1(opc, 1, OO_P));
}
oo_check(sc, opc);
return(true);
@@ -61994,7 +61812,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
{
opc->v[2].p = caddr(car_x);
opc->v[0].fp = opt_set_p_c;
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
if (is_symbol(caddr(car_x)))
{
@@ -62004,7 +61822,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
{
opc->v[2].p = val_slot;
opc->v[0].fp = opt_set_p_d_s;
- return(oo_set_type_2(opc, 3, 1, 2, OO_D, OO_D));
+ return(oo_set_type_2(opc, 1, 2, OO_D, OO_D));
}
}
else
@@ -62013,8 +61831,13 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
(float_optimize(sc, cddr(car_x))))
{
if (!set_p_d_f_combinable(sc, opc))
- opc->v[0].fp = opt_set_p_d_f;
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ {
+ opc->v[0].fp = opt_set_p_d_f;
+ opc->v[4].o1 = sc->opts[start_pc];
+ opc->v[5].fd = sc->opts[start_pc]->v[0].fd;
+ return(oo_set_type_1(opc, 1, OO_P));
+ }
+ return(oo_set_type_1(opc, 1, OO_P));
}
return(check_type_uncertainty(sc, target, car_x, opc, start_pc));
}
@@ -62026,7 +61849,9 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
if (cell_optimize(sc, cddr(car_x)))
{
opc->v[0].fp = opt_set_p_p_f;
- return(oo_set_type_1(opc, 3, 1, OO_P));
+ opc->v[3].o1 = sc->opts[start_pc];
+ opc->v[4].fp = sc->opts[start_pc]->v[0].fp;
+ return(oo_set_type_1(opc, 1, OO_P));
}
}
}
@@ -62081,52 +61906,17 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
}
else
{
- s7_pointer indexp1, indexp2, valp, slot;
- if (vector_rank(obj) != 2) return(return_false(sc, car_x, __func__, __LINE__));
+ if (vector_rank(obj) != 2)
+ return(return_false(sc, car_x, __func__, __LINE__));
opc->v[5].p_piip_f = (is_typed_vector(obj)) ? typed_vector_set_p_piip_direct : vector_set_p_piip_direct;
- indexp1 = cdr(target);
- indexp2 = cddr(target);
- valp = cddr(car_x);
- 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_symbol(car(valp))) ||
- (is_unquoted_pair(car(valp))))
- {
- if (cell_optimize(sc, valp))
- {
- opc->v[0].fp = opt_p_piip_sssf;
- return(oo_set_type_3(opc, 6, 1, 2, 3, (is_typed_vector(obj)) ? OO_TV : OO_PV, OO_I, OO_I));
- }
- return(return_false(sc, car_x, __func__, __LINE__));
- }
- opc->v[0].fp = opt_p_piip_sssc;
- opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp);
- return(oo_set_type_3(opc, 6, 1, 2, 3, (is_typed_vector(obj)) ? OO_TV : OO_PV, OO_I, OO_I));
- }
- }
- if ((int_optimize(sc, indexp1)) &&
- (int_optimize(sc, indexp2)) &&
- (cell_optimize(sc, valp)))
- {
- /* v[1].p is set above as the vector slot */
- opc->v[0].fp = opt_p_piip_sfff;
- return(oo_set_type_1(opc, 6, 1, (is_typed_vector(obj)) ? OO_TV : OO_PV));
- }
- return(return_false(sc, car_x, __func__, __LINE__));
+ 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), cddr(car_x)))
{
- if (oo_size(opc) < 8) oo_resize(opc, 8);
- opc->v[7].fd = opc->v[0].fd;
+ opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
oo_check(sc, opc);
return(true);
@@ -62137,8 +61927,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
case T_INT_VECTOR:
if (opt_int_vector_set(sc, OO_AV, opc, car(target), cdr(target), (is_null(cddr(target))) ? NULL : cddr(target), cddr(car_x)))
{
- if (oo_size(opc) < 8) oo_resize(opc, 8);
- opc->v[7].fi = opc->v[0].fi;
+ opc->v[O_WRAP].fi = opc->v[0].fi;
opc->v[0].fp = i_to_p;
oo_check(sc, opc);
return(true);
@@ -62157,26 +61946,31 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
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[7].fd = opt_d_7pid_ssf;
+ 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;
- return(oo_set_type_2(opc, 5, 1, 2, OO_V, OO_I));
+ opc->v[11].fd = opc->v[10].o1->v[0].fd;
+ return(oo_set_type_2(opc, 1, 2, OO_V, OO_I));
}
}
else
{
- if ((int_optimize(sc, cdr(target))) &&
- (float_optimize(sc, cddr(car_x))))
+ if (int_optimize(sc, cdr(target)))
{
- opc->v[7].fd = opt_d_7pid_sff;
- opc->v[0].fp = d_to_p;
- return(oo_set_type_1(opc, 5, 1, OO_V));
- }}}
- }
+ 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(oo_set_type_1(opc, 1, OO_V));
+ }}}}}
return(return_false(sc, car_x, __func__, __LINE__));
case T_PAIR:
@@ -62266,12 +62060,12 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
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(oo_set_type_3(opc, 5, 1, 2, 3, op2, OO_I, OO_P));
+ return(oo_set_type_3(opc, 1, 2, 3, op2, OO_I, OO_P));
}
opc->v[4].p_ppp_f = opc->v[3].p_ppp_f;
opc->v[3].p = val_slot;
opc->v[0].fp = opt_p_ppp_sss;
- return(oo_set_type_3(opc, 5, 1, 2, 3, op2, OO_P, OO_P));
+ return(oo_set_type_3(opc, 1, 2, 3, op2, OO_P, OO_P));
}
}
else
@@ -62287,40 +62081,49 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
(is_pair(obj)))
{
opc->v[0].fp = opt_p_pip_ssc;
- return(oo_set_type_2(opc, 5, 1, 2, op2, OO_I));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_I));
}
opc->v[0].fp = opt_p_ppp_ssc;
- return(oo_set_type_2(opc, 5, 1, 2, op2, OO_P));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
}
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)))
{
- oo_set_type_2(opc, 5, 1, 2, op2, OO_I); /* needed in p_pip_ssf_combinable! */
+ oo_set_type_2(opc, 1, 2, op2, OO_I); /* needed in p_pip_ssf_combinable! */
if (p_pip_ssf_combinable(sc, opc, start))
return(true);
opc->v[0].fp = opt_p_pip_ssf;
- return(oo_set_type_2(opc, 5, 1, 2, op2, OO_I));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_I));
}
opc->v[0].fp = opt_p_ppp_ssf;
- return(oo_set_type_2(opc, 5, 1, 2, op2, op2));
+ return(oo_set_type_2(opc, 1, 2, op2, op2));
}
}
}
else
{
+ opt_info *o1;
if ((is_string(obj)) ||
(is_pair(obj)) ||
(is_any_vector(obj)))
{
- if ((int_optimize(sc, cdr(target))) &&
- (cell_optimize(sc, cddr(car_x))))
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cdr(target)))
{
- opc->v[0].fp = opt_p_pip_sff;
- return(oo_set_type_1(opc, 4, 1, op2));
+ 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(oo_set_type_1(opc, 1, op2));
+ }
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -62334,11 +62137,13 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
opc->v[4].p = cadr(cadr(target));
opc->v[2].p = val_slot;
opc->v[0].fp = opt_p_ppp_scs;
- return(oo_set_type_2(opc, 5, 1, 2, op2, OO_P));
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
}
+ o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(target)))
{
+ opt_info *o2;
if (is_symbol(caddr(car_x)))
{
s7_pointer val_slot;
@@ -62347,13 +62152,20 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
{
opc->v[2].p = val_slot;
opc->v[0].fp = opt_p_ppp_sfs;
- return(oo_set_type_2(opc, 4, 1, 2, op2, OO_P));
+ opc->v[4].o1 = o1;
+ opc->v[5].fp = o1->v[0].fp;
+ return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
}
+ o2 = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x)))
{
opc->v[0].fp = opt_p_ppp_sff;
- return(oo_set_type_1(opc, 4, 1, op2));
+ 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(oo_set_type_1(opc, 1, op2));
}}}}}}
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -62364,26 +62176,35 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
static s7_pointer opt_begin_p(opt_info *o)
{
opt_info *o1;
- s7_int i, len;
- oo_rc(o->sc, o, 2, 0);
- len = o->v[1].i - 1;
+ s7_int i, k, len;
+ s7_scheme *sc;
+ sc = o->sc;
+ len = o->v[1].i; /* len = 1 if 2 exprs, etc */
+ if (len < 5)
+ {
+ for (i = 0, k = 2; i < len; i++, k += 2)
+ {
+ sc->pc++;
+ o->v[k + 1].fp(o->v[k].o1);
+ }
+ sc->pc++;
+ return(o->v[k + 1].fp(o->v[k].o1));
+ }
for (i = 0; i < len; i++)
{
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = sc->opts[++sc->pc]; /* 2..15 or does it collide above? */
o1->v[0].fp(o1);
}
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = sc->opts[++sc->pc];
return(o1->v[0].fp(o1));
}
static s7_pointer opt_begin_p_1(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 0, 0); /* ?? */
- o1 = o->sc->opts[++o->sc->pc];
- o1->v[0].fp(o1);
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ o->v[3].fp(o->v[2].o1);
+ o->sc->pc++;
+ return(o->v[5].fp(o->v[4].o1));
}
static void oo_idp_nr_fixup(opt_info *start)
@@ -62391,11 +62212,11 @@ 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[7].fd == opt_d_7pid_ssf)
+ if (start->v[O_WRAP].fd == opt_d_7pid_ssf)
start->v[0].fp = opt_d_7pid_ssf_nr;
else
{
- if (start->v[7].fd == opt_d_7pid_ssfo_fv)
+ 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)
@@ -62414,10 +62235,11 @@ static void oo_idp_nr_fixup(opt_info *start)
static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
+ int32_t i;
opt_info *opc;
s7_pointer p;
opc = alloc_opo(sc, car_x);
- for (p = cdr(car_x); is_pair(p); p = cdr(p))
+ for (i = 2, p = cdr(car_x); is_pair(p); i += 2, p = cdr(p))
{
opt_info *start;
start = sc->opts[sc->pc];
@@ -62425,52 +62247,76 @@ static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len)
return(return_false(sc, car_x, __func__, __LINE__));
if (is_pair(cdr(p)))
oo_idp_nr_fixup(start);
+ if (i < 12)
+ {
+ opc->v[i].o1 = start;
+ opc->v[i + 1].fp = start->v[0].fp;
+ }
}
- opc->v[1].i = len - 1;
+ opc->v[1].i = len - 2;
opc->v[0].fp = (len == 3) ? opt_begin_p_1 : opt_begin_p;
- return(oo_set_type_0(opc, 2));
+ return(oo_set_type_0(opc));
}
/* -------- cell_when|unless -------- */
+static s7_pointer opt_when_p_2(opt_info *o)
+{
+ s7_scheme *sc;
+ sc = o->sc;
+ sc->pc++;
+ if (o->v[11].fb(o->v[10].o1))
+ {
+ opt_info *o1;
+ o1 = sc->opts[++sc->pc];
+ o1->v[0].fp(o1);
+ o1 = sc->opts[++sc->pc];
+ return(o1->v[0].fp(o1));
+ }
+ sc->pc = o->v[3].i;
+ return(sc->unspecified);
+}
+
static s7_pointer opt_when_p(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[0].fb(o1))
+ s7_scheme *sc;
+ sc = o->sc;
+ sc->pc++;
+ if (o->v[11].fb(o->v[10].o1))
{
int32_t i, len;
+ opt_info *o1;
len = o->v[1].i - 1;
for (i = 0; i < len; i++)
{
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = sc->opts[++sc->pc]; /* 4..15 */
o1->v[0].fp(o1);
}
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = sc->opts[++sc->pc];
return(o1->v[0].fp(o1));
}
- o->sc->pc = o->v[3].i;
- return(o->sc->unspecified);
+ sc->pc = o->v[3].i;
+ return(sc->unspecified);
}
static s7_pointer opt_unless_p(opt_info *o)
{
opt_info *o1;
int32_t i, len;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[0].fb(o1))
+ s7_scheme *sc;
+ sc = o->sc;
+ sc->pc++;
+ if (o->v[11].fb(o->v[10].o1))
{
- o->sc->pc = o->v[3].i;
- return(o->sc->unspecified);
+ sc->pc = o->v[3].i;
+ return(sc->unspecified);
}
len = o->v[1].i - 1;
for (i = 0; i < len; i++)
{
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = sc->opts[++sc->pc]; /* 4..15 */
o1->v[0].fp(o1);
}
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = sc->opts[++sc->pc];
return(o1->v[0].fp(o1));
}
@@ -62479,6 +62325,7 @@ static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len)
s7_pointer p;
opt_info *opc;
opc = alloc_opo(sc, car_x);
+ opc->v[10].o1 = sc->opts[sc->pc];
if (!bool_optimize(sc, cdr(car_x)))
return(return_false(sc, car_x, __func__, __LINE__));
for (p = cddr(car_x); is_pair(p); p = cdr(p))
@@ -62490,21 +62337,21 @@ static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len)
if (is_pair(cdr(p)))
oo_idp_nr_fixup(start);
}
+ opc->v[11].fb = opc->v[10].o1->v[0].fb;
opc->v[1].i = len - 2;
opc->v[3].i = sc->pc - 1;
- opc->v[0].fp = ((car(car_x) == sc->when_symbol) ? opt_when_p : opt_unless_p);
- return(oo_set_type_0(opc, 4));
+ opc->v[0].fp = ((car(car_x) == sc->when_symbol) ? ((len == 4) ? opt_when_p_2 : opt_when_p) : opt_unless_p);
+ return(oo_set_type_0(opc));
}
/* -------- cell_cond -------- */
static s7_pointer opt_cond(opt_info *o)
{
- oo_rc(o->sc, o, 3, 0);
o->v[2].p = o->sc->unspecified;
while (o->sc->pc < o->v[1].i)
{
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = o->sc->opts[++o->sc->pc]; /* 3..15? */
o1->v[0].fp(o1);
}
return(o->v[2].p);
@@ -62514,16 +62361,18 @@ static s7_pointer case_value(opt_info *o)
{
opt_info *top, *o1;
int32_t i, len;
+ s7_scheme *sc;
+ sc = o->sc;
top = (opt_info *)(o->v[5].obj);
len = o->v[1].i - 1;
for (i = 0; i < len; i++)
{
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = sc->opts[++sc->pc]; /* 6..15 */
o1->v[0].fp(o1);
}
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = sc->opts[++sc->pc];
top->v[2].p = o1->v[0].fp(o1);
- o->sc->pc = top->v[1].i;
+ sc->pc = top->v[1].i;
return(top->v[2].p);
}
@@ -62540,12 +62389,11 @@ static s7_pointer opt_cond_clause(opt_info *o)
static s7_pointer opt_cond_1(opt_info *o) /* cond as when */
{
- opt_info *o1;
- oo_rc(o->sc, o, 3, 0);
- o->v[2].p = o->sc->unspecified;
- o1 = o->sc->opts[++o->sc->pc];
- o1->v[0].fp(o1);
- return(o->v[2].p);
+ o->sc->pc += 2;
+ if (o->v[5].fb(o->v[4].o1))
+ return(case_value(o->v[6].o1));
+ o->sc->pc = o->v[3].i;
+ return(o->sc->unspecified);
}
static s7_pointer opt_cond_2(opt_info *o)
@@ -62553,14 +62401,15 @@ static s7_pointer opt_cond_2(opt_info *o)
/* 2 branches, results 1 expr, else */
opt_info *o1, *o2;
s7_pointer res;
- oo_rc(o->sc, o, 2, 0);
- o->sc->pc += 2;
- o2 = o->sc->opts[o->sc->pc]; /* this is the boolean expr of the first clause */
+ s7_scheme *sc;
+ sc = o->sc;
+ sc->pc += 2;
+ o2 = sc->opts[sc->pc]; /* this is the boolean expr of the first clause */
if (!o2->v[0].fb(o2))
- o->sc->pc = o->v[3].i; /* jump over first clause and #t */
- o1 = o->sc->opts[++o->sc->pc];
+ sc->pc = o->v[3].i; /* jump over first clause and #t */
+ o1 = sc->opts[++sc->pc];
res = o1->v[0].fp(o1);
- o->sc->pc = o->v[1].i; /* end of cond index */
+ sc->pc = o->v[1].i; /* end of cond index */
return(res);
}
@@ -62587,14 +62436,14 @@ static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x)
last_clause = clause;
opc = alloc_opo(sc, car_x);
- oo_set_type_0(opc, 6);
+ oo_set_type_0(opc);
if ((car(clause) == sc->else_symbol) ||
(car(clause) == sc->T))
{
opt_info *opb;
opb = alloc_opo(sc, clause);
opb->v[0].fb = opt_b_t;
- oo_set_type_0(opb, 1);
+ oo_set_type_0(opb);
}
else
{
@@ -62615,50 +62464,57 @@ static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x)
top->v[1].i = sc->pc - 1;
top->v[0].fp = opt_cond;
if (branches == 1)
- top->v[0].fp = opt_cond_1;
- else
{
- if (branches == 2)
+ opt_info *o1;
+ o1 = sc->opts[start_pc + 1];
+ top->v[0].fp = 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(oo_set_type_0(top));
+ }
+ if (branches == 2)
+ {
+ if ((max_blen == 1) &&
+ ((car(last_clause) == sc->else_symbol) ||
+ (car(last_clause) == sc->T)))
{
- if ((max_blen == 1) &&
- ((car(last_clause) == sc->else_symbol) ||
- (car(last_clause) == sc->T)))
- {
- opt_info *o1;
- o1 = sc->opts[start_pc];
- top->v[3].i = o1->v[3].i + 2;
- top->v[0].fp = opt_cond_2;
- }
+ opt_info *o1;
+ o1 = sc->opts[start_pc];
+ top->v[3].i = o1->v[3].i + 2;
+ top->v[0].fp = opt_cond_2;
}
}
- return(oo_set_type_0(top, 6));
+ return(oo_set_type_0(top));
}
/* -------- cell_and|or -------- */
static s7_pointer opt_and_pp(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 2, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[0].fp(o1) == o->sc->F)
+ o->sc->pc++;
+ if (o->v[11].fp(o->v[10].o1) == o->sc->F)
{
o->sc->pc = o->v[1].i;
return(o->sc->F);
}
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[9].fp(o->v[8].o1));
}
static s7_pointer opt_and_any_p(opt_info *o)
{
int32_t i;
s7_pointer val;
- oo_rc(o->sc, o, 3, 0);
val = o->sc->T; /* (and) -> #t */
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ /* o1 = o->sc->opts[++o->sc->pc]; *//* 3..15? */
+ o->sc->pc++;
+ o1 = o->v[i + 3].o1;
+#if S7_DEBUGGING
+ if (o1 != o->sc->opts[o->sc->pc]) fprintf(stderr, "and o1 != opts\n");
+#endif
val = o1->v[0].fp(o1);
if (val == o->sc->F)
{
@@ -62671,29 +62527,31 @@ static s7_pointer opt_and_any_p(opt_info *o)
static s7_pointer opt_or_pp(opt_info *o)
{
- opt_info *o1;
s7_pointer val;
- oo_rc(o->sc, o, 2, 0);
- o1 = o->sc->opts[++o->sc->pc];
- val = o1->v[0].fp(o1);
+ o->sc->pc++;
+ val = o->v[11].fp(o->v[10].o1);
if (val != o->sc->F)
{
o->sc->pc = o->v[1].i;
return(val);
}
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[9].fp(o->v[8].o1));
}
static s7_pointer opt_or_any_p(opt_info *o)
{
int32_t i;
- oo_rc(o->sc, o, 3, 0);
for (i = 0; i < o->v[1].i; i++)
{
s7_pointer val;
opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
+ o->sc->pc++;
+ o1 = o->v[i + 3].o1;
+#if S7_DEBUGGING
+ if (o1 != o->sc->opts[o->sc->pc]) fprintf(stderr, "or o1 != opts\n");
+#endif
+ /* o1 = o->sc->opts[++o->sc->pc]; */ /* 3..15? */
val = o1->v[0].fp(o1);
if (val != o->sc->F)
{
@@ -62704,62 +62562,46 @@ static s7_pointer opt_or_any_p(opt_info *o)
return(o->sc->F);
}
+/* static s7_pointer b_to_p_0(opt_info *o) {return((o->v[0].fb(o)) ? o->sc->T : o->sc->F);} */
+
static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
opt_info *opc;
opc = alloc_opo(sc, car_x);
if (len == 3)
{
- opt_info *wrapper;
- int32_t start;
opc->v[0].fp = ((car(car_x) == sc->or_symbol) ? opt_or_pp : opt_and_pp);
- wrapper = sc->opts[sc->pc];
- start = sc->pc;
+
+ opc->v[10].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, cdr(car_x)))
- {
- pc_fallback(sc, start);
- if (!bool_optimize_nw(sc, cdr(car_x)))
- return(return_false(sc, car_x, __func__, __LINE__));
- if (oo_size(wrapper) < 8) oo_resize(wrapper, 8);
- wrapper->v[7].fb = wrapper->v[0].fb;
- wrapper->v[0].fp = b_to_p;
- }
- start = sc->pc;
+ return(return_false(sc, car_x, __func__, __LINE__));
+ 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)))
- {
- pc_fallback(sc, start);
- if (!bool_optimize_nw(sc, cddr(car_x)))
- return(return_false(sc, car_x, __func__, __LINE__));
- if (oo_size(wrapper) < 8) oo_resize(wrapper, 8);
- wrapper->v[7].fb = wrapper->v[0].fb;
- wrapper->v[0].fp = b_to_p;
- }
+ return(return_false(sc, car_x, __func__, __LINE__));
+ opc->v[9].fp = opc->v[8].o1->v[0].fp;
+
opc->v[1].i = sc->pc - 1;
- return(oo_set_type_0(opc, 2));
+ return(oo_set_type_0(opc));
}
- if (len > 0)
+
+ if ((len > 1) && (len < 11))
{
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 (p = cdr(car_x); is_pair(p); p = cdr(p))
+
+ for (i = 3, p = cdr(car_x); is_pair(p); i++, p = cdr(p))
{
- opt_info *wrapper;
- int32_t start;
- wrapper = sc->opts[sc->pc];
- start = sc->pc;
+ opc->v[i].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, p))
- {
- pc_fallback(sc, start);
- if (!bool_optimize_nw(sc, p))
- return(return_false(sc, car_x, __func__, __LINE__));
- if (oo_size(wrapper) < 8) oo_resize(wrapper, 8);
- wrapper->v[7].fb = wrapper->v[0].fb;
- wrapper->v[0].fp = b_to_p;
- }
+ return(return_false(sc, car_x, __func__, __LINE__));
}
+
opc->v[2].i = sc->pc - 1;
- return(oo_set_type_0(opc, 3));
+ return(oo_set_type_0(opc));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -62767,13 +62609,11 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len)
/* -------- cell_if -------- */
static s7_pointer opt_if_bp(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 2, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[0].fb(o1))
+ o->sc->pc++;
+ if (o->v[3].fb(o->v[2].o1))
{
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[5].fp(o->v[4].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62781,41 +62621,22 @@ static s7_pointer opt_if_bp(opt_info *o)
static s7_pointer opt_if_bp_nr(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 2, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[0].fb(o1))
+ o->sc->pc++;
+ if (o->v[3].fb(o->v[2].o1))
{
- o1 = o->sc->opts[++o->sc->pc];
- o1->v[0].fp(o1);
+ o->sc->pc++;
+ return(o->v[5].fp(o->v[4].o1));
}
return(NULL);
}
-static s7_pointer opt_if_bp_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 3, 0);
- o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- if (o->v[2].b_p_f(o1->v[0].fp(o1)))
- {
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
- }
- o->sc->pc = o->v[1].i;
- return(o->sc->unspecified);
-}
-
-static s7_pointer opt_if_bp_pb(opt_info *o)
+static s7_pointer opt_if_bp_pb(opt_info *o) /* p_to_b at outer */
{
- opt_info *o1;
- oo_rc(o->sc, o, 2, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[7].fp(o1) != o->sc->F)
+ o->sc->pc++;
+ if (o->v[3].fp(o->v[2].o1) != o->sc->F) /* this is p_to_b expanded and moved to o[3] */
{
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[5].fp(o->v[4].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62823,15 +62644,11 @@ static s7_pointer opt_if_bp_pb(opt_info *o)
static s7_pointer opt_if_bp_ii_fc(opt_info *o)
{
- opt_info *o1, *o2;
- oo_rc(o->sc, o, 2, 0);
- o1 = o->sc->opts[++o->sc->pc];
- o2 = o->sc->opts[++o->sc->pc];
- if (o1->v[3].b_ii_f(o2->v[0].fi(o2), o1->v[2].i))
- /* if (o1->v[7].fp(o1) != o->sc->F) */
+ o->sc->pc += 2;
+ if (o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i))
{
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[5].fp(o->v[4].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62839,29 +62656,11 @@ static s7_pointer opt_if_bp_ii_fc(opt_info *o)
static s7_pointer opt_if_nbp(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 2, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (!o1->v[0].fb(o1))
+ o->sc->pc++;
+ if (!o->v[5].fb(o->v[4].o1))
{
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
- }
- o->sc->pc = o->v[1].i;
- return(o->sc->unspecified);
-}
-/* also b_ii_sf (mac) */
-
-static s7_pointer opt_if_nbp_f(opt_info *o)
-{
- opt_info *o1;
- oo_rc(o->sc, o, 3, 0);
- o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- if (!(o->v[2].b_p_f(o1->v[0].fp(o1))))
- {
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[11].fp(o->v[10].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62869,13 +62668,10 @@ static s7_pointer opt_if_nbp_f(opt_info *o)
static s7_pointer opt_if_nbp_s(opt_info *o)
{
- oo_rc(o->sc, o, 4, 1);
if (!(o->v[2].b_p_f(slot_value(o->v[3].p))))
{
- opt_info *o1;
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o1->v[0].fp(o1));
+ return(o->v[11].fp(o->v[10].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62883,13 +62679,10 @@ static s7_pointer opt_if_nbp_s(opt_info *o)
static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */
{
- oo_rc(o->sc, o, 4, 1);
if (!(o->v[3].b_pp_f(slot_value(o->v[2].p), o->v[4].p)))
{
- opt_info *o1;
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o1->v[0].fp(o1));
+ return(o->v[11].fp(o->v[10].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62897,13 +62690,10 @@ static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */
static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */
{
- oo_rc(o->sc, o, 4, 1);
if (!(o->v[3].b_7pp_f(o->sc, slot_value(o->v[2].p), o->v[4].p)))
{
- opt_info *o1;
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o1->v[0].fp(o1));
+ return(o->v[11].fp(o->v[10].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62911,13 +62701,10 @@ static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */
static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */
{
- oo_rc(o->sc, o, 4, 2);
if (!(o->v[3].b_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[4].p)))))
{
- opt_info *o1;
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o1->v[0].fp(o1));
+ return(o->v[11].fp(o->v[10].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62925,14 +62712,11 @@ static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */
static s7_pointer opt_if_nbp_fs(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- if (!(o->v[2].b_pi_f(o->sc, o1->v[0].fp(o1), integer(slot_value(o->v[3].p))))) /* b_pi_fs */
+ if (!(o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) /* b_pi_fs */
{
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[11].fp(o->v[10].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62940,27 +62724,22 @@ static s7_pointer opt_if_nbp_fs(opt_info *o)
static s7_pointer opt_if_nbp_fs_nr(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
- o1 = o->sc->opts[o->sc->pc];
- if (!(o->v[2].b_pi_f(o->sc, o1->v[0].fp(o1), integer(slot_value(o->v[3].p))))) /* b_pi_fs */
+ /* not o->sc->pc += 2 as above because sc->pc is preset to 2 (far) below */
+ if (!(o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) /* b_pi_fs */
{
- o1 = o->sc->opts[++o->sc->pc];
- o1->v[0].fp(o1);
+ o->sc->pc++;
+ return(o->v[11].fp(o->v[10].o1));
}
return(NULL);
}
static s7_pointer opt_if_nbp_sf(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- if (!(o->v[2].b_pp_f(slot_value(o->v[3].p), o1->v[0].fp(o1)))) /* b_pp_sf */
+ if (!(o->v[2].b_pp_f(slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1)))) /* b_pp_sf */
{
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[11].fp(o->v[10].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62968,14 +62747,11 @@ static s7_pointer opt_if_nbp_sf(opt_info *o)
static s7_pointer opt_if_nbp_7sf(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 1);
o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- if (!(o->v[2].b_7pp_f(o->sc, slot_value(o->v[3].p), o1->v[0].fp(o1)))) /* b_7pp_sf */
+ if (!(o->v[2].b_7pp_f(o->sc, slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1)))) /* b_7pp_sf */
{
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ o->sc->pc++;
+ return(o->v[11].fp(o->v[10].o1));
}
o->sc->pc = o->v[1].i;
return(o->sc->unspecified);
@@ -62983,145 +62759,163 @@ static s7_pointer opt_if_nbp_7sf(opt_info *o)
static s7_pointer opt_if_bpp(opt_info *o)
{
- opt_info *o1;
- oo_rc(o->sc, o, 4, 0);
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[0].fb(o1))
+ o->sc->pc++;
+ if (o->v[5].fb(o->v[4].o1))
{
s7_pointer val;
- o1 = o->sc->opts[++o->sc->pc];
- val = o1->v[0].fp(o1);
+ o->sc->pc++;
+ val = o->v[9].fp(o->v[8].o1);
o->sc->pc = o->v[3].i;
return(val);
}
o->sc->pc = o->v[1].i;
- o1 = o->sc->opts[++o->sc->pc];
- return(o1->v[0].fp(o1));
+ return(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;
+ opt_info *opc, *bop, *top;
opc = alloc_opo(sc, car_x);
+ bop = sc->opts[sc->pc];
if (len == 3)
{
- opt_info *next;
- next = sc->opts[sc->pc];
if ((is_proper_list_2(sc, cadr(car_x))) && /* (not arg) */
(caadr(car_x) == sc->not_symbol))
{
- if ((bool_optimize(sc, cdadr(car_x))) &&
- (cell_optimize(sc, cddr(car_x))))
+ if (bool_optimize(sc, cdadr(car_x)))
{
- opc->v[0].fp = opt_if_nbp;
- opc->v[1].i = sc->pc - 1;
- if (next->v[0].fb == opt_b_p_f)
- {
- opc->v[2].b_p_f = next->v[2].b_p_f;
- opc->v[0].fp = opt_if_nbp_f;
- return(oo_set_type_0(opc, 3));
- }
- if (next->v[0].fb == opt_b_p_s)
- {
- opc->v[2].b_p_f = next->v[2].b_p_f;
- opc->v[3].p = next->v[1].p;
- opc->v[0].fp = opt_if_nbp_s;
- return(oo_set_type_1(opc, 4, 3, OO_P));
- }
- if (next->v[0].fb == opt_b_pi_fs)
- {
- opc->v[2].b_pi_f = next->v[2].b_pi_f;
- opc->v[3].p = next->v[1].p;
- opc->v[0].fp = opt_if_nbp_fs;
- return(oo_set_type_1(opc, 4, 3, OO_P));
- }
- if ((next->v[0].fb == opt_b_pp_sf) ||
- (next->v[0].fb == opt_b_7pp_sf))
+ top = sc->opts[sc->pc];
+ if (cell_optimize(sc, cddr(car_x)))
{
- if (next->v[0].fb == opt_b_pp_sf)
+ opc->v[1].i = sc->pc - 1;
+ 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_pp_f = next->v[3].b_pp_f;
- opc->v[0].fp = opt_if_nbp_sf;
+ 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(oo_set_type_1(opc, 3, OO_P));
}
- else
+ if (bop->v[0].fb == opt_b_pi_fs)
{
- opc->v[2].b_7pp_f = next->v[3].b_7pp_f;
- opc->v[0].fp = opt_if_nbp_7sf;
+ 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(oo_set_type_1(opc, 3, OO_P));
}
- opc->v[3].p = next->v[1].p;
- return(oo_set_type_1(opc, 4, 3, OO_P));
- }
- if ((next->v[0].fb == opt_b_pp_sc) ||
- (next->v[0].fb == opt_b_7pp_sc))
- {
- if (next->v[0].fb == opt_b_pp_sc)
+ if ((bop->v[0].fb == opt_b_pp_sf) ||
+ (bop->v[0].fb == opt_b_7pp_sf))
{
- opc->v[3].b_pp_f = next->v[3].b_pp_f;
- opc->v[0].fp = opt_if_nbp_sc;
+ 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(oo_set_type_1(opc, 3, OO_P));
}
- else
+ if ((bop->v[0].fb == opt_b_pp_sc) ||
+ (bop->v[0].fb == opt_b_7pp_sc))
{
- opc->v[3].b_7pp_f = next->v[3].b_7pp_f;
- opc->v[0].fp = opt_if_nbp_7sc;
+ 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(oo_set_type_1(opc, 2, OO_P));
}
- opc->v[2].p = next->v[1].p;
- opc->v[4].p = next->v[2].p;
- return(oo_set_type_1(opc, 5, 2, OO_P));
- }
- if ((next->v[0].fb == opt_b_ii_ss) || (next->v[0].fb == opt_b_ii_ss_eq) ||
- (next->v[0].fb == opt_b_ii_ss_lt) || (next->v[0].fb == opt_b_ii_ss_gt) ||
- (next->v[0].fb == opt_b_ii_ss_leq) || (next->v[0].fb == opt_b_ii_ss_geq))
- {
- opc->v[3].b_ii_f = next->v[3].b_ii_f;
- opc->v[2].p = next->v[1].p;
- opc->v[4].p = next->v[2].p;
- opc->v[0].fp = opt_if_nbp_ss;
- return(oo_set_type_2(opc, 5, 2, 4, OO_I, OO_I));
+ 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 = opt_if_nbp_ss;
+ return(oo_set_type_2(opc, 2, 4, OO_I, OO_I));
+ }
+ opc->v[4].o1 = bop;
+ opc->v[5].fb = bop->v[0].fb;
+ opc->v[0].fp = opt_if_nbp;
+ return(oo_set_type_0(opc));
}
- return(oo_set_type_0(opc, 2));
}
}
else
{
- if ((bool_optimize(sc, cdr(car_x))) &&
- (cell_optimize(sc, cddr(car_x))))
+ if (bool_optimize(sc, cdr(car_x)))
{
- opc->v[0].fp = opt_if_bp;
- opc->v[1].i = sc->pc - 1;
-
- if (next->v[0].fb == p_to_b)
- {
- opc->v[0].fp = opt_if_bp_pb;
- return(oo_set_type_0(opc, 2));
- }
- if (next->v[0].fb == opt_b_p_f)
- {
- opc->v[2].b_p_f = next->v[2].b_p_f;
- opc->v[0].fp = opt_if_bp_f;
- return(oo_set_type_0(opc, 3));
- }
- if (next->v[0].fb == opt_b_ii_fc)
+ opt_info *top;
+ top = sc->opts[sc->pc];
+ if (cell_optimize(sc, cddr(car_x)))
{
- opc->v[0].fp = opt_if_bp_ii_fc;
- return(oo_set_type_0(opc, 2));
+ opc->v[1].i = sc->pc - 1;
+ 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(oo_set_type_0(opc));
+ }
+ 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(oo_set_type_0(opc));
+ }
+ opc->v[0].fp = opt_if_bp;
+ opc->v[3].fb = bop->v[0].fb;
+ return(oo_set_type_0(opc));
}
- return(oo_set_type_0(opc, 2));
}
}
return(return_false(sc, car_x, __func__, __LINE__));
}
if (len == 4)
{
- if ((bool_optimize(sc, cdr(car_x))) &&
- (cell_optimize(sc, cddr(car_x))))
+ if (bool_optimize(sc, cdr(car_x)))
{
- opc->v[0].fp = opt_if_bpp;
- opc->v[1].i = sc->pc - 1;
- if (cell_optimize(sc, cdddr(car_x)))
+ top = sc->opts[sc->pc];
+ if (cell_optimize(sc, cddr(car_x)))
{
- opc->v[3].i = sc->pc - 1;
- return(oo_set_type_0(opc, 4));
- }}}
+ opt_info *o3;
+ o3 = sc->opts[sc->pc];
+ opc->v[0].fp = opt_if_bpp;
+ opc->v[1].i = sc->pc;
+ if (cell_optimize(sc, cdddr(car_x)))
+ {
+ opc->v[3].i = sc->pc - 1;
+ 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(oo_set_type_0(opc));
+ }}}}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -63144,13 +62938,12 @@ static bool case_memv(s7_scheme *sc, s7_pointer x, s7_pointer y)
static s7_pointer opt_case(opt_info *o)
{
opt_info *o1;
- oo_rc(o->sc, o, 5, 0);
o->v[2].p = o->sc->unspecified;
o1 = o->sc->opts[++o->sc->pc];
o->v[4].p = o1->v[0].fp(o1);
while (o->sc->pc < o->v[1].i)
{
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = o->sc->opts[++o->sc->pc]; /* 5..15? */
o1->v[0].fp(o1);
}
return(o->v[2].p);
@@ -63160,7 +62953,6 @@ static s7_pointer opt_case_clause(opt_info *o)
{
/* top->v[2].p gets result, top->i1 is end index, top->v[4].p is selector, o->v[3].i is end of current clause, o->v[1].i = body len */
opt_info *top;
- oo_rc(o->sc, o, 6, 0);
top = (opt_info *)(o->v[5].obj);
if ((o->v[2].p == o->sc->else_symbol) ||
(case_memv(o->sc, top->v[4].p, o->v[2].p)))
@@ -63214,13 +63006,13 @@ static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x)
opc->v[3].i = sc->pc - 1;
opc->v[5].obj = (void *)top;
opc->v[0].fp = opt_case_clause;
- oo_set_type_0(opc, 6);
+ oo_set_type_0(opc);
}
if (!is_null(p))
return(return_false(sc, p, __func__, __LINE__));
top->v[1].i = sc->pc - 1;
top->v[0].fp = opt_case;
- return(oo_set_type_0(top, 5));
+ return(oo_set_type_0(top));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -63234,7 +63026,6 @@ static s7_pointer opt_let_temporarily(opt_info *o)
#if S7_DEBUGGING
if (cur_sc->stack_end >= cur_sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
- oo_rc(o->sc, o, 5, 1);
o1 = o->sc->opts[++o->sc->pc];
o->v[4].p = slot_value(o->v[1].p); /* save and protect old value */
gc_protect_direct(o->sc, o->v[4].p);
@@ -63246,7 +63037,7 @@ static s7_pointer opt_let_temporarily(opt_info *o)
len = o->v[2].i - 1;
for (i = 0; i < len; i++)
{
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = o->sc->opts[++o->sc->pc]; /* 5..15? */
o1->v[0].fp(o1);
}
o1 = o->sc->opts[++o->sc->pc];
@@ -63286,7 +63077,7 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le
opc->v[2].i = len - 2;
opc->v[0].fp = opt_let_temporarily;
- return(oo_set_type_1(opc, 5, 1, OO_P));
+ return(oo_set_type_1(opc, 1, OO_P));
}
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -63360,12 +63151,13 @@ static s7_pointer opt_do_any(opt_info *o)
static s7_pointer opt_do_step_1(opt_info *o)
{
/* 1 stepper (multi inits perhaps), 1 body, 1 rtn */
- opt_info *o1, *ostart;
+ opt_info *o1, *ostart, *ostep;
int32_t loop;
s7_pointer vp, old_e, result, stepper = NULL;
s7_scheme *sc;
sc = o->sc;
+ ostep = o->v[9].o1;
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = T_Let(o->v[2].p);
@@ -63383,8 +63175,8 @@ static s7_pointer opt_do_step_1(opt_info *o)
if (ostart->v[0].fb(ostart)) break;
o1 = sc->opts[++sc->pc];
o1->v[0].fp(o1);
- o1 = sc->opts[++sc->pc];
- slot_set_value(stepper, o1->v[0].fp(o1));
+ sc->pc++;
+ slot_set_value(stepper, ostep->v[0].fp(ostep));
sc->pc = loop;
}
sc->pc = o->v[1].i;
@@ -63401,19 +63193,19 @@ static s7_pointer opt_do_no_vars(opt_info *o)
{
/* no vars, no return, o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index */
opt_info *ostart;
- int32_t loop;
+ int32_t loop, len;
s7_pointer old_e;
s7_scheme *sc;
sc = o->sc;
- oo_rc(sc, o, 6, 0);
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = o->v[2].p;
+ len = o->v[3].i;
loop = ++sc->pc;
ostart = sc->opts[loop];
- if (o->v[3].i == 0)
+ if (len == 0)
{
while (true)
{
@@ -63427,7 +63219,7 @@ static s7_pointer opt_do_no_vars(opt_info *o)
{
int32_t i;
if (ostart->v[0].fb(ostart)) break;
- for (i = 0; i < o->v[3].i; i++)
+ for (i = 0; i < len; i++)
{
opt_info *o1;
o1 = sc->opts[++sc->pc];
@@ -63445,17 +63237,17 @@ static s7_pointer opt_do_no_vars(opt_info *o)
static s7_pointer opt_do_1(opt_info *o)
{
/* 1 var, 1 expr, no return */
- opt_info *o1, *ostart; /* o->v[2].p=frame, o->v[5].i=end index */
+ opt_info *o1, *ostart, *ostep; /* o->v[2].p=frame, o->v[5].i=end index */
int32_t loop;
s7_pointer vp, old_e;
s7_scheme *sc;
sc = o->sc;
- oo_rc(sc, o, 6, 0);
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = o->v[2].p;
+ ostep = o->v[9].o1;
vp = let_slots(o->v[2].p);
o1 = sc->opts[++sc->pc];
slot_set_value(vp, o1->v[0].fp(o1));
@@ -63466,19 +63258,17 @@ static s7_pointer opt_do_1(opt_info *o)
if ((o->v[8].i == 1) &&
(is_t_integer(slot_value(vp))))
{
- if (sc->opts[o->v[9].i]->v[0].fp == opt_p_ii_ss_add)
+ if (ostep->v[0].fp == opt_p_ii_ss_add)
{
s7_pointer step_val;
- opt_info *step_o;
step_val = make_mutable_integer(sc, integer(slot_value(vp)));
slot_set_value(vp, step_val);
- step_o = sc->opts[o->v[9].i];
while (true)
{
if (ostart->v[0].fb(ostart)) break;
o1 = sc->opts[++sc->pc];
o1->v[0].fp(o1);
- integer(step_val) = opt_i_ii_ss_add(step_o);
+ integer(step_val) = opt_i_ii_ss_add(ostep);
sc->pc = loop;
}
sc->pc = o->v[5].i;
@@ -63500,8 +63290,8 @@ static s7_pointer opt_do_1(opt_info *o)
if (ostart->v[0].fb(ostart)) break;
o1 = sc->opts[++sc->pc];
o1->v[0].fp(o1);
- o1 = sc->opts[++sc->pc];
- slot_set_value(vp, o1->v[0].fp(o1));
+ sc->pc++;
+ slot_set_value(vp, ostep->v[0].fp(ostep));
sc->pc = loop;
}
sc->pc = o->v[5].i;
@@ -63513,16 +63303,17 @@ static s7_pointer opt_do_1(opt_info *o)
static s7_pointer opt_do_n(opt_info *o)
{
/* 1 var, no return */
- opt_info *o1, *ostart; /* o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index */
- int32_t loop;
+ opt_info *o1, *ostart, *ostep; /* o->v[2].p=frame, o->v[3].i=body length, o->v[5].i=end index */
+ int32_t loop, len;
s7_pointer vp, old_e;
s7_scheme *sc;
sc = o->sc;
- oo_rc(sc, o, 6, 0);
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = o->v[2].p;
+ ostep = o->v[9].o1;
+ len = o->v[3].i;
vp = let_slots(o->v[2].p);
o1 = sc->opts[++sc->pc];
@@ -63530,34 +63321,35 @@ static s7_pointer opt_do_n(opt_info *o)
loop = ++sc->pc;
ostart = sc->opts[loop];
- if (o->v[3].i == 2)
+ if (len == 2)
{
+ opt_info *e1, *e2;
+ e1 = o->v[10].o1;
+ e2 = o->v[11].o1;
while (true)
{
if (ostart->v[0].fb(ostart)) break;
- o1 = sc->opts[++sc->pc];
- o1->v[0].fp(o1);
- o1 = sc->opts[++sc->pc];
- o1->v[0].fp(o1);
- o1 = sc->opts[++sc->pc];
- slot_set_value(vp, o1->v[0].fp(o1));
+ sc->pc++;
+ e1->v[0].fp(e1);
+ sc->pc++;
+ e2->v[0].fp(e2);
+ sc->pc++;
+ slot_set_value(vp, ostep->v[0].fp(ostep));
sc->pc = loop;
}
}
else
{
- while (true)
+ while (!ostart->v[0].fb(ostart))
{
int32_t i;
- if (ostart->v[0].fb(ostart))
- break;
- for (i = 0; i < o->v[3].i; i++)
+ for (i = 0; i < len; i++)
{
o1 = sc->opts[++sc->pc];
o1->v[0].fp(o1);
}
- o1 = sc->opts[++sc->pc];
- slot_set_value(vp, o1->v[0].fp(o1));
+ sc->pc++;
+ slot_set_value(vp, ostep->v[0].fp(ostep));
sc->pc = loop;
}
}
@@ -63570,17 +63362,17 @@ static s7_pointer opt_do_n(opt_info *o)
static s7_pointer opt_dotimes_2(opt_info *o)
{
/* 1 var, no return */
- opt_info *o1; /* o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index, v6.i=end if int32_t */
- int32_t loop;
+ opt_info *o1; /* o->v[2].p=frame, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index, v6.i=end if int32_t */
+ int32_t loop, len;
s7_int end;
s7_pointer vp, old_e;
s7_scheme *sc;
sc = o->sc;
- oo_rc(sc, o, 6, 0);
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = o->v[2].p;
+ len = o->v[3].i;
vp = slot_value(let_dox_slot1(o->v[2].p));
if (is_slot(let_dox_slot2_unchecked(o->v[2].p)))
@@ -63591,15 +63383,18 @@ static s7_pointer opt_dotimes_2(opt_info *o)
integer(vp) = integer(o1->v[0].fp(o1));
loop = o->v[4].i - 1;
- if (o->v[3].i == 2)
+ if (len == 2)
{
+ opt_info *e1, *e2;
+ loop++;
+ e1 = o->v[10].o1;
+ e2 = o->v[11].o1;
while (integer(vp) < end)
{
sc->pc = loop;
- o1 = sc->opts[++sc->pc];
- o1->v[0].fp(o1);
- o1 = sc->opts[++sc->pc];
- o1->v[0].fp(o1);
+ e1->v[0].fp(e1);
+ sc->pc++;
+ e2->v[0].fp(e2);
integer(vp)++;
}
}
@@ -63609,7 +63404,7 @@ static s7_pointer opt_dotimes_2(opt_info *o)
{
int32_t i;
sc->pc = loop;
- for (i = 0; i < o->v[3].i; i++)
+ for (i = 0; i < len; i++)
{
o1 = sc->opts[++sc->pc];
o1->v[0].fp(o1);
@@ -63633,7 +63428,6 @@ static s7_pointer opt_do_list_simple(opt_info *o)
s7_pointer (*fp)(opt_info *o);
sc = o->sc;
- oo_rc(sc, o, 6, 0);
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = o->v[2].p;
@@ -63661,15 +63455,13 @@ static s7_pointer opt_do_list_simple(opt_info *o)
static s7_pointer opt_do_very_simple(opt_info *o)
{
- /* like simple but step can be direct */
+ /* like simple but step can be direct, v[2].p is a let */
opt_info *o1;
s7_int end, loop;
s7_pointer vp, old_e;
s7_pointer (*f)(opt_info *o);
s7_scheme *sc;
sc = o->sc;
-
- oo_rc(sc, o, 6, 0); /* v[2].p is a let */
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = o->v[2].p;
@@ -63730,12 +63522,31 @@ static s7_pointer opt_do_very_simple(opt_info *o)
}
else
{
- while (integer(vp) < end)
+ if ((f == opt_d_7pid_ssf_nr) &&
+ (o1->v[4].d_7pid_f == float_vector_set_unchecked))
{
- f(o1);
- sc->pc = loop;
- integer(vp)++;
- }}}}
+ s7_pointer fv, ind;
+ opt_info *o2;
+ s7_double (*fd)(opt_info *o);
+ o2 = sc->opts[++loop];
+ fv = slot_value(o1->v[1].p);
+ ind = o1->v[2].p;
+ fd = o2->v[0].fd;
+ while (integer(vp) < end)
+ {
+ sc->pc = loop;
+ float_vector_set_unchecked(sc, fv, integer(slot_value(ind)), fd(o2));
+ integer(vp)++;
+ }
+ }
+ else
+ {
+ while (integer(vp) < end)
+ {
+ f(o1);
+ sc->pc = loop;
+ integer(vp)++;
+ }}}}}
sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
@@ -63750,7 +63561,6 @@ static s7_pointer opt_do_prepackaged(opt_info *o)
s7_scheme *sc;
sc = o->sc;
- oo_rc(sc, o, 6, 0);
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = o->v[2].p;
@@ -63782,12 +63592,11 @@ static s7_pointer opt_do_dpnr(opt_info *o)
s7_scheme *sc;
sc = o->sc;
- oo_rc(sc, o, 7, 0);
end = o->v[1].i;
vp = o->v[6].p;
loop = o->v[4].i;
o1 = sc->opts[loop]; /* the body */
- f = o1->v[7].fd;
+ f = o1->v[O_WRAP].fd;
while (integer(vp) < end)
{
sc->pc = loop;
@@ -63807,12 +63616,11 @@ static s7_pointer opt_do_ipnr(opt_info *o)
s7_scheme *sc;
sc = o->sc;
- oo_rc(sc, o, 7, 0);
end = o->v[1].i;
vp = o->v[6].p;
loop = o->v[4].i;
o1 = sc->opts[loop]; /* the body */
- f = o1->v[7].fi;
+ f = o1->v[O_WRAP].fi;
while (integer(vp) < end)
{
sc->pc = loop;
@@ -63822,56 +63630,26 @@ static s7_pointer opt_do_ipnr(opt_info *o)
return(NULL);
}
-static s7_pointer opt_do_ifbp(opt_info *o)
-{
- opt_info *o1;
- int32_t loop;
- s7_pointer vp;
- s7_int end;
- bool (*f)(opt_info *o);
- s7_scheme *sc;
- sc = o->sc;
-
- oo_rc(sc, o, 7, 0);
- end = o->v[1].i;
- vp = o->v[6].p;
- loop = o->v[4].i + 1;
- o1 = sc->opts[loop];
- f = o1->v[0].fb;
- while (integer(vp) < end)
- {
- sc->pc = loop;
- if (f(o1))
- {
- opt_info *o2;
- o2 = sc->opts[++sc->pc];
- o2->v[0].fp(o2);
- }
- integer(vp)++;
- }
- return(NULL);
-}
-
static s7_pointer opt_do_setpif(opt_info *o)
{
opt_info *o1;
int32_t loop;
- s7_pointer vp, val;
- s7_int end;
+ s7_pointer vp, val, slot;
+ s7_int end, arg2;
s7_scheme *sc;
sc = o->sc;
-
- oo_rc(sc, o, 5, 2);
end = o->v[1].i;
vp = o->v[6].p;
loop = o->v[4].i;
o1 = sc->opts[loop];
+ arg2 = o->v[3].i;
+ slot = o1->v[2].p;
val = make_mutable_integer(sc, integer(slot_value(o1->v[1].p)));
slot_set_value(o1->v[1].p, val);
while (integer(vp) < end)
{
- integer(val) = o1->v[4].i_ii_f(integer(slot_value(o1->v[2].p)), o1->v[3].i);
+ integer(val) = o1->v[4].i_ii_f(integer(slot_value(slot)), arg2);
integer(vp)++;
}
clear_mutable_integer(val);
@@ -63910,7 +63688,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
opt_info *opc;
s7_pointer p, end, frame = NULL, old_e, slot, stop, ind, ind_step, var;
- int32_t i, var_len, body_len, body_index, step_len, rtn_len;
+ int32_t i, var_len, body_len, body_index, step_len, rtn_len, step_pc;
bool has_set = false;
/* fprintf(stderr, "%s: %s\n", __func__, DISPLAY_80(car_x)); */
@@ -64017,7 +63795,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
(opt_arg_type(sc, cddr(var)) != init_type))
{
#if OPT_PRINT
- fprintf(stderr, "init_type: %s, but opt_arg: %s\n", DISPLAY(init_type), DISPLAY(opt_arg_type(sc, cddr(var))));
+ fprintf(stderr, "%s[%d]: init_type: %s, but opt_arg: %s\n", __func__, __LINE__, DISPLAY(init_type), DISPLAY(opt_arg_type(sc, cddr(var))));
#endif
unstack(sc); /* not pop_stack! */
sc->envir = old_e;
@@ -64094,11 +63872,13 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
}
}
+ /* opt body */
body_index = sc->pc;
for (i = 3, p = cdddr(car_x); i < len; i++, p = cdr(p))
{
opt_info *start;
start = sc->opts[sc->pc];
+ if (i < 5) opc->v[i + 7].o1 = start;
if (!cell_optimize(sc, p))
break;
oo_idp_nr_fixup(start);
@@ -64114,6 +63894,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
/* we faked up sc->envir 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
*/
+ step_pc = sc->pc;
for (p = cadr(car_x); is_pair(p); p = cdr(p))
{
s7_pointer var;
@@ -64152,12 +63933,13 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
opc->v[3].i = len - 3; /* body_len */
opc->v[4].i = rtn_len;
opc->v[5].i = sc->pc - 1;
+ opc->v[9].o1 = sc->opts[step_pc];
sc->envir = old_e;
if ((var_len == 0) && (rtn_len == 0))
{
opc->v[0].fp = opt_do_no_vars;
- return(oo_set_type_0(opc, 6));
+ return(oo_set_type_0(opc));
}
opc->v[8].i = 0;
if (body_len == 1)
@@ -64174,7 +63956,8 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
if ((var_len != 1) || (step_len != 1) || (rtn_len != 0))
{
opc->v[0].fp = ((step_len == 1) && (body_len == 1) && (rtn_len == 1)) ? opt_do_step_1 : opt_do_any;
- return(oo_set_type_0(opc, 6));
+ /* (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 */
+ return(oo_set_type_0(opc));
}
opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n;
@@ -64210,7 +63993,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
opc->v[3].i = integer(caddr(end));
o1 = sc->opts[body_index];
- /* v2, v3, v4, v5 are in use */
+ /* v0..v7 are in use */
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))) */
@@ -64226,18 +64009,11 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
}
else
{
- if (o1->v[0].fp == opt_if_bp)
+ if (o1->v[0].fp == opt_set_p_i_fo1)
{
opc->v[0].fp = opt_do_prepackaged;
- opc->v[7].fp = opt_do_ifbp;
- }
- else
- {
- if (o1->v[0].fp == opt_set_p_i_fo1)
- {
- opc->v[0].fp = opt_do_prepackaged;
- opc->v[7].fp = opt_do_setpif;
- }}}}}
+ opc->v[7].fp = opt_do_setpif;
+ }}}}
else
{
opc->v[0].fp = opt_dotimes_2;
@@ -64257,7 +64033,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
opc->v[0].fp = opt_do_list_simple;
}
}
- return(oo_set_type_0(opc, 8));
+ return(oo_set_type_0(opc));
}
static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len)
@@ -64564,8 +64340,7 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
sc->pc = pstart - 1;
if (float_optimize(sc, expr))
{
- if (oo_size(opc) < 8) oo_resize(opc, 8);
- opc->v[7].fd = opc->v[0].fd;
+ opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
return(true);
}
@@ -64580,16 +64355,10 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
if ((ifunc) &&
(int_optimize(sc, expr)))
{
- if (oo_size(opc) < 8) oo_resize(opc, 8);
- opc->v[7].fi = opc->v[0].fi;
+ opc->v[O_WRAP].fi = opc->v[0].fi;
opc->v[0].fp = i_to_p;
- if (opc->v[7].fi == opt_i_ii_ss_add)
+ if (opc->v[O_WRAP].fi == opt_i_ii_ss_add)
opc->v[0].fp = opt_p_ii_ss_add;
- else
- {
- if (opc->v[7].fi == opt_i_ii_fc_add)
- opc->v[0].fp = opt_p_ii_fc_add;
- }
return(true);
}
pc_fallback(sc, pstart);
@@ -64597,7 +64366,7 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
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_cf_pp_ok(sc, opc, s_func, car_x, pstart)))
+ (p_call_pp_ok(sc, opc, s_func, car_x, pstart)))
return(true);
}
break;
@@ -64621,8 +64390,7 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
(d_7pid_ok(sc, opc, s_func, car_x)))
{
/* if d_7pid is ok, we need d_to_p for cell_optimize */
- if (oo_size(opc) < 8) oo_resize(opc, 8);
- opc->v[7].fd = opc->v[0].fd;
+ opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
return(true);
}
@@ -64632,8 +64400,7 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
(s7_i_7pii_function(s_func)) &&
(i_7pii_ok(sc, alloc_opo(sc, expr), s_func, car_x)))
{
- if (oo_size(opc) < 8) oo_resize(opc, 8);
- opc->v[7].fi = opc->v[0].fi;
+ opc->v[O_WRAP].fi = opc->v[0].fi;
opc->v[0].fp = i_to_p;
return(true);
}
@@ -64643,7 +64410,7 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
if ((p_ppi_ok(sc, opc, s_func, car_x)) ||
(p_ppp_ok(sc, opc, s_func, car_x)) ||
- (p_cf_ppp_ok(sc, opc, s_func, car_x)))
+ (p_call_ppp_ok(sc, opc, s_func, car_x)))
return(true);
break;
@@ -64651,28 +64418,25 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
if ((head == sc->float_vector_set_symbol) &&
(d_7piid_ok(sc, opc, s_func, car_x)))
{
- if (oo_size(opc) < 8) oo_resize(opc, 8);
- opc->v[7].fd = opc->v[0].fd;
+ 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);
}
/* pc_fallback(sc, pstart); */
if (i_7piii_ok(sc, opc, s_func, car_x))
{
- if (oo_size(opc) < 8) oo_resize(opc, 8);
- opc->v[7].fi = opc->v[0].fi;
+ opc->v[O_WRAP].fi = opc->v[0].fi;
opc->v[0].fp = i_to_p;
return(true);
}
if (head == sc->int_vector_set_symbol)
return(return_false(sc, car_x, __func__, __LINE__));
- /* pc_fallback(sc, pstart); */
if (p_piip_ok(sc, opc, s_func, car_x))
return(true);
pc_fallback(sc, pstart);
default:
- if (p_cf_any_ok(sc, opc, s_func, car_x, len))
+ if (p_call_any_ok(sc, opc, s_func, car_x, len))
return(true);
break;
}
@@ -64803,10 +64567,9 @@ static bool bool_optimize(s7_scheme *sc, s7_pointer expr)
wrapper = sc->opts[start];
if (cell_optimize(sc, expr))
{
- if (wrapper->v[7].fp) /* (when (+ i 1) ...) */
+ if (wrapper->v[O_WRAP].fp) /* (when (+ i 1) ...) */
return(return_false(sc, NULL, __func__, __LINE__));
- if (oo_size(wrapper) < 8) oo_resize(wrapper, 8);
- wrapper->v[7].fp = wrapper->v[0].fp;
+ wrapper->v[O_WRAP].fp = wrapper->v[0].fp;
wrapper->v[0].fb = p_to_b;
return(true);
}
@@ -64923,7 +64686,7 @@ static s7_function s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nr)
/* ---------------------------------------- for-each ---------------------------------------- */
#if WITH_GCC
-static inline s7_pointer make_counter(s7_scheme *sc, s7_pointer iter) __attribute__((always_inline));
+static inline s7_pointer make_counter(s7_scheme *sc, s7_pointer iter) __attribute__((always_inline)); /* we're playing whack-a-mole with blasted gcc */
#endif
static inline s7_pointer make_counter(s7_scheme *sc, s7_pointer iter)
@@ -65264,7 +65027,11 @@ static bool op_for_each(s7_scheme *sc)
* here we save that ctr, call body, on rerun check ctr, if it has not changed we are safe and can reuse frame.
*/
-static bool op_for_each_1(s7_scheme *sc)
+#if WITH_GCC
+static inline bool op_for_each_1(s7_scheme *sc) __attribute__((always_inline));
+#endif
+
+static inline bool op_for_each_1(s7_scheme *sc)
{
s7_pointer counter, p, arg, code;
counter = sc->args;
@@ -65554,7 +65321,6 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
sc->z = sc->nil;
return(sc->nil);
}
- /* fprintf(stderr, "fargs: %d, len: %ld, args: %s\n", fargs, len, DISPLAY(closure_args(f))); */
if ((fargs > len) ||
((fargs < len) &&
((fargs >= 0) ||
@@ -65735,12 +65501,15 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
case OP_SAFE_CLOSURE_FP_2:
stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_CLOSURE_FP_MV_1;
goto FP_MV;
+
case OP_SAFE_C_FP_2:
stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_FP_MV_1;
goto FP_MV;
+
case OP_SAFE_C_FP_1:
case OP_SAFE_CLOSURE_FP_1:
stack_element(sc->stack, top) = (s7_pointer)(stack_op(sc->stack, top) + 1); /* replace with mv version */
+
case OP_SAFE_C_FP_MV_1:
case OP_SAFE_CLOSURE_FP_MV_1:
FP_MV:
@@ -65759,7 +65528,6 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
case OP_SAFE_C_SP_1:
case OP_SAFE_CONS_SP_1:
- case OP_SAFE_MEMQ_SP_1:
case OP_SAFE_ADD_SP_1:
case OP_SAFE_SUBTRACT_SP_1:
case OP_SAFE_MULTIPLY_SP_1:
@@ -65981,6 +65749,7 @@ 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 #<values> (see s7test) */
s7_pointer x;
bool checked = false;
@@ -66133,8 +65902,7 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
if (!is_pair(form))
{
- if ((is_symbol(form)) &&
- (!is_keyword(form)))
+ if (is_normal_symbol(form))
return(list_2(sc, sc->quote_symbol, form));
/* things that evaluate to themselves don't need to be quoted. */
return(form);
@@ -66163,7 +65931,7 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
{
s7_int len, i;
- s7_pointer orig, bq, old_scw, old_lv;
+ s7_pointer orig, bq, old_scw;
bool dotted = false;
len = s7_list_length(sc, form);
@@ -66180,11 +65948,8 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
sc->w = cons(sc, sc->nil, sc->w);
set_car(sc->w, sc->list_values_symbol);
- old_lv = sc->w;
-
if (!dotted)
{
- bool simple = true;
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 */
@@ -66202,16 +65967,7 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
break;
}
else set_car(bq, g_quasiquote_1(sc, car(orig), false));
-
-#if S7_DEBUGGING
- if (car(bq) == sc->no_value) fprintf(stderr, "%s[%d] no-values!: %s\n", __func__, __LINE__, DISPLAY(form));
-#endif
- if ((simple) &&
- ((is_pair(car(bq))) && (caar(bq) != sc->quote_symbol)))
- simple = false;
}
- if (simple)
- set_car(old_lv, sc->list_symbol);
}
else
{
@@ -66224,7 +65980,6 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
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);
@@ -66760,7 +66515,7 @@ static void read_double_quote(s7_scheme *sc)
if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value);
}
-static bool read_sharp_const(s7_scheme *sc)
+static inline bool read_sharp_const(s7_scheme *sc)
{
sc->value = port_read_sharp(sc->input_port)(sc, sc->input_port);
if (sc->value == sc->no_value)
@@ -66912,8 +66667,20 @@ static s7_pointer read_expression(s7_scheme *sc)
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);
+}
-/* ---------------- *unbound-variable-hook* ---------------- */
+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 set_file_and_line_number(s7_scheme *sc, s7_pointer p)
{
@@ -66925,6 +66692,22 @@ static void set_file_and_line_number(s7_scheme *sc, s7_pointer p)
}
}
+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 = cons(sc, sc->value, sc->nil);
+ set_file_and_line_number(sc, sc->args);
+#if WITH_PROFILE
+ profile_set_location(x, remember_location(port_line_number(pt), port_file_number(pt)));
+#endif
+ 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;
@@ -67021,11 +66804,11 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
* so the "loaded" arg tries to catch such cases
*/
e = loaded_library(sc, file);
- if (!is_let(e))
- e = s7_load(sc, file);
+ if ((!e) || (!is_let(e)))
+ e = s7_load(sc, file); /* s7_load can return NULL */
result = s7_symbol_value(sc, sym); /* calls find_symbol, does not trigger unbound_variable search */
if ((result == sc->undefined) &&
- (is_let(e)))
+ (e) && (is_let(e)))
{
result = s7_let_ref(sc, e, sym);
/* I think to be consistent we should add '(sym . result) to the global env */
@@ -67297,6 +67080,35 @@ static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t ar
return(f);
}
+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) == OP_SSA_DIRECT)) /* a tedious experiment... OP=HOP here */
+ {
+ s7_pointer val;
+ val = cadddr(expr);
+ if ((is_pair(val)) && (car(val) == sc->add_symbol) && (safe_list_length(val) == 3) &&
+ ((cadr(val) == small_int(1)) || (caddr(val) == small_int(1))))
+ {
+ s7_pointer add1;
+ add1 = (cadr(val) == small_int(1)) ? caddr(val) : cadr(val);
+ if ((is_pair(add1)) && (car(add1) == sc->or_symbol) && (safe_list_length(add1) == 3) &&
+ (caddr(add1) == small_int(0)))
+ {
+ s7_pointer or1;
+ or1 = cadr(add1);
+ if ((is_pair(or1)) && (car(or1) == sc->hash_table_ref_symbol) && (safe_list_length(or1) == 3) &&
+ (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 */
+ /* fprintf(stderr, "%s: %s %s\n", DISPLAY(expr), op_names[optimize_op(expr)], op_names[optimize_op(or1)]); */
+ set_optimize_op(expr, OP_HASH_INCREMENT);
+ }
+ }
+ }
+ }
+ return(f);
+}
+
static s7_pointer argument_type(s7_scheme *sc, s7_pointer arg1)
{
if (is_pair(arg1))
@@ -67374,6 +67186,12 @@ static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poin
arg2 = caddr(expr);
if (arg2 == small_int(1)) /* (+ ... 1) */
return(sc->add_x1);
+ if ((is_t_integer(arg1)) && ((is_pair(arg2)) && (is_optimized(arg2)) && (is_h_safe_c_d(arg2)) && (c_callee(arg2) == g_random_i)))
+ {
+ set_opt3_any(cdr(expr), cadr(arg2));
+ set_safe_optimize_op(expr, HOP_SAFE_C_D); /* op if r op? */
+ return(sc->add_i_random);
+ }
if (arg1 == small_int(1))
return(sc->add_1x);
return(chooser_check_arg_types(sc, arg1, arg2, sc->add_2,
@@ -67417,8 +67235,8 @@ static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7
arg1 = cadr(expr);
arg2 = caddr(expr);
if (arg2 == small_int(1)) return(sc->subtract_s1);
- if (is_t_real(arg1)) return(sc->subtract_f2);
- if (is_t_real(arg2)) return(sc->subtract_2f);
+ if (is_t_real(arg1)) return(sc->subtract_f2);
+ if (is_t_real(arg2)) return(sc->subtract_2f);
}
return(sc->subtract_2);
}
@@ -67673,170 +67491,6 @@ static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer f, int32_t
return(f);
}
-static s7_pointer g_or_n(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p;
- for (p = args; 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 g_or_2(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p;
- p = fx_call(sc, args);
- if (p != sc->F) return(p);
- p = cdr(args);
- return(fx_call(sc, p));
-}
-
-static s7_pointer g_or_3(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p;
- p = fx_call(sc, args);
- if (p != sc->F) return(p);
- p = cdr(args);
- p = fx_call(sc, p);
- if (p != sc->F) return(p);
- p = cddr(args);
- return(fx_call(sc, p));
-}
-
-static s7_pointer g_and_n(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p, x;
- x = sc->T;
- for (p = args; is_pair(p); p = cdr(p))
- {
- x = fx_call(sc, p);
- if (is_false(sc, x))
- return(x);
- }
- return(x);
-}
-
-static s7_pointer g_and_2(s7_scheme *sc, s7_pointer args)
-{
- if (fx_call(sc, args) == sc->F)
- return(sc->F);
- return(fx_call(sc, cdr(args)));
-}
-
-static s7_pointer g_and_3(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p;
- if (fx_call(sc, args) == sc->F)
- return(sc->F);
- p = cdr(args);
- if (fx_call(sc, p) == sc->F)
- return(sc->F);
- p = cdr(p);
- return(fx_call(sc, p));
-}
-
-static s7_pointer g_if_a_a(s7_scheme *sc, s7_pointer args)
-{
- if (is_true(sc, fx_call(sc, args)))
- return(fx_call(sc, cdr(args)));
- return(sc->unspecified);
-}
-
-static s7_pointer g_if_a_aa(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p;
- if (is_true(sc, fx_call(sc, args)))
- p = cdr(args);
- else p = cddr(args);
- return(fx_call(sc, p));
-}
-
-static s7_pointer g_if_not_a_a(s7_scheme *sc, s7_pointer args)
-{
- if (is_true(sc, c_call(args)(sc, cadar(args))))
- return(sc->unspecified);
- return(fx_call(sc, cdr(args)));
-}
-
-static s7_pointer g_if_not_a_aa(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p;
- if (is_false(sc, c_call(args)(sc, cadar(args))))
- p = cdr(args);
- else p = cddr(args);
- return(fx_call(sc, p));
-}
-
-static s7_pointer g_if_a_qq(s7_scheme *sc, s7_pointer args)
-{
- if (is_true(sc, fx_call(sc, args)))
- return(opt3_any(args));
- return(opt3_any(cdr(args)));
-}
-
-static s7_pointer g_if_a_qa(s7_scheme *sc, s7_pointer args)
-{
- if (is_true(sc, fx_call(sc, args)))
- return(opt3_any(args));
- return(fx_call(sc, cddr(args)));
-}
-
-static s7_pointer g_or_s(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p;
- set_car(sc->t1_1, lookup(sc, cadar(args)));
- for (p = args; is_pair(p); p = cdr(p))
- {
- s7_pointer x;
- x = c_call(car(p))(sc, sc->t1_1);
- if (is_true(sc, x))
- return(x);
- }
- return(sc->F);
-}
-
-static s7_pointer g_or_s_2(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer x;
- set_car(sc->t1_1, lookup(sc, cadar(args)));
- x = c_call(car(args))(sc, sc->t1_1);
- if (is_true(sc, x)) return(x);
- return(c_call(cadr(args))(sc, sc->t1_1));
-}
-
-static s7_pointer g_or_s_type_2(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer x;
- x = lookup(sc, cadar(args));
- return(make_boolean(sc, (type(x) == symbol_type(caar(args))) || (type(x) == symbol_type(caadr(args)))));
-}
-
-static s7_pointer g_and_s(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer p, x = sc->T;
- set_car(sc->t1_1, lookup(sc, cadar(args)));
- for (p = args; is_pair(p); p = cdr(p))
- {
- x = c_call(car(p))(sc, sc->t1_1);
- if (is_false(sc, x))
- return(x);
- }
- return(x);
-}
-
-static s7_pointer g_and_s_2(s7_scheme *sc, s7_pointer args)
-{
- s7_pointer x;
- set_car(sc->t1_1, lookup(sc, cadar(args)));
- x = c_call(car(args))(sc, sc->t1_1);
- if (is_false(sc, x)) return(x);
- return(c_call(cadr(args))(sc, sc->t1_1));
-}
-
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)
{
@@ -67869,6 +67523,7 @@ static void init_choosers(s7_scheme *sc)
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);
#if (!WITH_GMP)
+ 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);
@@ -67952,6 +67607,10 @@ static void init_choosers(s7_scheme *sc)
sc->random_f = make_function_with_class(sc, f, "random", g_random_f, 1, 0, false);
#endif
+ /* 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);
@@ -68005,6 +67664,7 @@ static void init_choosers(s7_scheme *sc)
/* 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-ref */
@@ -68053,6 +67713,9 @@ static void init_choosers(s7_scheme *sc)
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! */
+ f = 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);
@@ -68103,25 +67766,6 @@ static void init_choosers(s7_scheme *sc)
/* 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);
-
- sc->or_n = s7_make_function(sc, "or", g_or_n, 0, 0, true, NULL);
- sc->or_2 = s7_make_function(sc, "or", g_or_2, 2, 0, false, NULL);
- sc->or_3 = s7_make_function(sc, "or", g_or_3, 3, 0, false, NULL);
- sc->and_n = s7_make_function(sc, "and", g_and_n, 0, 0, true, NULL);
- sc->and_2 = s7_make_function(sc, "and", g_and_2, 2, 0, false, NULL);
- sc->and_3 = s7_make_function(sc, "and", g_and_3, 3, 0, false, NULL);
- sc->if_a_a = s7_make_function(sc, "if", g_if_a_a, 2, 0, false, NULL);
- sc->if_a_aa = s7_make_function(sc, "if", g_if_a_aa, 3, 0, false, NULL);
- sc->if_not_a_a = s7_make_function(sc, "if", g_if_not_a_a, 2, 0, false, NULL);
- sc->if_not_a_aa = s7_make_function(sc, "if", g_if_not_a_aa, 3, 0, false, NULL);
- sc->if_a_qq = s7_make_function(sc, "if", g_if_a_qq, 3, 0, false, NULL);
- sc->if_a_qa = s7_make_function(sc, "if", g_if_a_qa, 3, 0, false, NULL);
-
- sc->or_s = s7_make_function(sc, "or", g_or_s, 0, 0, true, NULL);
- sc->and_s = s7_make_function(sc, "and", g_and_s, 0, 0, true, NULL);
- sc->or_s_2 = s7_make_function(sc, "or", g_or_s_2, 0, 0, true, NULL);
- sc->and_s_2 = s7_make_function(sc, "and", g_and_s_2, 0, 0, true, NULL);
- sc->or_s_type_2 = s7_make_function(sc, "or", g_or_s_type_2, 0, 0, true, NULL);
}
#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr, true))
@@ -68188,16 +67832,14 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
}
if (is_symbol(closure_args(func))) /* (define* (f1 . a) ...) called (f1) -- called a closure (not closure*) in define_unchecked */
{
- set_optimized(expr);
set_opt1_lambda(expr, func);
- set_optimize_op(expr, hop + OP_THUNK_NIL);
+ set_unsafe_optimize_op(expr, hop + OP_THUNK_NIL);
return(OPT_F);
}
if (is_closure_star(func))
{
- set_optimized(expr);
set_opt1_lambda(expr, func);
- set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_0 : OP_CLOSURE_STAR_FX));
+ set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_0 : OP_CLOSURE_STAR_FX));
}
return(OPT_F);
}
@@ -68209,8 +67851,7 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1;
if ((is_safe_procedure(func)) ||
- (c_function_call(func) == g_list) || /* (list) is safe */
- (c_function_call(func) == g_values)) /* (values) is safe */
+ (c_function_call(func) == g_list)) /* (list) is safe, (values) is not (in this context -- possibly used as list-values arg) */
{
set_safe_optimize_op(expr, hop + OP_SAFE_C_D);
choose_c_function(sc, expr, func, 0);
@@ -68221,8 +67862,7 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
if (is_c_function_star(func))
{
- set_optimized(expr);
- set_optimize_op(expr, hop + OP_SAFE_C_STAR);
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_FUNCTION_STAR);
set_c_function(expr, func);
return(OPT_T);
}
@@ -68232,12 +67872,11 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
static opt_t optimize_func_dotted_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e)
{
- if (fx_count(sc, expr) == args)
+ if (fx_count(sc, expr) == args) /* fx_count starts at cdr */
{
- set_unsafely_optimized(expr);
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, small_int(args));
- set_optimize_op(expr, hop + OP_CLOSURE_ANY_FX);
+ set_unsafe_optimize_op(expr, hop + OP_CLOSURE_ANY_FX);
set_opt1_lambda(expr, func);
return(OPT_F);
}
@@ -68255,8 +67894,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
arg_op = op_no_hop(e1);
switch (arg_op)
{
- case OP_SAFE_C_S:
- return(OP_SAFE_C_opSq);
+ case OP_SAFE_C_S: return(OP_SAFE_C_opSq);
case OP_SAFE_C_D: return(OP_SAFE_C_opDq);
case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq);
case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq);
@@ -68269,8 +67907,6 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
case OP_SAFE_C_AAA: return(OP_SAFE_C_opAAAq);
/* deeper opA...q nestings are rare */
}
- /* opsq_c opsq_opsq s_opdq sss opssq? opdq opssq_s? */
- /* fprintf(stderr, "combine %s: %s\n", op_names[arg_op], DISPLAY(expr)); */
return(OP_SAFE_C_P); /* this splits out to A in optimize_func one_arg */
case E_C_SP:
@@ -68307,9 +67943,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
case OP_SAFE_C_opSSq_opSSq: return(OP_SAFE_C_S_op_opSSq_opSSqq);
case OP_SAFE_C_A: return(OP_SAFE_C_S_opAq);
case OP_SAFE_C_AA: return(OP_SAFE_C_S_opAAq);
- case OP_SAFE_C_CAC: case OP_SAFE_C_CSA: case OP_SAFE_C_SCA:
- case OP_SAFE_C_SAS: case OP_SAFE_C_SSA: case OP_SAFE_C_AAA:
- return(OP_SAFE_C_S_opAAAq);
+ case OP_SAFE_C_AAA: return(OP_SAFE_C_S_opAAAq);
}
return(OP_SAFE_C_SP); /* if fxable -> AA later */
@@ -68341,7 +67975,6 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
set_opt1_con(cdr(expr), (is_quoted_pair(cadr(e1))) ? cadadr(e1) : cadr(e1));
set_opt2_con(cdr(expr), e2);
return(OP_SAFE_C_opSq_C);
- case OP_SAFE_C_D: return(OP_SAFE_C_opDq_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_opSq: return(OP_SAFE_C_op_opSq_q_C);
@@ -68421,10 +68054,6 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
return(OP_SAFE_C_opSSq_opSq);
break;
- case OP_SAFE_C_D:
- if (optimize_op_match(e1, OP_SAFE_C_D))
- return(OP_SAFE_C_opDq_opDq);
- break;
case OP_SAFE_C_SS:
if (optimize_op_match(e1, OP_SAFE_C_SS))
return(OP_SAFE_C_opSSq_opSSq);
@@ -68437,6 +68066,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
default:
break;
}
+ /* fprintf(stderr, "%s[%d]: unopt %s\n", __func__, __LINE__, DISPLAY(expr)); */
return(OP_UNOPT);
}
@@ -68526,8 +68156,7 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin
/* c function is not safe */
if (symbols == 0)
{
- set_unsafely_optimized(expr);
- set_optimize_op(expr, hop + OP_C_A); /* OP_C_C never happens */
+ set_unsafe_optimize_op(expr, hop + OP_C_A); /* OP_C_C never happens */
annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(expr, small_int(1));
}
@@ -69165,6 +68794,10 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
if (results_fxable) set_optimized(body);
return(results_fxable);
}
+#if 0
+ if (tree_count(sc, name, body, 0) == 1)
+ fprintf(stderr, "%s[%d]: %s %d %s\n\n", __func__, __LINE__, DISPLAY(name), vars, DISPLAY(body));
+#endif
return(false);
}
@@ -69615,7 +69248,6 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer
else set_opt2_con(expr, arg1);
set_opt1_lambda(expr, func);
- /* fprintf(stderr, "%s: %s %d %d %d %d\n", __func__, DISPLAY(expr), one_form, safe_case, is_fxable(sc, car(body)), hop); */
if (one_form)
{
if (safe_case)
@@ -69623,10 +69255,27 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer
if (is_fxable(sc, car(body)))
{
annotate_arg(sc, body, e);
- if ((sym) && (optimize_op(car(body)) == HOP_SAFE_C_S) && (car(closure_args(func)) == cadar(body)))
- set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S);
- else set_safe_optimize_op(expr, hop + ((sym) ? OP_SAFE_CLOSURE_S_A : OP_SAFE_CLOSURE_C_A));
-
+ if (sym)
+ {
+ if (((optimize_op(car(body)) == HOP_SAFE_C_S) || (optimize_op(car(body)) == HOP_SAFE_C_SC)) &&
+ (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
+ {
+ set_opt3_any(cdr(expr), caddar(body));
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC);
+ }
+ }
+ else
+ {
+ if (car(closure_args(func)) == car(body))
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_ID_S);
+ else set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A);
+ }
+ }
+ else set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_C_A);
set_closure_has_fx(func);
fx_tree(sc, body, car(closure_args(func)), NULL);
return(OPT_T);
@@ -69747,8 +69396,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu
(fx_count(sc, expr) == 1))
{
if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1;
- set_optimized(expr);
- set_optimize_op(expr, hop + OP_SAFE_C_STAR_A); /* if one arg passed, it's obviously not a keyword-as-parameter-name */
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_FUNCTION_STAR_A); /* if one arg passed, it's obviously not a keyword-as-parameter-name */
annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(expr, small_int(1));
set_c_function(expr, func);
@@ -69769,7 +69417,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu
(is_keyword(arg1))))
{
/* (*s7* ...) */
- set_optimize_op(expr, OP_IMPLICIT_S7_LET_REF);
+ set_safe_optimize_op(expr, OP_IMPLICIT_S7_LET_REF);
return(OPT_F);
}
/* unknown_* is set later */
@@ -69861,20 +69509,26 @@ static void opt_sp_1(s7_scheme *sc, s7_function g, s7_pointer expr)
#if WITH_GMP
/* if...endif written this way to make cppcheck happy */
set_opt1_any(cdr(expr),
- (s7_pointer)((intptr_t)((g == g_cons) ? OP_SAFE_CONS_SP_1 :
- ((g == g_memq) ? OP_SAFE_MEMQ_SP_1 :
- OP_SAFE_C_SP_1))));
+ (s7_pointer)((intptr_t)((g == g_cons) ? OP_SAFE_CONS_SP_1 : OP_SAFE_C_SP_1)));
#else
set_opt1_any(cdr(expr),
(s7_pointer)((intptr_t)((g == g_cons) ? OP_SAFE_CONS_SP_1 :
- ((g == g_memq) ? OP_SAFE_MEMQ_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 :
- (((g == g_subtract) || (g == g_subtract_2)) ? OP_SAFE_SUBTRACT_SP_1 :
- OP_SAFE_C_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 :
+ (((g == g_subtract) || (g == g_subtract_2)) ? OP_SAFE_SUBTRACT_SP_1 :
+ OP_SAFE_C_SP_1))))));
#endif
}
+static bool safe_c_aa_to_ca(s7_scheme *sc, s7_pointer arg, int hop)
+{
+ if (c_callee(cddr(arg)) == fx_c) {set_opt3_any(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);}
+ if (c_callee(cdr(arg)) == fx_c) {set_opt3_any(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);}
+ if (c_callee(cddr(arg)) == fx_q) {set_opt3_any(arg, cadr(caddr(arg))); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);}
+ if (c_callee(cdr(arg)) == fx_q) {set_opt3_any(arg, cadadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);}
+ return(false);
+}
+
static int32_t check_lambda_1(s7_scheme *sc, 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)
@@ -69899,7 +69553,6 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
((is_symbol(arg2)) &&
(!arg_findable(sc, arg2, e))))
{
- /* fprintf(stderr, "bad: %s %s e: %s\n", DISPLAY(arg1), DISPLAY(arg2), DISPLAY(e)); */
/* wrap bad args */
if ((is_fxable(sc, arg1)) &&
(is_fxable(sc, arg2)) &&
@@ -70043,7 +69696,8 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
set_optimize_op(expr, hop + OP_SAFE_C_AA);
annotate_args(sc, cdr(expr), e);
- set_opt3_arglen(expr, small_int(2));
+ if (!safe_c_aa_to_ca(sc, expr, hop))
+ set_opt3_arglen(expr, small_int(2));
}
else
{
@@ -70103,8 +69757,9 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
(is_fxable(sc, arg1))))
{
set_safe_optimize_op(expr, hop + OP_SAFE_C_AA);
- annotate_arg(sc, cdr(expr), e);
- annotate_arg(sc, cddr(expr), e);
+ annotate_args(sc, cdr(expr), e);
+ if (!safe_c_aa_to_ca(sc, expr, hop))
+ set_opt3_arglen(expr, small_int(2));
}
else
{
@@ -70171,8 +69826,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
if ((pairs == 1) && (is_pair(arg2))) /* QC never happens */
{
- set_optimized(expr);
- set_optimize_op(expr, hop + OP_SAFE_C_CQ);
+ 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);
@@ -70182,9 +69836,10 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2)))
{
- set_optimize_op(expr, hop + OP_SAFE_C_AA);
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_AA);
annotate_args(sc, cdr(expr), e);
- set_opt3_arglen(expr, small_int(2));
+ if (!safe_c_aa_to_ca(sc, expr, hop))
+ set_opt3_arglen(expr, small_int(2));
choose_c_function(sc, expr, func, 2);
return(OPT_T);
}
@@ -70208,7 +69863,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
if (quotes == 2)
{
if (func_is_safe)
- set_optimize_op(expr, hop + OP_SAFE_C_AA);
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_AA);
else set_unsafe_optimize_op(expr, hop + OP_C_AA);
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, small_int(2));
@@ -70250,7 +69905,8 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
set_optimize_op(expr, hop + OP_SAFE_C_AA);
annotate_args(sc, cdr(expr), e);
- set_opt3_arglen(expr, small_int(2));
+ if (!safe_c_aa_to_ca(sc, expr, hop))
+ set_opt3_arglen(expr, small_int(2));
choose_c_function(sc, expr, func, 2);
return(OPT_T);
}
@@ -70314,7 +69970,8 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
set_optimize_op(expr, hop + OP_SAFE_C_AA);
annotate_args(sc, cdr(expr), e);
- set_opt3_arglen(expr, small_int(2));
+ if (!safe_c_aa_to_ca(sc, expr, hop))
+ set_opt3_arglen(expr, small_int(2));
choose_c_function(sc, expr, func, 2);
return(OPT_T);
}
@@ -70364,7 +70021,8 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
set_safe_optimize_op(expr, hop + OP_SAFE_C_AA);
annotate_args(sc, cdr(expr), e);
- set_opt3_arglen(expr, small_int(2));
+ if (!safe_c_aa_to_ca(sc, expr, hop))
+ set_opt3_arglen(expr, small_int(2));
choose_c_function(sc, expr, func, 2);
return(OPT_T);
}
@@ -70506,7 +70164,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
if (is_fxable(sc, car(body)))
{
annotate_arg(sc, body, e);
- set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_A);
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_A);
set_closure_has_fx(func);
annotate_args(sc, cdr(expr), e);
set_opt1_lambda(expr, func);
@@ -70520,8 +70178,8 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
else
{
if ((safe_case) && (is_normal_symbol(arg1)))
- set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SA);
- else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA));
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SA);
+ else set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA));
}
annotate_args(sc, cdr(expr), e);
@@ -70534,7 +70192,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
set_unsafely_optimized(expr);
annotate_arg(sc, cdr(expr), e);
- set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP));
+ set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP));
set_opt1_lambda(expr, func);
return(OPT_F);
}
@@ -70603,7 +70261,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1;
set_optimized(expr);
- set_optimize_op(expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */
+ set_optimize_op(expr, hop + OP_SAFE_C_FUNCTION_STAR_AA); /* k+c? = cc */
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, small_int(2));
set_c_function(expr, func);
@@ -70764,8 +70422,16 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
{
set_opt1_sym(cdr(expr), arg2);
set_opt2_con(cdr(expr), arg3);
+ set_opt3_any(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_any(cdr(expr), arg1);
+ set_optimize_op(expr, hop + OP_SAFE_C_CCS);
+ }
}}}}
choose_c_function(sc, expr, func, 3);
return(OPT_T);
@@ -70788,17 +70454,30 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
choose_c_function(sc, expr, func, 3);
return(OPT_T);
}
- if ((symbols == 1) &&
- (is_normal_symbol(arg3)) &&
- (is_proper_quote(sc, arg2)) &&
- (is_safe_c_s(arg1)))
+ if (symbols == 1)
{
- set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS);
- 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(arg3)) &&
+ (is_proper_quote(sc, arg2)) &&
+ (is_safe_c_s(arg1)))
+ {
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS);
+ 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_opt1_sym(cdr(expr), arg2);
+ set_opt2_con(cdr(expr), arg3);
+ set_opt3_any(cdr(expr), cadr(arg1));
+ set_optimize_op(expr, hop + OP_SAFE_C_CSC);
+ choose_c_function(sc, expr, func, 3);
+ return(OPT_T);
+ }
}
}
annotate_args(sc, cdr(expr), e);
@@ -70958,10 +70637,9 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
if (symbols == 3)
{
- set_unsafely_optimized(expr);
set_opt1_lambda(expr, func);
set_opt3_arglen(expr, small_int(3));
- set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_3S : ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_3S_P : OP_CLOSURE_3S)));
+ set_unsafe_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_3S : ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_3S_P : OP_CLOSURE_3S)));
return(OPT_F);
}
@@ -71006,8 +70684,7 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
if ((is_c_function_star(func)) &&
(fx_count(sc, expr) == 3))
{
- set_optimized(expr);
- set_optimize_op(expr, hop + OP_SAFE_C_STAR_FX);
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_FUNCTION_STAR_FX);
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, small_int(3));
set_c_function(expr, func);
@@ -71035,11 +70712,7 @@ static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer e)
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;
-
/* fprintf(stderr, "%s[%d]: %s, args: %d, bad: %d, quotes: %d\n", __func__, __LINE__, DISPLAY_80(expr), args, bad_pairs, quotes); */
-#if 0
- if (bad_pairs > quotes) return(OPT_F);
-#endif
if (quotes > 0)
{
@@ -71073,10 +70746,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer
set_safe_optimize_op(expr, hop + OP_SAFE_C_ALL_S);
else
{
- set_optimized(expr);
- if (args == 4)
- set_optimize_op(expr, hop + OP_SAFE_C_4A);
- else set_optimize_op(expr, hop + OP_SAFE_C_FX);
+ set_safe_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_FX));
annotate_args(sc, cdr(expr), e);
}
set_opt3_arglen(expr, make_permanent_integer(args));
@@ -71091,24 +70761,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer
{
s7_pointer p;
set_optimized(expr);
- if (args == 4)
- {
- if ((symbols == 3) && (pairs == 0) &&
- (!is_symbol(car(cddddr(expr)))) &&
- (arg_findable(sc, cadr(expr), e)) &&
- (arg_findable(sc, caddr(expr), e)) &&
- (arg_findable(sc, cadddr(expr), e)))
- {
- set_optimize_op(expr, hop + OP_SAFE_C_SSSC);
- set_opt2_con(cdr(expr), car(cddddr(expr)));
- set_opt1_sym(cdr(expr), caddr(expr));
- set_opt3_sym(cdr(expr), cadddr(expr));
- choose_c_function(sc, expr, func, 4);
- return(OPT_T);
- }
- set_optimize_op(expr, hop + OP_SAFE_C_4A);
- }
- else set_optimize_op(expr, hop + OP_SAFE_C_FX);
+ set_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_FX));
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, make_permanent_integer(args));
choose_c_function(sc, expr, func, args);
@@ -71176,6 +70829,15 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, make_permanent_integer(args));
set_opt1_lambda(expr, func);
+#if 0
+ if ((s7_is_equal(sc, closure_args(func), cdar(closure_body(func)))) &&
+ (is_null(cdr(closure_body(func)))))
+ fprintf(stderr, "same: %s %s\n", DISPLAY(closure_args(func)), DISPLAY(closure_body(func)));
+ /* this actually happens: closure_s_to_s in 1-arg case?
+ * perhaps 2/3 arg cases too?
+ * closure_id_any?
+ */
+#endif
if ((symbols == args) &&
(symbols_are_safe(sc, cdr(expr), e)))
@@ -71202,8 +70864,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer
(fx_count(sc, expr) == args))
{
if (is_immutable(func)) hop = 1;
- set_optimized(expr);
- set_optimize_op(expr, hop + OP_SAFE_C_STAR_FX);
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_FUNCTION_STAR_FX);
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, make_permanent_integer(args));
set_c_function(expr, func);
@@ -71594,8 +71255,6 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
}
sc->temp9 = e;
- /* fprintf(stderr, "%s: %s, e: %s\n", __func__, DISPLAY_80(expr), DISPLAY(e)); */
-
for (p = body; is_pair(p); p = cdr(p))
if ((is_pair(car(p))) &&
(!is_checked(car(p))) && /* ((typeflag & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */
@@ -71649,7 +71308,6 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
{
if (op == OP_OR)
{
- set_safe_optimize_op(expr, hop + OP_SAFE_C_D);
if (args == 2)
{
set_opt3_sym(cdr(expr), cadadr(expr));
@@ -71658,37 +71316,35 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
{
set_opt3_any(expr, small_int(symbol_type(caadr(expr))));
set_opt2_any(cdr(expr), small_int(symbol_type(caaddr(expr))));
- set_c_function(expr, sc->or_s_type_2);
+ set_safe_optimize_op(expr, OP_OR_S_TYPE_2);
}
- else set_c_function(expr, sc->or_s_2);
+ else set_safe_optimize_op(expr, OP_OR_S_2);
}
- else set_c_function(expr, sc->or_s);
}
else
{
- if (op == OP_AND)
+ if ((op == OP_AND) && (args == 2))
{
- set_safe_optimize_op(expr, hop + OP_SAFE_C_D);
- set_c_function(expr, (args == 2) ? sc->and_s_2 : sc->and_s);
+ set_opt3_sym(cdr(expr), cadadr(expr));
+ set_safe_optimize_op(expr, OP_AND_S_2);
}
}
return(OPT_F);
}
- set_safe_optimize_op(expr, hop + OP_SAFE_C_D);
-
for (p = cdr(expr); is_pair(p); p = cdr(p))
set_c_call(p, fx_choose(sc, p, e, pair_symbol_is_safe));
+ /* move this up and use fx_call? */
if (op == OP_OR)
{
if (s7_list_length(sc, cdr(expr)) == 2)
- set_c_function(expr, sc->or_2);
+ set_safe_optimize_op(expr, OP_OR_2);
else
{
if (s7_list_length(sc, cdr(expr)) == 3)
- set_c_function(expr, sc->or_3);
- else set_c_function(expr, sc->or_n);
+ set_safe_optimize_op(expr, OP_OR_3);
+ else set_safe_optimize_op(expr, OP_OR_N);
}
}
else
@@ -71696,14 +71352,12 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
if (op == OP_AND)
{
if (s7_list_length(sc, cdr(expr)) == 2)
- {
- set_c_function(expr, sc->and_2);
- }
+ set_safe_optimize_op(expr, OP_AND_2);
else
{
if (s7_list_length(sc, cdr(expr)) == 3)
- set_c_function(expr, sc->and_3);
- else set_c_function(expr, sc->and_n);
+ set_safe_optimize_op(expr, OP_AND_3);
+ else set_safe_optimize_op(expr, OP_AND_N);
}
}
else
@@ -71718,10 +71372,17 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
set_opt3_any(test, cadar(b1));
if (c_callee(b2) == fx_q)
{
- set_opt3_any(cdr(test), cadar(b2));
- set_c_function(expr, sc->if_a_qq);
+ set_safe_optimize_op(expr, OP_IF_A_CC);
+ set_opt1_any(expr, cadar(b1));
+ set_opt2_any(expr, cadar(b2));
+ return(OPT_T);
+ }
+ else
+ {
+ set_opt1_pair(expr, b1);
+ set_opt2_pair(expr, b2);
+ set_safe_optimize_op(expr, OP_IF_A_AA);
}
- else set_c_function(expr, sc->if_a_qa);
}
else
{
@@ -71729,16 +71390,27 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
(caar(test) == sc->not_symbol) &&
(is_fxable(sc, cadar(test))))
{
- set_c_call(test, fx_choose(sc, cdar(test), e, pair_symbol_is_safe));
- if (is_null(b2))
- set_c_function(expr, sc->if_not_a_a);
- else set_c_function(expr, sc->if_not_a_aa);
+ set_c_call(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_AA);
}
- else
+ else
{
- if (is_null(b2))
- set_c_function(expr, sc->if_a_a);
- else set_c_function(expr, sc->if_a_aa);
+ if ((is_pair(b2)) && (c_callee(b1) == fx_c) && (c_callee(b2) == fx_c))
+ {
+ set_safe_optimize_op(expr, OP_IF_A_CC);
+ set_opt1_any(expr, car(b1));
+ set_opt2_any(expr, car(b2));
+ return(OPT_T);
+ }
+ else
+ {
+ 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 : OP_IF_A_AA);
+ }
}
}
}
@@ -71942,10 +71614,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7
if (len == 1)
{
if (car_expr != sc->quote_symbol) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */
- {
- set_unsafe_optimize_op(expr, OP_UNKNOWN_G);
- set_opt3_ctr(expr, 0);
- }
+ set_unsafe_optimize_op(expr, OP_UNKNOWN_G);
return(OPT_F);
}
@@ -72064,7 +71733,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7
{
set_opt1_con(expr, ptrue);
set_opt2_con(expr, pfalse);
- set_safe_optimize_op(expr, OP_SAFE_IFA_SS_A);
+ set_safe_optimize_op(expr, OP_opIF_A_SSq_A);
annotate_arg(sc, cdr(car_expr), e);
annotate_arg(sc, cdr(expr), e);
return(OPT_T);
@@ -72081,19 +71750,30 @@ static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e)
#endif
for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x))
{
+ s7_pointer obj;
+ obj = car(x);
set_checked(x);
- if ((is_pair(car(x))) &&
- (!is_checked(car(x))))
+ if (is_pair(obj))
{
- if (optimize_expression(sc, car(x), hop, e, true) == OPT_OOPS)
+ if (!is_checked(obj))
{
- s7_pointer p;
- for (p = cdr(x); is_pair(p); p = cdr(p));
- if (!is_null(p))
- eval_error_no_return(sc, sc->syntax_error_symbol, "stray dot in function body: ~S", 30, code);
- return(OPT_OOPS);
+ if (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_no_return(sc, sc->syntax_error_symbol, "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_no_return(sc, sc->syntax_error_symbol, "stray dot in function body: ~S", 30, code);
@@ -72101,8 +71781,6 @@ static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e)
}
-/* ---------------------------------------- error checks ---------------------------------------- */
-
static s7_pointer check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity)
{
s7_pointer x;
@@ -72148,10 +71826,11 @@ static s7_pointer check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *ari
return(sc->F);
}
-static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, int32_t *arity)
+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))
{
@@ -72159,10 +71838,10 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, int32_t
eval_error(sc, "lambda* parameter '~S is a constant", 35, args);
if (is_symbol(args))
set_local(args);
- if (arity) (*arity) = -1;
return(args);
}
+ has_defaults = false;
top = args;
v = args;
for (i = 0, w = args; is_pair(w); i++, v = w, w = cdr(w))
@@ -72171,6 +71850,7 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, int32_t
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) ...) */
@@ -72219,6 +71899,7 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, int32_t
}
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)) ...) */
@@ -72243,9 +71924,12 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, int32_t
eval_error(sc, "lambda* :rest parameter '~A is a constant", 41, w);
if (is_symbol(w))
set_local(w);
- i = -1;
}
- if (arity) (*arity) = i;
+ else
+ {
+ if ((body) && (!has_defaults) && (is_pair(args)))
+ set_has_no_defaults(body);
+ }
return(top);
}
@@ -72540,7 +72224,6 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at
}
else /* car(x) is not syntactic ?? */
{
- /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, DISPLAY(func), DISPLAY(expr), DISPLAY(x)); */
if (expr == func) /* try to catch tail call, expr is car(x) */
{
bool follow = false;
@@ -72800,7 +72483,6 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun
clear_all_optimizations(sc, body);
else
{
- /* fprintf(stderr, "%s safe: %d, tc: %d, rec: %d, result: %d\n", DISPLAY(body), is_safe_closure_body(body), sc->got_tc, sc->got_rec, result); */
if (result >= RECUR_BODY) /* (is_safe_closure_body(body)) */
{
int32_t nvars;
@@ -72825,7 +72507,6 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun
if (check_tc(sc, func, nvars, args, car(body)))
set_safe_closure_body(body);
}
- /* fprintf(stderr, "got_rec: %d %s %d\n", sc->got_rec, op_names[optimize_op(car(body))], result); */
if ((sc->got_rec) &&
(!is_tc_op(optimize_op(car(body)))) &&
(result >= RECUR_BODY))
@@ -73129,6 +72810,9 @@ static s7_pointer check_case(s7_scheme *sc)
{
if (!keys_simple) /* x_g|i_s */
{
+#if WITH_GMP
+ if (key_type == T_INTEGER) key_type = T_BIG_INTEGER;
+#endif
if (is_symbol(car(sc->code)))
pair_set_syntax_op(form, (key_type == T_INTEGER) ? OP_CASE_S_I_S : OP_CASE_S_G_S);
else
@@ -73278,7 +72962,7 @@ static bool op_case_e_g_1(s7_scheme *sc, s7_pointer selector, bool ok)
static bool op_case_g_g(s7_scheme *sc)
{
s7_pointer x, y;
-
+#if (!WITH_GMP)
if (has_integer_keys(sc->code))
{
s7_int selector;
@@ -73306,7 +72990,7 @@ static bool op_case_g_g(s7_scheme *sc)
pop_stack(sc);
return(true);
}
-
+#endif
sc->code = cddr(sc->code);
if (is_simple(sc->value))
{
@@ -73440,13 +73124,12 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s
set_opt2_sym(cdr(sc->code), car(binding)); /* these don't collide -- cdr(code) and code */
set_opt2_pair(sc->code, cadr(binding));
- if (is_h_optimized(cadr(binding)))
+ if (is_optimized(cadr(binding)))
{
/* if (not_in_heap(form)) fprintf(stderr, "unheap %s\n", DISPLAY_80(form)); */
if (is_null(cddr(sc->code))) /* one statement body */
{
- /* fprintf(stderr, "form: %d\n", (int)form_is_safe(sc, sc->unused, cadr(sc->code), true)); */
if (optimize_op(cadr(binding)) == HOP_SAFE_C_SS)
{
/* no lt fx here, 4 s7test */
@@ -73530,7 +73213,7 @@ static s7_pointer check_let(s7_scheme *sc)
eval_error(sc, "let has no body: ~A", 19, form);
if ((!is_list(car(sc->code))) && /* (let 1 ...) */
- (!is_symbol(car(sc->code))))
+ (!is_normal_symbol(car(sc->code))))
eval_error(sc, "let variable list is messed up or missing: ~A", 45, form);
named_let = (is_symbol(car(sc->code)));
@@ -73690,7 +73373,7 @@ static s7_pointer check_let(s7_scheme *sc)
set_opt3_let(sc->code, make_permanent_let(sc, car(sc->code)));
else
{
- set_optimize_op(form, optimize_op(form) + 1);
+ set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */
set_opt3_let(sc->code, sc->nil);
}
}
@@ -73789,11 +73472,7 @@ static bool op_let1(s7_scheme *sc)
while (true)
{
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value); /* the first time (now handled above), this saves the entire let body across the evaluations -- we pick it up later */
- set_cdr(x, sc->args);
- sc->args = x;
-
+ sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code))
{
x = cdar(sc->code);
@@ -73882,10 +73561,7 @@ static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */
{
s7_pointer x;
start_let(sc);
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->code);
- set_cdr(x, sc->nil);
- sc->args = x;
+ sc->args = cons(sc, sc->code, sc->nil);
sc->code = car(sc->code);
x = cdar(sc->code);
if (has_fx(x))
@@ -74348,7 +74024,7 @@ static bool check_let_star(s7_scheme *sc)
(is_fxable(sc, cadr(sc->code))))
{
annotate_arg(sc, cdr(sc->code), sc->envir);
- pair_set_syntax_op(form, OP_LET_STAR_FX_A_OLD);
+ pair_set_syntax_op(form, OP_LET_STAR_FX_A_OLD); /* does this ever happen? */
}
}
}
@@ -74406,7 +74082,7 @@ static bool check_let_star(s7_scheme *sc)
return(true);
}
-static bool op_let_star1(s7_scheme *sc)
+static inline bool op_let_star1(s7_scheme *sc)
{
/* we can't skip (or reuse) this new frame -- we have to imitate a nested let, otherwise
* (let ((f1 (lambda (arg) (+ arg 1))))
@@ -74617,8 +74293,12 @@ static bool op_letrec1(s7_scheme *sc)
for (slot = let_slots(sc->envir); tis_slot(slot); slot = next_slot(slot))
if (is_closure(slot_value(slot)))
{
- optimize_lambda(sc, true, slot_symbol(slot), closure_args(slot_value(slot)), closure_body(slot_value(slot)));
- make_funclet(sc, slot_value(slot), slot_symbol(slot), closure_let(slot_value(slot)));
+ s7_pointer func;
+ 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));
+ make_funclet(sc, func, slot_symbol(slot), closure_let(func));
}
sc->code = T_Pair(cdr(sc->code));
@@ -74679,7 +74359,11 @@ static bool op_letrec_star1(s7_scheme *sc)
for (slot = let_slots(sc->envir); tis_slot(slot); slot = next_slot(slot))
if (is_closure(slot_value(slot)))
{
- optimize_lambda(sc, true, slot_symbol(slot), closure_args(slot_value(slot)), closure_body(slot_value(slot)));
+ s7_pointer func;
+ 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));
make_funclet(sc, slot_value(slot), slot_symbol(slot), closure_let(slot_value(slot)));
}
@@ -74815,8 +74499,9 @@ static bool op_let_temp_init1(s7_scheme *sc)
return(false);
}
-typedef enum {goto_start, goto_begin, fall_through, goto_do_end_clauses, goto_safe_do_end_clauses, goto_eval,
- goto_top_no_pop, goto_apply, goto_eval_args, goto_eval_args_top, goto_do_unchecked, goto_pop_read_list, goto_read_tok} goto_t;
+typedef enum {goto_start, goto_begin, fall_through, goto_do_end_clauses, goto_safe_do_end_clauses,
+ goto_eval, goto_apply_lambda, goto_unopt, 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)
{
@@ -74926,7 +74611,7 @@ static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_po
eval(sc, OP_LET_TEMP_DONE);
}
-static void op_let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value)
+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) */
slot_set_value(slot, s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value)));
@@ -75002,6 +74687,27 @@ static void op_let_temp_setter(s7_scheme *sc)
sc->code = cdr(sc->code);
}
+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)
@@ -75064,7 +74770,7 @@ static bool check_and(s7_scheme *sc)
}
else
{
- pair_set_syntax_op(form, (any_nils > 0) ? OP_AND_P : OP_AND_SAFE_P);
+ pair_set_syntax_op(form, (any_nils > 0) ? OP_AND_P : OP_AND_N);
if ((any_nils == 1) && (len > 2))
{
if (!has_fx(sc->code))
@@ -75113,23 +74819,10 @@ static void op_and_safe_aa(s7_scheme *sc)
sc->value = fx_call(sc, cdr(sc->code));
}
-static void op_and_safe_p(s7_scheme *sc)
-{
- while (true)
- {
- sc->value = fx_call(sc, sc->code);
- if (is_false(sc, sc->value))
- return;
- sc->code = cdr(sc->code);
- if (is_null(sc->code))
- return;
- }
-}
-
static void op_and_safe_p1(s7_scheme *sc) /* sc->code: (and (func...) (fx...)...) */
{
sc->code = cdr(sc->code);
- push_stack_no_args(sc, OP_AND_SAFE_P_REST, cdr(sc->code));
+ push_stack_no_args(sc, OP_AND_SAFE_P_REST, sc->code);
sc->code = car(sc->code);
}
@@ -75138,7 +74831,7 @@ 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(sc, OP_AND_SAFE_P_REST, cdr(sc->code));
+ push_stack_no_args(sc, OP_AND_SAFE_P_REST, sc->code);
sc->code = car(sc->code);
return(false);
}
@@ -75182,9 +74875,9 @@ static bool check_or(s7_scheme *sc)
eval_error_no_return(sc, sc->syntax_error_symbol, "or: stray dot?: ~A", 18, form);
if ((c_callee(sc->code)) &&
- (is_proper_list_1(sc, cdr(sc->code))))
+ (is_proper_list_1(sc, cdr(sc->code)))) /* list_1 of cdr so there are 2 exprs */
pair_set_syntax_op(form, (any_nils) ? OP_OR_AP : OP_OR_SAFE_AA);
- else pair_set_syntax_op(form, OP_OR_P);
+ else pair_set_syntax_op(form, (any_nils) ? OP_OR_P : OP_OR_N);
sc->code = form;
return(false);
}
@@ -75210,10 +74903,11 @@ static void op_or_safe_aa(s7_scheme *sc)
/* -------------------------------- if -------------------------------- */
#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)
+static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool reversed) /* cdr(form) == sc->code */
{
s7_pointer test;
bool not_case = false;
+
test = car(sc->code);
if ((!reversed) &&
(is_pair(test)) &&
@@ -75224,29 +74918,26 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re
test = cadr(test);
}
+ set_opt1_any(form, cadr(sc->code));
+ if (!one_branch) set_opt2_any(form, caddr(sc->code));
+
+ /* perhaps: assume "normal" case and choose pf fp pp from fxable
+ * cfx-counts
+ * if_a_f_p [(hash 1.5M, sndtest 300k lg 1.2M)] | p_f (test, lg 700k)
+ * if_is_type_s_p_f [(hash 500k lg 400k)] | f_p (b 300k)
+ * if_and2_p_f (index 90k)
+ * if_or2_p_f (b 200k)
+ * if_s_p_f [(lg 2M)]
+ * if_opsq_n_n (lg 500k)
+ */
+
/* [and2 tset > 5% 3088->3268][is_type titer 2836->2931][cs fb 2694->2720] */
if (is_pair(test))
{
- if (is_h_optimized(test))
+ if (is_optimized(test))
{
- if (is_h_safe_c_d(test))
+ if (is_h_safe_c_d(test)) /* replace these with fx_and* */
{
- if (c_callee(test) == g_and_2)
- {
- clear_has_fx(sc->code);
- pair_set_syntax_op(form, choose_if_optc(IF_AND2, one_branch, reversed, not_case));
- set_opt2_pair(sc->code, cdr(test));
- set_opt3_pair(sc->code, cddr(test));
- return;
- }
- if (c_callee(test) == g_or_2)
- {
- clear_has_fx(sc->code);
- pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case));
- set_opt2_pair(sc->code, cdr(test));
- set_opt3_pair(sc->code, cddr(test));
- return;
- }
pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case));
if (not_case)
set_c_call(cdar(sc->code), fx_choose(sc, cdar(sc->code), sc->envir, let_symbol_is_safe));
@@ -75262,6 +74953,14 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re
{
pair_set_syntax_op(form, choose_if_optc(IF_IS_TYPE_S, one_branch, reversed, not_case));
set_opt3_byte(sc->code, typ);
+
+ if ((optimize_op(form) == OP_IF_IS_TYPE_S_P_P) &&
+ (is_fxable(sc, caddr(sc->code))))
+ {
+ pair_set_syntax_op(form, OP_IF_IS_TYPE_S_P_A);
+ annotate_arg(sc, cddr(sc->code), sc->envir);
+ set_opt2_any(form, cddr(sc->code));
+ }
}
else pair_set_syntax_op(form, choose_if_optc(IF_opSq, one_branch, reversed, not_case));
clear_has_fx(sc->code);
@@ -75271,10 +74970,41 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re
if (is_fxable(sc, test))
{
/* if (one_branch) fprintf(stderr, "%s\n", DISPLAY_80(sc->code)); */
+
+ if (optimize_op(test) == OP_OR_2)
+ {
+ pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case));
+ set_opt2_pair(sc->code, cdr(test));
+ set_opt3_pair(sc->code, cddr(test));
+ return;
+ }
+ if (optimize_op(test) == OP_AND_2)
+ {
+ pair_set_syntax_op(form, choose_if_optc(IF_AND2, one_branch, reversed, not_case));
+ set_opt2_pair(sc->code, cdr(test));
+ set_opt3_pair(sc->code, cddr(test));
+ return;
+ }
+ if (optimize_op(test) == OP_AND_3)
+ {
+ pair_set_syntax_op(form, choose_if_optc(IF_AND3, one_branch, reversed, not_case));
+ set_opt2_pair(sc->code, cdr(test));
+ set_opt3_pair(sc->code, cddr(test));
+ set_opt1_pair(sc->code, cdddr(test));
+ return;
+ }
+
pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case));
if (not_case)
set_c_call(cdar(sc->code), fx_choose(sc, cdar(sc->code), sc->envir, let_symbol_is_safe));
else set_c_call(sc->code, fx_choose(sc, sc->code, sc->envir, let_symbol_is_safe));
+ if ((optimize_op(form) == OP_IF_A_P_P) &&
+ (is_fxable(sc, cadr(sc->code))))
+ {
+ pair_set_syntax_op(form, OP_IF_A_A_P);
+ annotate_arg(sc, cdr(sc->code), sc->envir);
+ set_opt1_any(form, cdr(sc->code));
+ }
}
else
{
@@ -75302,7 +75032,7 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re
new_op = symbol_syntax_op_checked(test);
sc->code = old_code;
if ((new_op == OP_AND_P) || (new_op == OP_AND_AP) || (new_op == OP_AND_PAIR_P) || (new_op == OP_AND_SAFE_AA) ||
- (new_op == OP_AND_SAFE_P) || (new_op == OP_AND_SAFE_P1) || (new_op == OP_AND_SAFE_P2) || (new_op == OP_AND_SAFE_P3))
+ (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(sc->code, (one_branch) ? cadr(sc->code) : cdr(sc->code));
@@ -75321,13 +75051,26 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re
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) fprintf(stderr, "if_s: %s\n", DISPLAY_80(form)); */
+ pair_set_syntax_op(form, choose_if_optc(IF_S, one_branch, reversed, not_case));
+ if ((optimize_op(form) == OP_IF_S_P_P) &&
+ (is_fxable(sc, caddr(sc->code))))
+ {
+ pair_set_syntax_op(form, OP_IF_S_P_A);
+ annotate_arg(sc, cddr(sc->code), sc->envir);
+ set_opt2_any(form, cddr(sc->code));
+ }
+ }
+ else /* (if #f #f) */
+ {
+ if ((test == sc->F) && (one_branch) && (cadr(sc->code) == sc->F) && (!not_case))
+ set_safe_optimize_op(form, OP_UNSPECIFIED);
+ }
}
}
-/* (cond <> (else <>)) only happens in old-fashioned code, so set_if_opts covers if/when/unless but not cond
- * g_and_3 and g_or_3 are slightly slower here??
- */
+/* (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)
{
@@ -75424,9 +75167,16 @@ static s7_pointer check_when(s7_scheme *sc)
if (is_fxable(sc, test))
{
pair_set_syntax_op(form, OP_WHEN_A);
- set_opt2_con(form, cadr(sc->code));
- set_opt3_pair(form, cddr(sc->code));
- set_c_call(sc->code, fx_choose(sc, sc->code, sc->envir, let_symbol_is_safe));
+ if (is_pair(car(sc->code))) set_opt2_pair(form, cdar(sc->code));
+ set_opt3_pair(form, cdr(sc->code));
+ set_c_call(sc->code, fx_choose(sc, sc->code, sc->envir, let_symbol_is_safe)); /* "A" in when_a */
+ if (c_callee(sc->code) == fx_and_2)
+ pair_set_syntax_op(form, OP_WHEN_AND_2);
+ else
+ {
+ if (c_callee(sc->code) == fx_and_3)
+ pair_set_syntax_op(form, OP_WHEN_AND_3);
+ }
}
else
{
@@ -75471,8 +75221,35 @@ static bool op_when_a(s7_scheme *sc)
set_current_code(sc, sc->code);
if (is_true(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) */
+ push_stack_no_args(sc, sc->begin_op, 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_2(s7_scheme *sc)
+{
+ set_current_code(sc, sc->code);
+ 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, 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_3(s7_scheme *sc)
+{
+
+ set_current_code(sc, sc->code);
+ 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, cdr(opt3_pair(sc->code))); /* cdddr(sc->code) */
+ sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */
return(false);
}
sc->value = sc->unspecified;
@@ -75645,7 +75422,6 @@ static s7_pointer check_define(s7_scheme *sc)
{
s7_pointer func, caller, form;
bool starred;
- int32_t arity = CLOSURE_ARITY_NOT_SET;
form = sc->code;
sc->code = cdr(sc->code);
@@ -75699,11 +75475,11 @@ static s7_pointer check_define(s7_scheme *sc)
/* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */
if (!is_pair(cdadr(sc->code))) /* (define x (lambda . 1)) */
eval_error_with_caller(sc, "~A: stray dot? ~A", 17, caller, form);
- if (!is_pair(cddr(cadr(sc->code)))) /* (define (f (arg))) or (define f (lambda (arg))) */
+ if (!is_pair(cddr(cadr(sc->code)))) /* (define f (lambda (arg))) */
eval_error_with_caller(sc, "~A: no body: ~A", 15, caller, form);
if (caadr(sc->code) == sc->lambda_star_symbol)
- check_lambda_star_args(sc, cadadr(sc->code), &arity);
- else check_lambda_args(sc, cadadr(sc->code), &arity);
+ check_lambda_star_args(sc, cadadr(sc->code), cddr(cadr(sc->code)));
+ else check_lambda_args(sc, cadadr(sc->code), NULL);
optimize_lambda(sc, caadr(sc->code) == sc->lambda_symbol, func, cadadr(sc->code), cddr(cadr(sc->code)));
}
}
@@ -75719,8 +75495,8 @@ static s7_pointer check_define(s7_scheme *sc)
set_local(func);
}
if (starred)
- set_cdar(sc->code, check_lambda_star_args(sc, cdar(sc->code), &arity));
- else check_lambda_args(sc, cdar(sc->code), &arity);
+ set_cdar(sc->code, check_lambda_star_args(sc, cdar(sc->code), cdr(sc->code)));
+ else check_lambda_args(sc, cdar(sc->code), NULL);
optimize_lambda(sc, !starred, func, cdar(sc->code), cdr(sc->code));
}
@@ -75745,20 +75521,14 @@ static s7_pointer check_define(s7_scheme *sc)
static bool op_define_unchecked(s7_scheme *sc)
{
+ set_current_code(sc, sc->code);
+ sc->code = cdr(sc->code);
+
if (sc->cur_op == OP_DEFINE_STAR_UNCHECKED) /* sc->cur_op changed above if define* */
{
- s7_pointer x;
uint64_t typ;
if (is_pair(cdar(sc->code))) typ = T_CLOSURE_STAR | closure_bits(cdr(sc->code)); else typ = T_CLOSURE;
- new_cell(sc, x, typ);
- closure_set_args(x, cdar(sc->code));
- closure_set_body(x, cdr(sc->code));
- if (is_pair(cddr(sc->code))) set_closure_has_multiform(x); else set_closure_has_one_form(x);
- closure_set_let(x, sc->envir);
- closure_set_arity(x, CLOSURE_ARITY_NOT_SET);
- closure_set_setter(x, sc->F);
- sc->capture_let_counter++;
- sc->value = x;
+ sc->value = make_closure(sc, cdar(sc->code), cdr(sc->code), typ, CLOSURE_ARITY_NOT_SET);
sc->code = caar(sc->code);
return(false);
}
@@ -75774,7 +75544,6 @@ static bool op_define_unchecked(s7_scheme *sc)
sc->cur_op = optimize_op(sc->code);
return(true);
}
-
if (is_symbol(sc->code))
sc->value = lookup_global(sc, sc->code);
else sc->value = sc->code;
@@ -75909,6 +75678,16 @@ static bool op_define_constant(s7_scheme *sc)
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 */
@@ -75940,7 +75719,7 @@ static void op_define_constant1(s7_scheme *sc)
}
}
-static void define_funchecked(s7_scheme *sc)
+static inline void define_funchecked(s7_scheme *sc)
{
s7_pointer new_func, code, slot;
/* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */
@@ -76074,15 +75853,33 @@ static bool op_define_macro(s7_scheme *sc)
static bool op_macro_d(s7_scheme *sc)
{
sc->value = lookup(sc, car(sc->code));
- if (!is_macro(sc->value))
+ if (!is_macro(sc->value)) /* for-each (etc) called a macro before, now it's something else -- a very rare case */
+ {
+ set_unsafe_optimize_op(sc->code, OP_PAIR_SYM);
+ return(true);
+ }
+ sc->args = copy_list(sc, cdr(sc->code));
+ sc->code = sc->value; /* the macro */
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ new_frame(sc, closure_let(sc->code), sc->envir);
+ return(false);
+}
+
+static void apply_macro_star_1(s7_scheme *sc);
+
+static bool op_macro_star_d(s7_scheme *sc)
+{
+ sc->value = lookup(sc, car(sc->code));
+ if (!is_macro_star(sc->value))
{
- set_optimize_op(sc->code, OP_PAIR_SYM);
+ set_unsafe_optimize_op(sc->code, OP_PAIR_SYM);
return(true);
}
- sc->args = copy_list_with_arglist_error(sc, cdr(sc->code));
+ sc->args = copy_list(sc, cdr(sc->code));
sc->code = sc->value;
push_stack_op_let(sc, OP_EVAL_MACRO);
new_frame(sc, closure_let(sc->code), sc->envir);
+ apply_macro_star_1(sc);
return(false);
}
@@ -76168,46 +75965,147 @@ static goto_t op_expansion(s7_scheme *sc)
clear_expansion(symbol);
else
{
+ /* call the reader macro */
sc->args = copy_list(sc, cdr(sc->value));
- return(goto_apply);
+ push_stack_no_code(sc, OP_EXPANSION, sc->nil);
+ new_frame(sc, closure_let(sc->code), sc->envir);
+ 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 bool op_macroexpand(s7_scheme *sc)
+static void macroexpand_c_macro(s7_scheme *sc)
+{
+ s7_int len;
+ len = safe_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:
+ new_frame(sc, closure_let(sc->code), sc->envir);
+ return(goto_apply_lambda);
+
+ case T_BACRO:
+ new_frame(sc, sc->envir, sc->envir);
+ return(goto_apply_lambda);
+
+ case T_MACRO_STAR:
+ new_frame(sc, closure_let(sc->code), sc->envir);
+ apply_macro_star_1(sc);
+ return(goto_begin);
+
+ case T_BACRO_STAR:
+ new_frame(sc, sc->envir, sc->envir);
+ apply_macro_star_1(sc);
+ return(goto_begin);
+
+ case T_C_MACRO:
+ macroexpand_c_macro(sc);
+ return(goto_start);
+
+ default:
+ eval_error_no_return(sc, sc->syntax_error_symbol, "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)
{
set_current_code(sc, sc->code);
sc->code = cdr(sc->code);
- /* mimic APPLY above, but don't push OP_EVAL_MACRO or OP_EXPANSION
+ /* 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, sc->code);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "macroexpand argument is not a macro call: ~A", 44, sc->code);
if (!is_null(cdr(sc->code)))
- eval_error(sc, "macroexpand: too many arguments: ~A", 35, sc->code);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "macroexpand: too many arguments: ~A", 35, sc->code);
if (is_pair(caar(sc->code))) /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */
{
push_stack_no_args(sc, OP_MACROEXPAND_1, sc->code);
sc->code = caar(sc->code);
- return(true); /* goto EVAL */
+ return(goto_eval);
}
sc->args = copy_list(sc, cdar(sc->code)); /* apply_lambda reuses args as slots, and these have not been copied yet */
if (!is_symbol(caar(sc->code)))
- eval_error(sc, "macroexpand argument is not a macro call: ~A", 44, sc->code);
+ eval_error_no_return(sc, sc->syntax_error_symbol, "macroexpand argument is not a macro call: ~A", 44, sc->code);
sc->code = lookup_checked(sc, caar(sc->code));
- return(false);
+ return(macroexpand(sc));
}
-static void eval_args_expand_macro(s7_scheme *sc)
+static goto_t op_macroexpand_1(s7_scheme *sc)
{
- sc->args = copy_list_with_arglist_error(sc, cdr(sc->code));
- if (is_macro(sc->value))
- set_optimize_op(sc->code, OP_MACRO_D);
+ sc->args = copy_list(sc, 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(safe_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);
+ }
}
@@ -76252,7 +76150,7 @@ static bool op_with_let_unchecked(s7_scheme *sc)
return(true);
}
-static s7_pointer op_with_let_s(s7_scheme *sc)
+static inline s7_pointer op_with_let_s(s7_scheme *sc)
{
s7_pointer e;
set_current_code(sc, sc->code);
@@ -76283,7 +76181,7 @@ static s7_pointer op_with_let_s(s7_scheme *sc)
/* -------------------------------- cond -------------------------------- */
static s7_pointer check_cond(s7_scheme *sc)
{
- bool has_feed_to = false;
+ bool has_feed_to = false, result_fx = true;
s7_pointer x, form;
form = sc->code;
@@ -76325,13 +76223,12 @@ static s7_pointer check_cond(s7_scheme *sc)
p = car(x);
if (is_fxable(sc, car(p)))
annotate_arg(sc, p, sc->envir);
-#if 1
- if ((is_pair(cdr(p))) &&
- (is_fxable(sc, cadr(p))))
- annotate_arg(sc, cdr(p), sc->envir);
-#else
- annotate_args(sc, cdr(p), sc->envir);
-#endif
+ for (p = cdr(p); is_pair(p); p = cdr(p))
+ {
+ s7_function f;
+ f = fx_choose(sc, p, sc->envir, let_symbol_is_safe);
+ if (f) set_c_call(p, f); else result_fx = false;
+ }
}
if (has_feed_to)
@@ -76371,22 +76268,18 @@ static s7_pointer check_cond(s7_scheme *sc)
if (xopt)
{
bool eopt = true;
-
- pair_set_syntax_op(form, OP_COND_FX);
- if (i == 2)
- pair_set_syntax_op(form, OP_COND_FX_2);
+ pair_set_syntax_op(form, (result_fx) ? OP_COND_FX_FX : OP_COND_FX_FP);
for (p = sc->code; eopt && (is_pair(p)); p = cdr(p))
eopt = is_null(cddar(p));
if (eopt)
{
- pair_set_syntax_op(form, OP_COND_FX_P);
if (i == 2)
{
p = caadr(sc->code);
if ((p == sc->else_symbol) ||
(p == sc->T))
- pair_set_syntax_op(form, OP_COND_FX_1P_ELSE);
+ pair_set_syntax_op(form, OP_COND_FX_2E);
}
else
{
@@ -76395,7 +76288,7 @@ static s7_pointer check_cond(s7_scheme *sc)
p = caaddr(sc->code);
if ((p == sc->else_symbol) ||
(p == sc->T))
- pair_set_syntax_op(form, OP_COND_FX_2P_ELSE);
+ pair_set_syntax_op(form, OP_COND_FX_3E);
}
}
}
@@ -76428,7 +76321,7 @@ static bool op_cond_unchecked(s7_scheme *sc)
return(true);
}
-static bool op_cond_simple(s7_scheme *sc)
+static bool op_cond_simple(s7_scheme *sc) /* no => */
{
set_current_code(sc, sc->code);
sc->code = cdr(sc->code);
@@ -76442,7 +76335,7 @@ static bool op_cond_simple(s7_scheme *sc)
return(true);
}
-static bool op_cond_simple_p(s7_scheme *sc)
+static bool op_cond_simple_p(s7_scheme *sc) /* no =>, no null or multiform consequent */
{
set_current_code(sc, sc->code);
sc->code = cdr(sc->code);
@@ -76601,116 +76494,80 @@ static bool op_cond1_simple_p(s7_scheme *sc)
}
}
-static bool op_cond_fx(s7_scheme *sc)
+static bool op_cond_fx_fp(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))
{
- sc->value = fx_call(sc, car(p));
- if (is_true(sc, sc->value))
+ if (is_true(sc, fx_call(sc, car(p))))
{
- sc->code = T_Pair(cdar(p));
- if (has_fx(sc->code))
- {
- sc->value = fx_call(sc, sc->code);
- sc->code = cdr(sc->code); /* check for following exprs */
- return(!is_pair(sc->code));
- }
- return(false); /* goto begin */
+ 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_FP_1, cdr(p));
+ sc->code = car(p);
+ return(false);
+ }
+ }
+ return(true);
}
}
sc->value = sc->unspecified;
return(true);
}
-static bool op_cond_fx_2(s7_scheme *sc)
+static bool op_cond_fx_fp_1(s7_scheme *sc) /* continuing to handle a multi-statement result from cond_fx_fp */
{
s7_pointer p;
- p = cdr(sc->code);
- sc->value = fx_call(sc, car(p));
- if (!is_true(sc, sc->value))
+ for (p = sc->code; is_pair(p); p = cdr(p))
{
- p = cdr(p);
- sc->value = fx_call(sc, car(p));
- if (!is_true(sc, sc->value))
+ if (has_fx(T_Pair(p)))
+ sc->value = fx_call(sc, p);
+ else
{
- sc->value = sc->unspecified;
- return(true);
+ if (is_pair(cdr(p)))
+ push_stack_no_args(sc, OP_COND_FX_FP_1, cdr(p));
+ sc->code = car(p);
+ return(false);
}
}
- sc->code = T_Pair(cdar(p));
- if (has_fx(sc->code))
- {
- sc->value = fx_call(sc, sc->code);
- sc->code = cdr(sc->code);
- return(!is_pair(sc->code));
- }
- return(false);
+ return(true);
}
-static inline bool fx_cond_value(s7_scheme *sc)
+static inline bool fx_cond_value(s7_scheme *sc, s7_pointer p)
{
- if (has_fx(T_Pair(sc->code)))
+ if (has_fx(p))
{
- sc->value = fx_call(sc, sc->code);
+ sc->value = fx_call(sc, p);
return(true);
}
- sc->code = car(sc->code);
+ sc->code = car(p);
return(false);
}
-static bool op_cond_fx_p(s7_scheme *sc)
-{
- s7_pointer p;
- /* set_current_code(sc, sc->code); */
- for (p = cdr(sc->code); is_pair(p); p = cdr(p))
- {
- sc->value = fx_call(sc, car(p));
- if (is_true(sc, sc->value))
- {
- sc->code = T_Lst(cdar(p));
- return(fx_cond_value(sc));
- }
- }
- sc->value = sc->unspecified;
- return(true);
-}
-
-static bool op_cond_fx_1p_else(s7_scheme *sc)
+static bool op_cond_fx_2e(s7_scheme *sc)
{
s7_pointer p;
p = cdr(sc->code);
- sc->value = fx_call(sc, car(p));
- if (is_true(sc, sc->value))
- sc->code = T_Pair(cdar(p));
- else
- {
- sc->code = cdadr(p);
- sc->value = sc->else_symbol;
- }
- return(fx_cond_value(sc));
+ if (is_true(sc, fx_call(sc, car(p))))
+ return(fx_cond_value(sc, cdar(p)));
+ return(fx_cond_value(sc, cdadr(p)));
}
-static bool op_cond_fx_2p_else(s7_scheme *sc)
+static bool op_cond_fx_3e(s7_scheme *sc)
{
s7_pointer p;
p = cdr(sc->code);
- sc->value = fx_call(sc, car(p));
- if (is_true(sc, sc->value))
- sc->code = T_Pair(cdar(p));
- else
- {
- p = cdr(p);
- sc->value = fx_call(sc, car(p));
- if (is_true(sc, sc->value))
- sc->code = T_Pair(cdar(p));
- else
- {
- sc->code = cdadr(p);
- sc->value = sc->else_symbol; /* in case (else) */
- }
- }
- return(fx_cond_value(sc));
+ if (is_true(sc, fx_call(sc, car(p))))
+ return(fx_cond_value(sc, cdar(p)));
+ p = cdr(p);
+ if (is_true(sc, fx_call(sc, car(p))))
+ return(fx_cond_value(sc, cdar(p)));
+ return(fx_cond_value(sc, cdadr(p)));
}
static bool op_cond_feed(s7_scheme *sc)
@@ -76982,7 +76839,7 @@ static inline s7_pointer check_set(s7_scheme *sc)
pair_set_syntax_op(form, OP_SET_SYMBOL_P);
if (is_optimized(value))
{
- if (is_h_safe_c_d(value))
+ if (optimize_op(value) == HOP_SAFE_C_D)
{
pair_set_syntax_op(form, OP_SET_SYMBOL_A);
annotate_arg(sc, cdr(sc->code), sc->envir);
@@ -77098,7 +76955,7 @@ static void op_set_symbol_a(s7_scheme *sc)
slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code)));
}
-static void op_set_cons(s7_scheme *sc)
+static inline void op_set_cons(s7_scheme *sc)
{
s7_pointer slot;
slot = symbol_to_slot(sc, cadr(sc->code));
@@ -77139,7 +76996,7 @@ static void op_increment_sa(s7_scheme *sc)
slot_set_value(slot, sc->value = c_call(cadr(sc->code))(sc, sc->t2_1));
}
-static void op_set_pair_a(s7_scheme *sc)
+static inline void op_set_pair_a(s7_scheme *sc)
{
s7_pointer obj, val, setter;
sc->code = cdr(sc->code);
@@ -77171,7 +77028,7 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
{
if (is_slot(obj))
obj = slot_value(obj);
- else eval_error(sc, "no generalized set for ~A", 25, caar(sc->code));
+ else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(obj)]));
switch (type(obj))
{
@@ -77295,7 +77152,7 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
return(true); /* goto APPLY; */
}
}
- else eval_error(sc, "no generalized set for ~A", 25, obj);
+ else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(obj)]));
break;
case T_MACRO: case T_MACRO_STAR:
@@ -77318,11 +77175,11 @@ static bool set_pair_p_3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_point
return(true); /* goto APPLY; */
}
}
- else eval_error(sc, "no generalized set for ~A", 25, obj);
+ else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(obj)]));
break;
default: /* (set! (1 2) 3) */
- eval_error(sc, "no generalized set for ~A", 25, obj);
+ s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(obj)]));
}
return(false);
}
@@ -77403,7 +77260,7 @@ static s7_pointer op_set1(s7_scheme *sc)
else
{
sc->args = list_3(sc, sc->code, sc->value, sc->envir);
- push_stack(sc, OP_SET_WITH_SETTER, sc->args, lx); /* op, args, code */
+ push_stack(sc, OP_SET_FROM_SETTER, sc->args, lx); /* op, args, code */
sc->code = func;
return(NULL);
}
@@ -77419,7 +77276,7 @@ static s7_pointer op_set1(s7_scheme *sc)
else
{
sc->args = list_2(sc, sc->code, sc->value);
- push_stack(sc, OP_SET_WITH_SETTER, sc->args, lx); /* op, args, code */
+ push_stack(sc, OP_SET_FROM_SETTER, sc->args, lx); /* op, args, code */
sc->code = func;
return(NULL);
}
@@ -77503,6 +77360,13 @@ static s7_pointer op_set2(s7_scheme *sc)
return(NULL); /* i.e. goto SET1 */
}
+static void op_set_from_setter(s7_scheme *sc)
+{
+ if (is_immutable(sc->code))
+ immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sc->code));
+ slot_set_value(sc->code, sc->value);
+}
+
static bool op_set_with_let_1(s7_scheme *sc)
{
s7_pointer e, b, x;
@@ -77756,7 +77620,6 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form)
return(goto_top_no_pop);
}
- /* fprintf(stderr, "%s: %s %ld %ld\n", __func__, DISPLAY(form), argnum, vector_rank(cx)); */
if ((argnum > 1) || (vector_rank(cx) > 1))
{
if ((argnum == 2) &&
@@ -78143,7 +78006,7 @@ static goto_t set_implicit_function(s7_scheme *sc, s7_pointer cx) /* (let ((lst
sc->code = c_function_setter(cx);
return(goto_apply);
}
- eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code));
+ s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(cx)]));
}
sc->cur_op = optimize_op(sc->code);
return(goto_top_no_pop);
@@ -78183,7 +78046,7 @@ static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer cx)
sc->code = setter;
return(goto_apply);
}
- eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code));
+ s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(cx)]));
}
sc->cur_op = optimize_op(sc->code);
return(goto_top_no_pop);
@@ -78210,7 +78073,7 @@ static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer cx)
sc->code = setter;
return(goto_apply);
}
- eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code));
+ s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(cx)]));
}
sc->cur_op = optimize_op(sc->code);
return(goto_top_no_pop);
@@ -78230,7 +78093,7 @@ static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer cx)
sc->cur_op = optimize_op(sc->code);
return(goto_top_no_pop);
}
- eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code));
+ s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(cx)]));
return(goto_top_no_pop);
}
@@ -78255,7 +78118,7 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) ..
cx = symbol_to_slot(sc, caar_code);
if (is_slot(cx))
cx = slot_value(cx);
- else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar_code);
+ else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar_code, prepackaged_type_names[type(cx)]));
}
else cx = caar_code;
@@ -78298,7 +78161,7 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) ..
return(set_implicit_syntax(sc, cx));
default: /* (set! (1 2) 3) */
- eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar_code);
+ s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar_code, prepackaged_type_names[type(cx)]));
}
return(goto_top_no_pop);
}
@@ -78386,6 +78249,8 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p
var = caar(vars);
if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? nv : var_list))
{if (DO_PRINT) fprintf(stderr, "let shadows %d\n", __LINE__); return(false);}
+ if ((!is_symbol(var)) || (is_keyword(var)))
+ {if (DO_PRINT) fprintf(stderr, "let var name is bad: %d\n", __LINE__); return(false);}
nv = cons(sc, var, nv);
sc->x = nv;
}
@@ -78605,7 +78470,7 @@ static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v)
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)) &&
+ ((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_s1))) ||
@@ -78618,10 +78483,11 @@ static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v)
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)) &&
#if (!WITH_GMP)
- ((opt1_any(end) == sc->num_eq_xi) ||
+ ((opt1_cfunc(end) == sc->num_eq_xi) ||
(optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC)));
#else
((optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC)));
@@ -78668,6 +78534,10 @@ static s7_pointer fxify_step_exprs(s7_scheme *sc, s7_pointer code)
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?
+ */
s7_pointer p;
for (p = tree; is_pair(p); p = cdr(p))
{
@@ -78680,7 +78550,12 @@ static inline bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree)
((is_pair(cdr(p))) && /* if varlet, is target let local? */
(is_symbol(cadr(p))) &&
(!symbol_is_in_list(sc, cadr(p))))))
- return(true);
+ {
+#if DO_PRINT
+ fprintf(stderr, "definer: %s\n", DISPLAY(pp));
+#endif
+ return(true);
+ }
}
else
{
@@ -78772,7 +78647,27 @@ static s7_pointer check_do(s7_scheme *sc)
{
#if DO_PRINT
fprintf(stderr, "%s end unsafe\n", DISPLAY_80(form));
+ if (is_pair(end)) fprintf(stderr, " %d %s\n", is_fxable(sc, car(end)), op_names[optimize_op(car(end))]);
#endif
+ if (is_null(cddr(code)))
+ {
+ /* no body, end not fxable */
+ s7_pointer p;
+ fxify_step_exprs(sc, code);
+ for (p = car(code); is_pair(p); p = cdr(p))
+ {
+ s7_pointer var;
+ var = car(p);
+ if ((!has_fx(cdr(var))) ||
+ ((is_pair(cddr(var))) && (!has_fx(cddr(var)))))
+ break;
+ }
+ if (is_null(p))
+ {
+ pair_set_syntax_op(form, OP_DO_NO_BODY_FX_VARS);
+ return(sc->nil);
+ }
+ }
return(fxify_step_exprs(sc, code));
}
set_c_call(end, fx_choose(sc, end, sc->envir, let_symbol_is_safe_or_listed));
@@ -78809,7 +78704,7 @@ static s7_pointer check_do(s7_scheme *sc)
{
fx_tree(sc, end, caar(vars), NULL);
/* an experiment */
-#if 1
+
/* either we're the first thing in the closure body or it's a safe closure, else envir is unsafe */
/* this needs to be marked elsewhere */
if ((tis_slot(let_slots(sc->envir))) &&
@@ -78828,35 +78723,6 @@ static s7_pointer check_do(s7_scheme *sc)
(is_null(cdr(vars)))) /* 1 stepper */
fx_tree_outest(sc, end, var1, var2, caar(vars), NULL);
}
-#else
- if ((is_funclet(sc->envir)) &&
- (tis_slot(let_slots(sc->envir))) &&
- (is_symbol(funclet_function(sc->envir))))
- {
- s7_pointer clos;
- /* TODO: fix this! */
- clos = symbol_to_local_slot(sc, funclet_function(sc->envir), outlet(sc->envir));
- if (is_slot(clos)) /* else #<undefined> */
- {
- clos = slot_value(clos);
- if ((is_pair(car(closure_body(clos)))) &&
- (is_null(cdr(closure_body(clos))))) /* kinda deperate */
- {
- s7_pointer var1, var2 = NULL;
- var1 = slot_symbol(let_slots(sc->envir));
- if (tis_slot(next_slot(let_slots(sc->envir))))
- var2 = slot_symbol(next_slot(let_slots(sc->envir)));
- fx_tree_outer(sc, end, var1, var2);
- if ((is_pair(cdar(vars))) && (is_pair(cddar(vars))))
- fx_tree_outer(sc, caddar(vars), var1, var2);
-
- if (((!var2) || (!tis_slot(next_slot(next_slot(let_slots(sc->envir)))))) && /* func has 1 or 2 args */
- (is_null(cdr(vars)))) /* 1 stepper */
- fx_tree_outest(sc, end, var1, var2, caar(vars), NULL);
- }
- }
- }
-#endif
}
body = cddr(code);
@@ -78948,7 +78814,13 @@ static s7_pointer check_do(s7_scheme *sc)
for (q = vars; q != p; q = cdr(q))
clear_match_symbol(caar(q));
#if DO_PRINT
- fprintf(stderr, " step no fx safe\n");
+ fprintf(stderr, " step not fx safe: %s\n ", DISPLAY(var));
+ if (!is_fxable(sc, cadr(var)))
+ fprintf(stderr, "can't fxify %s (%s)\n", DISPLAY(cadr(var)), op_names[optimize_op(cadr(var))]);
+ if ((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var))))
+ fprintf(stderr, "can't fxify %s (%s)\n", DISPLAY(caddr(var)), op_names[optimize_op(caddr(var))]);
+ if ((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var))))
+ fprintf(stderr, "%s is a definer or binder\n", DISPLAY(cadr(var)));
#endif
return(fxify_step_exprs(sc, code));
}
@@ -79014,6 +78886,7 @@ static s7_pointer check_do(s7_scheme *sc)
else
{
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) ||
@@ -79101,8 +78974,6 @@ static s7_pointer check_do(s7_scheme *sc)
}
}
}
-
- /* fprintf(stderr, "body: %s, %d %d\n", DISPLAY_80(body), is_null(cdr(body)), is_fxable(sc, car(body))); */
if ((is_pair(body)) && (is_null(cdr(body))) &&
(is_fxable(sc, car(body))))
{
@@ -79182,13 +79053,6 @@ static bool has_safe_steppers(s7_scheme *sc, s7_pointer frame)
return(true);
}
-static void op_do_unchecked(s7_scheme *sc)
-{
- set_current_code(sc, sc->code);
- push_stack_no_code(sc, OP_GC_PROTECT, sc->code);
- sc->code = cdr(sc->code);
-}
-
static bool op_dox_init(s7_scheme *sc)
{
s7_pointer frame, vars, test;
@@ -79865,6 +79729,61 @@ static bool op_do_no_vars_no_opt_1(s7_scheme *sc)
return(false);
}
+static void op_do_no_body_fx_vars(s7_scheme *sc)
+{
+ s7_pointer frame, vars, stepper;
+ s7_int steppers = 0;
+ set_current_code(sc, sc->code);
+ sc->code = cdr(sc->code);
+ new_frame(sc, sc->envir, frame);
+ sc->temp10 = frame;
+ for (vars = car(sc->code); is_pair(vars); vars = cdr(vars))
+ {
+ add_slot(frame, caar(vars), fx_call(sc, cdar(vars)));
+ if (is_pair(cddar(vars)))
+ {
+ slot_set_expression(let_slots(frame), cddar(vars));
+ steppers++;
+ stepper = let_slots(frame);
+ }
+ else slot_just_set_expression(let_slots(frame), sc->nil);
+ }
+ if (steppers == 1) let_set_dox_slot1(frame, stepper);
+ sc->envir = frame;
+ push_stack_no_args(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_FX_VARS_STEP_1 : OP_DO_NO_BODY_FX_VARS_STEP), sc->code);
+ 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->envir); 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(sc, OP_DO_NO_BODY_FX_VARS_STEP, sc->code);
+ 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->envir), fx_call(sc, slot_expression(let_dox_slot1(sc->envir))));
+ push_stack_no_args(sc, OP_DO_NO_BODY_FX_VARS_STEP_1, sc->code);
+ sc->code = caadr(sc->code);
+ return(false);
+}
+
static bool do_step1(s7_scheme *sc)
{
/* on each iteration, each arg incr expr is evaluated and the value placed in caddr while we cdr down args */
@@ -79929,11 +79848,42 @@ static bool op_do_step(s7_scheme *sc)
return(false);
}
+static goto_t do_end_code(s7_scheme *sc)
+{
+ if (is_pair(cdr(sc->code)))
+ {
+ if ((car(sc->code) == sc->feed_to_symbol) &&
+ (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
+ 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))
+ {
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(true);
+ }
+ return(false);
+}
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) &&
@@ -80020,27 +79970,25 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code)
fp = o->v[0].fp;
if (fp == opt_p_ppp_sss)
{
- s7_p_ppp_t fp;
- fp = o->v[4].p_ppp_f;
+ 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));
- fp(sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p));
+ 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 fp;
- opt_info *o1;
- fp = o->v[3].p_ppp_f;
- o1 = sc->opts[1];
+ 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));
sc->pc = 1;
- fp(sc, slot_value(o->v[1].p), o1->v[0].fp(o1), slot_value(o->v[2].p));
+ fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p));
}
}
else
@@ -80491,51 +80439,23 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
s7_pointer step_slot, end_slot;
step_slot = let_dox_slot1(sc->envir);
end_slot = let_dox_slot2(sc->envir);
-
if (func == opt_cell_any_nr)
{
opt_info *o;
s7_pointer (*fp)(opt_info *o);
o = sc->opts[0];
fp = o->v[0].fp;
-
- if (fp == opt_if_bp_ii_fc)
- { /* can this call opt_if_bp_ii_fc directly and declare it inline? */
- opt_info *o1, *o2;
- s7_b_ii_t bif;
- s7_int i1;
- o1 = sc->opts[1];
- bif = o1->v[3].b_ii_f;
- i1 = o1->v[2].i;
- o2 = sc->opts[2];
+ if (!opt_do_copy(sc, o, integer(slot_value(step_slot)), integer(slot_value(end_slot))))
+ {
while (true)
{
- sc->pc = 2;
- if (bif(o2->v[0].fi(o2), i1))
- {
- opt_info *o3;
- o3 = sc->opts[++sc->pc];
- o3->v[0].fp(o3);
- }
+ sc->pc = 0;
+ fp(o);
step = integer(slot_value(step_slot)) + 1;
slot_set_value(step_slot, make_integer(sc, step));
if (step == integer(slot_value(end_slot))) break;
}
}
- else
- {
- if (!opt_do_copy(sc, o, integer(slot_value(step_slot)), integer(slot_value(end_slot))))
- {
- while (true)
- {
- sc->pc = 0;
- fp(o);
- step = integer(slot_value(step_slot)) + 1;
- slot_set_value(step_slot, make_integer(sc, step));
- if (step == integer(slot_value(end_slot))) break;
- }
- }
- }
}
else
{
@@ -80713,7 +80633,7 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
{
s7_pointer expr;
if ((!is_pair(car(p))) ||
- (!is_symbol(caar(p))) ||
+ (!is_normal_symbol(caar(p))) ||
(!is_pair(cdar(p))))
return(fall_through);
expr = cdar(p);
@@ -80771,7 +80691,6 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
(first->v[3].d_dd_f == add_d_dd) &&
(slot_symbol(step_slot) == slot_symbol(o->v[2].p))) /* and _dv et al throughout (so sc->pc ignored) etc */
{
- /* gcc now refuses to inline opt_fmv -- we are not amused... */
opt_info *o1, *o2, *o3;
s7_d_v_t vf1, vf2, vf3, vf4;
s7_d_vd_t vf5, vf6;
@@ -81249,6 +81168,95 @@ static bool op_do_init(s7_scheme *sc)
return(true);
}
+static void op_do_unchecked(s7_scheme *sc)
+{
+ set_current_code(sc, sc->code);
+ 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->envir = new_frame_in_env(sc, sc->envir);
+ 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 frame (like let, not let*) */
+ sc->args = sc->nil; /* the evaluated var-data */
+ sc->value = sc->code; /* protect it */
+ sc->code = car(sc->code); /* the vars */
+ return(do_init_ex(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(sc, OP_DO_END1, sc->args, sc->code);
+ 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 ((car(sc->code) == sc->feed_to_symbol) &&
+ (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
+ 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))
+ {
+ if (is_null(car(sc->args)))
+ push_stack(sc, OP_DO_END, sc->args, sc->code);
+ else push_stack(sc, OP_DO_STEP, sc->args, sc->code);
+ return(goto_begin);
+ }
+ if (is_null(car(sc->args))) /* no steppers */
+ return(goto_do_end);
+ return(fall_through);
+}
+
/* -------------------------------------------------------------------------------- */
/* closure_is_ok_1 checks the type and the body length indications
@@ -81312,6 +81320,12 @@ static inline bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t ty
(unchecked_slot_value(local_slot(car(Code))) == opt1_lambda_unchecked(Code))) || \
(closure_is_fine_1(Sc, Code, Type, Args)))
+static 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;
@@ -81393,12 +81407,11 @@ static goto_t op_unknown(s7_scheme *sc, s7_pointer f)
s7_pointer code;
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
- code = sc->code;
-
- increment_opt3_ctr(code);
- if (opt3_ctr(code) > 100)
- return(fixup_unknown_op(code, f, OP_S));
+#if SHOW_EVAL_OPS
+ fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+#endif
+ code = sc->code;
switch (type(f))
{
case T_CLOSURE:
@@ -81420,30 +81433,32 @@ static goto_t op_unknown(s7_scheme *sc, s7_pointer f)
if (is_fxable(sc, car(body)))
{
annotate_arg(sc, body, sc->envir);
- set_optimize_op(code, hop + OP_SAFE_THUNK_A);
+ set_safe_optimize_op(code, hop + OP_SAFE_THUNK_A);
set_closure_has_fx(f);
}
else
{
- set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK_P : OP_THUNK_P));
+ set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK_P : OP_THUNK_P));
closure_clear_multiform(f); /* i.e. clear possible has_fx */
}
}
- else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK : OP_THUNK));
+ else set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK : OP_THUNK));
set_opt1_lambda(code, f);
return(goto_eval);
}
if ((is_closure_star(f)) && (is_safe_closure(f)))
{
- set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_FX_0);
+ set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_FX_0);
set_opt1_lambda(code, f);
return(goto_eval);
}
}
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_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))) &&
@@ -81457,9 +81472,12 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
{
s7_pointer code;
bool sym_case;
-
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
+#if SHOW_EVAL_OPS
+ fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+#endif
+
code = sc->code;
#if S7_DEBUGGING
if (is_pair(cadr(code)))
@@ -81470,10 +81488,6 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
(!is_slot(symbol_to_slot(sc, cadr(code)))))
return(fall_through);
- increment_opt3_ctr(code);
- if (opt3_ctr(code) > 100)
- return(fixup_unknown_op(code, f, (sym_case) ? OP_S_S : OP_S_C));
-
switch (type(f))
{
case T_C_FUNCTION:
@@ -81520,7 +81534,7 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
if (is_fxable(sc, car(body)))
{
annotate_arg(sc, body, sc->envir);
- set_optimize_op(code, hop + ((sym_case) ? OP_SAFE_CLOSURE_S_A : OP_SAFE_CLOSURE_C_A));
+ set_safe_optimize_op(code, hop + ((sym_case) ? OP_SAFE_CLOSURE_S_A : OP_SAFE_CLOSURE_C_A));
set_closure_has_fx(f);
fx_tree(sc, body, car(closure_args(f)), NULL);
}
@@ -81529,11 +81543,11 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
/* hop if is_constant(sc, car(code)) is not foolproof here (see t967.scm):
* (define (f) (define-constant (f1) ... (f1))...) where each call on f makes a different f1
*/
- set_optimize_op(code, hop + ((sym_case) ? OP_SAFE_CLOSURE_S_P : OP_SAFE_CLOSURE_C_P));
+ set_safe_optimize_op(code, hop + ((sym_case) ? OP_SAFE_CLOSURE_S_P : OP_SAFE_CLOSURE_C_P));
closure_clear_multiform(f);
}
}
- else set_optimize_op(code, hop + ((sym_case) ? OP_SAFE_CLOSURE_S : OP_SAFE_CLOSURE_C));
+ else set_safe_optimize_op(code, hop + ((sym_case) ? OP_SAFE_CLOSURE_S : OP_SAFE_CLOSURE_C));
}
else
{
@@ -81613,6 +81627,12 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
annotate_arg(sc, cdr(code), sc->envir);
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;
}
@@ -81626,19 +81646,18 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f)
{
s7_pointer code;
-
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
+#if SHOW_EVAL_OPS
+ fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+#endif
+
code = sc->code;
#if S7_DEBUGGING
if (!has_fx(cdr(code)))
fprintf(stderr, "op_unknown_a missing _a support? %s\n", DISPLAY_80(code));
#endif
- increment_opt3_ctr(code);
- if (opt3_ctr(code) > 100)
- return(fixup_unknown_op(code, f, OP_S_A));
-
switch (type(f))
{
case T_C_FUNCTION:
@@ -81673,13 +81692,13 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f)
if (is_fxable(sc, car(body)))
{
annotate_arg(sc, body, sc->envir);
- set_optimize_op(code, hop + OP_SAFE_CLOSURE_A_A);
+ set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_A_A);
set_closure_has_fx(f);
fx_tree(sc, body, car(closure_args(f)), NULL);
}
else
{
- set_optimize_op(code, hop + OP_SAFE_CLOSURE_A_P);
+ set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_A_P);
closure_clear_multiform(f);
}
}
@@ -81738,7 +81757,7 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f)
}
return(fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_A)); /* arg is already annotated (unknown_a) */
}
- /* is this possible? */
+ /* this is possible, but it's probably an error: (obj 0) in t725 */
set_opt3_any(code, cadr(code));
return(fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_C));
}
@@ -81779,6 +81798,9 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f)
s7_pointer code;
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
+#if SHOW_EVAL_OPS
+ fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+#endif
code = sc->code;
#if S7_DEBUGGING
@@ -81863,12 +81885,12 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f)
{
annotate_arg(sc, body, sc->envir);
fx_tree(sc, body, car(closure_args(f)), cadr(closure_args(f)));
- set_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A);
+ set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A);
set_closure_has_fx(f);
}
else
{
- set_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_P);
+ set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_P);
closure_clear_multiform(f);
}
}
@@ -81881,7 +81903,7 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f)
if (one_form)
{
if (safe_case)
- set_optimize_op(code, hop + ((s1) ? OP_SAFE_CLOSURE_SC_P : OP_SAFE_CLOSURE_CS));
+ set_safe_optimize_op(code, hop + ((s1) ? OP_SAFE_CLOSURE_SC_P : OP_SAFE_CLOSURE_CS));
else set_optimize_op(code, hop + ((s1) ? OP_CLOSURE_SC_P : OP_CLOSURE_CS));
}
else set_optimize_op(code, hop + ((safe_case) ? ((s1) ? OP_SAFE_CLOSURE_SC : OP_SAFE_CLOSURE_CS) : ((s1) ? OP_CLOSURE_SC : OP_CLOSURE_CS)));
@@ -81907,6 +81929,13 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f)
annotate_args(sc, cdr(code), sc->envir);
return(fixup_unknown_op(code, f, OP_IMPLICIT_VECTOR_REF_AA));
+ case T_MACRO:
+ return(fixup_unknown_op(code, f, OP_MACRO_D));
+ /* T_MACRO -> MACRO_D? throughout unknown* */
+
+ case T_MACRO_STAR:
+ return(fixup_unknown_op(code, f, OP_MACRO_STAR_D));
+
default:
break;
}
@@ -81917,7 +81946,6 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f)
annotate_args(sc, cdr(code), sc->envir);
return(fixup_unknown_op(code, f, OP_S_AA));
- /* return(unknown_unknown(sc)); */
}
static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f)
@@ -81926,6 +81954,10 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f)
int32_t num_args;
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
+#if SHOW_EVAL_OPS
+ fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+#endif
+
code = sc->code;
num_args = integer(opt3_arglen(code));
for (arg = cdr(code); is_pair(arg); arg = cdr(arg))
@@ -81947,11 +81979,11 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f)
{
if (num_args == 3)
{
- set_optimize_op(code, OP_SAFE_C_SSS);
+ 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_optimize_op(code, OP_SAFE_C_ALL_S);
+ else set_safe_optimize_op(code, OP_SAFE_C_ALL_S);
}
else
{
@@ -81988,6 +82020,12 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f)
}
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));
+
default:
break;
}
@@ -82000,15 +82038,14 @@ static goto_t op_unknown_aa(s7_scheme *sc, s7_pointer f)
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
+#if SHOW_EVAL_OPS
+ fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+#endif
code = sc->code;
set_opt3_arglen(code, small_int(2));
annotate_args(sc, cdr(code), sc->envir);
- increment_opt3_ctr(code);
- if (opt3_ctr(code) > 100)
- return(fixup_unknown_op(code, f, OP_S_AA));
-
switch (type(f))
{
case T_C_FUNCTION:
@@ -82019,7 +82056,7 @@ static goto_t op_unknown_aa(s7_scheme *sc, s7_pointer f)
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
- set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_AA : OP_C_FX);
+ set_safe_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_AA : OP_C_FX);
set_c_function(code, f);
return(goto_eval);
@@ -82043,12 +82080,12 @@ static goto_t op_unknown_aa(s7_scheme *sc, s7_pointer f)
if (is_fxable(sc, car(body)))
{
annotate_arg(sc, body, sc->envir);
- set_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_A);
+ set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_A);
set_closure_has_fx(f);
}
else
{
- set_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_P);
+ set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_P);
closure_clear_multiform(f);
}
}
@@ -82084,6 +82121,10 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f)
int32_t num_args;
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
+#if SHOW_EVAL_OPS
+ fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+#endif
+
code = sc->code;
num_args = (is_pair(cdr(code))) ? integer(opt3_arglen(code)) : 0; /* opt3_arglen is on cdr(code) */
@@ -82098,8 +82139,8 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f)
case T_C_OPT_ARGS_FUNCTION:
case T_C_ANY_ARGS_FUNCTION:
if (is_safe_procedure(f))
- set_optimize_op(code, (num_args == 3) ? OP_SAFE_C_AAA : OP_SAFE_C_FX);
- else set_optimize_op(code, OP_C_FX);
+ set_safe_optimize_op(code, (num_args == 3) ? OP_SAFE_C_AAA : ((num_args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_FX));
+ else set_safe_optimize_op(code, OP_C_FX);
annotate_args(sc, cdr(code), sc->envir);
set_c_function(code, f);
return(goto_eval);
@@ -82115,11 +82156,11 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f)
{
if ((is_symbol(cadr(code))) &&
(num_args == 3))
- set_optimize_op(code, hop + OP_SAFE_CLOSURE_SAA);
- else set_optimize_op(code, hop + OP_SAFE_CLOSURE_FX);
+ set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SAA);
+ else set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_FX);
/* recur doesn't happen much here */
}
- else set_optimize_op(code, hop + OP_CLOSURE_FX);
+ else set_safe_optimize_op(code, hop + OP_CLOSURE_FX);
set_opt1_lambda(code, f);
return(goto_eval);
}
@@ -82255,7 +82296,7 @@ static goto_t op_read_s(s7_scheme *sc)
return(goto_start);
}
-static goto_t op_string_a(s7_scheme *sc)
+static goto_t op_implicit_string_a(s7_scheme *sc)
{
s7_int index;
s7_pointer s, x, code;
@@ -82284,7 +82325,11 @@ static goto_t op_string_a(s7_scheme *sc)
return(goto_start);
}
-static goto_t op_vector_a(s7_scheme *sc)
+#if WITH_GCC
+static inline goto_t op_implicit_vector_a(s7_scheme *sc) __attribute__((always_inline));
+#endif
+
+static inline goto_t op_implicit_vector_a(s7_scheme *sc)
{
s7_pointer v, x, code;
@@ -82314,7 +82359,7 @@ static goto_t op_vector_a(s7_scheme *sc)
return(goto_start);
}
-static goto_t op_vector_aa(s7_scheme *sc)
+static goto_t op_implicit_vector_aa(s7_scheme *sc)
{
s7_pointer v, x, y, code;
@@ -82350,13 +82395,12 @@ static goto_t op_vector_aa(s7_scheme *sc)
return(goto_start);
}
-static bool op_vector_set_3(s7_scheme *sc)
+static inline bool op_implicit_vector_set_3(s7_scheme *sc)
{
s7_pointer v, i1;
v = lookup(sc, caadr(sc->code));
if (!is_any_vector(v))
{
- /* fprintf(stderr, "%s[%d]: back out: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */
pair_set_syntax_op(sc->code, OP_SET_UNCHECKED);
return(true);
}
@@ -82369,13 +82413,12 @@ static bool op_vector_set_3(s7_scheme *sc)
return(false);
}
-static bool op_vector_set_4(s7_scheme *sc)
+static bool op_implicit_vector_set_4(s7_scheme *sc)
{
s7_pointer v, i1, i2;
v = lookup(sc, caadr(sc->code));
if (!is_any_vector(v))
{
- /* fprintf(stderr, "%s[%d]: back out: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */
pair_set_syntax_op(sc->code, OP_SET_UNCHECKED);
return(true);
}
@@ -82387,6 +82430,7 @@ static bool op_vector_set_4(s7_scheme *sc)
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);
}
@@ -82477,7 +82521,7 @@ static void op_set_pws(s7_scheme *sc)
obj = symbol_to_slot(sc, obj);
if (is_slot(obj))
obj = slot_value(obj);
- else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code));
+ else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(obj)]));
}
if ((is_c_function(obj)) &&
@@ -82491,7 +82535,7 @@ static void op_set_pws(s7_scheme *sc)
set_car(sc->t1_1, value);
sc->value = c_function_call(c_function_setter(obj))(sc, sc->t1_1);
}
- else eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, obj);
+ else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar(sc->code), prepackaged_type_names[type(obj)]));
}
@@ -82762,7 +82806,7 @@ static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, s7_pointer sym,
return(sc->no_value);
}
-static s7_pointer lambda_star_set_args(s7_scheme *sc)
+static inline s7_pointer lambda_star_set_args(s7_scheme *sc)
{
bool allow_other_keys;
s7_pointer lx, cx, zx, code, args, slot;
@@ -82777,7 +82821,7 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc)
while ((is_pair(cx)) &&
(is_pair(lx)))
{
- if (car(cx) == sc->key_rest_symbol) /* the rest arg, default arg not allowed here (see check_lambda_star_args) */
+ 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;
@@ -82906,55 +82950,51 @@ static inline goto_t lambda_star_default(s7_scheme *sc)
(slot_has_expression(z)) && /* if default val is not a pair or a symbol, this is false */
(!is_checked_slot(z)))
{
- if (is_closure_star(sc->code)) /* as opposed to macro* and bacro* */
+ s7_pointer val;
+ val = slot_expression(z);
+ if (is_symbol(val))
{
- s7_pointer val;
- val = slot_expression(z);
- if (is_symbol(val))
+ slot_set_value(z, lookup_checked(sc, val));
+ if (slot_value(z) == sc->undefined)
{
- slot_set_value(z, lookup_checked(sc, val));
+ /* 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, outlet(sc->envir)));
if (slot_value(z) == sc->undefined)
- {
- /* the current environment here contains the function parameters which
- * defaulted to #<undefined> (or maybe #<unused>?) earlier in apply_lambda_star,
- * so (define (f f) (define* (f (f f)) f) (f)) (f 0) looks for the
- * default f, finds itself currently undefined, and raises an error!
- * So, before claiming it is unbound, we need to check outlet as well.
- * But in the case above, the inner define* shadows the caller's
- * parameter before checking the default arg values, so the default f
- * refers to the define* -- I'm not sure this is a bug. It means
- * that (define* (f (a f)) a) returns f: (equal? f (f)) -> #t, so
- * any outer f needs an extra let and endless outlets:
- * (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3
- * We want the shadowing once the define* is done, so the current mess is simplest.
- */
- slot_set_value(z, s7_symbol_local_value(sc, val, outlet(sc->envir)));
- if (slot_value(z) == sc->undefined)
- eval_error_no_return(sc, sc->syntax_error_symbol, "lambda* defaults: ~A is unbound", 31, slot_symbol(z));
- }
+ eval_error_no_return(sc, sc->syntax_error_symbol, "lambda* defaults: ~A is unbound", 31, slot_symbol(z));
}
- else
+ }
+ else
+ {
+ if (is_pair(val))
{
- if (is_pair(val))
+ if (car(val) == sc->quote_symbol)
{
- if (car(val) == sc->quote_symbol)
- {
- if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */
- (is_pair(cddr(val))))
- eval_error_no_return(sc, sc->syntax_error_symbol, "lambda* default: ~A is messed up", 32, val);
- slot_set_value(z, cadr(val));
- }
- else
- {
- push_stack(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code);
- sc->code = val;
- return(goto_eval);
- }
+ if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */
+ (is_pair(cddr(val))))
+ eval_error_no_return(sc, sc->syntax_error_symbol, "lambda* default: ~A is messed up", 32, val);
+ slot_set_value(z, cadr(val));
+ }
+ else
+ {
+ push_stack(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code);
+ sc->code = val;
+ return(goto_eval);
}
- else slot_set_value(z, val);
}
+ else slot_set_value(z, val);
}
- else slot_set_value(z, slot_expression(z));
}
sc->args = next_slot(z);
}
@@ -82977,32 +83017,53 @@ static bool op_lambda_star_default(s7_scheme *sc)
return(false);
}
-static goto_t apply_lambda_star(s7_scheme *sc) /* -------- define* (lambda*) -------- */
+static inline bool set_star_args(s7_scheme *sc, s7_pointer top)
{
- s7_pointer z, car_z, val, 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(sc, OP_GC_PROTECT, sc->args, sc->code);
+ 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);
+}
- if (is_safe_closure(sc->code))
+static bool apply_safe_closure_star_1(s7_scheme *sc) /* -------- define* (lambda*) -------- */
+{
+ s7_pointer z;
+ /* fprintf(stderr, "%s %s\n", __func__, DISPLAY(sc->code)); */
+ /* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */
+
+ sc->envir = closure_let(sc->code);
+ if (has_no_defaults(sc->code))
{
- /* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */
- sc->envir = closure_let(sc->code);
- z = let_slots(sc->envir);
- if (tis_slot(z))
+ for (z = let_slots(sc->envir); tis_slot(z); z = next_slot(z))
{
- for (; tis_slot(z); z = next_slot(z))
- {
- clear_checked_slot(z);
- slot_set_value(z, (slot_defaults(z)) ? sc->undefined : slot_expression(z));
- }
- top = slot_pending_value(let_slots(sc->envir));
- goto SET_ARGS;
+ clear_checked_slot(z);
+ slot_set_value(z, sc->F);
}
if (!is_null(sc->args))
- s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, closure_name(sc, sc->code), sc->args));
- /* what about (define* (f :allow-other-keys) 0) (f :a-key 21) */
+ lambda_star_set_args(sc); /* load up current arg vals */
sc->code = closure_body(sc->code);
- return(goto_begin);
+ return(false); /* goto BEGIN */
}
+
+ for (z = let_slots(sc->envir); 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->envir))));
+}
+static bool apply_unsafe_closure_star_1(s7_scheme *sc)
+{
+ s7_pointer z, car_z, val, top;
+ /* fprintf(stderr, "%s %s\n", __func__, DISPLAY(sc->code)); */
top = sc->nil;
for (z = closure_args(sc->code); is_pair(z); z = cdr(z))
{
@@ -83040,20 +83101,81 @@ static goto_t apply_lambda_star(s7_scheme *sc) /* -------- de
if (is_symbol(z))
set_is_rest_slot(make_slot_1(sc, sc->envir, z, sc->nil)); /* set up rest arg */
let_set_slots(sc->envir, reverse_slots(sc, let_slots(sc->envir)));
+ return(set_star_args(sc, top));
+}
- SET_ARGS:
- lambda_star_set_args(sc); /* load up current arg vals */
- sc->args = top;
- if (is_slot(sc->args))
+static void apply_macro_star_1(s7_scheme *sc)
+{
+ /* here the defaults (if any) are not evalled, and there is not exisiting frame */
+ s7_pointer p;
+ for (p = closure_args(sc->code); is_pair(p); p = cdr(p))
{
- /* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */
- push_stack(sc, OP_GC_PROTECT, sc->args, sc->code);
- if (lambda_star_default(sc) == goto_eval) return(goto_eval);
- pop_stack_no_op(sc); /* get original args and code back */
+ s7_pointer par;
+ par = car(p);
+ if (is_pair(par))
+ make_slot_1(sc, sc->envir, car(par), cadr(par));
+ else
+ {
+ if (!is_keyword(par))
+ make_slot_1(sc, sc->envir, par, sc->F);
+ else
+ {
+ if (par == sc->key_rest_symbol)
+ {
+ set_is_rest_slot(make_slot_1(sc, sc->envir, cadr(p), sc->nil));
+ p = cdr(p);
+ }
+ }
+ }
}
+ if (is_symbol(p))
+ set_is_rest_slot(make_slot_1(sc, sc->envir, p, sc->nil));
+ let_set_slots(sc->envir, reverse_slots(sc, let_slots(sc->envir)));
+ lambda_star_set_args(sc);
+ sc->code = T_Pair(closure_body(sc->code));
+}
- sc->code = closure_body(sc->code);
- return(goto_begin);
+static void apply_macro(s7_scheme *sc)
+{
+ /* this is not from the reader, so treat expansions here as normal macros */
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ new_frame(sc, closure_let(sc->code), sc->envir);
+}
+
+static void apply_bacro(s7_scheme *sc)
+{
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ new_frame(sc, sc->envir, sc->envir); /* like let* -- we'll be adding macro args, so might as well sequester things here */
+}
+
+static void apply_macro_star(s7_scheme *sc)
+{
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ new_frame(sc, closure_let(sc->code), sc->envir);
+ apply_macro_star_1(sc);
+}
+
+static void apply_bacro_star(s7_scheme *sc)
+{
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ new_frame(sc, sc->envir, sc->envir);
+ 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);
+ new_frame(sc, closure_let(sc->code), sc->envir);
+}
+
+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->envir = new_frame_in_env(sc, closure_let(sc->code));
+ return(apply_unsafe_closure_star_1(sc));
}
static void safe_closure_star_a(s7_scheme *sc, s7_pointer code)
@@ -83137,18 +83259,18 @@ static void safe_closure_star_aa(s7_scheme *sc, s7_pointer code)
sc->code = T_Pair(closure_body(opt1_lambda(code)));
}
-static int32_t safe_closure_star_fx_0(s7_scheme *sc, s7_pointer code)
+static bool safe_closure_star_fx_0(s7_scheme *sc, s7_pointer code)
{
sc->args = sc->nil;
sc->code = opt1_lambda(code);
- return(apply_lambda_star(sc));
+ return(apply_safe_closure_star_1(sc));
}
-#define call_lambda_star(sc) do {sc->code = opt1_lambda(code); target = apply_lambda_star(sc); clear_list_in_use(arglist);} while (0)
+#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 int32_t safe_closure_star_fx_1(s7_scheme *sc, s7_pointer code)
+static bool safe_closure_star_fx_1(s7_scheme *sc, s7_pointer code)
{
- int32_t target;
+ bool target;
s7_pointer arglist;
sc->args = safe_list_1(sc);
arglist = sc->args;
@@ -83158,9 +83280,9 @@ static int32_t safe_closure_star_fx_1(s7_scheme *sc, s7_pointer code)
return(target);
}
-static int32_t safe_closure_star_fx_2(s7_scheme *sc, s7_pointer code)
+static bool safe_closure_star_fx_2(s7_scheme *sc, s7_pointer code)
{
- int32_t target;
+ bool target;
s7_pointer arglist, p;
sc->args = safe_list_2(sc);
arglist = sc->args;
@@ -83172,10 +83294,20 @@ static int32_t safe_closure_star_fx_2(s7_scheme *sc, s7_pointer code)
return(target);
}
-static int32_t safe_closure_star_fx(s7_scheme *sc, s7_pointer code)
+static goto_t op_check_safe_closure_star_fx(s7_scheme *sc)
+{
+ if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? integer(opt3_arglen(sc->code)) : 0))
+ {
+ if (op_unknown_fx(sc, sc->last_function) == goto_eval) return(goto_eval);
+ return(goto_unopt);
+ }
+ return(fall_through);
+}
+
+static bool safe_closure_star_fx(s7_scheme *sc, s7_pointer code)
{
s7_pointer old_args, p, arglist;
- int32_t target;
+ bool target;
#if S7_DEBUGGING
if (!is_pair(cdr(code))) fprintf(stderr, "%s[%d]: no args!\n", __func__, __LINE__);
#endif
@@ -83219,9 +83351,21 @@ static void closure_star_a(s7_scheme *sc, s7_pointer code)
sc->code = T_Pair(closure_body(func));
}
-static inline void closure_star_fx(s7_scheme *sc, s7_pointer code)
+static goto_t op_check_closure_star_fx(s7_scheme *sc)
+{
+ if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? integer(opt3_arglen(sc->code)) : 0))
+ {
+ if (op_unknown_fx(sc, sc->last_function) == goto_eval)
+ return(goto_eval);
+ return(goto_unopt);
+ }
+ return(fall_through);
+}
+
+static inline bool closure_star_fx(s7_scheme *sc, s7_pointer code)
{
s7_pointer p, old_args;
+ check_stack_size(sc);
if (is_pair(cdr(code)))
{
sc->w = cdr(code); /* args aren't evaluated yet */
@@ -83233,6 +83377,7 @@ static inline void closure_star_fx(s7_scheme *sc, s7_pointer code)
else sc->args = sc->nil;
sc->code = opt1_lambda(code);
new_frame(sc, closure_let(sc->code), sc->envir);
+ return(apply_unsafe_closure_star_1(sc));
}
static goto_t op_define1(s7_scheme *sc)
@@ -83544,6 +83689,44 @@ static void op_safe_thunk_p(s7_scheme *sc)
sc->code = car(closure_body(sc->code));
}
+static void op_closure_s(s7_scheme *sc)
+{
+ sc->value = lookup(sc, opt2_sym(sc->code));
+ check_stack_size(sc);
+ sc->code = opt1_lambda(sc->code);
+ new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value);
+ sc->code = T_Pair(closure_body(sc->code));
+ push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
+ sc->code = car(sc->code);
+}
+
+static void op_closure_s_p(s7_scheme *sc)
+{
+ sc->value = lookup(sc, opt2_sym(sc->code));
+ check_stack_size(sc);
+ sc->code = opt1_lambda(sc->code);
+ new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value);
+ sc->code = car(closure_body(sc->code));
+}
+
+static void op_safe_closure_s(s7_scheme *sc)
+{
+ sc->value = lookup(sc, opt2_sym(sc->code));
+ sc->code = opt1_lambda(sc->code);
+ sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value);
+ sc->code = T_Pair(closure_body(sc->code));
+ push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
+ sc->code = car(sc->code);
+}
+
+static void op_safe_closure_s_p(s7_scheme *sc)
+{
+ sc->value = lookup(sc, opt2_sym(sc->code));
+ sc->code = opt1_lambda(sc->code);
+ sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value);
+ sc->code = car(closure_body(sc->code));
+}
+
static void op_closure_c(s7_scheme *sc)
{
check_stack_size(sc);
@@ -83562,6 +83745,18 @@ static void op_closure_c_p(s7_scheme *sc)
sc->code = car(closure_body(sc->code));
}
+static void op_safe_closure_p(s7_scheme *sc)
+{
+ push_stack(sc, OP_SAFE_CLOSURE_P_1, sc->args, sc->code);
+ sc->code = cadr(sc->code);
+}
+
+static void op_safe_closure_p_1(s7_scheme *sc)
+{
+ sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(sc->code)), sc->value);
+ sc->code = T_Pair(closure_body(opt1_lambda(sc->code)));
+}
+
#if WITH_GCC
static inline void op_closure_a(s7_scheme *sc) __attribute__((always_inline));
#endif
@@ -83598,6 +83793,20 @@ static void op_safe_closure_saa(s7_scheme *sc)
sc->code = T_Pair(closure_body(f));
}
+static void op_closure_p(s7_scheme *sc)
+{
+ push_stack(sc, OP_CLOSURE_P_1, sc->args, sc->code);
+ sc->code = cadr(sc->code);
+}
+
+static void op_closure_p_1(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ sc->code = opt1_lambda(sc->code);
+ new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value);
+ sc->code = T_Pair(closure_body(sc->code));
+}
+
static void op_closure_p_mv(s7_scheme *sc)
{
sc->code = opt1_lambda(sc->code);
@@ -83754,7 +83963,7 @@ static void op_safe_closure_ss_p(s7_scheme *sc)
sc->code = car(closure_body(sc->code));
}
-static void op_closure_ss(s7_scheme *sc)
+static inline void op_closure_ss(s7_scheme *sc)
{
sc->temp5 = lookup(sc, opt2_sym(sc->code));
sc->value = lookup(sc, cadr(sc->code));
@@ -83764,7 +83973,7 @@ static void op_closure_ss(s7_scheme *sc)
closure_push(sc);
}
-static void op_closure_ss_p(s7_scheme *sc)
+static inline void op_closure_ss_p(s7_scheme *sc)
{
sc->temp5 = lookup(sc, opt2_sym(sc->code));
sc->value = lookup(sc, cadr(sc->code));
@@ -83854,6 +84063,15 @@ static void op_closure_3s(s7_scheme *sc)
sc->z = sc->nil;
}
+static void op_closure_3s_b(s7_scheme *sc)
+{
+ op_closure_3s(sc);
+ sc->code = T_Pair(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_closure_4s(s7_scheme *sc)
{
s7_pointer e, p, args, last_slot;
@@ -83880,6 +84098,15 @@ static void op_closure_4s(s7_scheme *sc)
sc->z = sc->nil;
}
+static void op_closure_4s_b(s7_scheme *sc)
+{
+ op_closure_4s(sc);
+ sc->code = T_Pair(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_aa(s7_scheme *sc)
{
s7_pointer p;
@@ -83926,7 +84153,7 @@ static void op_closure_aa_p(s7_scheme *sc)
sc->code = car(closure_body(sc->code));
}
-static void op_closure_fa(s7_scheme *sc)
+static inline void op_closure_fa(s7_scheme *sc)
{
s7_pointer farg, new_clo, aarg, func, func_args, code;
code = sc->code;
@@ -83994,6 +84221,17 @@ static void op_safe_closure_fx(s7_scheme *sc)
sc->code = car(sc->code);
}
+static goto_t op_check_closure_all_s(s7_scheme *sc)
+{
+ if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, integer(opt3_arglen(sc->code))))
+ {
+ if (op_unknown_all_s(sc, sc->last_function) == goto_eval)
+ return(goto_eval);
+ return(goto_unopt);
+ }
+ return(fall_through);
+}
+
static inline void op_closure_all_s(s7_scheme *sc)
{
s7_pointer args, p, e, last_slot;
@@ -84022,7 +84260,18 @@ static inline void op_closure_all_s(s7_scheme *sc)
sc->code = car(sc->code);
}
-static void op_closure_fx(s7_scheme *sc)
+static goto_t op_check_closure_fx(s7_scheme *sc)
+{
+ if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, integer(opt3_arglen(sc->code))))
+ {
+ if (op_unknown_fx(sc, sc->last_function) == goto_eval)
+ return(goto_eval);
+ return(goto_unopt);
+ }
+ return(fall_through);
+}
+
+static inline void op_closure_fx(s7_scheme *sc)
{
s7_pointer args, p, e, last_slot;
check_stack_size(sc);
@@ -84062,14 +84311,11 @@ static void op_closure_any_fx(s7_scheme *sc) /* for (lambda a ...) ? */
/* -------- */
#if S7_DEBUGGING
-static int *tc_rec_calls = NULL;
+static int *tc_rec_calls = NULL; /* check optimizer coverage */
#define TC_REC_SIZE NUM_OPS
#define TC_REC_LOW_OP OP_TC_AND_A_OR_A_LA
-static void init_tc_rec(void)
-{
- tc_rec_calls = (int *)calloc(TC_REC_SIZE, sizeof(int));
-}
+static void init_tc_rec(void) {tc_rec_calls = (int *)calloc(TC_REC_SIZE, sizeof(int));}
static s7_pointer g_report_missed_calls(s7_scheme *sc, s7_pointer args)
{
@@ -85358,7 +85604,7 @@ static void opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, s7_pointer code)
rec_set_f1(sc, cdr(caller));
rec_set_f2(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->envir);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer oprec_if_a_a_opa_laq(s7_scheme *sc)
@@ -85369,7 +85615,7 @@ static s7_pointer oprec_if_a_a_opa_laq(s7_scheme *sc)
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));
- return(sc->rec_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_pointer oprec_if_a_opa_laq_a(s7_scheme *sc)
@@ -85380,7 +85626,7 @@ static s7_pointer oprec_if_a_opa_laq_a(s7_scheme *sc)
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));
- return(sc->rec_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_pointer op_recur_if_a_a_opa_laq(s7_scheme *sc)
@@ -85429,7 +85675,7 @@ static void opinit_cond_a_a_opa_laq(s7_scheme *sc)
rec_set_f1(sc, cdr(caller));
rec_set_f2(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->envir);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer op_recur_cond_a_a_opa_laq(s7_scheme *sc)
@@ -85450,7 +85696,7 @@ static void opinit_if_a_a_opa_laaq(s7_scheme *sc, bool a_op)
rec_set_f3(sc, cddr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->envir);
sc->rec_slot2 = next_slot(sc->rec_slot1);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer oprec_if_a_a_opa_laaq(s7_scheme *sc)
@@ -85463,7 +85709,7 @@ static s7_pointer oprec_if_a_a_opa_laaq(s7_scheme *sc)
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));
- return(sc->rec_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_pointer oprec_if_a_opa_laaq_a(s7_scheme *sc)
@@ -85476,7 +85722,7 @@ static s7_pointer oprec_if_a_opa_laaq_a(s7_scheme *sc)
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_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_pointer op_recur_if_a_a_opa_laaq(s7_scheme *sc)
@@ -85503,7 +85749,7 @@ static void opinit_cond_a_a_opa_laaq(s7_scheme *sc)
rec_set_f3(sc, cddr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->envir);
sc->rec_slot2 = next_slot(sc->rec_slot1);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer op_recur_cond_a_a_opa_laaq(s7_scheme *sc)
@@ -85542,8 +85788,8 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
sc->rec_result_o = sc->opts[start_pc];
if (is_t_integer(slot_value(slot)))
{
- sc->rec_i_cf = s7_i_ii_function(s_func);
- if ((sc->rec_i_cf) &&
+ 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];
@@ -85571,8 +85817,8 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
}
if (is_float(slot_value(slot)))
{
- sc->rec_d_cf = s7_d_dd_function(s_func);
- if (sc->rec_d_cf)
+ 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];
@@ -85595,7 +85841,7 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
rec_set_f1(sc, cdadr(caller));
rec_set_f2(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->envir);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
return(OPT_PTR);
}
@@ -85614,7 +85860,7 @@ static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc)
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_cf(oprec_i_if_a_a_opla_laq(sc), i2)); /* call op(la1, la2) */
+ 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)
@@ -85633,10 +85879,10 @@ static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme *sc)
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_cf(oprec_i_if_a_a_opla_laq_0(sc), i3);
+ 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_cf(oprec_i_if_a_a_opla_laq_0(sc), i2));
+ 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)
@@ -85653,7 +85899,7 @@ static s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc)
real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o);
x2 = oprec_d_if_a_a_opla_laq(sc);
real(sc->rec_val1) = x1;
- return(sc->rec_d_cf(oprec_d_if_a_a_opla_laq(sc), x2));
+ 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)
@@ -85665,7 +85911,7 @@ static s7_pointer oprec_if_a_a_opla_laq(s7_scheme *sc)
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_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc)
@@ -85683,7 +85929,7 @@ static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc)
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_cf(oprec_i_if_a_opla_laq_a(sc), i2));
+ 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)
@@ -85702,10 +85948,10 @@ static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme *sc)
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_cf(oprec_i_if_a_opla_laq_a_0(sc), i3);
+ 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_cf(oprec_i_if_a_opla_laq_a_0(sc), i2));
+ 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)
@@ -85723,7 +85969,7 @@ static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc)
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_cf(oprec_d_if_a_opla_laq_a(sc), x2));
+ 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)
@@ -85735,7 +85981,7 @@ static s7_pointer oprec_if_a_opla_laq_a(s7_scheme *sc)
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_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static void wrap_recur_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
@@ -85773,7 +86019,7 @@ static void opinit_if_a_a_opa_la_laq(s7_scheme *sc, bool a_op)
rec_set_f2(sc, cdaddr(caller));
rec_set_f3(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->envir);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme *sc)
@@ -85787,7 +86033,7 @@ static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme *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_cf(sc, sc->t3_1));
+ return(sc->rec_call(sc, sc->t3_1));
}
static s7_pointer oprec_if_a_opa_la_laq_a(s7_scheme *sc)
@@ -85801,7 +86047,7 @@ static s7_pointer oprec_if_a_opa_la_laq_a(s7_scheme *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_cf(sc, sc->t3_1));
+ return(sc->rec_call(sc, sc->t3_1));
}
static s7_pointer op_recur_if_a_a_opa_la_laq(s7_scheme *sc)
@@ -85827,7 +86073,7 @@ static void opinit_if_a_a_opla_la_laq(s7_scheme *sc, bool a_op)
rec_set_f2(sc, cdaddr(caller));
rec_set_f3(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->envir);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme *sc)
@@ -85843,7 +86089,7 @@ static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme *sc)
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_cf(sc, sc->t3_1));
+ return(sc->rec_call(sc, sc->t3_1));
}
static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme *sc)
@@ -86007,7 +86253,7 @@ static void opinit_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer code)
rec_set_f3(sc, cdadr(caller));
rec_set_f4(sc, opt3_pair(caller));
sc->rec_slot1 = let_slots(sc->envir);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer oprec_cond_a_a_a_a_opla_laq(s7_scheme *sc)
@@ -86021,7 +86267,7 @@ static s7_pointer oprec_cond_a_a_a_a_opla_laq(s7_scheme *sc)
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_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_pointer op_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc)
@@ -86060,7 +86306,7 @@ static void opinit_cond_a_a_a_a_opa_laaq(s7_scheme *sc)
rec_set_f5(sc, cdr(opt3_pair(caller)));
sc->rec_slot1 = let_slots(sc->envir);
sc->rec_slot2 = next_slot(sc->rec_slot1);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer oprec_cond_a_a_a_a_opa_laaq(s7_scheme *sc)
@@ -86075,7 +86321,7 @@ static s7_pointer oprec_cond_a_a_a_a_opa_laaq(s7_scheme *sc)
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_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_pointer op_recur_cond_a_a_a_a_opa_laaq(s7_scheme *sc)
@@ -86106,7 +86352,7 @@ static void opinit_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc)
sc->rec_f5p = car(sc->rec_f5p);
sc->rec_slot1 = let_slots(sc->envir);
sc->rec_slot2 = next_slot(sc->rec_slot1);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
}
static s7_pointer oprec_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc)
@@ -86126,7 +86372,7 @@ static s7_pointer oprec_cond_a_a_a_a_oplaa_laaq(s7_scheme *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_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_pointer op_recur_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc)
@@ -86159,7 +86405,7 @@ static void opinit_cond_a_a_a_laa_opa_laaq(s7_scheme *sc, bool cond)
rec_set_f6(sc, cdr(sc->rec_f5p));
sc->rec_f5f = c_callee(sc->rec_f5p);
sc->rec_f5p = car(sc->rec_f5p);
- sc->rec_cf = c_callee(caller);
+ sc->rec_call = c_callee(caller);
sc->rec_slot1 = let_slots(sc->envir);
sc->rec_slot2 = next_slot(sc->rec_slot1);
@@ -86182,7 +86428,7 @@ static s7_pointer oprec_cond_a_a_a_laa_opa_laaq(s7_scheme *sc)
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));
- return(sc->rec_cf(sc, sc->t2_1));
+ return(sc->rec_call(sc, sc->t2_1));
}
static s7_pointer op_recur_cond_a_a_a_laa_opa_laaq(s7_scheme *sc)
@@ -86377,6 +86623,37 @@ static void wrap_recur(s7_scheme *sc, s7_pointer (*recur)(s7_scheme *sc))
/* -------------------------------- */
+static bool op_check_safe_c_s(s7_scheme *sc)
+{
+ /* hop_safe_c_t (if set in fx_tree) is uncommon: ca 20 hits in t103.scm */
+ if (!c_function_is_ok(sc, sc->code)) /* {set_optimize_op(sc->code, OP_S_S); goto EVAL;} */
+ {
+ if (op_unknown_g(sc, lookup(sc, car(sc->code))) != goto_eval)
+ set_optimize_op(sc->code, OP_S_S);
+ return(true);
+ }
+ return(false);
+}
+
+static void op_safe_c_p(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_no_args(sc, OP_SAFE_C_P_1, sc->code);
+ 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 = c_call(sc->code)(sc, sc->t1_1);
+}
+
+static void op_not_p(s7_scheme *sc)
+{
+ push_stack_no_args(sc, OP_NOT_P_1, sc->code);
+ sc->code = T_Pair(cadr(sc->code));
+}
+
static void op_safe_c_ssp(s7_scheme *sc)
{
check_stack_size(sc);
@@ -86398,6 +86675,25 @@ static void op_safe_c_ssp_mv_1(s7_scheme *sc)
sc->code = c_function_base(opt1_cfunc(sc->code));
}
+static goto_t op_check_safe_c_a(s7_scheme *sc)
+{
+ if (!c_function_is_ok(sc, sc->code))
+ {
+ if (op_unknown_a(sc, lookup_checked(sc, car(sc->code))) == goto_eval) /* for lt?? (matters at least in lt: 12!) */
+ {
+ if (op_no_hop(sc->code) == OP_SAFE_C_A)
+ {
+ set_car(sc->t1_1, c_call(cdr(sc->code))(sc, cadr(sc->code)));
+ sc->value = c_call(sc->code)(sc, sc->t1_1);
+ return(goto_start);
+ }
+ }
+ else set_optimize_op(sc->code, OP_S_A);
+ return(goto_eval);
+ }
+ return(fall_through);
+}
+
static s7_pointer op_c_s_opsq(s7_scheme *sc)
{
s7_pointer args, val;
@@ -86431,6 +86727,14 @@ static s7_pointer op_c_scs(s7_scheme *sc)
return(c_call(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;
+}
+
static s7_pointer op_s_c(s7_scheme *sc)
{
s7_pointer code;
@@ -86465,7 +86769,7 @@ static inline bool op_s_s(s7_scheme *sc)
return(false); /* goto APPLY; */
}
-static s7_pointer op_s_a(s7_scheme *sc)
+static inline s7_pointer op_s_a(s7_scheme *sc)
{
s7_pointer code;
code = sc->code;
@@ -86497,7 +86801,7 @@ static s7_pointer op_s_aa(s7_scheme *sc)
return(NULL);
}
-static void op_safe_c_star_fx(s7_scheme *sc)
+static void op_safe_c_function_star_fx(s7_scheme *sc)
{
s7_pointer args, p;
sc->args = safe_list_if_possible(sc, integer(opt3_arglen(sc->code)));
@@ -86509,13 +86813,13 @@ static void op_safe_c_star_fx(s7_scheme *sc)
sc->args = sc->nil;
}
-static void op_safe_c_star(s7_scheme *sc)
+static void op_safe_c_function_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)
+static void op_safe_c_function_star_a(s7_scheme *sc)
{
sc->args = list_1(sc, fx_call(sc, cdr(sc->code)));
sc->code = opt1_cfunc(sc->code);
@@ -86523,7 +86827,7 @@ static void op_safe_c_star_a(s7_scheme *sc)
apply_c_function_star_fill_defaults(sc, 1);
}
-static void op_safe_c_star_aa(s7_scheme *sc)
+static void op_safe_c_function_star_aa(s7_scheme *sc)
{
s7_pointer val;
val = fx_call(sc, cdr(sc->code));
@@ -86534,12 +86838,75 @@ static void op_safe_c_star_aa(s7_scheme *sc)
apply_c_function_star(sc);
}
+
+static void op_safe_c_ps(s7_scheme *sc)
+{
+ push_stack_no_args(sc, OP_SAFE_C_PS_1, sc->code); /* gotta 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)));
+ /* we have to wait because we say the evaluation order is left to right (in lambda*)
+ * and the first arg's evaluation might change the value of the second arg.
+ */
+ set_car(sc->t2_1, sc->value);
+ sc->value = c_call(sc->code)(sc, sc->t2_1);
+}
+
static void op_safe_c_ps_mv(s7_scheme *sc) /* (define (hi a) (+ (values 1 2) a)) */
{
sc->args = s7_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)
+{
+ check_stack_size(sc);
+ push_stack(sc, (opcode_t)opt1_any(cdr(sc->code)), lookup(sc, cadr(sc->code)), sc->code);
+ sc->code = caddr(sc->code);
+}
+
+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 = c_call(sc->code)(sc, sc->t2_1);
+}
+
+static void op_safe_c_sp_mv(s7_scheme *sc)
+{
+ sc->args = cons(sc, sc->args, sc->value); /* don't use u2_1 or some permanent list here: immutable=copied later */
+ sc->code = c_function_base(opt1_cfunc(sc->code));
+}
+
+#if (!WITH_GMP)
+static void op_safe_add_sp_1(s7_scheme *sc)
+{
+ if ((is_t_integer(sc->args)) && (is_t_integer(sc->value)))
+#if (!HAVE_OVERFLOW_CHECKS)
+ sc->value = make_integer(sc, integer(sc->args) + integer(sc->value));
+#else
+ {
+ s7_int val;
+ if (add_overflow(integer(sc->args), integer(sc->value), &val))
+ sc->value = make_real(sc, (double)integer(sc->args) + (double)integer(sc->value));
+ else sc->value = make_integer(sc, val);
+ }
+#endif
+ 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);
+}
+#endif
+
static void op_safe_c_pc(s7_scheme *sc)
{
check_stack_size(sc);
@@ -86573,6 +86940,19 @@ static void op_safe_c_cp(s7_scheme *sc)
sc->code = caddr(sc->code);
}
+static inline void op_safe_c_s(s7_scheme *sc)
+{
+ set_car(sc->t1_1, lookup(sc, cadr(sc->code)));
+ sc->value = c_call(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 = c_call(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)));
@@ -86590,11 +86970,12 @@ static void op_safe_c_ap(s7_scheme *sc)
sc->code = caddr(code);
}
-static void op_safe_c_sp_mv(s7_scheme *sc)
+static void op_safe_c_pp(s7_scheme *sc)
{
- sc->args = cons(sc, sc->args, sc->value); /* don't use u2_1 or some permanent list here: immutable=copied later */
- sc->code = c_function_base(opt1_cfunc(sc->code));
-}
+ check_stack_size(sc);
+ push_stack_no_args(sc, OP_SAFE_C_PP_1, sc->code);
+ sc->code = cadr(sc->code);
+}
static void op_safe_c_pp_1(s7_scheme *sc)
{
@@ -86678,9 +87059,25 @@ static void op_safe_c_fp(s7_scheme *sc) /* code: (func . args) where at least on
sc->code = T_Pair(car(p));
}
-static bool op_safe_c_fp_mv_1(s7_scheme *sc)
+static bool op_safe_c_fp_1(s7_scheme *sc)
+{
+ /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is the next arg if any */
+ if (collect_fp_args(sc, OP_SAFE_C_FP_1, cons(sc, sc->value, sc->args)))
+ return(true);
+ sc->args = safe_reverse_in_place(sc, sc->args);
+ sc->value = c_call(car(sc->args))(sc, cdr(sc->args));
+ return(false);
+}
+
+static void op_safe_c_fp_2(s7_scheme *sc)
+{
+ sc->args = safe_reverse_in_place(sc, sc->args = cons(sc, sc->value, sc->args));
+ sc->value = c_call(car(sc->args))(sc, cdr(sc->args));
+}
+
+static inline bool op_safe_c_fp_mv_1(s7_scheme *sc)
{
- /* s7_append copies its first argument, as does s7_reverse, so use append_uncopied */
+ /* we're looping through fp cases here, so sc->value can be non-mv after the first */
if (collect_fp_args(sc, OP_SAFE_C_FP_MV_1, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args)))
return(true);
sc->args = safe_reverse_in_place(sc, sc->args);
@@ -86795,6 +87192,18 @@ static void op_c_a(s7_scheme *sc)
sc->value = c_call(sc->code)(sc, sc->args);
}
+static void op_c_p(s7_scheme *sc)
+{
+ push_stack_no_args(sc, OP_C_P_1, sc->code);
+ 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 = c_call(sc->code)(sc, sc->args);
+}
+
static void op_c_ap(s7_scheme *sc)
{
s7_pointer val;
@@ -86856,20 +87265,11 @@ static void op_c_s(s7_scheme *sc)
sc->value = c_call(sc->code)(sc, sc->args);
}
-static inline void op_eval_args1(s7_scheme *sc) /* inline is needed here */
-{
- s7_pointer x;
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->args);
- sc->args = x;
-}
-
-static void op_safe_ifa_ss_a(s7_scheme *sc) /* ((if fx s s) fx) I think */
+static s7_pointer fx_opif_a_ssq_a(s7_scheme *sc, s7_pointer code) /* ((if fx s s) fx) I think */
{
s7_function f;
- f = c_function_call((is_true(sc, fx_call(sc, cdar(sc->code)))) ? opt1_con(sc->code) : opt2_con(sc->code));
- sc->value = f(sc, set_plist_1(sc, fx_call(sc, cdr(sc->code))));
+ f = c_function_call((is_true(sc, fx_call(sc, cdar(code)))) ? opt1_con(code) : opt2_con(code));
+ return(f(sc, set_plist_1(sc, fx_call(sc, cdr(code)))));
}
#if WITH_GCC
@@ -86913,9 +87313,7 @@ static void op_eval_args2(s7_scheme *sc)
{
s7_pointer x;
sc->code = pop_op_stack(sc);
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->args);
+ x = cons(sc, sc->value, sc->args);
if (!is_null(sc->args))
sc->args = safe_reverse_in_place(sc, x);
else sc->args = x;
@@ -86927,38 +87325,47 @@ static void op_eval_args3(s7_scheme *sc)
val = sc->code;
if (is_symbol(val))
val = lookup_checked(sc, val);
- new_cell(sc, x, T_PAIR);
- new_cell_no_check(sc, y, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->args);
- set_car(y, val);
- set_cdr(y, x);
+ x = cons(sc, sc->value, sc->args);
+ y = cons_unchecked(sc, val, x);
sc->args = safe_reverse_in_place(sc, y);
sc->code = pop_op_stack(sc);
}
-static void op_eval_args4(s7_scheme *sc)
-{
- s7_pointer x;
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->args);
- sc->args = x; /* all the others reverse -- why not this case? -- reverse is at end? (below) */
-}
-
static void op_eval_args5(s7_scheme *sc) /* sc->value is the last arg, sc->code is the previous */
{
s7_pointer x, y;
- new_cell(sc, x, T_PAIR);
- new_cell_no_check(sc, y, T_PAIR);
- set_car(x, sc->code);
- set_cdr(x, sc->args);
- set_car(y, sc->value);
- set_cdr(y, x);
+ x = cons(sc, sc->code, sc->args);
+ y = cons_unchecked(sc, sc->value, x);
sc->args = safe_reverse_in_place(sc, y);
sc->code = pop_op_stack(sc);
}
+static bool eval_args_no_eval_args(s7_scheme *sc)
+{
+ if (is_any_macro(sc->value))
+ {
+ sc->args = copy_list_with_arglist_error(sc, cdr(sc->code)); /* check the first time around */
+ 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:
@@ -86970,12 +87377,10 @@ static void op_read_internal(s7_scheme *sc)
* and the original is inaccessible! So we get a segfault in token. We don't want to put
* a port_is_closed check there because token only rarely is in this danger. I think this
* is the only place where we can be about to call token, and someone has screwed up our port.
- *
- * We can't call read_error here because it assumes the input string is ok!
*/
if (port_is_closed(sc->input_port))
- s7_error(sc, sc->read_error_symbol,
+ 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);
@@ -87018,6 +87423,23 @@ static bool op_read_quasiquote(s7_scheme *sc)
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->envir is apparently not needed here */
+ sc->stack_end -= 4;
+ sc->args = sc->stack_end[2];
+ if (is_null(sc->args))
+ {
+ sc->args = cons(sc, sc->value, sc->args);
+ set_file_and_line_number(sc, sc->args);
+#if WITH_PROFILE
+ profile_set_location(x, remember_location(port_line_number(sc->input_port), port_file_number(sc->input_port)));
+#endif
+ return(true);
+ }
+ return(false);
+}
+
static bool op_load_return_if_eof(s7_scheme *sc)
{
/* loop here until eof (via push stack below) */
@@ -87173,67 +87595,6 @@ static bool op_read_byte_vector(s7_scheme *sc)
return(main_stack_op(sc) != OP_READ_LIST);
}
-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(safe_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);
- }
-}
-
-static void macroexpand_c_macro(s7_scheme *sc)
-{
- s7_int len;
- len = safe_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 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 */
@@ -87247,15 +87608,33 @@ static void eval_last_arg(s7_scheme *sc, s7_pointer car_code)
val = lookup_checked(sc, car_code); /* this has to precede the set_type below */
else val = car_code;
sc->temp4 = val;
- new_cell(sc, x, T_PAIR);
- set_car(x, val);
- set_cdr(x, sc->args);
-
+ x = cons(sc, val, sc->args);
if (!is_null(sc->args))
sc->args = safe_reverse_in_place(sc, x);
else sc->args = x;
}
+static void eval_args_pair_car(s7_scheme *sc)
+{
+ if (sc->stack_end >= sc->stack_resize_trigger)
+ check_for_cyclic_code(sc, sc->code);
+
+ /* all 3 of these push_stacks can result in stack overflow, see above 64065 */
+ if (is_null(cdr(sc->code)))
+ push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args);
+ else
+ {
+ if (!is_pair(cdr(sc->code))) /* (= 0 '(1 . 2) . 3) */
+ improper_arglist_error(sc);
+
+ if ((is_null(cddr(sc->code))) &&
+ (!is_pair(cadr(sc->code))))
+ push_stack(sc, OP_EVAL_ARGS3, sc->args, cadr(sc->code));
+ else push_stack(sc, OP_EVAL_ARGS4, sc->args, cdr(sc->code));
+ }
+ sc->code = car(sc->code);
+}
+
static bool eval_car_pair(s7_scheme *sc)
{
s7_pointer code, carc;
@@ -87289,6 +87668,34 @@ static bool eval_car_pair(s7_scheme *sc)
return(false);
}
+static bool eval_args_last_arg(s7_scheme *sc)
+{
+ s7_pointer x, y, val, car_code;
+ /* we're at the last arg, sc->value is the previous one, not yet saved in the args list */
+ car_code = car(sc->code);
+ if (is_pair(car_code))
+ {
+ if (sc->stack_end >= sc->stack_resize_trigger)
+ check_for_cyclic_code(sc, sc->code);
+ push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value);
+ sc->code = car_code;
+ return(true);
+ }
+
+ /* get the last arg */
+ if (is_symbol(car_code))
+ val = lookup_checked(sc, car_code);
+ else val = car_code;
+ sc->temp4 = val;
+
+ /* get the current arg, which is not a list */
+ sc->code = pop_op_stack(sc);
+ x = cons(sc, sc->value, sc->args);
+ y = cons_unchecked(sc, val, x);
+ sc->args = safe_reverse_in_place(sc, y);
+ return(false);
+}
+
static void op_pair_pair(s7_scheme *sc)
{
if (sc->stack_end >= sc->stack_resize_trigger)
@@ -87299,8 +87706,6 @@ static void op_pair_pair(s7_scheme *sc)
}
-#define UNOPT_PRINT 0
-
static goto_t trailers(s7_scheme *sc)
{
s7_pointer code;
@@ -87313,9 +87718,6 @@ static goto_t trailers(s7_scheme *sc)
{
sc->cur_op = (opcode_t)symbol_syntax_op_checked(code);
pair_set_syntax_op(code, sc->cur_op);
-#if UNOPT_PRINT && (0)
- fprintf(stderr, " syntax (1): %s\n", DISPLAY_80(sc->code));
-#endif
return(goto_top_no_pop);
}
@@ -87326,16 +87728,10 @@ static goto_t trailers(s7_scheme *sc)
{
sc->cur_op = (opcode_t)symbol_syntax_op_checked(code);
pair_set_syntax_op(sc->code, sc->cur_op);
-#if UNOPT_PRINT
- fprintf(stderr, " syntax (2): %s\n", DISPLAY_80(sc->code));
-#endif
return(goto_top_no_pop);
}
sc->value = lookup_global(sc, carc);
set_optimize_op(code, OP_PAIR_SYM);
-#if UNOPT_PRINT
- fprintf(stderr, " pair_sym: %s\n", DISPLAY_80(code));
-#endif
/* pair_sym -> unknown* check seems to make no difference? maybe split pair_sym? */
return(goto_eval_args_top);
}
@@ -87349,16 +87745,10 @@ static goto_t trailers(s7_scheme *sc)
{
sc->cur_op = (opcode_t)syntax_opcode(carc);
pair_set_syntax_op(sc->code, sc->cur_op);
-#if UNOPT_PRINT
- fprintf(stderr, " syntax (4): %s\n", DISPLAY_80(sc->code));
-#endif
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);
-#if UNOPT_PRINT
- fprintf(stderr, " pair_any: %s\n", DISPLAY_80(sc->code));
-#endif
sc->value = T_Pos(carc);
return(goto_eval_args_top);
}
@@ -87366,18 +87756,11 @@ static goto_t trailers(s7_scheme *sc)
{
sc->value = lookup_checked(sc, code);
set_optimize_op(code, (is_keyword(code)) ? OP_CON : ((is_global(code)) ? OP_GLOBAL_SYM : OP_SYM));
- /* set_optimize_op(code, (is_keyword(code)) ? OP_CON : OP_SYM); */
-#if UNOPT_PRINT
- fprintf(stderr, " con/sym: %s\n", DISPLAY_80(sc->code));
-#endif
}
else
{
sc->value = T_Pos(code);
set_optimize_op(code, OP_CON);
-#if UNOPT_PRINT
- fprintf(stderr, " con: %s\n", DISPLAY_80(sc->code));
-#endif
}
return(goto_start);
}
@@ -87436,25 +87819,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_D: if (!c_function_is_ok(sc, sc->code)) break; /* break refers to the switch statement */
case HOP_SAFE_C_D: sc->value = d_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */
- case OP_SAFE_C_S: /* hop_safe_c_t (if set in fx_tree) is uncommon: ca 20 hits in t103.scm */
- if (!c_function_is_ok(sc, sc->code)) /* {set_optimize_op(sc->code, OP_S_S); goto EVAL;} */
- {
- if (op_unknown_g(sc, lookup(sc, car(sc->code))) != goto_eval)
- set_optimize_op(sc->code, OP_S_S);
- goto EVAL;
- }
- case HOP_SAFE_C_S:
- set_car(sc->t1_1, lookup(sc, cadr(sc->code)));
- sc->value = c_call(sc->code)(sc, sc->t1_1);
- continue;
+ case OP_SAFE_C_S: if (op_check_safe_c_s(sc)) goto EVAL;
+ 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:
- set_car(sc->t2_1, lookup(sc, cadr(sc->code)));
- set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(sc->code))));
- sc->value = c_call(sc->code)(sc, sc->t2_1);
- 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_ALL_S: if (!c_function_is_ok(sc, sc->code)) break;
case HOP_SAFE_C_ALL_S: sc->value = fx_c_all_s(sc, sc->code); continue;
@@ -87468,43 +87837,18 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_P:
- if (!c_function_is_ok(sc, sc->code)) break;
- case HOP_SAFE_C_P:
- check_stack_size(sc);
- push_stack_no_args(sc, OP_SAFE_C_P_1, sc->code);
- sc->code = T_Pair(cadr(sc->code));
- goto EVAL;
-
- case OP_SAFE_C_P_1:
- set_car(sc->t1_1, sc->value);
- sc->value = c_call(sc->code)(sc, sc->t1_1);
- continue;
-
- case OP_NOT_P:
- if (!c_function_is_ok(sc, sc->code)) break;
- case HOP_NOT_P:
- push_stack_no_args(sc, OP_NOT_P_1, sc->code);
- sc->code = T_Pair(cadr(sc->code));
- goto EVAL;
+ 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_NOT_P: if (!c_function_is_ok(sc, sc->code)) break;
+ case HOP_NOT_P: op_not_p(sc); goto EVAL;
case OP_NOT_P_1: sc->value = ((sc->value == sc->F) ? sc->T : sc->F); continue;
- case OP_SAFE_C_FP: if (!c_function_is_ok(sc, sc->code)) break;
- case HOP_SAFE_C_FP: op_safe_c_fp(sc); goto EVAL;
-
- case OP_SAFE_C_FP_1: /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is the next arg if any */
- if (collect_fp_args(sc, OP_SAFE_C_FP_1, cons(sc, sc->value, sc->args)))
- goto EVAL;
- sc->args = safe_reverse_in_place(sc, sc->args);
- sc->value = c_call(car(sc->args))(sc, cdr(sc->args));
- continue;
-
- case OP_SAFE_C_FP_2:
- sc->args = safe_reverse_in_place(sc, sc->args = cons(sc, sc->value, sc->args));
- sc->value = c_call(car(sc->args))(sc, cdr(sc->args));
- continue;
-
+ case OP_SAFE_C_FP: if (!c_function_is_ok(sc, sc->code)) break;
+ case HOP_SAFE_C_FP: op_safe_c_fp(sc); goto EVAL;
+ case OP_SAFE_C_FP_1: if (op_safe_c_fp_1(sc)) goto EVAL; continue;
+ case OP_SAFE_C_FP_2: op_safe_c_fp_2(sc); continue;
case OP_SAFE_C_FP_MV_1: if (op_safe_c_fp_mv_1(sc)) goto EVAL; goto APPLY;
case OP_SAFE_C_SSP: if (!c_function_is_ok(sc, sc->code)) break;
@@ -87512,21 +87856,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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, lookup_checked(sc, car(sc->code))) == goto_eval) /* for lt?? (matters at least in lt: 12!) */
- {
- if (op_no_hop(sc->code) == OP_SAFE_C_A)
- {
- set_car(sc->t1_1, c_call(cdr(sc->code))(sc, cadr(sc->code)));
- sc->value = c_call(sc->code)(sc, sc->t1_1);
- continue;
- }
- }
- else set_optimize_op(sc->code, OP_S_A);
- goto EVAL;
- }
+ case OP_SAFE_C_A: switch (op_check_safe_c_a(sc)) {case goto_start: continue; case goto_eval: goto EVAL; default: break;}
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;
@@ -87553,12 +87883,19 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) break;
case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue;
+ case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) break;
+ 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)) break;
+ 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_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 OP_SSA_DIRECT: sc->value = fx_c_ssa_direct(sc, sc->code); continue;
+ case OP_HASH_INCREMENT: sc->value = fx_hash_increment(sc, sc->code); continue;
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;
@@ -87572,9 +87909,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_SSSC: if (!c_function_is_ok(sc, sc->code)) break;
- case HOP_SAFE_C_SSSC: sc->value = fx_c_sssc(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;
@@ -87596,6 +87930,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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;
@@ -87618,22 +87955,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_op_opSq_S_q: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break;
case HOP_SAFE_C_op_opSq_S_q: sc->value = fx_c_op_opsq_s_q(sc, sc->code); continue;
- case OP_SAFE_C_PS:
- if (!c_function_is_ok(sc, sc->code)) break;
- case HOP_SAFE_C_PS:
- push_stack_no_args(sc, OP_SAFE_C_PS_1, sc->code); /* gotta wait in this case */
- sc->code = cadr(sc->code);
- goto EVAL;
-
- case OP_SAFE_C_PS_1:
- set_car(sc->t2_2, lookup(sc, caddr(sc->code)));
- /* we have to wait because we say the evaluation order is left to right (in lambda*)
- * and the first arg's evaluation might change the value of the second arg.
- */
- set_car(sc->t2_1, sc->value);
- sc->value = c_call(sc->code)(sc, sc->t2_1);
- 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;
@@ -87641,62 +87965,18 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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:
- check_stack_size(sc);
- push_stack(sc, (opcode_t)opt1_any(cdr(sc->code)), lookup(sc, cadr(sc->code)), sc->code);
- sc->code = caddr(sc->code);
- goto EVAL;
-
- case OP_SAFE_C_SP_1: /* 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 = c_call(sc->code)(sc, sc->t2_1);
- continue;
+ case OP_SAFE_C_SP: if (!c_function_is_ok(sc, sc->code)) break;
+ case HOP_SAFE_C_SP: op_safe_c_sp(sc); goto EVAL;
+ case OP_SAFE_C_SP_1: op_safe_c_sp_1(sc); continue;
+ case OP_SAFE_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;
-
#if (!WITH_GMP)
- case OP_SAFE_ADD_SP_1:
- if ((is_t_integer(sc->args)) && (is_t_integer(sc->value)))
-#if HAVE_OVERFLOW_CHECKS
- {
- s7_int val;
- if (add_overflow(integer(sc->args), integer(sc->value), &val))
- sc->value = make_real(sc, (double)integer(sc->args) + (double)integer(sc->value));
- else sc->value = make_integer(sc, val);
- }
-#else
- sc->value = make_integer(sc, integer(sc->args) + integer(sc->value));
-#endif
- else sc->value = add_p_pp(sc, sc->args, sc->value);
- continue;
-
- case OP_SAFE_SUBTRACT_SP_1:
- sc->value = subtract_p_pp(sc, sc->args, sc->value);
- continue;
-
- case OP_SAFE_MULTIPLY_SP_1:
- 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);
- continue;
+ case OP_SAFE_ADD_SP_1: op_safe_add_sp_1(sc); continue;
+ case OP_SAFE_SUBTRACT_SP_1: sc->value = subtract_p_pp(sc, sc->args, sc->value); continue;
+ case OP_SAFE_MULTIPLY_SP_1: op_safe_multiply_sp_1(sc); continue;
#endif
- case OP_SAFE_MEMQ_SP_1:
- if (is_pair(sc->value))
- sc->value = s7_memq(sc, sc->args, sc->value);
- else
- {
- if (is_null(sc->value))
- sc->value = sc->F;
- else sc->value = method_or_bust_with_type(sc, sc->value, sc->memq_symbol, list_2(sc, sc->args, sc->value), a_list_string, 2);
- }
- continue;
-
- case OP_SAFE_C_SP_MV: op_safe_c_sp_mv(sc); goto APPLY;
-
case OP_SAFE_C_AP: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code)))) break;
case HOP_SAFE_C_AP: op_safe_c_ap(sc); goto EVAL;
@@ -87708,13 +87988,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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:
- check_stack_size(sc);
- push_stack_no_args(sc, OP_SAFE_C_PP_1, sc->code);
- sc->code = cadr(sc->code);
- 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;
@@ -87811,18 +88086,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_opDq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break;
case HOP_SAFE_C_opDq_S: sc->value = fx_c_opdq_s(sc, sc->code); continue;
- case OP_SAFE_C_opDq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break;
- case HOP_SAFE_C_opDq_C: sc->value = fx_c_opdq_c(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_opDq_opDq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break;
- case HOP_SAFE_C_opDq_opDq: sc->value = fx_c_opdq_opdq(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;
@@ -87832,7 +88101,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_opSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break;
case HOP_SAFE_C_opSq_opSSq: sc->value = fx_c_opsq_opssq(sc, sc->code); continue;
- /* -------------------------------------------------------------------------------- */
+
case OP_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;
@@ -87842,22 +88111,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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:
- push_stack_no_args(sc, OP_C_P_1, sc->code);
- sc->code = T_Pair(cadr(sc->code));
- goto EVAL;
+ 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 = c_call(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:
- sc->args = list_2(sc, lookup(sc, cadr(sc->code)), lookup(sc, caddr(sc->code)));
- sc->value = c_call(sc->code)(sc, sc->args);
- continue;
+ case OP_C_SS: if (!c_function_is_ok(sc, sc->code)) break;
+ case HOP_C_SS: op_c_ss(sc); continue;
case OP_C_AP: if (!c_function_is_ok(sc, sc->code)) break;
case HOP_C_AP: op_c_ap(sc); goto EVAL;
@@ -87883,7 +88144,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_C_FX: if (!c_function_is_ok(sc, sc->code)) break;
case HOP_C_FX: op_c_fx(sc); continue;
- case OP_SAFE_IFA_SS_A: op_safe_ifa_ss_a(sc); continue;
+ case OP_opIF_A_SSq_A: sc->value = fx_opif_a_ssq_a(sc, sc->code); continue;
case OP_APPLY_SS: op_apply_ss(sc); goto APPLY;
case OP_APPLY_SA: op_apply_sa(sc); goto APPLY;
@@ -87907,33 +88168,26 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_C_CATCH_ALL_FX: if (!c_function_is_ok(sc, sc->code)) break;
case HOP_C_CATCH_ALL_FX: op_c_catch_all_fx(sc); continue;
- /* -------------------------------------------------------------------------------- */
- /* unknown* fallback on these */
- case OP_S:
- sc->code = lookup(sc, car(sc->code));
- if (!is_applicable(sc->code))
- apply_error(sc, sc->code, sc->nil);
- sc->args = sc->nil;
- goto APPLY;
+ 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_s_a(sc); goto APPLY;
case OP_S_AA: op_s_aa(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_FUNCTION_STAR: if (!c_function_is_ok(sc, sc->code)) break;
+ case HOP_SAFE_C_FUNCTION_STAR: op_safe_c_function_star(sc); continue;
+
+ case OP_SAFE_C_FUNCTION_STAR_A: if (!c_function_is_ok(sc, sc->code)) break;
+ case HOP_SAFE_C_FUNCTION_STAR_A: op_safe_c_function_star_a(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_FUNCTION_STAR_AA: if (!c_function_is_ok(sc, sc->code)) break;
+ case HOP_SAFE_C_FUNCTION_STAR_AA: op_safe_c_function_star_aa(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_FUNCTION_STAR_FX: if (!c_function_is_ok(sc, sc->code)) break;
+ case HOP_SAFE_C_FUNCTION_STAR_FX: op_safe_c_function_star_fx(sc); continue;
- case OP_SAFE_C_STAR_FX: if (!c_function_is_ok(sc, sc->code)) break;
- case HOP_SAFE_C_STAR_FX: op_safe_c_star_fx(sc); continue;
- /* -------------------------------------------------------------------------------- */
case OP_THUNK: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_THUNK: op_thunk(sc); goto EVAL;
@@ -87947,51 +88201,35 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case HOP_THUNK_NIL: op_thunk_nil(sc); goto BEGIN;
case OP_SAFE_THUNK_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;}
- case HOP_SAFE_THUNK_A: sc->value = fx_thunk_a(sc, sc->code); continue;
+ case HOP_SAFE_THUNK_A: sc->value = fx_safe_thunk_a(sc, sc->code); continue;
case OP_SAFE_THUNK_P: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_SAFE_THUNK_P: op_safe_thunk_p(sc); goto EVAL;
- case OP_CLOSURE_S:
- if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
- case HOP_CLOSURE_S:
- sc->value = lookup(sc, opt2_sym(sc->code));
- check_stack_size(sc);
- sc->code = opt1_lambda(sc->code);
- new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value);
- closure_push_and_goto_eval(sc);
-
- case OP_CLOSURE_S_P:
- if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
- case HOP_CLOSURE_S_P:
- sc->value = lookup(sc, opt2_sym(sc->code));
- check_stack_size(sc);
- sc->code = opt1_lambda(sc->code);
- new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value);
- closure_goto_eval(sc);
-
- case OP_SAFE_CLOSURE_S:
- if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
- case HOP_SAFE_CLOSURE_S:
- sc->value = lookup(sc, opt2_sym(sc->code));
- sc->code = opt1_lambda(sc->code);
- sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value);
- closure_push_and_goto_eval(sc);
-
- case OP_SAFE_CLOSURE_S_P:
- if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
- case HOP_SAFE_CLOSURE_S_P:
- sc->value = lookup(sc, opt2_sym(sc->code));
- sc->code = opt1_lambda(sc->code);
- sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value);
- closure_goto_eval(sc);
+ case OP_CLOSURE_S: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case HOP_CLOSURE_S: op_closure_s(sc); goto EVAL;
+
+ case OP_CLOSURE_S_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case HOP_CLOSURE_S_P: op_closure_s_p(sc); goto EVAL;
+
+ case OP_SAFE_CLOSURE_S: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case HOP_SAFE_CLOSURE_S: op_safe_closure_s(sc); goto EVAL;
+
+ case OP_SAFE_CLOSURE_S_P: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case HOP_SAFE_CLOSURE_S_P: op_safe_closure_s_p(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, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_SAFE_CLOSURE_S_A: sc->value = fx_safe_closure_s_a(sc, sc->code); continue;
- case OP_SAFE_CLOSURE_S_TO_S: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case OP_SAFE_CLOSURE_ID_S: if (!closure_is_eq(sc)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case HOP_SAFE_CLOSURE_ID_S: sc->value = fx_safe_closure_id_s(sc, sc->code); continue;
+
+ case OP_SAFE_CLOSURE_S_TO_S: if (!closure_is_eq(sc)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
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 (!closure_is_eq(sc)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_safe_closure_s_to_sc(sc, sc->code); continue;
+
case OP_CLOSURE_C: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_CLOSURE_C: op_closure_c(sc); goto EVAL;
@@ -88007,33 +88245,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_CLOSURE_C_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_SAFE_CLOSURE_C_A: op_safe_closure_c_a(sc); continue;
- case OP_CLOSURE_P:
- if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break;
- case HOP_CLOSURE_P:
- push_stack(sc, OP_CLOSURE_P_1, sc->args, sc->code);
- sc->code = cadr(sc->code);
- goto EVAL;
-
- case OP_CLOSURE_P_1:
- check_stack_size(sc);
- sc->code = opt1_lambda(sc->code);
- new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value);
- sc->code = T_Pair(closure_body(sc->code));
- goto BEGIN;
-
+ case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break;
+ case HOP_CLOSURE_P: op_closure_p(sc); goto EVAL;
+ case OP_CLOSURE_P_1: op_closure_p_1(sc); goto BEGIN;
case OP_CLOSURE_P_MV: op_closure_p_mv(sc); goto APPLY;
- case OP_SAFE_CLOSURE_P:
- if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break;
- case HOP_SAFE_CLOSURE_P:
- push_stack(sc, OP_SAFE_CLOSURE_P_1, sc->args, sc->code);
- sc->code = cadr(sc->code);
- goto EVAL;
-
- case OP_SAFE_CLOSURE_P_1:
- sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(sc->code)), sc->value);
- sc->code = T_Pair(closure_body(opt1_lambda(sc->code)));
- goto BEGIN;
+ case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break;
+ 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_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_CLOSURE_A: op_closure_a(sc); closure_push_and_goto_eval(sc);
@@ -88092,14 +88311,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_CLOSURE_3S_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_CLOSURE_3S_P: op_closure_3s(sc); sc->code = car(closure_body(sc->code)); goto EVAL;
- /* an experiment -- if closure through unknown_all_s M/P case may change on every call */
case OP_CLOSURE_3S_B: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;}
- case HOP_CLOSURE_3S_B: op_closure_3s(sc);
- sc->code = T_Pair(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);
- goto EVAL;
+ case HOP_CLOSURE_3S_B: op_closure_3s_b(sc); goto EVAL;
case OP_CLOSURE_4S: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 4)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_CLOSURE_4S: op_closure_4s(sc); closure_push(sc); goto EVAL;
@@ -88108,12 +88321,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case HOP_CLOSURE_4S_P: op_closure_4s(sc); sc->code = car(closure_body(sc->code)); goto EVAL;
case OP_CLOSURE_4S_B: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;}
- case HOP_CLOSURE_4S_B: op_closure_4s(sc);
- sc->code = T_Pair(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);
- goto EVAL;
+ case HOP_CLOSURE_4S_B: op_closure_4s_b(sc); goto EVAL;
case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_CLOSURE_SC: op_closure_sc(sc); goto EVAL;
@@ -88163,27 +88371,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) break;
case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto BEGIN;
- case OP_CLOSURE_ALL_S:
- if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, integer(opt3_arglen(sc->code))))
- {
- if (op_unknown_all_s(sc, sc->last_function) == goto_eval)
- goto EVAL;
- break;
- }
- case HOP_CLOSURE_ALL_S:
- op_closure_all_s(sc);
- goto EVAL;
+ case OP_CLOSURE_ALL_S: switch (op_check_closure_all_s(sc)) {case goto_eval: goto EVAL; case goto_unopt: goto UNOPT; default: break;}
+ case HOP_CLOSURE_ALL_S: op_closure_all_s(sc); goto EVAL;
- case OP_CLOSURE_FX:
- if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, integer(opt3_arglen(sc->code))))
- {
- if (op_unknown_fx(sc, sc->last_function) == goto_eval)
- goto EVAL;
- break;
- }
- case HOP_CLOSURE_FX:
- op_closure_fx(sc);
- goto EVAL;
+ case OP_CLOSURE_FX: switch (op_check_closure_fx(sc)) {case goto_eval: goto EVAL; case goto_unopt: goto UNOPT; default: break;}
+ case HOP_CLOSURE_FX: op_closure_fx(sc); goto EVAL;
case OP_CLOSURE_ANY_FX: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, -1)) break;
case HOP_CLOSURE_ANY_FX: op_closure_any_fx(sc); goto BEGIN;
@@ -88191,23 +88383,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_CLOSURE_FP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, integer(opt3_arglen(sc->code)))) break;
case HOP_SAFE_CLOSURE_FP: op_safe_closure_fp(sc); goto EVAL;
- case OP_SAFE_CLOSURE_FP_1:
- if (!(collect_fp_args(sc, OP_SAFE_CLOSURE_FP_1, cons(sc, sc->value, sc->args))))
- op_safe_closure_fp_1(sc);
- goto EVAL;
-
- case OP_SAFE_CLOSURE_FP_2:
- sc->args = cons(sc, sc->value, sc->args);
- op_safe_closure_fp_1(sc);
- goto EVAL;
-
+ case OP_SAFE_CLOSURE_FP_1: if (!(collect_fp_args(sc, OP_SAFE_CLOSURE_FP_1, cons(sc, sc->value, sc->args)))) op_safe_closure_fp_1(sc); goto EVAL;
+ case OP_SAFE_CLOSURE_FP_2: sc->args = cons(sc, sc->value, sc->args); op_safe_closure_fp_1(sc); goto EVAL;
case OP_SAFE_CLOSURE_FP_MV_1:
if (!(collect_fp_args(sc, OP_SAFE_CLOSURE_FP_MV_1, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args))))
op_safe_closure_fp_1(sc);
goto EVAL;
- /* -------------------------------------------------------------------------------- */
case OP_TC_AND_A_OR_A_LA: tick_tc_rec(sc); op_tc_and_a_or_a_la(sc, sc->code); continue;
case OP_TC_OR_A_AND_A_LA: tick_tc_rec(sc); op_tc_or_a_and_a_la(sc, sc->code); continue;
case OP_TC_AND_A_OR_A_LAA: tick_tc_rec(sc); op_tc_and_a_or_a_laa(sc, sc->code); continue;
@@ -88258,63 +88441,48 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); 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, sc->last_function) == goto_eval) goto EVAL; break;}
+ case OP_SAFE_CLOSURE_STAR_A:
+ if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_SAFE_CLOSURE_STAR_A: safe_closure_star_a(sc, sc->code); goto BEGIN;
case OP_SAFE_CLOSURE_STAR_AA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) break;
case HOP_SAFE_CLOSURE_STAR_AA: safe_closure_star_aa(sc, sc->code); goto BEGIN;
- case OP_SAFE_CLOSURE_STAR_FX:
- if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? integer(opt3_arglen(sc->code)) : 0))
- {
- if (op_unknown_fx(sc, sc->last_function) == goto_eval)
- goto EVAL;
- break;
- }
- case HOP_SAFE_CLOSURE_STAR_FX:
- if (safe_closure_star_fx(sc, sc->code) == goto_eval) goto EVAL;
- goto BEGIN;
+ case OP_SAFE_CLOSURE_STAR_FX: switch (op_check_safe_closure_star_fx(sc)) {case goto_eval: goto EVAL; case goto_unopt: goto UNOPT; default: break;}
+ case HOP_SAFE_CLOSURE_STAR_FX: if (safe_closure_star_fx(sc, sc->code)) goto EVAL; goto BEGIN;
case OP_SAFE_CLOSURE_STAR_FX_0:
if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_SAFE_CLOSURE_STAR_FX_0:
- if (safe_closure_star_fx_0(sc, sc->code) == goto_eval) goto EVAL;
+ if (safe_closure_star_fx_0(sc, sc->code)) goto EVAL;
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_FX_1:
if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_SAFE_CLOSURE_STAR_FX_1:
- if (safe_closure_star_fx_1(sc, sc->code) == goto_eval) goto EVAL;
+ if (safe_closure_star_fx_1(sc, sc->code)) goto EVAL;
goto BEGIN;
case OP_SAFE_CLOSURE_STAR_FX_2:
if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_SAFE_CLOSURE_STAR_FX_2:
- if (safe_closure_star_fx_2(sc, sc->code) == goto_eval) goto EVAL;
+ if (safe_closure_star_fx_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, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_CLOSURE_STAR_A:
closure_star_a(sc, sc->code);
goto BEGIN;
- case OP_CLOSURE_STAR_FX:
- if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? integer(opt3_arglen(sc->code)) : 0))
- {
- if (op_unknown_fx(sc, sc->last_function) == goto_eval)
- goto EVAL;
- break;
- }
- case HOP_CLOSURE_STAR_FX:
- check_stack_size(sc);
- closure_star_fx(sc, sc->code);
- if (apply_lambda_star(sc) == goto_eval) goto EVAL;
+ case OP_CLOSURE_STAR_FX:
+ switch (op_check_closure_star_fx(sc)) {case goto_eval: goto EVAL; case goto_unopt: goto UNOPT; default: break;}
+ case HOP_CLOSURE_STAR_FX:
+ if (closure_star_fx(sc, sc->code)) goto EVAL;
goto BEGIN;
- /* -------------------------------------------------------------------------------- */
+
case OP_UNKNOWN: if (op_unknown(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break;
case OP_UNKNOWN_G: if (op_unknown_g(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break;
case OP_UNKNOWN_GG: if (op_unknown_gg(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break;
@@ -88323,34 +88491,33 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_UNKNOWN_AA: if (op_unknown_aa(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break;
case OP_UNKNOWN_FX: if (op_unknown_fx(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break;
- /* -------------------------------------------------------------------------------- */
case OP_IMPLICIT_VECTOR_REF_A:
- if (op_vector_a(sc) == goto_start) continue;
+ if (op_implicit_vector_a(sc) == goto_start) continue;
if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_VECTOR_REF_AA:
- if (op_vector_aa(sc) == goto_start) continue;
+ if (op_implicit_vector_aa(sc) == goto_start) continue;
if (op_unknown_aa(sc, sc->last_function) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_STRING_REF_A:
- if (op_string_a(sc) == goto_start) continue;
+ if (op_implicit_string_a(sc) == goto_start) continue;
if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_HASH_TABLE_REF_A:
- if (op_hash_table_a(sc)) continue;
+ if (op_implicit_hash_table_a(sc)) continue;
if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_CONTINUATION_A:
- if (op_continuation_a(sc)) continue;
+ if (op_implicit_continuation_a(sc)) continue;
if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_ITERATE:
- if (op_iterate(sc)) continue;
+ if (op_implicit_iterate(sc)) continue;
if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL;
break;
@@ -88359,41 +88526,41 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
continue;
case OP_IMPLICIT_LET_REF_C:
- if (op_environment_c(sc)) continue;
+ if (op_implicit_let_ref_c(sc)) continue;
if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc, sc->last_function) == goto_eval)) goto EVAL;
break;
case OP_IMPLICIT_LET_REF_A:
- if (op_environment_a(sc)) continue;
+ if (op_implicit_let_ref_a(sc)) continue;
if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_PAIR_REF_A:
- if (op_pair_a(sc)) continue;
+ if (op_implicit_pair_a(sc)) continue;
if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_C_OBJECT_REF_A:
- if (op_c_object_a(sc)) continue;
+ if (op_implicit_c_object_a(sc)) continue;
if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_GOTO:
- if (op_goto(sc)) continue;
+ if (op_implicit_goto(sc)) continue;
if (op_unknown(sc, opt1_goto(sc->code)) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_GOTO_A:
- if (op_goto_a(sc)) continue;
+ if (op_implicit_goto_a(sc)) continue;
if (op_unknown_a(sc, opt1_goto(sc->code)) == goto_eval) goto EVAL;
break;
case OP_IMPLICIT_VECTOR_SET_3: /* (set! (v i) x) */
- if (op_vector_set_3(sc)) goto EVAL;
+ if (op_implicit_vector_set_3(sc)) goto EVAL;
continue;
case OP_IMPLICIT_VECTOR_SET_4: /* (set! (v i j) x) */
- if (op_vector_set_4(sc)) goto EVAL;
+ if (op_implicit_vector_set_4(sc)) goto EVAL;
continue;
case OP_UNOPT:
@@ -88402,119 +88569,56 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
#endif
goto UNOPT;
- case OP_SYM: sc->value = lookup_checked(sc, sc->code); continue;
-
- case OP_GLOBAL_SYM:
-#if S7_DEBUGGING && (0)
- if (lookup_global(sc, sc->code) != lookup_checked(sc, sc->code))
- fprintf(stderr, "global?? %s %d: %s %s\n",
- DISPLAY(sc->code), is_global(sc->code),
- DISPLAY(lookup_global(sc, sc->code)),
- DISPLAY(lookup_checked(sc, sc->code)));
- if (!is_global(sc->code)) fprintf(stderr, "%s is no longer global\n", DISPLAY(sc->code));
-#endif
- 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_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_UNSPECIFIED: sc->value = sc->unspecified; 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_PAIR_SYM:
-#if 0
- if (!tree_is_cyclic(sc, sc->code))
- fprintf(stderr, "op_pair_sym: %s\n", DISPLAY_80(sc->code));
- else fprintf(stderr, "cyclic op_pair_sym: (%s ...)\n", DISPLAY(car(sc->code)));
-#endif
- /* car is a non-syntax symbol, sc->code a list */
- /* op_c_sym? op_c_sym_1? op_pair_closure_... */
- sc->value = lookup_global(sc, car(sc->code));
- /* sc->value = lookup_checked(sc, car(sc->code)); */
- goto EVAL_ARGS_TOP;
-
- /* sc->value is car=something applicable, sc->code = rest of expression
- * sc->args is nil (set by the drop-through cases above -- perhaps clearer to bring that down?)
- */
case OP_EVAL_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: op_eval_args4(sc); goto EVAL_ARGS_PAIR; /* sc->code is a pair, and either cdr(sc->code) is not null or car(sc->code) is a pair */
- case OP_EVAL_ARGS1: op_eval_args1(sc); goto EVAL_ARGS;
+ 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 (is_any_macro(sc->value))
- {
- eval_args_expand_macro(sc);
- goto APPLY;
- }
- /* (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);
- }
+ if (eval_args_no_eval_args(sc)) goto APPLY;
goto TOP_NO_POP;
}
sc->code = cdr(sc->code);
-
/* sc->value is the func
* we don't have to delay lookup of the func because arg evaluation order is not specified, so
* (let ((func +)) (func (let () (set! func -) 3) 2))
* can return 5.
*/
- /* if (is_null(sc->code)) {sc->code = sc->value; goto APPLY;}
- * this is hit very rarely so it costs more than it saves
- */
-
push_op_stack(sc, sc->value);
if (sc->op_stack_now >= sc->op_stack_end)
resize_op_stack(sc);
-
sc->args = sc->nil;
- /* fall through */
EVAL_ARGS: /* first time, value = op, args = nil, code is args */
+ /* fprintf(stderr, "%d %s\n", __LINE__, DISPLAY(sc->code)); */
if (is_pair(sc->code)) /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */
{
- s7_pointer car_code;
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: /* pulling this out as a function slowed us down noticeably */
- car_code = car(sc->code);
- /* switch statement here is much slower */
- if (is_pair(car_code))
+ EVAL_ARGS_PAIR:
+ if (is_pair(car(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(cdr(sc->code)))
- push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args);
- else
- {
- if (!is_pair(cdr(sc->code))) /* (= 0 '(1 . 2) . 3) */
- improper_arglist_error(sc);
-
- if ((is_null(cddr(sc->code))) &&
- (!is_pair(cadr(sc->code))))
- push_stack(sc, OP_EVAL_ARGS3, sc->args, cadr(sc->code));
- else push_stack(sc, OP_EVAL_ARGS4, sc->args, cdr(sc->code));
- }
- sc->code = car_code;
+ eval_args_pair_car(sc);
goto EVAL;
}
-
- /* car(sc->code) is not a pair */
- /* fprintf(stderr, "%s[%d]: code: %s, car_code: %s\n", __func__, __LINE__, DISPLAY(sc->code), DISPLAY(car_code)); */
if (is_pair(cdr(sc->code)))
{
+ s7_pointer car_code;
+ car_code = car(sc->code); /* not a pair */
sc->code = cdr(sc->code);
if (is_symbol(car_code))
sc->value = lookup_checked(sc, car_code);
@@ -88524,47 +88628,19 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
/* cdr(sc->code) may not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */
if (is_null(cdr(sc->code)))
{
- s7_pointer x, y, val;
- /* we're at the last arg, sc->value is the previous one, not yet saved in the args list */
- car_code = car(sc->code);
- if (is_pair(car_code))
- {
- if (sc->stack_end >= sc->stack_resize_trigger)
- check_for_cyclic_code(sc, sc->code);
- push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value);
- sc->code = car_code;
- goto EVAL;
- }
-
- /* get the last arg */
- if (is_symbol(car_code))
- val = lookup_checked(sc, car_code);
- else val = car_code;
- sc->temp4 = val;
-
- /* get the current arg, which is not a list */
- sc->code = pop_op_stack(sc);
- new_cell(sc, x, T_PAIR);
- new_cell_no_check(sc, y, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->args);
- set_car(y, val);
- set_cdr(y, x);
- sc->args = safe_reverse_in_place(sc, y);
+ 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 */
s7_pointer x;
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->args);
+ x = cons(sc, sc->value, sc->args);
sc->args = x;
goto EVAL_ARGS_PAIR;
}
}
- else eval_last_arg(sc, car_code);
+ else eval_last_arg(sc, car(sc->code));
/* drop into APPLY */
}
else /* got all args -- go to apply */
@@ -88575,16 +88651,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
sc->code = pop_op_stack(sc);
sc->args = safe_reverse_in_place(sc, sc->args);
- /* we could omit the arg reversal in many cases, but lots of code assumes the args are in order;
- * adding a bit for this in the type field saves some time in s7test (many + and * tests), but costs
- * about the same time in other cases, so it's not a clear win.
- */
}
}
/* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower.
* the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead,
- * and the function-local overhead currently otherwise 0 (I assume because the compiler can simply plug it in here).
+ * and the function-local overhead currently otherwise 0.
*/
APPLY:
case OP_APPLY:
@@ -88613,132 +88685,42 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case T_LET: apply_let(sc); continue;
case T_SYNTAX: apply_syntax(sc); goto TOP_NO_POP;
case T_PAIR: if (apply_pair(sc)) continue; goto APPLY;
-
- case T_MACRO:
- /* this is not from the reader, so treat expansions here as normal macros */
- push_stack_op_let(sc, OP_EVAL_MACRO);
- new_frame(sc, closure_let(sc->code), sc->envir);
- goto APPLY_LAMBDA;
-
- case T_BACRO:
- push_stack_op_let(sc, OP_EVAL_MACRO);
- new_frame(sc, sc->envir, sc->envir); /* like let* -- we'll be adding macro args, so might as well sequester things here */
- goto APPLY_LAMBDA;
-
- case T_CLOSURE:
- /* 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);
- new_frame(sc, closure_let(sc->code), sc->envir);
- goto APPLY_LAMBDA;
-
- case T_MACRO_STAR:
- push_stack_op_let(sc, OP_EVAL_MACRO);
- new_frame(sc, closure_let(sc->code), sc->envir);
- if (apply_lambda_star(sc) == goto_eval) goto EVAL;
- goto BEGIN;
-
- case T_BACRO_STAR:
- push_stack_op_let(sc, OP_EVAL_MACRO);
- new_frame(sc, sc->envir, sc->envir);
- if (apply_lambda_star(sc) == goto_eval) goto EVAL;
- goto BEGIN;
-
- case T_CLOSURE_STAR:
- check_stack_size(sc);
- sc->envir = new_frame_in_env(sc, closure_let(sc->code));
- if (apply_lambda_star(sc) == goto_eval) goto EVAL;
- goto BEGIN;
-
- default:
- apply_error(sc, sc->code, sc->args);
+ case T_CLOSURE: apply_closure(sc); goto APPLY_LAMBDA;
+ case T_CLOSURE_STAR: if (apply_closure_star(sc)) goto EVAL; goto BEGIN;
+ case T_MACRO: apply_macro(sc); goto APPLY_LAMBDA;
+ case T_MACRO_STAR: apply_macro_star(sc); goto BEGIN;
+ case T_BACRO: apply_bacro(sc); goto APPLY_LAMBDA;
+ case T_BACRO_STAR: apply_bacro_star(sc); goto BEGIN;
+ default: apply_error(sc, sc->code, sc->args);
}
- case OP_MACRO_D:
- if (op_macro_d(sc)) goto EVAL_ARGS_TOP;
- /* fall through */
+ case OP_MACRO_STAR_D: if (op_macro_star_d(sc)) goto EVAL_ARGS_TOP; goto BEGIN;
+ case OP_MACRO_D: if (op_macro_d(sc)) goto EVAL_ARGS_TOP;
APPLY_LAMBDA:
- case OP_APPLY_LAMBDA:
- apply_lambda(sc);
+ 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_LAMBDA_STAR_DEFAULT: if (op_lambda_star_default(sc)) goto EVAL; goto BEGIN;
case OP_MACROEXPAND_1:
- sc->args = copy_list(sc, cdar(sc->code));
- sc->code = sc->value;
- goto MACROEXPAND;
+ 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:
- if (op_macroexpand(sc)) goto EVAL;
-
- MACROEXPAND:
- switch (type(sc->code))
- {
- case T_MACRO:
- new_frame(sc, closure_let(sc->code), sc->envir);
- goto APPLY_LAMBDA;
+ switch (op_macroexpand(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;}
- case T_BACRO:
- new_frame(sc, sc->envir, sc->envir);
- goto APPLY_LAMBDA;
- case T_MACRO_STAR:
- new_frame(sc, closure_let(sc->code), sc->envir);
- if (apply_lambda_star(sc) == goto_eval) goto EVAL;
- goto BEGIN;
+ HEAPSORT: if (op_heapsort(sc)) continue; if (sc->value != sc->F) goto APPLY;
+ case OP_SORT1: op_sort1(sc); goto APPLY;
+ case OP_SORT2: if (op_sort2(sc)) continue; goto HEAPSORT;
+ case OP_SORT: if (!op_sort(sc)) goto HEAPSORT;
+ case OP_SORT3: if (op_sort3(sc)) continue; goto HEAPSORT;
+ case OP_SORT_PAIR_END: sc->value = vector_into_list(sc->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 T_BACRO_STAR:
- new_frame(sc, sc->envir, sc->envir);
- if (apply_lambda_star(sc) == goto_eval) goto EVAL;
- goto BEGIN;
-
- case T_C_MACRO:
- macroexpand_c_macro(sc);
- continue;
- }
- eval_error(sc, "macroexpand argument is not a macro call: ~A", 44, sc->args);
-
-
- /* -------------------- sort! (heapsort, done directly so that call/cc in the sort function will work correctly) -------------------- */
- 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 is the sort vector which needs to be copied into the original list */
- sc->value = vector_into_list(sc->value, car(sc->args));
- free_cell(sc, sc->args);
- continue;
-
- case OP_SORT_VECTOR_END: /* sc->value is the sort (s7_pointer) vector which needs to be copied into the original (double/int) vector */
- sc->value = vector_into_fi_vector(sc->value, car(sc->args));
- free_cell(sc, sc->args);
- continue;
-
- case OP_SORT_STRING_END:
- sc->value = vector_into_string(sc->value, car(sc->args));
- free_cell(sc, sc->args);
- continue;
-
-
- /* -------------------------------- map, for-each -------------------------------- */
case OP_MAP_GATHER: op_map_gather(sc);
case OP_MAP: if (op_map(sc)) continue; goto APPLY;
@@ -88762,7 +88744,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_ASSOC_IF1: if (assoc_if(sc)) continue; goto APPLY;
- /* -------------------------------- do -------------------------------- */
case OP_SAFE_DOTIMES:
SAFE_DOTIMES: /* check_do */
switch (safe_dotimes_ex(sc))
@@ -88806,6 +88787,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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;
@@ -88821,9 +88807,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_INIT: if (op_do_init(sc)) goto DO_END; goto EVAL;
case OP_DO:
set_current_code(sc, sc->code);
@@ -88834,140 +88818,52 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_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_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;
}
-
+#if 0
+ fprintf(stderr, "----------------------------------------\n");
+ fprintf(stderr, "%s (do %s\n %s\n %s)\n\n", op_names[optimize_op(sc->code)], DISPLAY_80(cadr(sc->code)), DISPLAY_80(caddr(sc->code)), DISPLAY_80(cdddr(sc->code)));
+#endif
case OP_DO_UNCHECKED:
op_do_unchecked(sc);
- DO_UNCHECKED: /* fall through above, safe_do_ex, dotimes_p_ex */
- if (is_null(car(sc->code))) /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */
- {
- sc->envir = new_frame_in_env(sc, sc->envir);
- sc->args = cons_unchecked(sc, sc->nil, cadr(sc->code));
- sc->code = cddr(sc->code);
- goto DO_END;
- }
- /* eval each init value, then set up the new frame (like let, not let*) */
- sc->args = sc->nil; /* the evaluated var-data */
- sc->value = sc->code; /* protect it */
- sc->code = car(sc->code); /* the vars */
- if (do_init_ex(sc) == goto_eval) goto EVAL;
+ DO_UNCHECKED:
+ if (do_unchecked(sc)) goto EVAL;
DO_END:
case OP_DO_END:
- /* 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(sc, OP_DO_END1, sc->args, sc->code);
- sc->code = cadr(sc->args); /* evaluate the end expr */
- goto EVAL;
- }
- sc->value = fx_call(sc, cdr(sc->args));
- }
- else sc->value = sc->F; /* goto "if (is_pair(sc->code))..." below */
+ if (op_do_end(sc)) goto EVAL;
case OP_DO_END1:
- 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
- */
- continue;
- }
- /* 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);
- continue;
- }
- sc->code = car(sc->code);
- goto EVAL;
- }
- if ((car(sc->code) == sc->feed_to_symbol) &&
- (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
- goto FEED_TO;
- push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
- sc->code = car(sc->code);
- goto EVAL;
- }
- if (is_pair(sc->code))
+ switch (op_do_end1(sc))
{
- if (is_null(car(sc->args)))
- push_stack(sc, OP_DO_END, sc->args, sc->code);
- else push_stack(sc, OP_DO_STEP, sc->args, sc->code);
- goto BEGIN;
+ case 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;
}
- if (is_null(car(sc->args))) /* no steppers */
- goto DO_END;
- /* else fall through */
- case OP_DO_STEP:
- if (op_do_step(sc)) goto DO_END;
- goto EVAL;
-
- case OP_DO_STEP2:
- if (op_do_step2(sc)) goto DO_END;
- goto EVAL;
+ 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 (is_null(sc->code))
- {
- if (is_multiple_value(sc->value))
- sc->value = splice_in_values(sc, multiple_value(sc->value));
- continue;
- }
+ if (do_end_clauses(sc)) continue;
DO_END_CODE:
- if (is_pair(cdr(sc->code)))
- {
- if ((car(sc->code) == sc->feed_to_symbol) &&
- (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))
- 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);
- goto EVAL;
- }
- if (has_fx(sc->code))
+ switch (do_end_code(sc))
{
- sc->value = fx_call(sc, sc->code);
- continue;
+ case goto_feed_to: goto FEED_TO;
+ case goto_eval: goto EVAL;
+ default: continue;
}
- sc->code = T_Pair(car(sc->code));
- goto EVAL;
- /* -------------------------------- begin -------------------------------- */
case OP_BEGIN_UNCHECKED:
set_current_code(sc, sc->code);
sc->code = cdr(sc->code);
@@ -88993,8 +88889,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_BEGIN_1:
sc->code = car(sc->code);
- case OP_EVAL:
- goto EVAL;
+ 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;
@@ -89011,21 +88907,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_DEFINE_CONSTANT_UNCHECKED:
case OP_DEFINE_STAR_UNCHECKED:
case OP_DEFINE_UNCHECKED:
- set_current_code(sc, sc->code);
- sc->code = cdr(sc->code);
if (op_define_unchecked(sc)) goto TOP_NO_POP;
- case OP_DEFINE1:
- if (op_define1(sc) == goto_apply) goto APPLY;
+ case OP_DEFINE1: if (op_define1(sc) == goto_apply) goto APPLY;
+ case OP_DEFINE_WITH_SETTER: op_define_with_setter(sc); continue;
- case OP_DEFINE_WITH_SETTER:
- op_define_with_setter(sc);
- continue;
-
- case OP_EVAL_STRING: op_eval_string(sc); goto EVAL;
-
-
- /* -------------------------------- set! -------------------------------- */
case OP_SET_LET_S: /* (set! (*s7* 'print-length) i) */
sc->code = cdr(sc->code);
if (set_pair_p_3(sc, symbol_to_slot(sc, caar(sc->code)), cadr(cadar(sc->code)), lookup(sc, cadr(sc->code))))
@@ -89041,7 +88927,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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));
- /* fall through */
+
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;
@@ -89076,15 +88962,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SET_CONS: op_set_cons(sc); continue;
case OP_SET_SAFE: op_set_safe(sc); continue;
- case OP_SET2:
- if (op_set2(sc)) goto EVAL;
-
- case OP_SET: /* entry for set! */
- check_set(sc);
+ case OP_SET2: if (op_set2(sc)) goto EVAL;
+ case OP_SET: check_set(sc);
case OP_SET_UNCHECKED:
set_current_code(sc, sc->code);
- if (is_pair(cadr(sc->code))) /* has setter */
+ if (is_pair(cadr(sc->code))) /* has setter */
switch (set_implicit(sc))
{
case goto_top_no_pop: goto TOP_NO_POP;
@@ -89093,25 +88976,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
default: goto EVAL_ARGS;
}
- case OP_SET_NORMAL:
- if (op_set_normal(sc)) goto EVAL;
+ case OP_SET_NORMAL: if (op_set_normal(sc)) goto EVAL;
+ case OP_SET1: if (op_set1(sc)) continue; goto APPLY;
- case OP_SET1:
- if (op_set1(sc)) continue;
- goto APPLY;
-
- case OP_SET_WITH_SETTER:
- if (is_immutable(sc->code))
- immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sc->code));
- slot_set_value(sc->code, sc->value);
- continue;
-
- case OP_SET_WITH_LET_1:
- if (op_set_with_let_1(sc)) goto TOP_NO_POP;
- goto SET_WITH_LET;
+ case OP_SET_FROM_SETTER: op_set_from_setter(sc); continue;
- case OP_SET_WITH_LET_2:
- if (op_set_with_let_2(sc)) continue;
+ 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_let(sc, sc->value); /* this activates sc->value, so the set! will happen in that environment */
@@ -89126,84 +88997,129 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
s7_error(sc, sc->error_symbol, set_elist_2(sc, wrap_string(sc, "can't set ~S", 12), sc->args));
- /* -------------------------------- if -------------------------------- */
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_CASE(Op, Code, Not_Code) \
- case Op ## _P: Code {sc->code = caddr(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; \
- case Op ## _R: Code {sc->value = sc->unspecified; continue;} sc->code = caddr(sc->code); goto EVAL; \
- case Op ## _P_P: Code {sc->code = caddr(sc->code); goto EVAL;} sc->code = cadddr(sc->code); goto EVAL; \
- case Op ## _N: Not_Code {sc->code = caddr(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; \
- case Op ## _N_N: Not_Code {sc->code = caddr(sc->code); goto EVAL;} sc->code = cadddr(sc->code); goto EVAL;
-
- IF_CASE(OP_IF_S,
- if (is_true(sc, lookup(sc, cadr(sc->code)))),
- if (is_false(sc, lookup(sc, cadadr(sc->code)))))
- IF_CASE(OP_IF_A,
- if (is_true(sc, fx_call(sc, cdr(sc->code)))),
- if (is_false(sc, fx_call(sc, cdadr(sc->code)))))
-
- IF_CASE(OP_IF_IS_TYPE_S,
- if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))),
- if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))))
-
- IF_CASE(OP_IF_opSq,
- set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, c_call(cadr(sc->code))(sc, sc->t1_1))),
- set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_false(sc, c_call(cadadr(sc->code))(sc, sc->t1_1))))
- /* lg: A: opCSq: 0, fx_gt_ss: 9, and_pair_closure_s: 11, is_pair_cdr_s: 0, and_3: 77
- */
-
- IF_CASE(OP_IF_AND2,
- if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))),
- if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))))
-
- IF_CASE(OP_IF_OR2,
- if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))),
- 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_P_P: push_stack_no_args(sc, OP_IF_PP, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL;
- case OP_IF_P_N: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL;
- case OP_IF_P_R: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL;
- case OP_IF_P_P_P: push_stack_no_args(sc, OP_IF_PPP, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL;
- case OP_IF_P_N_N: push_stack_no_args(sc, OP_IF_PRR, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL;
-
- case OP_IF_ANDP_P: push_stack_no_args(sc, OP_IF_PP, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P;
- case OP_IF_ANDP_N: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P;
- case OP_IF_ANDP_R: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P;
- case OP_IF_ANDP_P_P: push_stack_no_args(sc, OP_IF_PPP, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P;
- case OP_IF_ANDP_N_N: push_stack_no_args(sc, OP_IF_PRR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P;
-
- case OP_IF_ORP_P: push_stack_no_args(sc, OP_IF_PP, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P;
- case OP_IF_ORP_N: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P;
- case OP_IF_ORP_R: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P;
- case OP_IF_ORP_P_P: push_stack_no_args(sc, OP_IF_PPP, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P;
- case OP_IF_ORP_N_N: push_stack_no_args(sc, OP_IF_PRR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P;
+ case OP_IF_A_CC: sc->value = fx_if_a_cc(sc, sc->code); continue;
+ case OP_IF_A_A: sc->value = fx_if_a_a(sc, sc->code); continue;
+ case OP_IF_A_AA: sc->value = fx_if_a_aa(sc, sc->code); continue;
+ case OP_IF_NOT_A_A: sc->value = fx_if_not_a_a(sc, sc->code); continue;
+ case OP_IF_NOT_A_AA: sc->value = fx_if_not_a_aa(sc, sc->code); continue;
+
+ #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, 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_any(sc->code)); 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, cdadr(sc->code))))
+
+ 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_A_A_P: if_a_p(sc) {sc->value = fx_call(sc, opt1_any(sc->code)); continue;} sc->code = opt2_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_P_A: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_any(sc->code)); continue;
+
+ #define if_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, c_call(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, c_call(cadadr(sc->code))(sc, sc->t1_1)))
+
+ 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_PPP: sc->code = (sc->value != sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL;
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;
- /* -------------------------------- when, unless -------------------------------- */
- 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: 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_2: if (op_when_and_2(sc)) continue; goto EVAL;
+ case OP_WHEN_AND_3: if (op_when_and_3(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_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_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;
- /* -------------------------------- let -------------------------------- */
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_FX: if (op_named_let_fx(sc)) goto BEGIN; goto EVAL;
@@ -89266,13 +89182,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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;
- /* -------------------------------- let-temporarily -------------------------------- */
- 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_TEMPORARILY: check_let_temporarily(sc);
+ case OP_LET_TEMP_UNCHECKED: op_let_temp_unchecked(sc); goto LET_TEMP_INIT1;
case OP_LET_TEMP_INIT1:
caddr(sc->args) = cons(sc, sc->value, caddr(sc->args));
@@ -89287,76 +89199,42 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
default: break;
}
- case OP_LET_TEMP_DONE:
- push_stack(sc, OP_GC_PROTECT, sc->args, sc->value);
-
- case OP_LET_TEMP_DONE1:
- if (op_let_temp_done1(sc)) continue;
- goto EVAL;
+ case OP_LET_TEMP_DONE: push_stack(sc, OP_GC_PROTECT, sc->args, sc->value);
+ case OP_LET_TEMP_DONE1: if (op_let_temp_done1(sc)) continue; goto EVAL;
case OP_LET_TEMP_S7: op_let_temp_s7(sc); goto BEGIN;
case OP_LET_TEMP_FX: op_let_temp_fx(sc); goto BEGIN;
case OP_LET_TEMP_FX_1: op_let_temp_fx_1(sc); goto BEGIN;
case OP_LET_TEMP_SETTER: op_let_temp_setter(sc); goto BEGIN;
- case OP_LET_TEMP_UNWIND:
- op_let_temp_unwind(sc, sc->code, sc->args);
- if (is_multiple_value(sc->value))
- sc->value = splice_in_values(sc, multiple_value(sc->value));
- 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_LET_TEMP_S7_UNWIND:
- 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));
- continue;
- case OP_LET_TEMP_SETTER_UNWIND:
- slot_set_setter(sc->code, sc->args);
- if (is_multiple_value(sc->value))
- sc->value = splice_in_values(sc, multiple_value(sc->value));
- 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;
- /* -------------------------------- cond -------------------------------- */
- 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;
- /* fall through */
-
- FEED_TO:
- if (feed_to(sc)) goto APPLY;
+ 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_FEED_TO_1: sc->code = sc->value; goto APPLY; /* sc->args saved in feed_to via push_stack */
- case OP_COND_SIMPLE: /* no => */
- if (op_cond_simple(sc)) goto EVAL;
+ 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_COND1_SIMPLE:
- if (op_cond1_simple(sc)) goto TOP_NO_POP;
- goto BEGIN;
+ case OP_COND_SIMPLE_P: if (op_cond_simple_p(sc)) goto EVAL;
+ case OP_COND1_SIMPLE_P: if (op_cond1_simple_p(sc)) continue; goto EVAL;
- case OP_COND_SIMPLE_P: /* no =>, no null or multiform consequent */
- if (op_cond_simple_p(sc)) goto EVAL;
+ case OP_COND_FX_FX: sc->value = fx_cond_fx_fx(sc, sc->code); continue;
+ case OP_COND_FX_FP: if (op_cond_fx_fp(sc)) continue; goto EVAL;
+ case OP_COND_FX_FP_1: if (op_cond_fx_fp_1(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_COND1_SIMPLE_P:
- if (op_cond1_simple_p(sc)) continue;
- goto EVAL;
- case OP_COND_FX: if (op_cond_fx(sc)) continue; goto BEGIN;
- case OP_COND_FX_2: if (op_cond_fx_2(sc)) continue; goto BEGIN;
- case OP_COND_FX_P: if (op_cond_fx_p(sc)) continue; goto EVAL;
- case OP_COND_FX_1P_ELSE: if (op_cond_fx_1p_else(sc)) continue; goto EVAL;
- case OP_COND_FX_2P_ELSE: if (op_cond_fx_2p_else(sc)) continue; goto EVAL;
-
- /* -------------------------------- and -------------------------------- */
case OP_AND:
set_current_code(sc, sc->code);
if (check_and(sc)) continue;
@@ -89386,24 +89264,19 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
goto AND_P;
case OP_AND_AP: if (op_and_ap(sc)) continue; goto EVAL;
+ case OP_AND_2: sc->value = fx_and_2(sc, sc->code); continue;
+ case OP_AND_3: sc->value = fx_and_3(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_AA: op_and_safe_aa(sc); continue;
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: /* cdr(sc->code) is known to be a pair (and was pushed => sc->code) */
- if (is_false(sc, sc->value))
- continue;
- op_and_safe_p(sc);
- continue;
+ case OP_AND_SAFE_P_REST: if (is_true(sc, sc->value)) sc->value = fx_and_n(sc, sc->code); continue;
- case OP_AND_SAFE_P:
- sc->code = cdr(sc->code);
- op_and_safe_p(sc);
- continue;
- /* -------------------------------- or -------------------------------- */
case OP_OR:
set_current_code(sc, sc->code);
if (check_or(sc)) continue;
@@ -89432,11 +89305,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
continue;
goto OR_P;
- case OP_OR_AP: if (op_or_ap(sc)) continue; goto EVAL;
- case OP_OR_SAFE_AA: op_or_safe_aa(sc); continue;
+ case OP_OR_AP: if (op_or_ap(sc)) continue; goto EVAL;
+ case OP_OR_2: sc->value = fx_or_2(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_3: sc->value = fx_or_3(sc, sc->code); continue;
+ case OP_OR_N: sc->value = fx_or_n(sc, sc->code); continue;
+ case OP_OR_SAFE_AA: op_or_safe_aa(sc); continue;
- /* -------------------------------- macro evaluation -------------------------------- */
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;
@@ -89455,7 +89332,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc); continue;
- /* -------------------------------- case -------------------------------- */
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 */
@@ -89508,11 +89384,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
fprintf(stderr, "%d: op_error_hook_quit did not jump, returns %s\n", __LINE__, DISPLAY(sc->value));
#endif
- case OP_EVAL_DONE: /* this is the "time to quit" operator */
- return(sc->F);
+ case OP_EVAL_DONE: return(sc->F);
- case OP_GC_PROTECT:
- case OP_BARRIER:
+ case OP_GC_PROTECT: case OP_BARRIER:
case OP_CATCH_ALL: case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2:
continue;
@@ -89520,38 +89394,20 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_UNWIND_OUTPUT: op_unwind_output(sc); continue;
+ case OP_UNWIND_INPUT: op_unwind_input(sc); 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 */
- /* -------------------------------- with-let -------------------------------- */
- case OP_WITH_LET_S:
- op_with_let_s(sc);
- goto BEGIN;
-
- 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:
- activate_let(sc, sc->value);
- goto BEGIN;
-
- /* -------------------------------- with-baffle -------------------------------- */
- case OP_WITH_BAFFLE:
- check_with_baffle(sc);
+ case OP_WITH_LET_S: op_with_let_s(sc); goto BEGIN;
+ 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: activate_let(sc, sc->value); goto BEGIN;
- case OP_WITH_BAFFLE_UNCHECKED:
- if (op_with_baffle_unchecked(sc)) continue;
- goto BEGIN;
+ case OP_WITH_BAFFLE: check_with_baffle(sc);
+ case OP_WITH_BAFFLE_UNCHECKED: if (op_with_baffle_unchecked(sc)) continue; goto BEGIN;
- /* -------------------------------- the reader -------------------------------- */
case OP_READ_INTERNAL: op_read_internal(sc); continue;
case OP_READ_DONE: op_read_done(sc); continue;
@@ -89559,31 +89415,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_LOAD_CLOSE_AND_POP_IF_EOF: if (op_load_close_and_pop_if_eof(sc)) goto EVAL; continue;
POP_READ_LIST:
- /* push-stack OP_READ_LIST is always no_code and op is always OP_READ_LIST (and not used), sc->envir is apparently not needed here */
- sc->stack_end -= 4;
- sc->args = sc->stack_end[2];
- if (is_null(sc->args))
- {
- s7_pointer x;
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->args);
- sc->args = x;
- set_file_and_line_number(sc, x);
-#if WITH_PROFILE
- profile_set_location(x, remember_location(port_line_number(sc->input_port), port_file_number(sc->input_port)));
-#endif
- goto READ_NEXT;
- }
+ if (pop_read_list(sc)) goto READ_NEXT;
READ_LIST:
case OP_READ_LIST: /* sc->args is sc->nil at first */
{
- s7_pointer x;
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->args);
- sc->args = x;
+ sc->args = cons(sc, sc->value, sc->args);
#if WITH_PROFILE
profile_set_location(x, remember_location(port_line_number(sc->input_port), port_file_number(sc->input_port)));
#endif
@@ -89616,20 +89453,16 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case '#': sc->tok = read_sharp(sc, pt); break;
case '\0': case EOF: sc->tok = TOKEN_EOF; break;
- default:
+ default: /* read first element of list (ignore callgrind confusion -- this happens a lot) */
{
- s7_pointer x;
sc->strbuf[0] = (unsigned char)c;
push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
check_stack_size(sc);
sc->value = port_read_name(pt)(sc, pt);
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->nil);
- sc->args = x;
- set_file_and_line_number(sc, x);
+ sc->args = cons(sc, sc->value, sc->nil);
+ set_file_and_line_number(sc, sc->args);
#if WITH_PROFILE
- profile_set_location(x, remember_location(port_line_number(sc->input_port), port_file_number(sc->input_port)));
+ profile_set_location(x, remember_location(port_line_number(pt), port_file_number(pt)));
#endif
c = port_read_white_space(pt)(sc, pt);
goto READ_C;
@@ -89638,19 +89471,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
if (sc->tok == TOKEN_ATOM)
{
- s7_pointer x;
- push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
- check_stack_size(sc);
- sc->value = port_read_name(pt)(sc, pt);
- new_cell(sc, x, T_PAIR);
- set_car(x, sc->value);
- set_cdr(x, sc->nil);
- sc->args = x;
- set_file_and_line_number(sc, x);
-#if WITH_PROFILE
- profile_set_location(x, remember_location(port_line_number(sc->input_port), port_file_number(sc->input_port)));
-#endif
- c = port_read_white_space(pt)(sc, pt);
+ c = read_atom(sc, pt);
goto READ_C;
}
@@ -89730,51 +89551,23 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
READ_TOK:
switch (sc->tok)
{
- case TOKEN_RIGHT_PAREN:
- /* sc->args can't be null here */
+ case TOKEN_RIGHT_PAREN: /* sc->args can't be null here */
sc->value = safe_reverse_in_place(sc, sc->args);
- if ((is_expansion(car(sc->value))) &&
- (op_expansion(sc) == goto_apply))
- {
- push_stack_no_code(sc, OP_EXPANSION, sc->nil);
- new_frame(sc, closure_let(sc->code), sc->envir);
- if (is_macro(sc->value)) goto APPLY_LAMBDA; /* define-expansion* */
- if (apply_lambda_star(sc) == goto_eval) goto EVAL; /* define-expansion* */
- 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
- */
- }
- break;
-
- case TOKEN_EOF: /* can't happen, I believe */
- return(missing_close_paren_error(sc));
-
- case TOKEN_ATOM:
- sc->value = port_read_name(sc->input_port)(sc, sc->input_port);
- goto READ_LIST;
-
- case TOKEN_SHARP_CONST:
- 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:
- push_stack_no_let_no_code(sc, OP_READ_DOT, sc->args);
- sc->tok = token(sc);
- sc->value = read_expression(sc);
+ if (is_expansion(car(sc->value)))
+ switch (op_expansion(sc))
+ {
+ case goto_begin: goto BEGIN;
+ case goto_apply_lambda: goto APPLY_LAMBDA;
+ default: break;
+ }
break;
- default:
- /* by far the main case here is TOKEN_LEFT_PAREN, but it doesn't save anything to move it to this level */
- push_stack_no_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 */
- break;
+ case TOKEN_EOF: return(missing_close_paren_error(sc)); /* can't happen, I believe */
+ case TOKEN_ATOM: sc->value = port_read_name(sc->input_port)(sc, sc->input_port); 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;
@@ -89800,10 +89593,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
fprintf(stderr, "unknown operator: %" print_pointer " in %s\n", sc->cur_op, DISPLAY(current_code(sc)));
return(sc->F);
}
- /* else cancel all the optimization info -- someone stepped on our symbol */
- /* there is a problem with this -- if the caller still insists on goto EVAL, for example,
- * we get here over and over. (let ((x (list (car y))))...) where list is redefined away.
- */
+
clear_all_optimizations(sc, sc->code);
#if UNOPT_PRINT
fprintf(stderr, "cleared: %s\n", DISPLAY_80(sc->code));
@@ -89880,7 +89670,7 @@ static char *mpfr_to_string(mpfr_t val, int32_t radix)
str[i + 1] = '\0';
len += 64;
- tmp = (char *)malloc(len * sizeof(char));
+ tmp = (char *)malloc(len);
if (str[0] == '-')
snprintf(tmp, len, "-%c.%s%c%d", str[1], (char *)(str + 2), (radix <= 10) ? 'E' : '@', ep - 1);
@@ -89904,7 +89694,7 @@ static char *mpc_to_string(mpc_t val, int32_t radix, use_write_t use_write)
im = mpfr_to_string(b, radix);
len = safe_strlen(rl) + safe_strlen(im) + 128;
- tmp = (char *)malloc(len * sizeof(char));
+ tmp = (char *)malloc(len);
if (use_write == P_READABLE)
snprintf(tmp, len, "(complex %s %s)", rl, im);
@@ -89934,7 +89724,7 @@ static char *big_number_to_string_with_radix(s7_pointer p, int32_t radix, s7_int
if (width > len)
{
int32_t spaces;
- str = (char *)realloc(str, (width + 1) * sizeof(char));
+ str = (char *)realloc(str, width + 1);
spaces = width - len;
str[width] = '\0';
memmove((void *)(str + spaces), (void *)str, len);
@@ -94101,7 +93891,14 @@ static s7_pointer memory_usage(s7_scheme *sc) /* (for-each (lambda
v = gp->list[i];
if (port_data(v)) len += port_data_size(v);
}
- make_slot_1(sc, mu_let, make_symbol(sc, "input-ports"), cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, len)));
+ gp = sc->input_string_ports;
+ for (i = 0, len = 0; i < gp->loc; i++)
+ {
+ s7_pointer v;
+ v = gp->list[i];
+ if (port_data(v)) len += port_data_size(v);
+ }
+ make_slot_1(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++)
@@ -94843,10 +94640,6 @@ static s7_pointer make_unique(s7_scheme *sc, const char* name, uint64_t typ)
return(p);
}
-#if OPT_EXTREME_DEBUGGING
-#include "opt_names.h"
-#endif
-
#if (!MS_WINDOWS)
static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER;
#endif
@@ -94920,7 +94713,7 @@ s7_scheme *s7_init(void)
sc->max_vector_dimensions = 512;
sc->strbuf_size = INITIAL_STRBUF_SIZE;
- sc->strbuf = (char *)calloc(sc->strbuf_size, sizeof(char));
+ sc->strbuf = (char *)calloc(sc->strbuf_size, 1);
sc->print_width = sc->max_string_length;
sc->short_print = false;
sc->in_with_let = false;
@@ -95486,7 +95279,9 @@ s7_scheme *s7_init(void)
defun("coverlets", coverlets, 0, 0, false);
defun("openlets", openlets, 0, 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 */
@@ -96407,7 +96202,7 @@ s7_scheme *s7_init(void)
s7_set_b_p_function(slot_value(global_slot(sc->is_pair_symbol)), s7_is_pair);
s7_set_b_7p_function(slot_value(global_slot(sc->is_port_closed_symbol)), is_port_closed_b_7p);
s7_set_b_p_function(slot_value(global_slot(sc->is_procedure_symbol)), s7_is_procedure);
- s7_set_b_7p_function(slot_value(global_slot(sc->is_proper_list_symbol)), is_proper_list_b_7p);
+ s7_set_b_7p_function(slot_value(global_slot(sc->is_proper_list_symbol)), s7_is_proper_list);
s7_set_b_p_function(slot_value(global_slot(sc->is_random_state_symbol)), is_random_state_b);
s7_set_b_p_function(slot_value(global_slot(sc->is_rational_symbol)), s7_is_rational);
s7_set_b_p_function(slot_value(global_slot(sc->is_real_symbol)), s7_is_real);
@@ -96537,14 +96332,19 @@ s7_scheme *s7_init(void)
s7_set_b_pi_function(slot_value(global_slot(sc->leq_symbol)), leq_b_pi);
s7_set_b_pi_function(slot_value(global_slot(sc->gt_symbol)), gt_b_pi);
s7_set_b_pi_function(slot_value(global_slot(sc->geq_symbol)), geq_b_pi);
+
+ s7_set_p_pi_function(slot_value(global_slot(sc->add_symbol)), g_add_xi);
+ s7_set_p_pi_function(slot_value(global_slot(sc->multiply_symbol)), g_mul_xi);
+ /* s7_set_p_pd_function(slot_value(global_slot(sc->add_symbol)), g_add_xf); */
+ /* no ip pd dp! */
#endif
s7_set_b_pp_function(slot_value(global_slot(sc->is_eq_symbol)), s7_is_eq);
s7_set_p_pp_function(slot_value(global_slot(sc->is_eq_symbol)), is_eq_p_pp);
s7_set_b_pp_function(slot_value(global_slot(sc->is_eqv_symbol)), s7_is_eqv);
s7_set_p_pp_function(slot_value(global_slot(sc->is_eqv_symbol)), is_eqv_p_pp);
- s7_set_b_7pp_function(slot_value(global_slot(sc->is_equal_symbol)), is_equal_b_7pp);
- s7_set_b_7pp_function(slot_value(global_slot(sc->is_equivalent_symbol)), is_equivalent_b_7pp);
+ s7_set_b_7pp_function(slot_value(global_slot(sc->is_equal_symbol)), s7_is_equal);
+ s7_set_b_7pp_function(slot_value(global_slot(sc->is_equivalent_symbol)), s7_is_equivalent);
s7_set_p_pp_function(slot_value(global_slot(sc->is_equal_symbol)), is_equal_p_pp);
s7_set_p_pp_function(slot_value(global_slot(sc->is_equivalent_symbol)), is_equivalent_p_pp);
s7_set_b_7pp_function(slot_value(global_slot(sc->char_lt_symbol)), char_lt_b_7pp);
@@ -96711,8 +96511,8 @@ s7_scheme *s7_init(void)
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 (strcmp(op_names[OP_SAFE_CLOSURE_A_A], "safe_closure_a_a") != 0) fprintf(stderr, "clo op_name: %s\n", op_names[OP_SAFE_CLOSURE_A_A]);
- if (NUM_OPS != 823) fprintf(stderr, "size: cell: %d, block: %d, max op: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS);
- /* 64 bit machine: cell size: 48, 80 if gmp, 160 if debugging, block size: 40 */
+ if (NUM_OPS != 855) 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));
+ /* 64 bit machine: cell size: 48, 80 if gmp, 160 if debugging, block size: 40, opt: 128 */
#endif
save_unlet(sc);
@@ -96780,7 +96580,7 @@ int main(int argc, char **argv)
* in *BSD: gcc s7.c -o repl -DWITH_MAIN -DUSE_SND=0 -I. -O2 -g -lm -Wl,-export-dynamic
* in OSX: gcc s7.c -o repl -DWITH_MAIN -DUSE_SND=0 -I. -O2 -g -lm
* (clang also needs LDFLAGS="-Wl,-export-dynamic" in Linux and "-fPIC")
- * (compile time 29-Aug-19 42.5 secs)
+ * (s7.c compile time 23-Sep-19 42.0 secs)
*/
#endif
@@ -96788,43 +96588,43 @@ int main(int argc, char **argv)
*
* new snd version: snd.h configure.ac HISTORY.Snd NEWS barchive diffs, /usr/ccrma/web/html/software/snd/index.html
*
- * --------------------------------------------------------------------------------
- * 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19.6 19.7 19.8
- * --------------------------------------------------------------------------------
- * tpeak | | | | 391 | 377 | 199 | 164 163
- * tauto | | | 1752 | 1689 | 1700 | 835 | 622 630
- * tshoot | | | | | | 1095 | 831 804
- * tref | | | 2372 | 2125 | 1036 | 983 | 949 876
- * index 44.3 | 3291 | 1725 | 1276 | 1255 | 1168 | 1022 | 875 880
- * teq | | | 6612 | 2777 | 1931 | 1539 | 1492 1485
- * s7test 1721 | 1358 | 995 | 1194 | 2926 | 2110 | 1726 | 1702 1685
- * tvect | | | | | | 5729 | 2033 1919
- * tmisc | | | | | | 2636 | 1949
- * lint | | | | 4041 | 2702 | 2120 | 2121 2090
- * tform | | | 6816 | 3714 | 2762 | 2362 | 2288 2238
- * tlet | | | | | 4717 | 2959 | 2285 2241
- * tcopy | | | 13.6 | 3183 | 2974 | 2320 | 2255 2251
- * tread | | | | | 2357 | 2336 | 2269 2258
- * tclo | | 4391 | 4666 | 4651 | 4682 | 3084 | 2705 2626
- * tmat 8641 | 8458 | | 7279 | 7248 | 7252 | 6823 | 2664 2655
- * fbench 4123 | 3869 | 3486 | 3609 | 3602 | 3637 | 3495 | 2783 2681
- * titer | | | | 5971 | 4646 | 3587 | 3022 2828
- * trclo | | | | 10.3 | 10.5 | 8758 | 3011 2886
- * tset | | | | | 10.0 | 6432 | 3477 2980
- * dup | | | | | 20.8 | 5711 | 3715 3028
- * tmap | | | 9.3 | 5279 | 3445 | 3015 | 3123 3049
- * tsort | | | | 8584 | 4111 | 3327 | 3314 3236
- * tmac 8550 | 8396 | 7556 | 5606 | 5503 | 5404 | 3969 | 3624
- * tfft | | 17.1 | 17.3 | 19.2 | 19.3 | 4466 | 4029
- * trec 35.0 | 29.3 | 24.8 | 25.5 | 24.9 | 25.6 | 20.0 | 7115 6435
- * thash | | | | | | 10.3 | 8852 8467
+ * ------------------------------------------------------------------------------
+ * 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19.7 19.8 19.9
+ * ------------------------------------------------------------------------------
+ * tpeak | | | | 391 | 377 | 199 | 163 163
+ * tauto | | | 1752 | 1689 | 1700 | 835 | 630 621
+ * tref | | | 2372 | 2125 | 1036 | 983 | 876 791
+ * tshoot | | | | | | 1224 | 847
+ * index 44.3 | 3291 | 1725 | 1276 | 1255 | 1168 | 1022 | 880 876
+ * teq | | | 6612 | 2777 | 1931 | 1539 | 1485 1479
+ * s7test 1721 | 1358 | 995 | 1194 | 2926 | 2110 | 1726 | 1685 1674
+ * tvect | | | | | | 5729 | 1919 1793
+ * tmisc | | | | | | 2636 | 1949 1846
+ * lint | | | | 4041 | 2702 | 2120 | 2090 2053
+ * tlet | | | | | 4717 | 2959 | 2241 2148
+ * tform | | | 6816 | 3714 | 2762 | 2362 | 2238 2207
+ * tcopy | | | 13.6 | 3183 | 2974 | 2320 | 2251 2220
+ * tread | | | | | 2357 | 2336 | 2258 2264
+ * tclo | | 4391 | 4666 | 4651 | 4682 | 3084 | 2626 2397
+ * tmat 8641 | 8458 | | 7279 | 7248 | 7252 | 6823 | 2655 2463
+ * fbench 4123 | 3869 | 3486 | 3609 | 3602 | 3637 | 3495 | 2681 2653
+ * titer | | | | 5971 | 4646 | 3587 | 2828 2727
+ * trclo | | | | 10.3 | 10.5 | 8758 | 2886 2820
+ * tmap | | | 9.3 | 5279 | 3445 | 3015 | 3049 2897
+ * tset | | | | | 10.0 | 6432 | 2980 2928
+ * tsort | | | | 8584 | 4111 | 3327 | 3236 3090
+ * dup | | | | | 20.8 | 5711 | 3028 3362
+ * tmac 8550 | 8396 | 7556 | 5606 | 5503 | 5404 | 3969 | 3624 3514
+ * tfft | | 17.1 | 17.3 | 19.2 | 19.3 | 4466 | 4029 3873
+ * trec 35.0 | 29.3 | 24.8 | 25.5 | 24.9 | 25.6 | 20.0 | 6435 6432
+ * thash | | | | | | 10.3 | 8467 6647
* tgen | 71.0 | 70.6 | 38.0 | 12.6 | 11.9 | 11.2 | 10.8 10.8
- * tall 90.0 | 43.0 | 14.5 | 12.7 | 17.9 | 18.8 | 17.1 | 14.9 14.8
- * calls 359.0 |275.0 | 54.0 | 34.7 | 43.7 | 40.4 | 38.4 | 35.6 35.6
- * sg | | | |139.0 | 85.9 | 78.0 | 69.5 69.1
- * lg | | | |211.0 |133.0 |112.7 |109.3 106.8
- * tbig | | | | |246.9 |230.6 |182.2 181.2
- * --------------------------------------------------------------------------------
+ * tall 90.0 | 43.0 | 14.5 | 12.7 | 17.9 | 18.8 | 17.1 | 14.8 14.6
+ * calls 359.0 |275.0 | 54.0 | 34.7 | 43.7 | 40.4 | 38.4 | 35.6 35.1
+ * sg | | | |139.0 | 85.9 | 78.0 | 69.1 68.6
+ * lg | | | |211.0 |133.0 |112.7 |106.8 103.8
+ * tbig | | | | |246.9 |230.6 |181.2 177.9
+ * ------------------------------------------------------------------------------
*
* glistener, gtk-script, s7.html for gtk4, grepl.c gcall.c gcall2.c?
* grepl compiles but the various key_press events are not valid, gtk-script appears to be ok
@@ -96834,26 +96634,18 @@ int main(int argc, char **argv)
* also __float128 -> s7_big_int|double
*
* fx*direct p_pp opts, opt_set_p_i_f* call make_integer, also p_d_f
- *
- * if envir is funclet or 1-var let, mark? then any annotate in marked env => fx_tree
- * safe if we're the first expr in the body, or body is safe/recur
- * lt_gtg and leq_gs (lint)
- * permanent lets might also use the lamlet clear
- *
- * apply_lambda_star can preset simple opt args (lamlet list? in op_lambda?)
- * a list of all opt vals (if fxable), then use list-tail to choose append
- * or not append, just load (slot-pending-value instead? if saved let)
- * (misc, mac, clo): simple_closure_star?
- *
- * c_s_opssq_direct->c_g_opgtq_direct, cond_fx with fxable results, do_no_body_simple_vars&result (closure in end-test)
- * cond_fx or add cond_fp as check_and (fx if present else push return and jump to eval)
- * safe_closure_fp if argnum less?
- *
- * permanent_let_star? (as the full stack of lets or did the old form work?)
- * expand as fx_is_type_car for others like is_pair_car? (lg) see 53771 trec/trclo/lg: at least symbol? integer?
- * s_to_s (a_to_s) could include and_s_2 etc [fx_safe_closure_s|t_d|a] et al + opssq if sc->envir=outlet [sc cs etc]
- * a_to_a is hard -- c_s as "a" never happens, vector_ref needs the second arg (and needs yet another op) etc
- * setter gc list (protected_setters) et al -> lamlet? but no one will mark it outside the setter list?
- * as in old trace, if unheaped func refers to heaped func, the latter needs to be marked.
- * many places in Snd assume non-bignum args (e.g. set-x-bounds)
+ * split format as per s7.html, can optimizer catch no string result cases?
+ * split add|mul_p_pp -- aren't there splittable pp cases? add_p_pi ip pd dp and mul/-/= [di id?]
+ * op_c_s_opssq_direct -> add should notice int-vector et al and use add_p_xx?
+ * no ip dp pd yet
+ * perhaps hash-table-default [where to store it? -- add room in block data?]
+ * need timing for rats/complex -- make sure rats stay that way: continued fractions (t184)
+ * replace closure_id_s with all_s? = (define x y) but done stupidly, 71533
+ * fx_sqr_1 using t [let* first?] ftree opssq_s? -- wrong order?
+ * (t180=overheads)
+ * check (named-)let(*) for optimize_lambda, but letrec(*) is safer since outlet is blocked here [these need tests]
+ * closure_s_to_opscq_c?
+ * if all opts[pc] refs gone at runtime, can all pc++ be removed? [267(+44?) o->sc->pc++][9|56 ++o...]
+ * can o_wrap be finessed via b_to_p_0 et al? [28? cases]
+ * direct op|fx_safe_c_s|s?
*/
diff --git a/s7.html b/s7.html
index d5ee169..5c2481b 100644
--- a/s7.html
+++ b/s7.html
@@ -906,6 +906,16 @@ implement the standard old-time macros.
<em class="gray">1.5</em>
</pre>
+<!-- this also probably works:
+(define-macro (trace f)
+ `(define ,f
+ (apply lambda 'args
+ `((format () "(~A ~{~A~^ ~}) -> " ',',f args)
+ (let ((val (apply ,',f args)))
+ (format () "~A~%" val)
+ val)))))
+-->
+
<p>macroexpand can help debug a macro. I always forget that it
wants an expression:
</p>
@@ -2920,38 +2930,12 @@ and openlet? -&gt; methods?.
<div class="indented">
<p>let-ref and let-set! are problematic as methods. It is very easy to get into an infinite
loop, especially with let-ref since any reference to the let within the method body probably
-calls let-ref, which notices the let-ref method... One way around this is to call coverlet
-on the let before doing anything, then at the end, call openlet:
-</p>
-<pre class="indented">
-&gt; (let ((hi (openlet
- (inlet 'a 1
- 'let-ref (lambda (obj val)
- (<em class="red">coverlet</em> obj)
- (let ((res (+ (obj val) 1)))
- (<em class="red">openlet</em> obj)
- res))))))
- (hi 'a))
-<em class="gray">2</em>
-</pre>
-
-<p>Use let-ref-fallback and let-set-fallback instead, if possible. A let-set!
-method can implement a copy-on-write let:
+calls let-ref, which calls the let-ref method. We used to recommend coverlet here, but
+even that is not enough, so not let-ref and let-set! are immutable; they can't be used
+as methods.
+Use let-ref-fallback and let-set-fallback instead, if possible.
</p>
-<pre class="indented">
-(define (cowlet . fields) ; copy-on-write let
- (openlet (apply inlet
- 'let-set! (lambda (obj field val)
- (let ((new-obj (copy (coverlet obj))))
- (set! (new-obj field) val)
- (openlet obj)
- (openlet new-obj)))
- fields)))
-(let ((lt1 (cowlet 'a 1 'b 2)))
- (set! (lt1 'b) 1)) ; this leaves lt1 unchanged, returns a new let with b=1
-</pre>
-
</div>
</blockquote>
@@ -3563,8 +3547,24 @@ a modern GUI leaves formatting decisions to a text or table widget.
`(set! ,obj (eval (read))))
objs))))
</pre>
+</div>
-
+<div class="indented">
+<p>format is a mess. It is trying to cram two different choices into its first ("port") argument.
+Perhaps it should be split into format-&gt;string and format-&gt;port. format-&gt;string has no
+port argument and returns a string. format-&gt;port writes to its port argument (which must be an output
+port, not a boolean), and returns #f or maybe &lt;unspecified&gt;. Then:
+</p>
+<pre>
+(format #f ...) -&gt; (format-&gt;string ...)
+(format () ...) -&gt; (format-&gt;port (current-output-port) ...)
+(format #t ...) -&gt; (display (format-&gt;string ...))
+(format port ...) -&gt; (display (format-&gt;string ...) port)
+</pre>
+<p>and the currently unavailable choice, format to port without creating a string:
+<code>(format-&gt;port port ...)</code>.
+</p>
+</div>
<!--
:(objects->string "int: " 32 ", string: " "hi")
@@ -3602,8 +3602,6 @@ a modern GUI leaves formatting decisions to a text or table widget.
-->
-</div>
-
</blockquote>
diff --git a/s7test.scm b/s7test.scm
index c67f910..71243e9 100644
--- a/s7test.scm
+++ b/s7test.scm
@@ -561,8 +561,8 @@ static void g_cycle_mark(void *val)
static void g_cycle_free(void *val)
{
- g_block *g = (g_block *)val;
- free(g);
+ /* g_block *g = (g_block *)val; */
+ free(val);
}
static s7_pointer g_to_block(s7_scheme *sc, s7_pointer args)
@@ -1582,14 +1582,16 @@ void block_init(s7_scheme *sc)
(test (eq? #f . 1) 'error)
(test (eq #f #f) 'error)
-(let ((things (vector #t #f #\space () "" 0 1 3/4 1+i 1.5 '(1 .2) #() (vector) (vector 1) (list 1) 'f 't #\t)))
- (let ((len (length things)))
- (do ((i 0 (+ i 1)))
- ((= i (- len 1)))
- (do ((j (+ i 1) (+ j 1)))
- ((= j len))
- (if (eq? (vector-ref things i) (vector-ref things j))
- (format #t ";(eq? ~A ~A) -> #t?~%" (vector-ref things i) (vector-ref things j)))))))
+(define (feq)
+ (let ((things (vector #t #f #\space () "" 0 1 3/4 1+i 1.5 '(1 .2) #() (vector) (vector 1) (list 1) 'f 't #\t)))
+ (let ((len (length things)))
+ (do ((i 0 (+ i 1)))
+ ((= i (- len 1)))
+ (do ((j (+ i 1) (+ j 1)))
+ ((= j len))
+ (if (eq? (vector-ref things i) (vector-ref things j))
+ (format #t ";(eq? ~A ~A) -> #t?~%" (vector-ref things i) (vector-ref things j))))))))
+(feq)
;;; these are defined at user-level in s7 -- why are other schemes so coy about them?
(test (eq? (if #f #f) #<unspecified>) #t)
@@ -2196,14 +2198,16 @@ void block_init(s7_scheme *sc)
(test (eqv? '(()) '(())) #f)
(test (eqv? (list 'abs 'cons) '(abs cons)) #f)
-(let ((things (vector #t #f #\space '() "" 0 1 3/4 1+i 1.5 '(1 .2) #() (vector) (vector 1) (list 1) 'f 't #\t)))
- (let ((len (length things)))
- (do ((i 0 (+ i 1)))
- ((= i (- len 1)))
- (do ((j (+ i 1) (+ j 1)))
- ((= j len))
- (if (eqv? (vector-ref things i) (vector-ref things j))
- (format #t ";(eqv? ~A ~A) -> #t?~%" (vector-ref things i) (vector-ref things j)))))))
+(define (feqv)
+ (let ((things (vector #t #f #\space '() "" 0 1 3/4 1+i 1.5 '(1 .2) #() (vector) (vector 1) (list 1) 'f 't #\t)))
+ (let ((len (length things)))
+ (do ((i 0 (+ i 1)))
+ ((= i (- len 1)))
+ (do ((j (+ i 1) (+ j 1)))
+ ((= j len))
+ (if (eqv? (vector-ref things i) (vector-ref things j))
+ (format #t ";(eqv? ~A ~A) -> #t?~%" (vector-ref things i) (vector-ref things j))))))))
+(feqv)
(test (eqv?) 'error)
(test (eqv? #t) 'error)
@@ -2419,14 +2423,16 @@ void block_init(s7_scheme *sc)
(test (equal? "asd""asd") #t) ; is this the norm?
(let ((streq (lambda (a b) (equal? a b)))) (test (streq "asd""asd") #t))
-(let ((things (vector #t #f #\space () "" 0 1 3/4 1+i 1.5 '(1 .2) #() (vector 1) (list 1) 'f 't #\t)))
- (let ((len (length things)))
- (do ((i 0 (+ i 1)))
- ((= i (- len 1)))
- (do ((j (+ i 1) (+ j 1)))
- ((= j len))
- (if (equal? (vector-ref things i) (vector-ref things j))
- (format #t ";(equal? ~A ~A) -> #t?~%" (vector-ref things i) (vector-ref things j)))))))
+(define (fequal)
+ (let ((things (vector #t #f #\space () "" 0 1 3/4 1+i 1.5 '(1 .2) #() (vector 1) (list 1) 'f 't #\t)))
+ (let ((len (length things)))
+ (do ((i 0 (+ i 1)))
+ ((= i (- len 1)))
+ (do ((j (+ i 1) (+ j 1)))
+ ((= j len))
+ (if (equal? (vector-ref things i) (vector-ref things j))
+ (format #t ";(equal? ~A ~A) -> #t?~%" (vector-ref things i) (vector-ref things j))))))))
+(fequal)
(test (equal?) 'error)
(test (equal? #t) 'error)
@@ -4163,7 +4169,7 @@ void block_init(s7_scheme *sc)
(test (symbol? :hi) #t)
(test (symbol? hi:) #t)
(test (symbol? :hi:) #t)
-(test (symbol? ::) #t)
+(test (symbol? '::) #t)
(test (symbol? ':) #t)
(test (symbol? '|) #t)
(test (symbol? '|') #t)
@@ -11003,6 +11009,30 @@ i" (lambda (p) (eval (read p)))) pi)
(define (hi) (let ((v2 (make-float-vector '(2 3)))) (float-vector-set! v2 1 12.0) v2))
(test (hi) 'error))
+(let ()
+ (define (f1) ; opt_d_7piid_sfff
+ (let ((fv (make-float-vector '(2 3))))
+ (do ((i 0 (+ i 1)))
+ ((= i 2) fv)
+ (float-vector-set! fv (+ i 0) (+ i 1) (* 2.0 3.0)))))
+ (test (f1) #r2d((0.0 6.0 0.0) (0.0 0.0 6.0)))
+
+ (define (f2) ; opt_d_7pii_sff
+ (let ((iv (make-float-vector '(2 3) 1.0))
+ (sum 0.0))
+ (do ((i 0 (+ i 1)))
+ ((= i 2) sum)
+ (set! sum (+ sum (iv (- (+ i 1) 1) (+ i 1)))))))
+ (test (f2) 2.0)
+
+ (define (f3) ; opt_d_7pii_sff
+ (let ((iv (make-float-vector '(2 3) 1.0))
+ (sum 0.0))
+ (do ((i 0 (+ i 1)))
+ ((= i 2) sum)
+ (set! sum (+ sum (float-vector-ref iv (- (+ i 1) 1) (+ i 1)))))))
+ (test (f3) 2.0))
+
(let () ; regression test for optimizer safe_c_opcq_opcq bug
(define (fx n x y)
(make-float-vector (if x (+ n 1) n)
@@ -11211,6 +11241,24 @@ i" (lambda (p) (eval (read p)))) pi)
(izf)
(test iv #i(1 1 1 0 0 0 0 0 1 1)))
+(let ()
+ (define (f) ; opt_i_7pii_sff
+ (let ((iv (make-int-vector '(2 3) 1))
+ (sum 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 2) sum)
+ (set! sum (+ sum (iv (- (+ i 1) 1) (+ i 1)))))))
+ (test (f) 2)
+
+ (define (g) ; opt_i_7pii_sff
+ (let ((iv (make-byte-vector '(2 3) 1))
+ (sum 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 2) sum)
+ (set! sum (+ sum (iv (- (+ i 1) 1) (+ i 1)))))))
+ (test (g) 2))
+
+
;;; --------------------------------------------------------------------------------
;;; vector
@@ -14590,6 +14638,17 @@ i" (lambda (p) (eval (read p)))) pi)
'error)
(test (let ((h (hash-table 'a (hash-table 'b 2)))) (h 'a 'b)) 2)
+(let ((h (hash-table)))
+ (hash-table-set! h 'a (+ (or (hash-table-ref h 'a) 0) 1))
+ (test (hash-table-ref h 'a) 1)
+ (hash-table-set! h 'a (+ (or (hash-table-ref h 'a) 0) 1))
+ (test (hash-table-ref h 'a) 2))
+(let ((h (hash-table)))
+ (define (hash-inc)
+ (hash-table-set! h 'a (+ 1 (or (hash-table-ref h 'a) 0)))
+ (hash-table-set! h 'a (+ (or (hash-table-ref h 'a) 0) 1)))
+ (hash-inc)
+ (test (hash-table-ref h 'a) 2))
(for-each
(lambda (arg)
@@ -21032,7 +21091,7 @@ c"
(list 'abc :abc abc:
(symbol "a") (symbol "#<>")
(gensym "|") (gensym "#<>") (gensym "}")
- :: ':abc
+ ':: ':abc
(gensym "\\"))))
(lambda (type info)
(format *stderr* "readable symbols: ~A ~A~%" type info)))
@@ -21326,13 +21385,13 @@ c"
(test (object->string (inlet 'a (lambda (b) (+ b 1))) :readable) "(inlet :a (lambda (b) (+ b 1)))")
(test (object->string (inlet 'a (lambda b (list b 1))) :readable) "(inlet :a (lambda b (list b 1)))")
(test (object->string (inlet 'a (lambda (a . b) (list a b))) :readable) "(inlet :a (lambda (a . b) (list a b)))")
-(test (object->string (inlet 'a (define-macro (_m_ b) `(+ ,b 1))) :readable) "(inlet :a (define-macro (_m_ b) (list '+ b 1)))")
-(test (object->string (inlet 'a (define-bacro (_m_ b) `(+ ,b 1))) :readable) "(inlet :a (define-bacro (_m_ b) (list '+ b 1)))")
+(test (object->string (inlet 'a (define-macro (_m_ b) `(+ ,b 1))) :readable) "(inlet :a (define-macro (_m_ b) (list-values '+ b 1)))")
+(test (object->string (inlet 'a (define-bacro (_m_ b) `(+ ,b 1))) :readable) "(inlet :a (define-bacro (_m_ b) (list-values '+ b 1)))")
(test (object->string (inlet 'a (lambda* ((b 1)) (+ b 1))) :readable) "(inlet :a (lambda* ((b 1)) (+ b 1)))")
(test (object->string (inlet 'a (lambda* a (list a))) :readable) "(inlet :a (lambda a (list a)))") ; lambda* until 22-Jan-19
(test (object->string (inlet 'a (lambda* (a (b 1) c) (list a b c))) :readable) "(inlet :a (lambda* (a (b 1) c) (list a b c)))")
-(test (object->string (inlet 'a (define-macro* (_m_ (b 1)) `(+ ,b 1))) :readable) "(inlet :a (define-macro* (_m_ (b 1)) (list '+ b 1)))")
-(test (object->string (inlet 'a (define-bacro* (_m_ (b 1)) `(+ ,b 1))) :readable) "(inlet :a (define-bacro* (_m_ (b 1)) (list '+ b 1)))")
+(test (object->string (inlet 'a (define-macro* (_m_ (b 1)) `(+ ,b 1))) :readable) "(inlet :a (define-macro* (_m_ (b 1)) (list-values '+ b 1)))")
+(test (object->string (inlet 'a (define-bacro* (_m_ (b 1)) `(+ ,b 1))) :readable) "(inlet :a (define-bacro* (_m_ (b 1)) (list-values '+ b 1)))")
(when with-block
(test (object->string (inlet 'a (block)) :readable) "(inlet :a (block))")
(test (object->string (inlet 'a blocks) :readable) "(inlet :a blocks)")
@@ -22913,6 +22972,14 @@ similarly:
(test (when (unless (= 2 3) #t) 1) 1)
+(let () ; opt_if_bp_ii_fc
+ (define (f)
+ (let ((sum 0))
+ (do ((i 0 (+ i 1))
+ (j 0 (+ j 2)))
+ ((= i 3) sum)
+ (if (> (+ i j) 0) (set! sum (+ sum i j))))))
+ (test (f) 9))
@@ -25161,6 +25228,12 @@ in s7:
(test (let ((x (do ((i 0 (+ i 1))) (#t)))) x) #t) ; guile: #<unspecified>
(test (let () (define (f lst) (do ((lst lst (cddr lst)) (a () (cons (car lst) a))) ((null? lst) a))) (f '(1 2 3 4))) '(3 1))
+(let ((y 0)) ; coverage test (do_no_body_fx_vars)
+ (define (end x) (set! y x) (= y 3))
+ (define (dot) (do ((i 0 (+ i 1)) (j 3)) ((or (< i 0) (end i)))))
+ (dot)
+ (test y 3))
+
(test (let ((lst '(1 2 3))
(v (vector 0 0 0)))
(do ((l lst (map (lambda (a) (+ a 1)) (cdr l))))
@@ -26424,6 +26497,37 @@ in s7:
;; to run chibi repl, goto /home/bil/test/chibi-scheme-master, setenv LD_LIBRARY_PATH /home/bil/test/chibi-scheme-master, chibi-scheme
;; to run chicken, goto /home/bil/test/chicken-4.7.0.6/, csi
+(let ()
+ (define (cond-fx-2e-fx x) (cond ((= x 0) (+ x 1)) (else (+ x 2))))
+ (define (test-cond-fx-2e-fx)
+ (cond-fx-2e-fx 0) ; prime the pump
+ (test (cond-fx-2e-fx 0) 1)
+ (test (cond-fx-2e-fx 1) 3))
+ (test-cond-fx-2e-fx)
+
+ (define (cond-fx-3e-fx x) (cond ((= x 0) (+ x 1)) ((= x 1) (+ x 2)) (else (+ x 3))))
+ (define (test-cond-fx-3e-fx)
+ (cond-fx-3e-fx 0)
+ (test (cond-fx-3e-fx 0) 1)
+ (test (cond-fx-3e-fx 1) 3)
+ (test (cond-fx-3e-fx 2) 5))
+ (test-cond-fx-3e-fx)
+
+ (define (cond-fx-2e x) (cond ((= x 0) (+ x 1)) (else (call-with-exit (lambda (g) (+ x 2))))))
+ (define (test-cond-fx-2e)
+ (cond-fx-2e 0) ; prime the pump
+ (test (cond-fx-2e 0) 1)
+ (test (cond-fx-2e 1) 3))
+ (test-cond-fx-2e)
+
+ (define (cond-fx-3e x) (cond ((= x 0) (+ x 1)) ((= x 1) (call-with-exit (lambda (g) (+ x 2)))) (else (+ x 3))))
+ (define (test-cond-fx-3e)
+ (cond-fx-3e 0)
+ (test (cond-fx-3e 0) 1)
+ (test (cond-fx-3e 1) 3)
+ (test (cond-fx-3e 2) 5))
+ (test-cond-fx-3e))
+
(let () ; check an optimizer typo
(define (f x g h)
(call-with-exit
@@ -26443,6 +26547,14 @@ in s7:
(#t 2)))
1)
+(let () ; opt_cond_1 as expr (for sc->pc check)
+ (define (cd)
+ (let ((v (make-vector 6 #f)))
+ (do ((i 0 (+ i 1)))
+ ((= i 6) v)
+ (vector-set! v i (cond ((< i 3) (+ i 10)))))))
+ (test (cd) #(10 11 12 #<unspecified> #<unspecified> #<unspecified>)))
+
(let ((c1 #f)
(x 1))
(let ((y (cond ((let ()
@@ -26872,7 +26984,14 @@ in s7:
(when with-bignums
(test (case 8819522415901031498123 ((1) 2) ((8819522415901031498123) 3) (else 4)) 3)
- (test (case -9223372036854775809 ((1 9223372036854775807) 2) (else 3)) 3))
+ (test (case -9223372036854775809 ((1 9223372036854775807) 2) (else 3)) 3)
+ (let ()
+ (define (cgmp x) (case x ((0) 1) ((1) 2)))
+ (define (test-cgmp) (cgmp (bignum "1")))
+ (test (cgmp 0) 1)
+ (test (cgmp (bignum "1")) 2)
+ (test (cgmp (bignum "0")) 1)
+ (test (test-cgmp) 2)))
;;; one thing that will hang case I think: circular key list
@@ -28938,6 +29057,12 @@ in s7:
(test (use-redef-1 8) 14) ; a=8 -> 14
(test (use-redef-2 8) 20))) ; but use-redef-2 (same let as shadowing use-redef-1) is (+ [new redef-1](+ a 7) 5), a=8 -> 20
+(let ()
+ (define (redef-3 a) (+ a 1))
+ (test (redef-3 2) 3)
+ (define (redef-3 a) (abs a))
+ (test (redef-3 -2) 2))
+
(test (let () (define (f1 x) (abs x)) (define (f2 x) (f1 x)) (f2 -1)) 1) ; just trying to hit a portion of the s7 code
(when with-block
@@ -29551,6 +29676,7 @@ in s7:
(test (let () (define (f) (and () (values #f 1 2) (vector 0))) (f) (f)) #f) ; and_safe_p2->and_safe_p_rest
(test (let () (define (f) (and (values #f 1 2) 1 (vector 0))) (f) (f)) #f) ; same p1
(test (let () (define (f) (and (values #f 1 2) 1 (subvector (vector 0) 0))) (f) (f)) #f)
+(test (let () (define (fv) (let ((x (list-values (values)))) (null? x))) (fv)) #t)
(test (+ (call-with-exit (lambda (ret) (values 1 2 3)))) 6)
(test (+ 4 (call-with-exit (lambda (ret) (values 1 2 3))) 5) 15)
@@ -29570,6 +29696,10 @@ in s7:
(test (+ (call-with-input-string "123" (lambda (p) (values 1 2 3)))) 6)
(test (+ (eval-string "(values 1 2 3)")) 6)
+(let ((_d_ (values)))
+ (test (list-values _d_) ())
+ (test (let () (define (func) (list-values _d_)) (func)) ()))
+
(let ()
(test (let ((x 1)) (set! x (apply values (signature (hash-table))))) 'error)
(test (signature (hash-table)) (let ((sig (list #t 'hash-table? #t))) (set-cdr! (cddr sig) (cddr sig)) sig)))
@@ -30036,9 +30166,9 @@ in s7:
(define (flatten lst)
(map values (list (let flatten-1 ((lst lst))
(cond ((null? lst) (values))
- ((not (pair? lst)) lst)
- (else (values (flatten-1 (car lst))
- (flatten-1 (cdr lst)))))))))
+ ((not (pair? lst)) lst)
+ (else (values (flatten-1 (car lst))
+ (flatten-1 (cdr lst)))))))))
#|
;; old form
(define (flatten lst) ; flatten via values and map
@@ -30364,7 +30494,7 @@ in s7:
(test (symbol? (with-input-from-string ":" read)) #t)
(test (let ((: 3)) :) 3)
(test (keyword? ':) #f)
-(test (symbol->keyword ':) '::)
+(test (symbol->keyword ':) '::) ; which is not a keyword!! -- '::: is -- this is getting ugly
(test (let () (define : 3) :) 3)
(test (let hi x 1) 'error)
(test (letrec ((x)) 1) 'error)
@@ -30378,6 +30508,7 @@ in s7:
(test (let ((pi 3)) pi) 'error)
(test (let ((:key 1)) :key) 'error)
+(test (let () (define (f) (do ((__i__ 0 (+ __i__ 1))) ((= __i__ 1) 'error) (let ((:key 1)) :key))) (f)) 'error) ; do_let
(test (let ((:3 1)) 1) 'error)
(test (let ((3 1)) 1) 'error)
(test (let ((3: 1)) 1) 'error)
@@ -34516,7 +34647,6 @@ who says the continuation has to restart the map from the top?
(test (keyword? '3) #f)
(test (keyword? ':) #f)
(test (keyword? '::) #t)
- (test (keyword? ::) #t)
(test (keyword? ::a) #t)
(test (eq? ::a ::a) #t)
(test (eq? (keyword->symbol ::a) :a) #t)
@@ -34525,13 +34655,13 @@ who says the continuation has to restart the map from the top?
(test ((lambda* (:a 32) ::a) 0) 'error) ; :a is a constant
(test (eq? :::a::: :::a:::) #t)
(test (keyword? a::) #t)
- (test (keyword->symbol ::) ':)
+ (test (keyword->symbol '::) ':)
(test (symbol->string (keyword->symbol hi:)) "hi")
(test (symbol->string (keyword->symbol :hi)) "hi")
(test (keyword? (string->keyword (string #\x (integer->char 128) #\x))) #t)
(test (keyword? (string->keyword (string #\x (integer->char 200) #\x))) #t)
(test (keyword? (string->keyword (string #\x (integer->char 255) #\x))) #t)
- (test (string->keyword ":") ::)
+ (test (string->keyword ":") '::)
(test (string->keyword (string #\")) (symbol ":\""))
(test (keyword? (string->keyword (string #\"))) #t)
(test (keyword->symbol (string->keyword (string #\"))) (symbol "\""))
@@ -34606,6 +34736,28 @@ who says the continuation has to restart the map from the top?
(test (symbol->keyword) 'error)
(test (symbol->keyword 'hi 'ho) 'error)
+;;; troubles (: :: etc -- these need to be cleaned up somehow)
+(test (keyword->symbol :asd:) 'asd:)
+(test (keyword->symbol (keyword->symbol :asd:)) 'asd)
+(test (procedure? (let ((+signature+ '(:all 3 #<eof>))) (lambda (a) a))) #t) ; ?? this should be an error somewhere
+(test (keyword? ::) #t)
+(test (keyword? ':) #f)
+(test (keyword->symbol ':) 'error)
+(test (keyword? :::) #t)
+(test (keyword->symbol :::) '::)
+(test ((lambda* ((: 3)) (+ : 1)) :: 4) 5)
+(test ((lambda* ((:: 3)) (+ :: 1)) ::: 4) 'error)
+(test (let ((: 3)) :) 3)
+(test (let ((:: 3)) ::) 'error)
+(test (let ((::: 3)) :::) 'error)
+(test ((inlet ': 3) ':) 3)
+(test (keyword? (keyword->symbol ::asdf)) #t)
+(test (keyword? (symbol->keyword ':)) #t)
+(test (keyword? (symbol->keyword '::)) #t)
+(test (apply let (list (list (symbol "") 3)) (symbol "")) 'error) ; null symbol name
+(test ((lambda* ((asdf 4)) (+ 1 asdf)) :asdf: 5) 'error)
+(test (define-constant :rest :allow-other-keys) 'error)
+(test (define-constant :rest :rest) :rest)
;;; --------------------------------------------------------------------------------
@@ -36509,8 +36661,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test ((lambda* (:rest) 3)) 'error)
(test ((lambda* (:rest 1) 3)) 'error)
(test ((lambda* (:rest :rest) 3)) 'error)
-(test ((lambda* ((: 1)) :)) 1)
-(test ((lambda* ((: 1)) :) :: 21) 21)
+(test ((lambda* ((: 1)) :)) 1) ; but there's no keyword name for this parameter!
(test ((lambda* ((a 1)) a) a: 21) 21)
(test ((lambda* ((a 1)) a) :a: 21) 'error)
(test (let ((func (let ((a 3)) (lambda* ((b (+ a 1))) b)))) (let ((a 21)) (func))) 4)
@@ -36933,6 +37084,25 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (let ((x 1)) (define* (hi (a (+ x "hi"))) a) (let ((x 32)) (hi))) 'error)
(test (let ((x 1)) (define-macro* (ho (a (+ x "hi"))) `(+ x ,a)) (let ((x 32)) (ho))) 'error)
(test (let ((x 1)) (define-macro (f1) `(+ x 1)) (f1)) 2)
+(test (let ((x 1)) (define-macro (add-1 y) `(+ ,y 1)) (add-1 (add-1 (add-1 x)))) 4)
+(let () ; wikipedia example of function composition using macros
+ (define-macro (sqrt-1 x) `(sqrt ,x))
+ (define-macro (negate-1 x) `(- ,x))
+ (define-macro (square-1 x) `(* ,x ,x))
+ (let ((val1 (sqrt-1 (negate-1 (square-1 5)))))
+ (define (compose . fs)
+ (if (null? fs)
+ (lambda (x) x)
+ (lambda (x)
+ ((car fs) ((apply compose (cdr fs)) x)))))
+ (test ((compose sqrt-1 negate-1 square-1) 5) val1)
+ (define-macro (compose-1 . fs)
+ `(if (null? ',fs)
+ (lambda (x) x)
+ (lambda (x)
+ ((symbol->value (car ',fs)) ((apply compose-1 (cdr ',fs)) x)))))
+ (test ((compose-1 sqrt-1 negate-1 square-1) 5) val1))
+ (test ((symbol->value 'negate-1) -4) 4))
(let ()
(define-macro (until test . body) `(do () (,test) ,@body))
@@ -36981,6 +37151,12 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (let ((b 2)) (let ((b 23)) (m))) 23))
(let ()
+ (define-macro* (mac1 (x (+ y 1))) `(+ ,x 2))
+ (let ((y 12)) (test (mac1) 15))
+ (define-macro* (mac2 (x (+ y 1))) `(let ((y 5)) (+ ,x 2)))
+ (let ((y 12)) (test (mac2) 8)))
+
+(let ()
(let ((x 1) (y 2))
(define-bacro (bac1 a) `(+ ,x y ,a))
(let ((x 32) (y 64))
@@ -38583,6 +38759,10 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test lst '(1 2))
(set! (setter (setter car)) #f))
+(test (let ((x 1)) (set! (setter 'x) integer?) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x pi))) 'error)
+(test (let ((x 1)) (set! (setter 'x) integer?) (define (f) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x pi))) (f)) 'error)
+(test (let ((x 1)) (set! (setter 'x) integer?) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x i))) 0)
+
;;; --------------------------------------------------------------------------------
;;; documentation
@@ -41910,6 +42090,20 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
'error)
(when with-block
+ (define (f) ; opt_cell_set -> opt_d_7pid_sff
+ (let ((iv (make-block 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) iv)
+ (set! (iv (- (+ i 1) 1)) (* 3.0 2.0)))))
+ (test (f) (block 6 6 6 6 6 6 6 6 6 6))
+
+ (define (g) ; d_7pid_ok -> opt_d_7pid_sff
+ (let ((iv (make-block 10)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) iv)
+ (block-set! iv (- (+ i 1) 1) (* 3.0 2.0)))))
+ (test (g) (block 6 6 6 6 6 6 6 6 6 6))
+
(define (f6 b) (do ((i 0 (+ i 1)) (x 0.0 (+ x 0.1))) ((= i 10) b) (set! (b i) x)))
(define (f7 b) (do ((i 0 (+ i 1)) (x 0.0 (+ x 0.1))) ((= i 10) b) (block-set! b i x)))
@@ -42469,6 +42663,13 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (equal? (inlet a: 1) (inlet :a 1)) #t)
(test (inlet 'if 3) 'error)
(test (inlet 'pi 3) 'error)
+(test (inlet 'let-ref (lambda (obj val) val)) 'error)
+(test (inlet 'let-set! (lambda (obj arg val) val)) 'error)
+(test (let ((incr (lambda (val) (+ val 1))))
+ (let ((e1 (curlet))
+ (incr (lambda (val) (+ val 2))))
+ (+ (with-let e1 (incr 2)) (incr 5))))
+ 10)
(test (varlet (immutable! (inlet 'a 1)) 'b 2) 'error)
(test (cutlet (immutable! (inlet 'a 1)) 'a) 'error)
@@ -44428,7 +44629,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (e 'value) 1+)
(test (e 'type) 'macro?)
(test (e 'arity) '(1 . 1))
- (test (e 'source) '(lambda (x) (list '+ x 1)))))
+ (test (e 'source) '(lambda (x) (list-values '+ x 1)))))
(test (substring "1234" ((openlet (inlet 'value 1)) 'value) ((openlet (object->let 3)) 'value)) "23")
@@ -45137,7 +45338,7 @@ hi6: (string-app...
(test (let ((str (object->string (dilambda (lambda (x) x) logior) :readable)))
(pair? (member str '("(dilambda (lambda (x) x) #_logior)" "(dilambda (lambda (x) x) logior)"))))
#t)
-(test (let () (define-macro (mac x) `(+ ,x 1)) (object->string (dilambda (lambda (x) x) mac) :readable)) "(dilambda (lambda (x) x) (lambda (x) (list '+ x 1)))")
+(test (let () (define-macro (mac x) `(+ ,x 1)) (object->string (dilambda (lambda (x) x) mac) :readable)) "(dilambda (lambda (x) x) (lambda (x) (list-values '+ x 1)))")
(test (object->string (dilambda (lambda (x) x) (lambda* (x y . z) x)) :readable) "(dilambda (lambda (x) x) (lambda* (x y . z) x))")
(test (object->string (dilambda (lambda (x) x) (lambda (x . y) x)) :readable) "(dilambda (lambda (x) x) (lambda (x . y) x))")
(test (object->string (dilambda (lambda* (x) x) (lambda* ((x 1) :rest y) x)) :readable) "(dilambda (lambda* (x) x) (lambda* ((x 1) :rest y) x))")
@@ -65795,6 +65996,14 @@ hi6: (string-app...
;; mpfr says the first fraction is 1.000000000000000020925101928970235578612E-3
(num-test (max 1e18 most-positive-fixnum) most-positive-fixnum) ; in bignum case there's type confusion here I think (hence num-test)
+(let ()
+ (define (f) ; opt_d_7dd_ff and opt_d_dd_ff
+ (let ((sum 0.0))
+ (do ((i 0 (+ i 1)))
+ ((= i 3) sum)
+ (set! sum (/ (+ sum 2.0) (max (* 2.0 sum) (+ sum 1.0)))))))
+ (num-test (f) 1.5))
+
(test (max) 'error)
(test (max 1.23+1.0i) 'error)
(test (max -0.0+0.00000001i) 'error)
@@ -66365,6 +66574,12 @@ hi6: (string-app...
(test (< 1267650600228229401496703205376) 'error)
(test (< 1.0 1267650600228229401496703205376+i) 'error))
+;; need 2 globals here, fx_lt_gsg
+(define _lt_test_1 2)
+(define _lt_test_2 1+i)
+(let ((mid 1))
+ (define (func) (list (< _lt_test_1 mid _lt_test_2)))
+ (test (func) 'error))
;;; --------------------------------------------------------------------------------
@@ -81519,6 +81734,14 @@ hi6: (string-app...
; (num-test (+ most-positive-fixnum most-positive-fixnum) 1.8446744073709551614e19)
; (num-test (+ most-negative-fixnum most-negative-fixnum) -1.8446744073709551616e19)
+(let () ; opt_d_dd_ff_add_mul
+ (define (f)
+ (let ((sum (float-vector 1 2 3)))
+ (do ((i 0 (+ i 1)))
+ ((= i 3) sum)
+ (float-vector-set! sum i (+ (sum i) (* (sum i) (sum i)))))))
+ (test (f) #r(2.0 6.0 12.0)))
+
(let ()
(define (add1)
(+ 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99))
@@ -84784,6 +85007,26 @@ hi6: (string-app...
(test (nan? (random 1/0)) #t)
(test (zero? (random 1e-30)) #f)
+(let ((size 20)) ; check add_i_random_i and subtract cases
+ (define (cr)
+ (let ((fv (make-float-vector size))
+ (iv (make-int-vector size))
+ (iv1 (make-int-vector size)))
+ (do ((i 0 (+ i 1)))
+ ((= i size))
+ (int-vector-set! iv i (+ 3 (random 9)))
+ (int-vector-set! iv1 i (- (random 9) 3))
+ (float-vector-set! fv i (- (random 9.0) 3.0)))
+ (do ((i 0 (+ i 1)))
+ ((= i size))
+ (if (or (>= (int-vector-ref iv i) 12) (< (int-vector-ref iv i) 3))
+ (format *stderr* "iv[~D] is ~A?~%" i (int-vector-ref iv i)))
+ (if (or (>= (int-vector-ref iv1 i) 6) (< (int-vector-ref iv1 i) -3))
+ (format *stderr* "iv1[~D] is ~A?~%" i (int-vector-ref iv1 i)))
+ (if (or (>= (float-vector-ref fv i) 6.0) (< (float-vector-ref fv i) -3.0))
+ (format *stderr* "iv1[~D] is ~A?~%" i (float-vector-ref fv i))))))
+ (cr))
+
(unless with-bignums
(test ((object->string (random-state 1234) :readable) 1) #\r) ; print-readably here
(test ((object->string (random-state 1234)) 1) #\<)) ; write (#t as default) here
@@ -84816,6 +85059,7 @@ hi6: (string-app...
(test (equal? (copy r1) r1) #t)
(test (random-state? r2) #t)
(test (random-state? (copy r1)) #t)))
+(test (let () (define (func) (+ -1 (random 1))) (func)) -1) ; add_i_random test
(test (complex? (random 1+i (random-state 1234))) #t)
(when with-bignums
@@ -91854,6 +92098,8 @@ etc
(when with-block
(test (let () (define (func x) (syntax? (values -1 (copy (block) (vector))))) (define (hi) (func #f)) (display (hi)) (newline)) 'error))
+(test (dynamic-wind (lambda () (int-vector (cons x x) (call/cc (call-with-exit (lambda (goto) goto))))) (lambda () #f) (lambda () #f)) 'error)
+
(when (defined? 's7-optimize)
(test (s7-optimize '((cdadr (cddddr (symbol->string (min '((x 1 . 2) . 3) #<undefined> '((x 1) . 2))))))) #<undefined>) ; #<undefined> is s7-optimize's error value
(test (s7-optimize '((set! (cyclic-sequences . 0+0/0i) #f))) #<undefined>)
@@ -94972,7 +95218,7 @@ etc
let: assuming we see all set!s, the binding (list x) is pointless: perhaps (let ((list x)) (if (null? list) 3 2)) -> (if (null? x) 3 2)")
(lint-test "(null? (string->list x))" " null?: perhaps (null? (string->list x)) -> (zero? (length x))")
(lint-test "(memq x (if (memq y '(< <=)) '(< <=) '(> >=)))" "") ; this is checking the ->simple-type escape
- (lint-test "(if q `(not ,op ,x) `(not ,op ,y))" "if: perhaps (if q (list 'not op x) (list 'not op y)) -> (list 'not op (if q x y))")
+ (lint-test "(if q `(not ,op ,x) `(not ,op ,y))" "") ; make sure we don't try to rewrite quasiquote
(let-temporarily ((*report-one-armed-if* #t))
(lint-test "(if a (begin (set! x y) z))" " if: perhaps (if a (begin (set! x y) z)) -> (when a (set! x y) z)")
@@ -95087,8 +95333,10 @@ etc
cond: assuming we see all set!s, the binding (z w) is pointless: perhaps (let ((z w)) (+ x z)) -> (+ x w)")
(lint-test "(cond (x (if x y z) (+ x 1)) (z 2))" " cond: this could be omitted: (if x y z)")
(lint-test "(cond ((g x) `(c ,x) `(c ,y)))"
- " cond: this could be omitted: (list 'c x)
- cond: perhaps (cond ((g x) (list 'c x) (list 'c y))) -> (when (g x) (list 'c x) (list 'c y))")
+ " cond: this could be omitted: (list-values 'c x)
+ cond: perhaps (list-values 'c x) -> (list 'c x)
+ cond: perhaps (list-values 'c y) -> (list 'c y)
+ cond: perhaps (cond ((g x) (list-values 'c x) (list-values 'c y))) -> (when (g x) (list-values 'c x) (list-values 'c y))")
(lint-test "(cond ((= x 1) 2) ((= x 2) 3))" " cond: perhaps use case instead of cond: (cond ((= x 1) 2) ((= x 2) 3)) -> (case x ((1) 2) ((2) 3))")
(lint-test "(cond ((= x y) (begin (display x) y)) (else x))" " cond: redundant begin: (begin (display x) y)")
(lint-test "(cond ((= x y) y) (else (begin (display x) x)))"
@@ -95766,35 +96014,38 @@ etc
list-values: perhaps (list-values (apply-values z) (apply-values z)) -> (append z z)")
(lint-test "`(,@x ,@(map (lambda (z) `(,@z ,@z ,@x)) y))"
" list-values: perhaps (list-values (apply-values z) (apply-values z) (apply-values x)) -> (append z z x)")
- (lint-test "(append `(,x) z)" " append: perhaps (append (list x) z) -> (cons x z)")
+ (lint-test "(append `(,x) z)" " append: perhaps (append (list x) z) -> (cons x z) append: perhaps (list-values x) -> (list x)")
(lint-test "(values `(x ,@y))"
- " values: perhaps (values (list-values 'x (apply-values y))) -> (cons 'x y)
+ " values: perhaps (values (list-values 'x (apply-values y))) -> (cons 'x y)
values: perhaps (list-values 'x (apply-values y)) -> (cons 'x y)")
+ (lint-test "(values `(x ,y) a)" " values: perhaps (values (list-values 'x y) a) -> (values (list 'x y) a) values: perhaps (list-values 'x y) -> (list 'x y)")
(lint-test "(values `(,x ,@y) z)"
" values: perhaps (values (list-values x (apply-values y)) z) -> (values (cons x y) z)
values: perhaps (list-values x (apply-values y)) -> (cons x y)")
(lint-test "(values `(,@x ,@y) `(,x z))"
- " values: perhaps (values (list-values (apply-values x) (apply-values y)) (list x 'z)) -> (values (append x y) (list x 'z))
- values: perhaps (list-values (apply-values x) (apply-values y)) -> (append x y)")
+ " values: perhaps (values (list-values (apply-values x) (apply-values y)) (list-values x 'z)) -> (values (append x y) (list x 'z))
+ values: perhaps (list-values (apply-values x) (apply-values y)) -> (append x y)
+ values: perhaps (list-values x 'z) -> (list x 'z)")
(lint-test "(define (g x) `(+ ,y ,@(map f x)))" " g: perhaps (list-values '+ y (apply-values (map f x))) -> (cons '+ (cons y (map f x)))")
(lint-test "(define (g x) `(+ ,@(map f x)))" " g: perhaps (list-values '+ (apply-values (map f x))) -> (cons '+ (map f x))")
(lint-test "(define (g x) `(,e ,@(map f x)))" " g: perhaps (list-values e (apply-values (map f x))) -> (cons e (map f x))")
(lint-test "(define (g x) `(f ,@x ,@y))" " g: perhaps (list-values 'f (apply-values x) (apply-values y)) -> (cons 'f (append x y))")
(lint-test "(define (g x) `(display ,(map f x)))" " g: perhaps (list-values 'display (map f x)) -> (list 'display (map f x))")
+ (lint-test "(define-macro (g x) `(f ,x))"
+ " define-macro: perhaps (define-macro (g x) (list-values 'f x)) -> (define g f)
+ g: perhaps (list-values 'f x) -> (list 'f x)")
(lint-test "(define-macro (g x) `(,@x ,y))" " g: perhaps (list-values (apply-values x) y) -> (append x (list y))")
(lint-test "(define-macro (g x) `(,@x z))" " g: perhaps (list-values (apply-values x) 'z) -> (append x (list 'z))")
(lint-test "(define-macro (g x) `(,@x ,(f y)))" " g: perhaps (list-values (apply-values x) (f y)) -> (append x (list (f y)))")
(lint-test "(define-macro (g x) `(+ ,y ,@(map f x)))" " g: perhaps (list-values '+ y (apply-values (map f x))) -> (cons '+ (cons y (map f x)))")
(lint-test "(define-macro (g x) `(,@x ,y ,@z))" " g: perhaps (list-values (apply-values x) y (apply-values z)) -> (append x (cons y z))")
(lint-test "(define-macro (g x) `(,@x ,@y ,z))" " g: perhaps (list-values (apply-values x) (apply-values y) z) -> (append x y (list z))")
-
(lint-test "(define f `((cond . ,forced-indent) (case . ,print-case) (let . ,let-expr)))"
- " f: perhaps (append (list 'cond) forced-indent) -> (cons 'cond forced-indent)")
+ " f: perhaps (list-values (append (list-values 'cond) forced-indent) (append... -> (list (cons 'cond forced-indent) (cons 'case print-case) ...)
+ f: perhaps (append (list 'cond) forced-indent) -> (cons 'cond forced-indent)")
(lint-test "(define f `((cond . ,forced-indent) (let . ,let-expr)))"
- " f: perhaps (list-values (append (list 'cond) forced-indent) (append (list 'let) let-expr)) ->
- (list (cons 'cond forced-indent) (cons 'let let-expr))
+ " f: perhaps (list-values (append (list-values 'cond) forced-indent) (append... -> (list (cons 'cond forced-indent) (cons 'let let-expr))
f: perhaps (append (list 'cond) forced-indent) -> (cons 'cond forced-indent)")
-
(lint-test "(set! x `(f . (,g . 100)))"
" set!: perhaps (append (list 'f g) 100) -> (cons 'f (cons g 100))
set!: perhaps (list-values 'f g) -> (list 'f g)")
@@ -96910,9 +97161,8 @@ etc
(do ((ds ()) (d 0 (+ d 1))) ((= d r) ds) (set! ds (cons d ds)))")
(lint-test "(let loop ((i 0) (lst ())) (if (= i 10) lst (loop (+ i 1) (cons 1 lst))))"
" loop: perhaps (let loop ((i 0) (lst ())) (if (= i 10) lst (loop (+ i 1) (cons 1 lst)))) ->
- (do ((i 0 (+ i 1)) (lst () (cons 1 lst))) ((= i 10) lst))
+ (do ((i 0 (+ i 1)) (lst () (cons 1 lst))) ((= i 10) lst))
loop: perhaps (let loop ((i 0) (lst ())) (if (= i 10) lst (loop (+ i 1) (cons 1 lst)))) -> (make-list 10 1)")
-
(lint-test "(let ((x (f y))) (display x) (define z (f x)) (do ((i 0 (+ i 1))) ((= i 3)) (display (+ x z i))))"
" let: the scope of z could be reduced: (... (define z (f x)) (do ((i 0 (+ i 1))) ((= i 3)) (display (+ x z i)))) ->
(... (let ((z (f x))) (do ((i 0 (+ i 1))) ((= i 3)) (display (+ x z i)))))
@@ -98142,7 +98392,7 @@ etc
(lint-test "(apply f `(,@(list x y)))"
" apply: perhaps (apply f (list-values (apply-values (list x y)))) -> (apply f (list x y))
apply: perhaps (list-values (apply-values (list x y))) -> (list x y)")
- (lint-test "(apply f `(x (,y 1) ,z))" " apply: perhaps (apply f (list-values 'x (list y 1) z)) -> (f 'x (list y 1) z)")
+ (lint-test "(apply f `(x (,y 1) ,z))" " apply: perhaps (apply f (list-values 'x (list-values y 1) z)) -> (f 'x (list y 1) z)")
(lint-test "(apply make-string tcnt initializer)" "")
(lint-test "(apply cons x y)" " apply: perhaps (apply cons x y) -> (cons x (car y))")
(lint-test "(apply string (make-list pad #\\null))" " apply: perhaps (apply string (make-list pad #\\null)) -> (make-string pad #\\null)")
@@ -98271,7 +98521,8 @@ etc
(lint-test "(number->string (cdr (or (assv i alist) (cons 0 0))))"
" number->string: perhaps (cdr (or (assv i alist) (cons 0 0))) -> (cond ((assv i alist) => cdr) (else 0))")
(lint-test "(cdr (or (assoc n oi) `(,n)))"
- " cdr: perhaps (cdr (or (assoc n oi) (list n))) -> (cond ((assoc n oi) => cdr) (else (list)))")
+ " cdr: perhaps (cdr (or (assoc n oi) (list-values n))) -> (cond ((assoc n oi) => cdr) (else (list)))
+ cdr: perhaps (list-values n) -> (list n)")
(lint-test "(cdr (or (assoc n oi) (list n y)))"
" cdr: perhaps (cdr (or (assoc n oi) (list n y))) -> (cond ((assoc n oi) => cdr) (else (list y)))")
(lint-test "(cdr (or (assoc n oi) (list n y z)))"
@@ -98360,12 +98611,13 @@ etc
;; and here also
(lint-test "(defmacro hi ())" " defmacro: defmacro declaration is messed up: (defmacro hi ())")
- (lint-test "(defmacro (hi x) `(+ ,x 1))" " defmacro: defmacro used where s7 uses define-defmacro: (defmacro (hi x) (list '+ x 1))?")
+ (lint-test "(defmacro (hi x) `(+ ,x 1))" " defmacro: defmacro used where s7 uses define-defmacro: (defmacro (hi x) (list-values '+ x 1))?")
(lint-test "(defmacro hi (a b a) a)" " defmacro: defmacro parameter is repeated: (a b a) hi: defmacro parameter a is declared twice")
-
(lint-test "(defmacro hi (a b) `(+ ,a ,b))"
- " defmacro: defmacro is deprecated; perhaps (defmacro hi (a b) (list '+ a b)) -> (define-macro (hi a b) (list '+ a b))
- defmacro: perhaps (define-macro (hi a b) (list '+ a b)) -> (define hi +)")
+ " defmacro: defmacro is deprecated; perhaps (defmacro hi (a b) (list-values '+ a b)) -> (define-macro (hi a b) (list-values '+ a b))
+ defmacro: perhaps (define-macro (hi a b) (list-values '+ a b)) -> (define hi +)")
+ (lint-test "(defmacro hi a `(+ ,a ,b))"
+ " defmacro: defmacro is deprecated; perhaps (defmacro hi a (list-values '+ a b)) -> (define-macro (hi . a) (list-values '+ a b))")
(lint-test "(defmacro* mac1 (a :key b :optional c . d) `(list ,a ,b ,c ,@d))"
" defmacro*: defmacro* is deprecated; perhaps (defmacro* mac1 (a :key b :optional c . d) (list-values 'list a b c... ->
(define-macro* (mac1 a b c . d) (list-values 'list a b c (apply-values d)))")
@@ -98378,7 +98630,6 @@ etc
(lint-test "(define a a)" " define: this define is either not needed, or is an error: (define a a)")
(lint-test "(define #(a) 2)" " define: strange form: (define #(a) 2)")
(lint-test "(define (f1 a) (abs a))" " f1: f1 could be (define f1 abs)")
- (lint-test "(define f1 (lambda (a) (cddr a)))" " f1: perhaps (lambda (a) (cddr a)) -> cddr")
(lint-test "(define (f1 a b) \"a docstring\" (log a b))" " f1: f1 could be (define f1 log)")
(lint-test "(let () (define (f1 a b) (* 2 (log a b))) (define (f2 a b) (f1 a b)) (f2 1 2))"
" let: perhaps change f2 to a let:
@@ -98533,7 +98784,7 @@ etc
let: f1 has too many arguments: (f1 2 3)")
(lint-test "(let () (define-macro (m1 a) a) (m1 2 3))" " let: m1 has too many arguments: (m1 2 3)")
(lint-test "(let () (define-macro (m2 b) `(let ((a 12)) (+ a ,b))) (let ((a 1) (+ *)) (+ a (m2 a))))"
- " let: possible problematic macro expansion: (m2 a) may collide with subsequently defined 'a
+ " let: possible problematic macro expansion: (m2 a) may collide with subsequently defined 'a, +
let: assuming we see all set!s, the binding (+ *) is pointless: perhaps (let ((a 1) (+ *)) (+ a (m2 a))) -> (let ((a 1)) (* a (m2 a)))")
(lint-test "(let () (define-macro (m3 b) `(let ((a 12)) (+ (symbol->value ,b) a))) (let ((a 1)) (+ a (m3 'a))))"
" let: possible problematic macro expansion: (m3 'a) could conceivably collide with subsequently defined 'a")
@@ -98543,7 +98794,7 @@ etc
(lint-test "(define-macro (f a . x) `(+ ,a ,@x))"
" define-macro: perhaps (define-macro (f a . x) (list-values '+ a (apply-values x))) -> (define f +)
f: perhaps (list-values '+ a (apply-values x)) -> (cons '+ (cons a x))")
- (lint-test "(define-macro (m1 a) `((,a b c)))" " m1: perhaps (list-values (list a 'b 'c)) -> (list (list a 'b 'c))")
+ (lint-test "(define-macro (m1 a) `((,a b c)))" " m1: perhaps (list-values (list-values a 'b 'c)) -> (list (list a 'b 'c))")
(lint-test "(define pi (acos -1))" " define: (acos -1) is one of its many names, but pi is a predefined constant in s7 pi: perhaps (acos -1) -> pi")
(lint-test "(+ x (atan 0 -1))" " +: perhaps (+ x (atan 0 -1)) -> (+ x pi)")
@@ -98573,17 +98824,16 @@ etc
(lint-test "(define-macro (m3) ''a)"
" define-macro: perhaps (define-macro (m3) ''a) -> (define m3 'a) or (define (m3) 'a)
m3: returns a list constant: ''a")
-
(lint-test "(define-macro (m4 a) `(abs ,a))"
- " define-macro: perhaps (define-macro (m4 a) (list 'abs a)) -> (define m4 abs)")
- (lint-test "(define-macro (m5 a) `(log ,a 2))" " define-macro: perhaps (define-macro (m5 a) (list 'log a 2)) -> (define (m5 a) (log a 2))")
-
+ " define-macro: perhaps (define-macro (m4 a) (list-values 'abs a)) -> (define m4 abs)
+ m4: perhaps (list-values 'abs a) -> (list 'abs a)")
+ (lint-test "(define-macro (m5 a) `(log ,a 2))" " define-macro: perhaps (define-macro (m5 a) (list-values 'log a 2)) -> (define (m5 a) (log a 2))")
(lint-test "(define-macro (m6 a) `(+ ,a ,a))" "") ; here a might be (display 32) -- should happen twice
- (lint-test "(define-macro (m7 a b) `(set! ,a ,b))" " define-macro: perhaps (define-macro (m7 a b) (list 'set! a b)) -> (define m7 set!)")
+ (lint-test "(define-macro (m7 a b) `(set! ,a ,b))" " define-macro: perhaps (define-macro (m7 a b) (list-values 'set! a b)) -> (define m7 set!)")
(lint-test "(define-macro (m8 a) `(lambda () ,a))" "")
(lint-test "(define-macro (m8 a) `(let () ,a))" "")
(lint-test "(define-macro (m9 a b) `(+ ,a (* ,b 2)))" "")
- (lint-test "(define-macro (m10 a) `(+ ,a x))" " define-macro: perhaps (define-macro (m10 a) (list '+ a 'x)) -> (define (m10 a) (+ a x))")
+ (lint-test "(define-macro (m10 a) `(+ ,a x))" " define-macro: perhaps (define-macro (m10 a) (list-values '+ a 'x)) -> (define (m10 a) (+ a x))")
(lint-test "(define-macro (m11) (- -1 (* -2 (expt 2 28))))"
" define-macro: perhaps (define-macro (m11) (- -1 (* -2 (expt 2 28)))) ->
(define m11 (- -1 (* -2 (expt 2 28)))) or (define (m11) (- -1 (* -2 (expt 2 28))))")
@@ -98598,11 +98848,11 @@ etc
(lint-test "(define-macro (m a) `(+ 1 a))"
" define-macro: missing comma? (define-macro (m a) '(+ 1 a)) m: returns a list constant: '(+ 1 a)")
(lint-test "(define-macro (m a) `(+ 1 ,a (* a 2)))"
- " define-macro: perhaps (define-macro (m a) (list '+ 1 a '(* a 2))) -> (define (m a) (+ 1 a (* a 2)))
- define-macro: missing comma? (define-macro (m a) (list '+ 1 a '(* a 2)))")
+ " define-macro: perhaps (define-macro (m a) (list-values '+ 1 a '(* a 2))) -> (define (m a) (+ 1 a (* a 2)))
+ define-macro: missing comma? (define-macro (m a) (list-values '+ 1 a '(* a 2)))")
(lint-test "(define-macro (m1 x) `(begin (vector-set! ,x 0 1)))"
- " m1: pointless begin: (list-values 'begin (list 'vector-set! x 0 1)) -> (list 'vector-set! x 0 1)
- m1: perhaps (list-values 'begin (list 'vector-set! x 0 1)) -> (list 'begin (list 'vector-set! x 0 1))")
+ " m1: pointless begin: (list-values 'begin (list-values 'vector-set! x 0 1)) -> (list-values 'vector-set! x 0 1)
+ m1: perhaps (list-values 'begin (list-values 'vector-set! x 0 1)) -> (list 'begin (list 'vector-set! x 0 1))")
(lint-test "(let ((a 1)) (define (f1 b) (+ a b)) (f1 0))"
" let: perhaps (... (define (f1 b) (+ a b)) (f1 0)) -> (... (let ((b 0)) (+ a b)))
@@ -98775,14 +99025,14 @@ etc
" f21: perhaps (set! x 3) -> (let ((x 3)) ...)
begin: f21's parameter 1's value is not used, but a value is passed: (+ z 1)")
(lint-test "(begin (define (f22 x) (case y ((0) `(+ ,x 1)) (else #f))) (f22 2))"
- " f22: perhaps (case y ((0) (list '+ x 1)) (else #f)) -> (and (eqv? y 0) (list '+ x 1))")
+ " f22: perhaps (case y ((0) (list-values '+ x 1)) (else #f)) -> (and (eqv? y 0) (list-values '+ x 1))")
(lint-test "(begin (define (f23 x) (+ y 1)) (define (f24 x) (f23 (+ x 1))) (f24 0))"
" f24: f23's parameter 1 is not used, but a value is passed: (+ x 1)")
(unless pure-s7
(lint-test "(begin (define x 1) `#(,x))" ; this can be expanded: (lambda (x) #((unquote x)))
" begin: quasiquoted vectors are not supported: #((unquote x)) perhaps use `(vector ...) rather than `#(...)"))
(lint-test "(begin (define-macro (m1 x y) `(+ ,y 1)) (m1 a b))"
- " begin: perhaps (define-macro (m1 x y) (list '+ y 1)) -> (define (m1 x y) (+ y 1))
+ " begin: perhaps (define-macro (m1 x y) (list-values '+ y 1)) -> (define (m1 x y) (+ y 1))
begin: m1's parameter 1 is not used, but a value is passed: a")
(lint-test "(begin (define (f30 x) (if (> x 0) (f30 #() (- x 1)))) (f30 1))" " f30: f30 has too many arguments: (f30 #() (- x 1))")
@@ -100373,8 +100623,8 @@ etc
(lint-test "(define (func x) (when `((x)) when '((())) and . case))" " func: when is messed up: (when '((x)) when '((())) and . case)")
(lint-test "(define (func x) (do . 0)) (define (hi) (func (define-macro (_m1_ a) `(+ ,a 1)))) (hi)"
" func: do is messed up: (do . 0)
- hi: func's parameter 1 is not used, but a value is passed: (define-macro (_m1_ a) (list '+ a 1))
- hi: perhaps (define-macro (_m1_ a) (list '+ a 1)) -> (define (_m1_ a) (+ a 1))")
+ hi: func's parameter 1 is not used, but a value is passed: (define-macro (_m1_ a) (list-values '+ a 1))
+ hi: perhaps (define-macro (_m1_ a) (list-values '+ a 1)) -> (define (_m1_ a) (+ a 1))")
(lint-test "(define (func x) (unless .(atan . __asdf__)))" " func: unless is messed up: (unless atan . __asdf__)")
(lint-test "(define (func x) (floor (* +.(inexact->exact))))" " func: inexact->exact needs 1 argument: (inexact->exact)")
(lint-test "(define (func x) (if (proper-list? ) (and / when '((())) () begin) (call-with-input-string (stacktrace +0 -1 1 20100))))"
@@ -100771,38 +101021,6 @@ etc
(test (c-pointer? (coverlet (c-pointer 1 2 (inlet 'aaa 1)))) #t)
;;; next two redefine let-ref and let-set! which messes up lint optimization above
-(let ((hi (openlet (inlet 'a 1
- 'let-ref (lambda (obj val)
- (coverlet obj)
- (let ((res (+ (obj val) 1)))
- (openlet obj)
- res))))))
- (test (hi 'a) 2))
-(let ()
- (define (cowlet . fields) ; copy-on-write let
- (openlet (apply inlet
- 'let-set! (lambda (obj field val)
- (let ((new-obj (copy (coverlet obj))))
- (set! (new-obj field) val)
- (openlet obj)
- (openlet new-obj)))
- fields)))
- (let ((hi (cowlet 'a 1 'b 2)))
- (let-set! hi 'b 1)
- (test (hi 'b) 2)
- (set! (hi 'b) 12)
- (test (hi 'b) 2)
- (let ((ho (let-set! hi 'b 32))
- (ha (set! (hi 'b) 32)))
- (test (openlet? hi) #t)
- (test (openlet? ho) #t)
- (test (let? ho) #t)
- (test (eq? hi ho) #f)
- (test (hi 'b) 2)
- (test (ho 'b) 32)
- (test (eq? ho ha) #f)
- (test (ha 'b) 32))))
-
(test (#_eval '(define x 3) (null-environment)) 3)
(test (#_eval '(< x 4) (null-environment)) 'error)
(test (object->string (null-environment)) "(inlet 'x 3)")
@@ -101059,6 +101277,14 @@ etc
(test (let ((a 1) (+ *) (let /)) (mac a)) 13)
(test (let ((a 1) (+ *) (let /)) (mac (mac a))) 25))
+(let () ; from Kjetil Matheussen
+ (define-expansion (push2! list el) `(set! ,list (cons ,el ,list)))
+ (define aa '())
+ (define (afunction) (define a 'a) (push2! aa a))
+ (define (<_>2 a b) (string->symbol (string-append (symbol->string a) (symbol->string b))))
+ (define-expansion (<ra2> command . args) `( ,(<_>2 'ra2: (keyword->symbol command)) ,@args))
+ (define (get-all-lines-in-file2 wfilename) (<ra2> :open-file-for-reading2 wfilename)))
+
(test (let ((begin +)) (with-let (unlet) (begin 1 2))) 2)
(test (let () (define (f x) (let > (begin (vector-dimensions 22)))) (f 0)) 'error)
(test (let () (define (f x) (let asd ())) (f 1)) 'error)
diff --git a/snd-chn.c b/snd-chn.c
index 73b230d..aa4f6ef 100644
--- a/snd-chn.c
+++ b/snd-chn.c
@@ -980,7 +980,7 @@ void set_x_axis_x0x1(chan_info *cp, double x0, double x1)
ap->changed = true;
}
-
+#if 0
static void set_x_axis_x0(chan_info *cp, mus_long_t left)
{
if (cp)
@@ -997,7 +997,7 @@ static void set_x_axis_x0(chan_info *cp, mus_long_t left)
}
}
}
-
+#endif
static void set_x_axis_x1(chan_info *cp, mus_long_t right)
{
@@ -1520,6 +1520,7 @@ static int make_graph_1(chan_info *cp, double cur_srate, graph_choice_t graph_ch
ap->losamp = snd_round_mus_long_t(ap->x0 * cur_srate); /* was ceil??? */
if (ap->losamp < 0) ap->losamp = 0;
ap->hisamp = (mus_long_t)((ap->x1 * cur_srate) + 0.5); /* + 0.5 for 1-sample case */
+ if (ap->hisamp >= current_samples(cp)) ap->hisamp = current_samples(cp) - 1;
if ((ap->losamp == 0) && (ap->hisamp == 0)) return(0);
}
@@ -5689,7 +5690,7 @@ void graph_button_release_callback(chan_info *cp, int x, int y, int key_state, i
mus_long_t rsamp;
rsamp = samp + snd_round_mus_long_t(0.5 * (cp->axis->hisamp - cp->axis->losamp));
if (rsamp < 0) rsamp = 0;
- if (rsamp > current_samples(cp)) rsamp = current_samples(cp);
+ if (rsamp >= current_samples(cp)) rsamp = current_samples(cp) - 1;
set_x_axis_x1(cp, rsamp);
update_graph(cp);
}
@@ -6846,14 +6847,49 @@ static Xen channel_set(Xen snd, Xen chn_n, Xen on, cp_field_t fld, const char *c
return(on);
case CP_LOSAMP:
+#if 0
Xen_check_type(Xen_is_integer(on), on, 1, S_set S_left_sample, "an integer");
set_x_axis_x0(cp, beg_to_sample(on, caller));
return(on);
+#else
+ /* keep losamp (and hisamp below) within the current sound bounds -- 20-Sep-19 thanks to Tito Latini */
+ /* I changed Tito's code to try to keep the unset axis side unmoved */
+ {
+ axis_info *ap;
+ mus_long_t lsamp;
+ Xen_check_type(Xen_is_integer(on), on, 1, S_set S_left_sample, "an integer");
+ lsamp = beg_to_sample(on, caller);
+ ap = cp->axis;
+ if (ap)
+ {
+ if (lsamp >= ap->hisamp) lsamp = ap->hisamp - 1;
+ set_x_axis_x0x1(cp, (double)lsamp / (double)snd_srate(cp->sound), ap->x1);
+ }
+ return(C_int_to_Xen_integer(lsamp));
+ }
+#endif
case CP_HISAMP:
+#if 0
Xen_check_type(Xen_is_integer(on), on, 1, S_set S_right_sample, "an integer");
set_x_axis_x1(cp, beg_to_sample(on, caller));
return(on);
+#else
+ {
+ mus_long_t rsamp;
+ axis_info *ap;
+ ap = cp->axis;
+ Xen_check_type(Xen_is_integer(on), on, 1, S_set S_right_sample, "an integer");
+ rsamp = beg_to_sample(on, caller);
+ if (rsamp >= current_samples(cp)) rsamp = current_samples(cp) - 1;
+ if (ap)
+ {
+ if (rsamp <= ap->losamp) rsamp = ap->losamp + 1;
+ set_x_axis_x0x1(cp, ap->x0, (double)rsamp / (double)snd_srate(cp->sound));
+ }
+ return(C_int_to_Xen_integer(rsamp));
+ }
+#endif
case CP_SQUELCH_UPDATE:
cp->squelch_update = Xen_boolean_to_C_bool(on);
diff --git a/snd-edits.c b/snd-edits.c
index e438914..765af0f 100644
--- a/snd-edits.c
+++ b/snd-edits.c
@@ -7468,6 +7468,7 @@ static void as_one_edit_set_origin(chan_info *cp, void *origin)
{
if (ed->origin) free(ed->origin);
ed->origin = mus_strdup((char *)origin);
+ reflect_edit_history_change(cp);
}
}
}
diff --git a/snd-marks.c b/snd-marks.c
index 8f21bc7..1655dab 100644
--- a/snd-marks.c
+++ b/snd-marks.c
@@ -445,7 +445,7 @@ static bool move_mark_1(chan_info *cp, mark *mp, int x)
if (mp->samp < 0) mp->samp = 0;
samps = current_samples(cp);
- if (mp->samp > samps) mp->samp = samps;
+ if (mp->samp >= samps) mp->samp = samps - 1;
if (Xen_hook_has_list(mark_drag_hook))
ss->squelch_mark_drag_info = Xen_is_true(run_progn_hook(mark_drag_hook,
@@ -1557,7 +1557,7 @@ static bool move_syncd_mark(chan_info *cp, mark *m, int x)
mp->samp += diff;
if (mp->samp < 0) mp->samp = 0;
samps = current_samples(ncp);
- if (mp->samp > samps) mp->samp = samps;
+ if (mp->samp >= samps) mp->samp = samps - 1;
if (mark_control_clicked)
make_mark_graph(ncp, mark_sd->initial_samples[i], mp->samp, i);
if ((mp->samp >= ap->losamp) &&
diff --git a/snd-motif.c b/snd-motif.c
index 32de45d..6b0338d 100644
--- a/snd-motif.c
+++ b/snd-motif.c
@@ -374,8 +374,11 @@ void check_for_event(void)
{
msk = XtAppPending(app);
/* if (msk & (XtIMXEvent | XtIMAlternateInput)) */
- if (msk & XtIMXEvent)
- /* was also tracking alternate input events, but these are problematic if libfam is in use (even with check) */
+ /* if (msk & XtIMXEvent) */
+ /* was also tracking alternate input events, but these are problematic if libfam is in use (even with check)
+ * but libfam is now long-since forgotten; new form below is thanks to Tito Latini
+ */
+ if ((msk & (XtIMXEvent | XtIMAlternateInput)) == XtIMXEvent)
{
XtAppNextEvent(app, &event);
XtDispatchEvent(&event);
diff --git a/snd-select.c b/snd-select.c
index 17d1d25..9cbe852 100644
--- a/snd-select.c
+++ b/snd-select.c
@@ -675,8 +675,8 @@ void update_possible_selection_in_progress(mus_long_t samp)
ed = cp->edits[cp->edit_ctr];
ed->selection_maxamp = -1.0;
ed->selection_maxamp_position = -1;
- if (samp > current_samples(cp))
- new_end = current_samples(cp);
+ if (samp >= current_samples(cp))
+ new_end = current_samples(cp) - 1;
else new_end = samp;
if (new_end < original_beg)
diff --git a/snd-sig.c b/snd-sig.c
index 03ce72c..8737555 100644
--- a/snd-sig.c
+++ b/snd-sig.c
@@ -2151,7 +2151,7 @@ static char *direct_filter(chan_info *cp, int order, env *e, snd_fd *sf, mus_lon
}
if (reporting) finish_progress_report(cp);
- if (origin)
+ if ((origin) && (!mus_strcmp(origin, S_filter_channel)))
new_origin = mus_strdup(origin);
else
{
@@ -5698,6 +5698,12 @@ applies an FIR filter to snd's channel chn. 'env' is the frequency response enve
}
if (Xen_is_string(origin))
caller = Xen_string_to_C_string(origin);
+ else caller = S_filter_channel;
+ /* if origin is NULL, direct_filter fills out the necessary parameters so that edit-list->function can re-call it,
+ * so if we set it to S_filter_channel here, we need to ignore it in direct_filter.
+ * Actually, the origin calculation in direct_filter should probably be moved here --
+ * otherwise convolution_filter will not work with edit-list->function -- I haven't tested this.
+ */
errstr = filter_channel(cp, order_1, e_1, beg_1, dur_1, edpos_1, caller, truncate_1, coeffs);
diff --git a/snd-test.scm b/snd-test.scm
index 28d526a..97eb246 100644
--- a/snd-test.scm
+++ b/snd-test.scm
@@ -1,32 +1,31 @@
;;; Snd tests
;;;
-;;; test 0: constants [372]
-;;; test 1: defaults [1017]
-;;; test 2: headers [1370]
-;;; test 3: variables [1684]
-;;; test 4: sndlib [2236]
-;;; test 5: simple overall checks [3975]
-;;; test 6: float-vectors [8585]
-;;; test 7: colors [8845]
-;;; test 8: clm [9334]
-;;; test 9: mix [21100]
-;;; test 10: marks [22819]
-;;; test 11: dialogs [23737]
-;;; test 12: extensions [23896]
-;;; test 13: menus, edit lists, hooks, etc [24133]
-;;; test 14: all together now [25438]
-;;; test 15: chan-local vars [26242]
-;;; test 16: regularized funcs [27904]
-;;; test 17: dialogs and graphics [31398]
-;;; test 18: save and restore [31501]
-;;; test 19: transforms [33141]
-;;; test 20: new stuff [35190]
-;;; test 21: optimizer [36360]
-;;; test 22: with-sound [38198]
-;;; test 23: errors [40958]
-;;; test 24: s7 [42356]
-;;; test all done [42489]
-;;; test the end [42651]
+;;; test 0: constants [376]
+;;; test 1: defaults [1021]
+;;; test 2: headers [1374]
+;;; test 3: variables [1688]
+;;; test 4: sndlib [2240]
+;;; test 5: simple overall checks [3979]
+;;; test 6: float-vectors [8589]
+;;; test 7: colors [8849]
+;;; test 8: clm [9338]
+;;; test 9: mix [21111]
+;;; test 10: marks [22830]
+;;; test 11: dialogs [23748]
+;;; test 12: extensions [23907]
+;;; test 13: menus, edit lists, hooks, etc [24144]
+;;; test 14: all together now [25451]
+;;; test 15: chan-local vars [26255]
+;;; test 16: regularized funcs [27917]
+;;; test 17: dialogs and graphics [31411]
+;;; test 18: save and restore [31514]
+;;; test 19: transforms [33154]
+;;; test 20: new stuff [35203]
+;;; test 21: optimizer [36373]
+;;; test 22: with-sound [38211]
+;;; test 23: errors [40971]
+;;; test 24: s7 [42369]
+;;; test all done [42502]
;;; (set! (hook-functions *load-hook*) (list (lambda (hook) (format *stderr* "loading ~S...~%" (hook 'name)))))
@@ -42659,228 +42658,3 @@ EDITS: 1
(gc) (gc)
(if with-exit (#_exit))
-
-;;; ---------------- test the end
-
-
-#|
-valgrind --tool=callgrind snd -l snd-test
-callgrind_annotate --auto=yes callgrind.out.<pid> > hi
-
-10-Feb-10 (full snd-test, not just test 23):
-372,028,372,850
-45,638,227,518 io.c:mus_read_any_1 [/home/bil/snd-11/snd]
-44,386,146,639 s7.c:eval [/home/bil/snd-11/snd]
-26,599,493,642 s7.c:eval'2 [/home/bil/snd-11/snd]
-20,950,395,846 s7.c:gc [/home/bil/snd-11/snd]
-20,800,612,761 snd-edits.c:next_sample_value_unscaled [/home/bil/snd-11/snd]
-17,699,734,242 snd-edits.c:channel_local_maxamp [/home/bil/snd-11/snd]
-14,661,979,458 io.c:mus_write_1 [/home/bil/snd-11/snd]
-14,486,041,393 snd-sig.c:direct_filter [/home/bil/snd-11/snd]
-10,836,543,187 run.c:eval_ptree [/home/bil/snd-11/snd]
-
-14-Dec-11:
-153,472,402,051
-15,964,352,672 ???:sin [/lib64/libm-2.12.so]
-15,349,566,001 io.c:mus_read_any_1 [/home/bil/snd/snd]
- 9,724,315,504 s7.c:eval [/home/bil/snd/snd]
- 9,340,050,109 snd-edits.c:channel_local_maxamp [/home/bil/snd/snd]
- 8,904,652,480 snd-sig.c:direct_filter [/home/bil/snd/snd]
- 8,727,766,020 run.c:eval_ptree [/home/bil/snd/snd]
- 7,219,826,287 io.c:mus_write_1 [/home/bil/snd/snd]
- 5,925,019,812 s7.c:eval'2 [/home/bil/snd/snd]
- 2,960,895,840 clm.c:mus_fir_filter [/home/bil/snd/snd]
- 2,765,667,308 clm.c:mus_out_any_to_file [/home/bil/snd/snd]
- 2,732,722,538 ???:cos [/lib64/libm-2.12.so]
- 2,654,002,973 clm.c:mus_src [/home/bil/snd/snd]
- 2,216,029,830 s7.c:find_symbol_or_bust [/home/bil/snd/snd]
- 2,051,926,172 s7.c:gc [/home/bil/snd/snd]
-
-6-Jul-12:
-314,557,435,854
-96,266,822,080 s7.c:eval [/home/bil/snd/snd]
-20,140,459,790 s7.c:find_symbol_or_bust [/home/bil/snd/snd]
-15,094,536,285 ???:sin [/lib64/libm-2.12.so]
-14,561,228,879 io.c:mus_read_any_1 [/home/bil/snd/snd]
-13,267,844,138 s7.c:gc [/home/bil/snd/snd]
-10,735,806,413 s7.c:s7_make_real [/home/bil/snd/snd]
- 9,597,104,099 snd-edits.c:channel_local_maxamp [/home/bil/snd/snd]
- 8,903,732,430 snd-sig.c:direct_filter [/home/bil/snd/snd]
- 8,756,184,253 s7.c:eval'2 [/home/bil/snd/snd]
- 6,939,439,659 io.c:mus_write_1 [/home/bil/snd/snd]
- 4,221,129,319 s7.c:g_add [/home/bil/snd/snd]
- 3,790,496,511 s7.c:g_multiply_2 [/home/bil/snd/snd]
- 2,960,895,524 clm.c:mus_fir_filter [/home/bil/snd/snd]
- 2,866,346,964 s7.c:g_equal_2 [/home/bil/snd/snd]
- 2,647,149,349 clm.c:mus_src [/home/bil/snd/snd]
- 2,373,255,704 s7.c:g_add_2 [/home/bil/snd/snd]
- 2,365,017,452 s7.c:g_add_1s [/home/bil/snd/snd]
- 2,014,711,657 ???:cos [/lib64/libm-2.12.so]
-
-23-Apr-13:
-52,886,592,302
-6,697,050,795 s7.c:eval [/home/bil/snd/snd]
-6,228,616,918 ???:sin [/lib64/libm-2.12.so]
-2,546,631,823 clm.c:mus_src [/home/bil/snd/snd]
-2,496,647,180 ???:cos [/lib64/libm-2.12.so]
-2,176,750,987 s7.c:find_symbol_or_bust [/home/bil/snd/snd]
-1,263,726,083 s7.c:eval'2 [/home/bil/snd/snd]
-1,248,608,065 s7.c:gc [/home/bil/snd/snd]
-1,021,282,278 io.c:mus_read_any_1 [/home/bil/snd/snd]
-1,003,986,022 clm.c:mus_phase_vocoder_with_editors [/home/bil/snd/snd]
- 933,290,098 clm.c:mus_formant_bank [/home/bil/snd/snd]
- 911,248,552 clm.c:fir_8 [/home/bil/snd/snd]
- 885,305,356 ???:t2_32 [/home/bil/snd/snd]
- 796,412,317 snd-edits.c:channel_local_maxamp [/home/bil/snd/snd]
- 785,981,295 ???:t2_64 [/home/bil/snd/snd]
- 693,360,038 clm.c:run_hilbert [/home/bil/snd/snd]
- 507,150,000 clm.c:mus_formant_bank_with_inputs [/home/bil/snd/snd]
- 459,853,855 clm.c:mus_src_20 [/home/bil/snd/snd]
- 449,476,048 ???:n1_64 [/home/bil/snd/snd]
- 444,970,752 io.c:mus_write_1 [/home/bil/snd/snd]
- 428,928,818 float-vector.c:g_float-vector_add [/home/bil/snd/snd]
-
-27-Apr-14:
-35,390,341,125
-5,444,441,772 s7.c:eval [/home/bil/gtk-snd/snd]
-2,255,959,839 ???:sin [/lib64/libm-2.12.so]
-2,027,776,135 ???:cos [/lib64/libm-2.12.so]
-1,266,976,906 clm.c:fir_ge_20 [/home/bil/gtk-snd/snd]
-1,041,138,903 clm.c:mus_src [/home/bil/gtk-snd/snd]
- 886,288,100 ???:t2_32 [/home/bil/gtk-snd/snd]
- 784,981,866 s7.c:gc [/home/bil/gtk-snd/snd]
- 781,643,274 ???:t2_64 [/home/bil/gtk-snd/snd]
- 653,499,001 snd-edits.c:channel_local_maxamp [/home/bil/gtk-snd/snd]
- 648,406,214 clm.c:mus_phase_vocoder_with_editors [/home/bil/gtk-snd/snd]
- 592,801,688 clm.c:fb_one_with_amps_c1_c2 [/home/bil/gtk-snd/snd]
- 558,124,334 io.c:mus_read_any_1 [/home/bil/gtk-snd/snd]
- 449,476,076 ???:n1_64 [/home/bil/gtk-snd/snd]
- 418,857,421 s7.c:eval'2 [/home/bil/gtk-snd/snd]
- 414,027,948 vct.c:g_vct_add [/home/bil/gtk-snd/snd]
- 394,639,129 clm.c:mus_src_to_buffer [/home/bil/gtk-snd/snd]
- 372,681,428 clm.c:mus_env_linear [/home/bil/gtk-snd/snd]
- 338,359,320 clm.c:run_hilbert [/home/bil/gtk-snd/snd]
- 327,141,926 clm.c:fb_many_with_amps_c1_c2 [/home/bil/gtk-snd/snd]
-
-15-Feb-15:
-33,895,270,323
-5,048,563,075 s7.c:eval [/home/bil/motif-snd/snd]
-2,109,026,775 ???:sin [/lib64/libm-2.12.so]
-2,024,119,795 ???:cos [/lib64/libm-2.12.so]
-1,267,013,962 clm.c:fir_ge_20 [/home/bil/motif-snd/snd]
-1,033,000,931 clm.c:mus_src [/home/bil/motif-snd/snd]
- 902,016,316 ???:t2_32 [/home/bil/motif-snd/snd]
- 736,981,999 ???:t2_64 [/home/bil/motif-snd/snd]
- 698,073,576 s7.c:gc [/home/bil/motif-snd/snd]
- 627,011,081 clm.c:mus_phase_vocoder_with_editors [/home/bil/motif-snd/snd]
- 594,199,460 clm.c:fb_one_with_amps_c1_c2 [/home/bil/motif-snd/snd]
- 584,394,041 snd-edits.c:channel_local_maxamp [/home/bil/motif-snd/snd]
- 489,621,727 io.c:mus_read_any_1 [/home/bil/motif-snd/snd]
- 440,021,064 ???:n1_64 [/home/bil/motif-snd/snd]
- 434,398,893 s7.c:eval'2 [/home/bil/motif-snd/snd]
- 412,021,596 vct.c:g_vct_add [/home/bil/motif-snd/snd]
- 379,620,192 clm.c:mus_src_to_buffer [/home/bil/motif-snd/snd]
- 358,009,460 clm.c:mus_env_linear [/home/bil/motif-snd/snd]
- 345,704,896 clm.c:run_hilbert [/home/bil/motif-snd/snd]
- 330,406,288 clm.c:fb_many_with_amps_c1_c2 [/home/bil/motif-snd/snd]
-
-2-Jan-16:
-40,365,626,332
-5,490,099,643 s7.c:eval'2 [/home/bil/motif-snd/snd]
-2,848,387,254 ???:sin [/lib64/libm-2.12.so]
-2,014,790,092 ???:cos [/lib64/libm-2.12.so]
-1,267,013,962 clm.c:fir_ge_20 [/home/bil/motif-snd/snd]
-1,135,195,524 s7.c:eval [/home/bil/motif-snd/snd]
-1,045,606,298 clm.c:mus_src [/home/bil/motif-snd/snd]
- 976,057,808 s7.c:gc [/home/bil/motif-snd/snd]
- 902,125,544 ???:t2_32 [/home/bil/motif-snd/snd]
- 803,333,049 ???:t2_64 [/home/bil/motif-snd/snd]
- 675,050,078 snd-edits.c:channel_local_maxamp [/home/bil/motif-snd/snd]
- 627,021,459 clm.c:mus_phase_vocoder_with_editors [/home/bil/motif-snd/snd]
- 594,199,460 clm.c:fb_one_with_amps_c1_c2 [/home/bil/motif-snd/snd]
- 489,246,418 io.c:mus_read_any_1 [/home/bil/motif-snd/snd]
- 459,910,388 ???:n1_64 [/home/bil/motif-snd/snd]
- 412,068,324 clm2xen.c:outa_x_rf_to_mus_xen [/home/bil/motif-snd/snd]
- 394,019,684 vct.c:vct_add [/home/bil/motif-snd/snd]
- 370,136,022 ???:memcpy [/lib64/ld-2.12.so]
- 358,200,130 clm.c:mus_env_linear [/home/bil/motif-snd/snd]
- 345,704,896 clm.c:run_hilbert [/home/bil/motif-snd/snd]
- 339,193,555 clm.c:filter_ge_10 [/home/bil/motif-snd/snd]
- 337,020,228 clm.c:mus_src_to_buffer [/home/bil/motif-snd/snd]
- 330,406,288 clm.c:fb_many_with_amps_c1_c2 [/home/bil/motif-snd/snd]
-
-4-Jan-17:
-40,444,112,752
-5,554,262,169 s7.c:eval'2 [/home/bil/motif-snd/snd]
-2,847,440,755 ???:sin [/lib64/libm-2.12.so]
-2,008,826,659 ???:cos [/lib64/libm-2.12.so]
-1,267,013,962 clm.c:fir_ge_20 [/home/bil/motif-snd/snd]
-1,131,280,306 s7.c:eval [/home/bil/motif-snd/snd]
-1,046,123,928 clm.c:mus_src [/home/bil/motif-snd/snd]
- 985,044,773 s7.c:gc [/home/bil/motif-snd/snd]
- 901,961,680 ???:t2_32 [/home/bil/motif-snd/snd]
- 803,333,049 ???:t2_64 [/home/bil/motif-snd/snd]
- 627,021,459 clm.c:mus_phase_vocoder_with_editors [/home/bil/motif-snd/snd]
- 608,930,865 snd-edits.c:channel_local_maxamp [/home/bil/motif-snd/snd]
- 594,199,460 clm.c:fb_one_with_amps_c1_c2 [/home/bil/motif-snd/snd]
- 489,290,304 io.c:mus_read_any_1 [/home/bil/motif-snd/snd]
- 459,835,320 ???:n1_64 [/home/bil/motif-snd/snd]
- 412,138,226 clm2xen.c:outa_x_rf_to_mus_xen [/home/bil/motif-snd/snd]
- 394,019,684 vct.c:vct_add [/home/bil/motif-snd/snd]
- 371,153,394 clm.c:mus_env_linear [/home/bil/motif-snd/snd]
- 350,476,620 ???:memcpy [/lib64/ld-2.12.so]
- 345,704,896 clm.c:run_hilbert [/home/bil/motif-snd/snd]
- 339,193,555 clm.c:filter_ge_10 [/home/bil/motif-snd/snd]
- 337,020,228 clm.c:mus_src_to_buffer [/home/bil/motif-snd/snd]
- 330,406,288 clm.c:fb_many_with_amps_c1_c2 [/home/bil/motif-snd/snd]
-
-14-Jul-17:
-39,992,822,005
-5,087,369,302 s7.c:eval'2 [/home/bil/motif-snd/snd]
-2,767,363,726 sin.c:sincos
-2,489,931,500 sin.c:__sin_avx
-1,882,891,339 sin.c:__cos_avx
-1,050,059,865 s7.c:gc [/home/bil/motif-snd/snd]
- 971,702,388 s7.c:eval [/home/bil/motif-snd/snd]
- 888,579,240 clm.c:fir_ge_20 [/home/bil/motif-snd/snd]
- 812,154,805 clm.c:mus_src [/home/bil/motif-snd/snd]
- 578,669,563 clm.c:mus_phase_vocoder_with_editors [/home/bil/motif-snd/snd]
- 540,581,915 snd-edits.c:channel_local_maxamp [/home/bil/motif-snd/snd]
- 481,331,424 clm.c:mus_env_linear [/home/bil/motif-snd/snd]
- 476,778,133 sincos.c:sincos
- 471,298,034 io.c:mus_read_any_1 [/home/bil/motif-snd/snd]
- 460,565,829 clm2xen.c:safe_out_any_2_to_mus_xen [/home/bil/motif-snd/snd]
- 400,507,324 s7.c:find_symbol_unchecked.isra.41 [/home/bil/motif-snd/snd]
- 316,839,152 clm.c:fb_one_with_amps_c1_c2 [/home/bil/motif-snd/snd]
- 296,511,570 clm.c:filter_ge_10 [/home/bil/motif-snd/snd]
- 289,431,086 s7.c:s7_make_real [/home/bil/motif-snd/snd]
- 282,377,079 s7.c:opt_dotimes [/home/bil/motif-snd/snd]
- 264,755,736 clm.c:run_hilbert [/home/bil/motif-snd/snd]
- 239,373,538 clm.c:mus_src_to_buffer [/home/bil/motif-snd/snd]
-
-6-Aug-18:
-38,927,410,104
-4,452,499,340 s7.c:eval [/home/bil/motif-snd/snd]
-3,154,641,007 /build/glibc-OTsEL5/glibc-2.27/math/../sysdeps/ieee754/dbl-64/s_sin.c:sincos
-2,320,192,291 /build/glibc-OTsEL5/glibc-2.27/math/../sysdeps/ieee754/dbl-64/s_sin.c:__sin_fma [/lib/x86_64-linux-gnu/libm-2.27.so]
-1,724,852,171 /build/glibc-OTsEL5/glibc-2.27/math/../sysdeps/ieee754/dbl-64/s_sin.c:__cos_fma [/lib/x86_64-linux-gnu/libm-2.27.so]
- 960,563,119 s7.c:gc [/home/bil/motif-snd/snd]
- 899,741,681 clm.c:fir_ge_20 [/home/bil/motif-snd/snd]
- 842,540,085 /build/glibc-OTsEL5/glibc-2.27/string/../sysdeps/x86_64/multiarch/memset-vec-unaligned-erms.S:__memset_avx2_erms [/lib/x86_64-linux-gnu/libc-2.27.so]
- 827,739,907 clm.c:mus_src [/home/bil/motif-snd/snd]
- 603,673,241 clm.c:mus_phase_vocoder_with_editors [/home/bil/motif-snd/snd]
- 567,734,028 snd-edits.c:channel_local_maxamp [/home/bil/motif-snd/snd]
- 560,397,395 /build/glibc-OTsEL5/glibc-2.27/math/../sysdeps/ieee754/dbl-64/s_sincos.c:sincos [/lib/x86_64-linux-gnu/libm-2.27.so]
- 483,161,481 clm.c:mus_env_linear [/home/bil/motif-snd/snd]
- 466,582,141 io.c:mus_read_any_1.part.0 [/home/bil/motif-snd/snd]
- 460,946,971 clm2xen.c:safe_out_any_2_to_mus_xen [/home/bil/motif-snd/snd]
- 456,777,517 s7.c:eval'2 [/home/bil/motif-snd/snd]
- 349,537,710 clm.c:fb_one_with_amps_c1_c2 [/home/bil/motif-snd/snd]
- 274,938,780 clm.c:filter_ge_10 [/home/bil/motif-snd/snd]
- 265,902,302 /build/glibc-OTsEL5/glibc-2.27/math/../sysdeps/generic/math_private_calls.h:sincos
- 264,743,136 clm.c:run_hilbert [/home/bil/motif-snd/snd]
- 254,407,429 s7.c:fx_c_ss [/home/bil/motif-snd/snd]
- 247,359,272 s7.c:opt_dotimes [/home/bil/motif-snd/snd]
- 238,517,771 clm.c:mus_src_to_buffer [/home/bil/motif-snd/snd]
-
-|#
diff --git a/snd.h b/snd.h
index 683b26e..6672675 100644
--- a/snd.h
+++ b/snd.h
@@ -55,11 +55,11 @@
#include "snd-strings.h"
-#define SND_DATE "3-Sep-19"
+#define SND_DATE "14-Oct-19"
#ifndef SND_VERSION
-#define SND_VERSION "19.7"
+#define SND_VERSION "19.8"
#endif
#define SND_MAJOR_VERSION "19"
-#define SND_MINOR_VERSION "7"
+#define SND_MINOR_VERSION "8"
#endif
diff --git a/sndclm.html b/sndclm.html
index 5b75f04..7a48d39 100644
--- a/sndclm.html
+++ b/sndclm.html
@@ -6728,7 +6728,7 @@ called whenever convolve needs input.
(with-sound (:play #t :statistics #t)
(let ((cnv (make-convolve
(make-readin "pistol.snd")
- (file-&gt;float-vector "oboe.snd" 0 (make-float-vector (framples "pistol.snd"))))))
+ (samples 0 (framples "pistol.snd") "oboe.snd"))))
(do ((i 0 (+ i 1)))
((= i 88200))
(outa i (* 0.25 (convolve cnv))))))
@@ -9629,7 +9629,7 @@ We could mimic the fft display window in the "lisp graph" via:
<p>moving-spectrum provides a sample-by-sample spectrum (amplitudes, frequencies, and current phases) of its
input (currently assumed to be a readin generator). It is identical to the first (analysis) portion of
the phase-vocoder generator (see test-sv in generators.scm for details). To access the current amps and so on,
-use moving-spectrum-amps, moving-spectrum-phases, and moving-spectrum-freqs.
+use (gen 'amps), (gen 'phases), and (gen 'freqs).
</p>
<div class="separator"></div>
diff --git a/tools/dup.scm b/tools/dup.scm
index f5fc45f..217dc8c 100644
--- a/tools/dup.scm
+++ b/tools/dup.scm
@@ -4,7 +4,7 @@
;;; "alloc-lines" is any number bigger than the number of lines in "file"
;;; (dups 16 "s7.c" 91000) finds all 16-line matches in s7.c which (we wish) has less than 91000 lines in all
-(set! (*s7* 'heap-size) (* 2 1024000))
+;(set! (*s7* 'heap-size) (* 2 1024000))
(define dups
(let ((unique #f))
diff --git a/tools/t101.scm b/tools/t101.scm
index e2a8774..0470bc4 100644
--- a/tools/t101.scm
+++ b/tools/t101.scm
@@ -22,7 +22,7 @@
(let ((aux-file (format #f "t101-aux-~D.scm" (set! aux-counter (+ aux-counter 1)))))
(call-with-output-file aux-file
(lambda (p)
- (format p "(with-input-from-file \"all-lg-results\" (lambda () (display (with-output-to-string (lambda () (load \"s7test.scm\")))) (newline)))")
+ (format p "(with-input-from-file \"/home/bil/cl/all-lg-results\" (lambda () (display (with-output-to-string (lambda () (load \"s7test.scm\")))) (newline)))")
(format p "(load \"s7test.scm\")~%(exit)~%")))
(format *stderr* "~%~NC~%test: stdin from all-lg-results~%" 80 #\-)
(system (string-append "./repl " aux-file)))
diff --git a/tools/tbig.scm b/tools/tbig.scm
index b23aded..db14586 100644
--- a/tools/tbig.scm
+++ b/tools/tbig.scm
@@ -5,6 +5,7 @@
(set! (*s7* 'max-vector-length) (ash 1 36))
(set! (*s7* 'max-string-length) (ash 1 36))
(set! (*s7* 'safety) -1)
+;; setting heap-size slows us down
(load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init)))
@@ -27,7 +28,6 @@
(define fft-size (ash 1 17))
(define little-size 1000000)
-
;; --------------------------------------------------------------------------------
(format () "complex fft...~%")
@@ -626,7 +626,6 @@
(float-vector-test)
(clear-and-gc)
-
(define (float-2d-fft rl n dir)
(when rl
(let ((tempr 0.0)
diff --git a/tools/tclo.scm b/tools/tclo.scm
index 64edf80..8de766b 100644
--- a/tools/tclo.scm
+++ b/tools/tclo.scm
@@ -1,3 +1,5 @@
+(set! (*s7* 'heap-size) (* 8 1024000))
+
(define* (f0 a b)
(display b #f))
diff --git a/tools/tcopy.scm b/tools/tcopy.scm
index 0d52cd8..4a75d87 100644
--- a/tools/tcopy.scm
+++ b/tools/tcopy.scm
@@ -2,7 +2,7 @@
;; depends on running s7test first normally
(load "s7test-block.so" new-env))
-(set! (*s7* 'heap-size) 1024000)
+;(set! (*s7* 'heap-size) 1024000)
(define (test-copy size)
(let ((old-string (make-string size #\a))
diff --git a/tools/teq.scm b/tools/teq.scm
index 0079ed7..d139619 100644
--- a/tools/teq.scm
+++ b/tools/teq.scm
@@ -1,6 +1,6 @@
;;; cyclic/shared timing tests
-(set! (*s7* 'heap-size) (* 2 1024000))
+;(set! (*s7* 'heap-size) (* 2 1024000))
;;; equal? write/object->string/format cyclic-sequences
diff --git a/tools/testsnd b/tools/testsnd
index d1ea149..6f8cad8 100755
--- a/tools/testsnd
+++ b/tools/testsnd
@@ -76,10 +76,10 @@ echo ' '
./snd -l snd-test
# ./snd lint.scm -e '(begin (lint "s7test.scm" #f) (exit))'
-cp s7test.scm tmptest.scm
-./snd tools/sed.scm -e '(sed "tmptest.scm" "tmp" "(define full-test #f)" "(define full-test #t)")'
-mv tmp tmptest.scm
-./snd tmptest.scm
+# cp s7test.scm tmptest.scm
+# ./snd tools/sed.scm -e '(sed "tmptest.scm" "tmp" "(define full-test #f)" "(define full-test #t)")'
+# mv tmp tmptest.scm
+# ./snd tmptest.scm
echo ' '
echo ' '
@@ -345,6 +345,7 @@ cp orig-snd-test.scm snd-test.scm
# sed snd-test.scm -e 's/(define test-at-random 0)/(define test-at-random 100)/g' > tmp
mv tmp snd-test.scm
+# this hangs sometimes?
echo ' '
echo ' '
./snd --version
diff --git a/tools/tfft.scm b/tools/tfft.scm
index 8da1272..55cc680 100644
--- a/tools/tfft.scm
+++ b/tools/tfft.scm
@@ -146,8 +146,7 @@
(fill! cdata 0.0)
(vector-set! cdata 2 1+i)
(vector-set! cdata (- n 1) 1-i)
- (cfft cdata)))
- )
+ (cfft cdata))))
(fft-bench)
diff --git a/tools/thash.scm b/tools/thash.scm
index 2003d91..1828322 100644
--- a/tools/thash.scm
+++ b/tools/thash.scm
@@ -28,9 +28,8 @@
(<= k start))
(+ k 1)))))
(when (> end start)
- (let* ((word (string->symbol (substring line start end)))
- (refs (or (hash-table-ref counts word) 0)))
- (hash-table-set! counts word (+ refs 1)))))
+ (let ((word (string->symbol (substring line start end))))
+ (hash-table-set! counts word (+ (or (hash-table-ref counts word) 0) 1)))))
(set! new-pos (+ pos 1))))
(close-input-port port)
@@ -83,7 +82,7 @@
(let ()
(define (hash-ints)
- (let ((counts (make-hash-table 8 = (cons integer? integer?))))
+ (let ((counts (make-hash-table)))
(do ((i 0 (+ i 1))
(z (random 100) (random 100)))
((= i 5000000) counts)
diff --git a/tools/tmap.scm b/tools/tmap.scm
index 4098d28..e96133d 100644
--- a/tools/tmap.scm
+++ b/tools/tmap.scm
@@ -1,6 +1,6 @@
;;; sequence tests
-(set! (*s7* 'heap-size) (* 4 1024000))
+;(set! (*s7* 'heap-size) (* 4 1024000))
(define (less-than a b)
(or (< a b) (> b a)))
diff --git a/tools/tmisc.scm b/tools/tmisc.scm
index 1984506..107219e 100644
--- a/tools/tmisc.scm
+++ b/tools/tmisc.scm
@@ -1,4 +1,4 @@
-(set! (*s7* 'heap-size) 1024000)
+(set! (*s7* 'heap-size) (* 2 1024000))
(define size 500000)
diff --git a/tools/tshoot.scm b/tools/tshoot.scm
index 9085c38..84bfdf5 100644
--- a/tools/tshoot.scm
+++ b/tools/tshoot.scm
@@ -176,7 +176,7 @@
(format *stderr* "~D~9Ttrees of depth ~D~30Tcheck: ~D~%" iterations depth check)))))
(format *stderr* "long lived tree of depth ~D~30Tcheck: ~D~%" max-depth (item-check long-lived-tree)))))))
-;(binary-tree 21) ; 26 secs
+;;(binary-tree 21) ; 20 secs
(binary-tree 6)
;;; stretch tree of depth 22 check: 8388607
@@ -217,7 +217,8 @@
;(collatz 300000)
;; Maximum stopping distance 442, starting number 230631
-;; .66 secs
+;; .6 secs
+
(collatz 20000)
;;; --------------------------------------------------------------------------------
@@ -240,16 +241,71 @@
(set! L (cdr L))))))))
(let ()
- (define (count-primes limit) ; for limit=10000000 12.7 secs 664579
+ (define (count-primes limit) ; for limit=10000000 12.3 secs 664579
(let ((primes 0))
(do ((i 2 (+ i 1)))
((= i limit)
primes)
(if (prime? i)
(set! primes (+ primes 1))))))
-
(display (count-primes 100000)) (newline)) ; 9592
;;; --------------------------------------------------------------------------------
+;;;
+;;; spectral-norm, based on code by Anthony Borla (Computer Benchmarks Game)
+
+(let ((weights #f))
+
+ (define (mulAv n v av)
+ (fill! av 0.0)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (float-vector-set! av i (+ (float-vector-ref av i)
+ (* (/ 1.0 (+ i (float-vector-ref weights (+ i j))))
+ (float-vector-ref v j)))))))
+
+ (define (mulAtV n v atv)
+ (fill! atv 0.0)
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (do ((j 0 (+ j 1)))
+ ((= j n))
+ (float-vector-set! atv i (+ (float-vector-ref atv i)
+ (* (/ 1.0 (+ j (float-vector-ref weights (+ i j))))
+ (float-vector-ref v j)))))))
+
+ (define (mulAtAv n v atav)
+ (let ((u (make-float-vector n 0.0)))
+ (mulAv n v u)
+ (mulAtV n u atav)))
+
+ (define (spectral-norm n)
+ (let ((u (make-float-vector n 1.0))
+ (v (make-float-vector n 0.0))
+ (vBv 0.0) (vV 0.0))
+
+ (set! weights (make-float-vector (* 2 n)))
+ (do ((i 0 (+ i 1)))
+ ((= i (* 2 n)))
+ (float-vector-set! weights i (+ (* 0.5 i (+ i 1)) 1.0)))
+
+ (do ((i 0 (+ i 1)))
+ ((= i 10))
+ (mulAtAv n u v)
+ (mulAtAv n v u))
+
+ (do ((i 0 (+ i 1)))
+ ((= i n))
+ (set! vBv (+ vBv (* (float-vector-ref u i) (float-vector-ref v i))))
+ (set! vV (+ vV (* (float-vector-ref v i) (float-vector-ref v i)))))
+
+ (sqrt (/ vBv vV))))
+
+ (display (spectral-norm 125)) ; (spectral-norm 5500) takes about 19.4 secs
+ (newline))
+
+;;; --------------------------------------------------------------------------------
(exit)
diff --git a/tools/tsort.scm b/tools/tsort.scm
index adfb562..1d5b558 100644
--- a/tools/tsort.scm
+++ b/tools/tsort.scm
@@ -1,4 +1,4 @@
-(set! (*s7* 'heap-size) 1024000)
+;(set! (*s7* 'heap-size) 1024000)
(let ((size 100000))
(define (less a b)
@@ -12,7 +12,7 @@
(<= a b)))
(define (closure-less a b)
(and (< a b)
- (= (abs (+ (* 2 (- 3)) 1)) 5))) ; force all-x to give up!
+ (= (abs (+ (* 2 (- 3)) 1)) 5))) ; force optimizer to give up!
(define (begin-less a b)
(if (and (< a b) (> a b)) (display "oops"))
(< a b))
diff --git a/tools/valcall.scm b/tools/valcall.scm
index ab78110..58a1964 100644
--- a/tools/valcall.scm
+++ b/tools/valcall.scm
@@ -75,16 +75,16 @@
(list (list "repl" "tpeak.scm")
(list "repl" "tauto.scm")
- (list "repl" "tshoot.scm")
(list "repl" "tref.scm")
+ (list "repl" "tshoot.scm")
(list "snd -noinit" "make-index.scm")
(list "repl" "teq.scm")
(list "repl" "s7test.scm")
(list "repl" "tvect.scm")
(list "repl" "tmisc.scm")
(list "repl" "lt.scm")
- (list "repl" "tform.scm")
(list "repl" "tlet.scm")
+ (list "repl" "tform.scm")
(list "repl" "tcopy.scm")
(list "repl" "tread.scm")
(list "repl" "tclo.scm")
@@ -92,10 +92,10 @@
(list "repl" "fbench.scm")
(list "repl" "titer.scm")
(list "repl" "trclo.scm")
- (list "repl" "tset.scm")
- (list "repl" "dup.scm")
(list "repl" "tmap.scm")
+ (list "repl" "tset.scm")
(list "repl" "tsort.scm")
+ (list "repl" "dup.scm")
(list "repl" "tmac.scm")
(list "repl" "tfft.scm")
(list "repl" "trec.scm")
diff --git a/ws.scm b/ws.scm
index 93b8644..88ece06 100644
--- a/ws.scm
+++ b/ws.scm
@@ -729,7 +729,7 @@ symbol: 'e4 for example. If 'pythagorean', the frequency calculation uses small
(not (char=? (name 1) #\n))
(name 1)))
(octave (if octave-char (- (char->integer octave-char) (char->integer #\0)) last-octave))
- (base-pitch (let ((base (modulo (- (+ (char->integer (name 0)) 5) (char->integer #\a)) 7)) ; c-based (diatonic) octaves
+ (base-pitch (let ((base (modulo (- (+ (char->integer (name 0)) 5) (char->integer #\a)) 7)) ; c-based (diatonic) octaves
(sign (case sign-char ((#f) 0) ((#\f) -1) (else 1))))
(+ sign (case base ((0)) ((1) 2) ((2) 4) ((3) 5) ((4) 7) ((5) 9) ((6) 11)))))
(et-pitch (+ base-pitch (* 12 octave))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-30 09:14:03 +0000