summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIOhannes m zmölnig <zmoelnig@umlautT.umlaeute.mur.at>2024-05-17 08:46:06 +0200
committerIOhannes m zmölnig <zmoelnig@umlautT.umlaeute.mur.at>2024-05-17 08:46:06 +0200
commita7d3b19eea1dc0ba7805092703759f1a5989d27a (patch)
tree39abff4eb1a4ad1c94edeaf38c662c9a7dd8a9f1
parent34a2764bcce5c65f67c1b0eb8b51791d934af93e (diff)
New upstream version 24.4
-rw-r--r--HISTORY.Snd1
-rw-r--r--NEWS9
-rw-r--r--case.scm2
-rw-r--r--clm2xen.c2
-rwxr-xr-xconfigure20
-rw-r--r--configure.ac4
-rw-r--r--lint.scm2
-rw-r--r--r7rs.scm11
-rw-r--r--s7.c1542
-rw-r--r--s7.h9
-rw-r--r--s7.html63
-rw-r--r--s7test.scm452
-rw-r--r--snd-test.scm5
-rw-r--r--snd.h6
-rw-r--r--tools/auto-tester.scm58
-rw-r--r--tools/dup.scm2
-rw-r--r--tools/fbench.scm2
-rw-r--r--tools/ffitest.c22
-rw-r--r--tools/sam.c51
-rw-r--r--tools/tari.scm40
-rw-r--r--tools/timp.scm2
-rw-r--r--tools/tio.scm245
-rw-r--r--tools/valcall.scm6
23 files changed, 1638 insertions, 918 deletions
diff --git a/HISTORY.Snd b/HISTORY.Snd
index 4e81bc5..b249e37 100644
--- a/HISTORY.Snd
+++ b/HISTORY.Snd
@@ -1,5 +1,6 @@
Snd change log
+ 17-May: Snd 24.4.
14-Apr: Snd 24.3.
12-Mar: Snd 24.2.
2-Feb: Snd 24.1.
diff --git a/NEWS b/NEWS
index 868ecff..5ae0762 100644
--- a/NEWS
+++ b/NEWS
@@ -1,9 +1,6 @@
-Snd 24.3:
+Snd 24.4:
-s7: format now always returns a string (where it used to return #f it
- now returns "")
-sam.c: bugfixes and improvements thanks to David Jaffe
+s7: added (settable) port-string
-checked: sbcl 2.4.3
+checked: sbcl 2.4.4
-Thanks!: Michael Edwards, Norman Gray, David Jaffe
diff --git a/case.scm b/case.scm
index 7ca9fe8..b715caa 100644
--- a/case.scm
+++ b/case.scm
@@ -24,6 +24,8 @@
;;; the labels and case*'s matching function can be used anywhere -- see below, "match?" etc
;;;
;;; (case* x ((3.14) 'pi)) returns 'pi if x is 3.14
+;;; (case* "asdf" (("asde") 0) (("asdf") 1) (else 2)) is 1
+;;; (case* "asdf" ((#<"asd*">) 0) (("asdf") 1) (else 2)) is 0
;;; (case* x ((#<symbol?>))) returns #t if x is a symbol
;;; (case* x (((+ 1 #<symbol?>)))) matches if x is any list of the form '(+ 1 x) or any other symbol in place of "x"
;;; (case* x (((#<symbol?> #<e1:...> (+ #<e2:...>))) (append #<e1> #<e2>))), passed '(a b c d (+ 1 2)), returns '(b c d 1 2)
diff --git a/clm2xen.c b/clm2xen.c
index 8ede328..ffb6d01 100644
--- a/clm2xen.c
+++ b/clm2xen.c
@@ -11598,7 +11598,7 @@ static mus_float_t mus_src_two(mus_any *p, mus_float_t x) {return(mus_src(p, x,
static mus_float_t mus_convolve_simple(mus_any *p) {return(mus_convolve(p, NULL));}
/* static mus_float_t mus_phase_vocoder_simple(mus_any *p) {return(mus_phase_vocoder(p, NULL));} */
-/* almost no error checking here; for example all the s7_c_object_value calls should check that their argument is a c-object */
+/* almost no error checking here; for example all the s7_c_object_value calls should check that their argument is a c-object of the correct type */
#define GEN_1(Type, Func) \
static bool is_ ## Type ## _b(s7_pointer p) \
diff --git a/configure b/configure
index 48433d9..069e8b4 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.71 for snd 24.3.
+# Generated by GNU Autoconf 2.71 for snd 24.4.
#
# Report bugs to <bil@ccrma.stanford.edu>.
#
@@ -611,8 +611,8 @@ MAKEFLAGS=
# Identity of this package.
PACKAGE_NAME='snd'
PACKAGE_TARNAME='ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-24.tar.gz'
-PACKAGE_VERSION='24.3'
-PACKAGE_STRING='snd 24.3'
+PACKAGE_VERSION='24.4'
+PACKAGE_STRING='snd 24.4'
PACKAGE_BUGREPORT='bil@ccrma.stanford.edu'
PACKAGE_URL=''
@@ -1346,7 +1346,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 24.3 to adapt to many kinds of systems.
+\`configure' configures snd 24.4 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1417,7 +1417,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of snd 24.3:";;
+ short | recursive ) echo "Configuration of snd 24.4:";;
esac
cat <<\_ACEOF
@@ -1537,7 +1537,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-snd configure 24.3
+snd configure 24.4
generated by GNU Autoconf 2.71
Copyright (C) 2021 Free Software Foundation, Inc.
@@ -2025,7 +2025,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 24.3, which was
+It was created by snd $as_me 24.4, which was
generated by GNU Autoconf 2.71. Invocation command line was
$ $0$ac_configure_args_raw
@@ -3967,7 +3967,7 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
-VERSION=24.3
+VERSION=24.4
#--------------------------------------------------------------------------------
# configuration options
@@ -7433,7 +7433,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 24.3, which was
+This file was extended by snd $as_me 24.4, which was
generated by GNU Autoconf 2.71. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -7497,7 +7497,7 @@ ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config='$ac_cs_config_escaped'
ac_cs_version="\\
-snd config.status 24.3
+snd config.status 24.4
configured by $0, generated by GNU Autoconf 2.71,
with options \\"\$ac_cs_config\\"
diff --git a/configure.ac b/configure.ac
index a9d5d2c..e84c76e 100644
--- a/configure.ac
+++ b/configure.ac
@@ -5,7 +5,7 @@
# gmp, mpfr, and mpc deliberately have none!
-AC_INIT(snd, 24.3, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-24.tar.gz)
+AC_INIT(snd, 24.4, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-24.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=24.3
+VERSION=24.4
#--------------------------------------------------------------------------------
# configuration options
diff --git a/lint.scm b/lint.scm
index 2dfd9e8..139a9ca 100644
--- a/lint.scm
+++ b/lint.scm
@@ -152,7 +152,7 @@
zero?
c-pointer-weak2 c-pointer-type bignum port-position byte-vector->string c-pointer-info c-pointer->list subvector-vector c-pointer-weak1
- funclet? bignum? weak-hash-table? goto? port-file byte? hash-code
+ funclet? bignum? weak-hash-table? goto? port-file port-string byte? hash-code
dilambda ; these 3 lines added 5-May-22, not getenv directory->list or file-mtime because bools are evaluated if constant args!
list-values apply-values unquote))
diff --git a/r7rs.scm b/r7rs.scm
index dd95765..f0186ac 100644
--- a/r7rs.scm
+++ b/r7rs.scm
@@ -77,7 +77,7 @@
(define char-foldcase char-downcase)
(define string-foldcase string-downcase)
;;; these and the string functions in s7 are not unicode-aware. To get true unicode
-;;; handling of the bytes, use the glib functions in libxg or use cload (see xgdata.scm).
+;;; handling of the bytes, use libutf8proc.scm, the glib functions in libxg or use cload (see xgdata.scm).
(define (digit-value c) (and (char-numeric? c) (- (char->integer c) (char->integer #\0))))
@@ -206,11 +206,20 @@
(define interaction-environment curlet)
;; for null-environment see stuff.scm
+
(define-macro (include . files)
`(begin
,@(map (lambda (file)
`(load ,file (outlet (curlet))))
files)))
+;; according to someone, this should insert the text from the included files directly into the loader input stream, perhaps:
+;; (let ((old-string (port-string (current-input-port))) ; do we need to start at port-position?
+;; (new-string (let ((f (open-input-file file)))
+;; (let ((str (port-string f))) ; since it's actually a string port?
+;; (close-input-port f)
+;; str))))
+;; (set! (port-string (current-input-file)) (string-append new-string old-string)))
+;; but this is alien to lisp, and even in C it's a horrible kludge -- why did the r7rs committee accept such crap?
(set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*))
;; I prefer (define-expansion (comment . stuff) (values))
diff --git a/s7.c b/s7.c
index 35c5587..29faae2 100644
--- a/s7.c
+++ b/s7.c
@@ -148,7 +148,7 @@
#endif
/* the stack grows as needed, each frame takes 4 entries, this is its initial size. (*s7* 'stack-top) divides size by 4 */
-#define STACK_RESIZE_TRIGGER (INITIAL_STACK_SIZE / 2)
+#define STACK_RESIZE_TRIGGER 256 /* was INITIAL_STACK_SIZE/2 which seems excessive */
#ifndef INITIAL_PROTECTED_OBJECTS_SIZE
#define INITIAL_PROTECTED_OBJECTS_SIZE 16
@@ -1318,7 +1318,7 @@ struct s7_scheme {
object_to_string_symbol, object_to_let_symbol, open_input_file_symbol, open_input_function_symbol, open_input_string_symbol,
open_output_file_symbol, open_output_function_symbol, open_output_string_symbol, openlet_symbol, outlet_symbol, owlet_symbol,
pair_filename_symbol, pair_line_number_symbol, peek_char_symbol, pi_symbol, port_filename_symbol, port_line_number_symbol,
- port_file_symbol, port_position_symbol, procedure_source_symbol, provide_symbol,
+ port_file_symbol, port_position_symbol, port_string_symbol, procedure_source_symbol, provide_symbol,
qq_append_symbol, quotient_symbol,
random_state_symbol, random_state_to_list_symbol, random_symbol, rationalize_symbol, read_byte_symbol,
read_char_symbol, read_line_symbol, read_string_symbol, read_symbol, real_part_symbol, remainder_symbol,
@@ -1431,7 +1431,7 @@ struct s7_scheme {
#if S7_DEBUGGING
int32_t *tc_rec_calls;
bool printing_gc_info;
- s7_int blocks_allocated;
+ s7_int blocks_allocated, format_ports_allocated;
#endif
};
@@ -1712,6 +1712,7 @@ static block_t *callocate(s7_scheme *sc, size_t bytes)
static block_t *reallocate(s7_scheme *sc, block_t *op, size_t bytes)
{
block_t *np = inline_mallocate(sc, bytes);
+ if ((S7_DEBUGGING) && (bytes < (size_t)block_size(op))) fprintf(stderr, "reallocate to smaller block?\n");
if (block_data(op)) /* presumably block_data(np) is not null */
memcpy((uint8_t *)(block_data(np)), (uint8_t *)(block_data(op)), block_size(op));
liberate(sc, op);
@@ -2980,7 +2981,6 @@ static void init_types(void)
#define fn_proc(f) ((s7_function)(opt2(f, OPT2_FN)))
#define fx_proc(f) ((s7_function)(opt2(f, OPT2_FX)))
#define fn_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.o2.opt2))
-#define fx_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.o2.opt2)) /* unused */
#define set_fx(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FX); if (X) set_has_fx(f); else clear_has_fx(f);} while (0)
#define set_fx_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FX); set_has_fx(f);} while (0)
@@ -3664,7 +3664,7 @@ const char *display(s7_pointer obj)
#else
#define display(Obj) string_value(s7_object_to_string(cur_sc, Obj, false))
#endif
-#define display_80(Obj) string_value(object_to_truncated_string(cur_sc, Obj, 80))
+#define display_truncated(Obj) string_value(object_to_string_truncated(cur_sc, Obj))
#if S7_DEBUGGING
static void set_type_1(s7_pointer p, uint64_t f, const char *func, int32_t line)
@@ -3894,6 +3894,7 @@ static void try_to_call_gc(s7_scheme *sc);
#define new_cell(Sc, Obj, Type) \
do { \
+ if (Sc->gc_in_progress) fprintf(stderr, "%s[%d]: new_cell during GC\n", __func__, __LINE__); \
if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \
Obj = (*(--(Sc->free_heap_top))); \
Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \
@@ -3902,6 +3903,7 @@ static void try_to_call_gc(s7_scheme *sc);
#define new_cell_no_check(Sc, Obj, Type) \
do { \
+ if (Sc->gc_in_progress) fprintf(stderr, "%s[%d]: new_cell_no_check during GC\n", __func__, __LINE__); \
Obj = (*(--(Sc->free_heap_top))); \
if (Sc->free_heap_top < Sc->free_heap) {fprintf(stderr, "%s[%d]: free heap exhausted\n", __func__, __LINE__); abort();}\
Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \
@@ -4621,7 +4623,7 @@ static const char *s7_starlet_names[SL_NUM_FIELDS] =
"gc-temps-size", "gc-resize-heap-fraction", "gc-resize-heap-by-4-fraction", "openlets", "expansions?",
"number-separator"};
-static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int len); /* display_80 etc */
+static s7_pointer object_to_string_truncated(s7_scheme *sc, s7_pointer p);
static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article);
static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b);
static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym);
@@ -4709,7 +4711,7 @@ void s7_show_history(s7_scheme *sc)
s7_pointer p = cdr(sc->cur_code);
fprintf(stderr, "history:\n");
for (int32_t i = 0; i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */
- safe_print(fprintf(stderr, "%d: %s\n", i, display_80(car(p))));
+ safe_print(fprintf(stderr, "%d: %s\n", i, display_truncated(car(p))));
fprintf(stderr, "\n");
}
#else
@@ -5068,10 +5070,7 @@ static const char *checked_type_name(s7_scheme *sc, int32_t typ)
static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line)
{
if (is_global(symbol))
- fprintf(stderr, "%s[%d]: %s%s%s in %s\n",
- func, line,
- bold_text, display(symbol), unbold_text,
- display_80(sc->cur_code));
+ fprintf(stderr, "%s[%d]: %s%s%s in %s\n", func, line, bold_text, display(symbol), unbold_text, display_truncated(sc->cur_code));
full_type(symbol) = (full_type(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));
}
#endif
@@ -5630,13 +5629,13 @@ static void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, uint64_t role,
(x == NULL) &&
(f_call_func_mismatch(func)))
fprintf(stderr, "%s[%d]: set fx_proc for %s to null (%s%s%s)\n", func, line,
- string_value(object_to_truncated_string(sc, p, 80)),
+ string_value(object_to_string_truncated(sc, p)),
((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? bold_text : "",
op_names[optimize_op(car(p))],
((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? unbold_text : "");
if ((role != OPT2_FX) && (role != OPT2_DIRECT) && (has_fx(p))) /* sometimes opt2_direct just specializes fx */
{
- fprintf(stderr, "%s[%d]: overwrite has_fx: %s %s\n", func, line, opt2_role_name(role), display_80(p));
+ fprintf(stderr, "%s[%d]: overwrite has_fx: %s %s\n", func, line, opt2_role_name(role), display_truncated(p));
if (sc->stop_at_error) abort();
}
p->object.cons.o2.opt2 = x;
@@ -6244,11 +6243,11 @@ static s7_pointer missing_method_class_name(s7_scheme *sc, s7_pointer obj)
static noreturn void missing_method_error_nr(s7_scheme *sc, s7_pointer method, s7_pointer obj)
{
error_nr(sc, sc->missing_method_symbol,
- set_elist_4(sc, wrap_string(sc, "missing ~S method in ~A ~A", 26), method,
+ set_elist_4(sc, wrap_string(sc, "~S method is not defined in ~A ~A", 33), method,
(is_c_object(obj)) ? c_object_scheme_name(sc, obj) :
(((is_let(obj)) && (is_openlet(obj))) ? missing_method_class_name(sc, obj) :
s7_make_string_wrapper(sc, type_name(sc, obj, NO_ARTICLE))),
- obj));
+ object_to_string_truncated(sc, obj)));
}
static noreturn void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);}
@@ -6833,7 +6832,7 @@ static void sweep(s7_scheme *sc)
{ \
Code; \
} \
- else gp->list[j++] = s1; \
+ else if (in_heap(s1)) gp->list[j++] = s1; \
} \
gp->loc = j; \
} \
@@ -7585,17 +7584,11 @@ static int64_t gc(s7_scheme *sc)
gc_mark(car(sc->elist_6));
gc_mark(car(sc->elist_7));
-#if 0
- if (sc->current_safe_list > 0) /* safe_lists are semipermanent, so we have to mark contents by hand */
- for (s7_pointer p = sc->safe_lists[sc->current_safe_list]; is_pair(p); p = cdr(p))
- gc_mark(car(p));
-#else
for (i = 1; i < NUM_SAFE_LISTS; i++) /* see tgen.scm -- we can't just check sc->current_safe_list */
if ((is_pair(sc->safe_lists[i])) &&
(list_is_in_use(sc->safe_lists[i]))) /* safe_lists are semipermanent, so we have to mark contents by hand */
for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p))
gc_mark(car(p));
-#endif
for (i = 0; i < sc->setters_loc; i++)
gc_mark(cdr(sc->setters[i]));
@@ -7867,7 +7860,8 @@ static s7_pointer g_gc(s7_scheme *sc, s7_pointer args)
Evaluation produces a surprising amount of garbage, so don't leave the GC off for very long!"
#define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol)
- /* g_gc can't be called in a situation where these lists matter (I think...) */
+ /* g_gc can't be called in a situation where these lists matter -- oops, gc called in scheme can be using these! and maybe elist... */
+#if 0
set_mlist_1(sc, sc->unused);
set_mlist_2(sc, sc->unused, sc->unused);
set_plist_1(sc, sc->unused);
@@ -7876,6 +7870,8 @@ Evaluation produces a surprising amount of garbage, so don't leave the GC off fo
set_car(sc->plist_4, sc->unused);
set_qlist_2(sc, sc->unused, sc->unused);
set_car(sc->qlist_3, sc->unused);
+ set_ulist_1(sc, sc->unused, sc->unused);
+#endif
set_elist_1(sc, sc->unused);
set_elist_2(sc, sc->unused, sc->unused);
set_elist_3(sc, sc->unused, sc->unused, sc->unused);
@@ -7883,7 +7879,6 @@ Evaluation produces a surprising amount of garbage, so don't leave the GC off fo
set_car(sc->elist_5, sc->unused);
set_car(sc->elist_6, sc->unused);
set_car(sc->elist_7, sc->unused); /* clist and dlist are weak references */
- set_ulist_1(sc, sc->unused, sc->unused);
if (is_not_null(args))
{
if (!is_boolean(car(args)))
@@ -8171,6 +8166,7 @@ void s7_show_stack(s7_scheme *sc);
#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__)
static void pop_stack_1(s7_scheme *sc, const char *func, int32_t line)
{
+ /* if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: pop_stack %s\n", func, line, op_names[(opcode_t)stack_top_op(sc)]); */
sc->stack_end -= 4;
if (sc->stack_end < sc->stack_start)
{
@@ -8194,6 +8190,7 @@ static void pop_stack_1(s7_scheme *sc, const char *func, int32_t line)
#define pop_stack_no_op(Sc) pop_stack_no_op_1(Sc, __func__, __LINE__)
static void pop_stack_no_op_1(s7_scheme *sc, const char *func, int32_t line)
{
+ /* if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: pop_stack_no_op %s\n", func, line, op_names[(opcode_t)stack_top_op(sc)]); */
sc->stack_end -= 4;
if (sc->stack_end < sc->stack_start)
{
@@ -8209,6 +8206,7 @@ static void pop_stack_no_op_1(s7_scheme *sc, const char *func, int32_t line)
static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer code, s7_pointer *end, const char *func, int32_t line)
{
+ /* if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: %u push_stack %s\n", func, line, (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), op_names[op]); */
if ((SHOW_EVAL_OPS) && (op == OP_EVAL_DONE)) fprintf(stderr, " %s[%d]: push eval_done\n", func, line);
if (sc->stack_end >= sc->stack_start + sc->stack_size)
{
@@ -8221,8 +8219,10 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer
if (sc->stop_at_error) abort();
}
if (sc->stack_end >= sc->stack_resize_trigger)
- fprintf(stderr, "%s%s[%d] from %s: stack resize skipped, stack at %u of %u%s\n",
- bold_text, func, line, op_names[op], (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start) / 4), sc->stack_size / 4, unbold_text);
+ fprintf(stderr, "%s%s[%d] from %s: stack resize skipped, stack at %u of %u %s%s\n",
+ bold_text, func, line, op_names[op],
+ (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)),
+ sc->stack_size, display_truncated(code), unbold_text);
if (sc->stack_end != end)
fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func, line);
if (op >= NUM_OPS)
@@ -8252,8 +8252,8 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer
#else
-#define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0)
-#define pop_stack_no_op(Sc) {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0)
+#define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0)
+#define pop_stack_no_op(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0)
#define push_stack(Sc, Op, Args, Code) \
do { \
@@ -8443,32 +8443,62 @@ s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x)
return(x);
}
-#define stack_protected1(Sc) stack_top_args(Sc) /* it's easier to remember these aliases in this context (GC protection so code/args business is irrelevant) */
-#define stack_protected2(Sc) stack_top_code(Sc)
-#define stack_protected3(Sc) stack_top_let(Sc)
-
#if S7_DEBUGGING
- #define set_stack_protected1(Sc, Val) do {if (stack_top_op(Sc) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected1(Sc) = Val;} while (0)
- #define set_stack_protected2(Sc, Val) do {if (stack_top_op(Sc) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected2(Sc) = Val;} while (0)
- #define set_stack_protected3(Sc, Val) do {if (stack_top_op(Sc) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected3(Sc) = Val;} while (0)
+ static s7_pointer stack_protected1_1(s7_scheme *sc, opcode_t op, const char *func, int line)
+ {
+ if (stack_top_op(sc) != op) fprintf(stderr, "%s[%d]: stack_protected1 %s\n", func, line, op_names[stack_top_op(sc)]);
+ return(stack_top_args(sc));
+ }
+
+ static s7_pointer stack_protected2_1(s7_scheme *sc, opcode_t op, const char *func, int line)
+ {
+ if (stack_top_op(sc) != op) fprintf(stderr, "%s[%d]: stack_protected2 %s\n", func, line, op_names[stack_top_op(sc)]);
+ return(stack_top_code(sc));
+ }
+
+ static s7_pointer stack_protected3_1(s7_scheme *sc, opcode_t op, const char *func, int line)
+ {
+ if (stack_top_op(sc) != op) fprintf(stderr, "%s[%d]: stack_protected3 %s\n", func, line, op_names[stack_top_op(sc)]);
+ return(stack_top_let(sc));
+ }
+
+ #define stack_protected1(Sc, Op) stack_protected1_1(Sc, Op, __func__, __LINE__)
+ #define stack_protected2(Sc, Op) stack_protected2_1(Sc, Op, __func__, __LINE__)
+ #define stack_protected3(Sc, Op) stack_protected3_1(Sc, Op, __func__, __LINE__)
+
+ #define set_stack_protected1(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected1 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_args(Sc) = Val;} while (0)
+ #define set_stack_protected2(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected2 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_code(Sc) = Val;} while (0)
+ #define set_stack_protected3(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected3 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_let(Sc) = Val;} while (0)
- #define set_stack_protected1_with(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected1(Sc) = Val;} while (0)
- #define set_stack_protected2_with(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected2(Sc) = Val;} while (0)
- #define set_stack_protected3_with(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected3(Sc) = Val;} while (0)
#else
- #define set_stack_protected1(Sc, Val) stack_protected1(Sc) = Val
- #define set_stack_protected2(Sc, Val) stack_protected2(Sc) = Val
- #define set_stack_protected3(Sc, Val) stack_protected3(Sc) = Val
- #define set_stack_protected1_with(Sc, Val, Op) stack_protected1(Sc) = Val
- #define set_stack_protected2_with(Sc, Val, Op) stack_protected2(Sc) = Val
- #define set_stack_protected3_with(Sc, Val, Op) stack_protected3(Sc) = Val
+ #define stack_protected1(Sc, Op) stack_top_args(Sc)
+ #define stack_protected2(Sc, Op) stack_top_code(Sc)
+ #define stack_protected3(Sc, Op) stack_top_let(Sc)
+
+ #define set_stack_protected1(Sc, Val, Op) stack_top_args(Sc) = Val
+ #define set_stack_protected2(Sc, Val, Op) stack_top_code(Sc) = Val
+ #define set_stack_protected3(Sc, Val, Op) stack_top_let(Sc) = Val
#endif
+#define gc_protected1(Sc) stack_protected1(Sc, OP_GC_PROTECT)
+#define gc_protected2(Sc) stack_protected2(Sc, OP_GC_PROTECT)
+#define gc_protected3(Sc) stack_protected3(Sc, OP_GC_PROTECT)
+
+#define set_gc_protected1(Sc, Val) set_stack_protected1(Sc, Val, OP_GC_PROTECT)
+#define set_gc_protected2(Sc, Val) set_stack_protected2(Sc, Val, OP_GC_PROTECT)
+#define set_gc_protected3(Sc, Val) set_stack_protected3(Sc, Val, OP_GC_PROTECT)
+
+#define map_iterator(Sc) stack_protected2(Sc, OP_MAP_UNWIND)
+#define set_map_iterator(Sc, Val) set_stack_protected2(Sc, Val, OP_MAP_UNWIND)
+#define map_unwind_list(Sc) stack_protected3(Sc, OP_MAP_UNWIND)
+#define set_map_unwind_list(Sc, Val) set_stack_protected3(Sc, Val, OP_MAP_UNWIND)
+
#define gc_protect_via_stack(Sc, Obj) push_stack_no_code(Sc, OP_GC_PROTECT, Obj)
#define gc_protect_via_stack_no_let(Sc, Obj) push_stack_no_let_no_code(Sc, OP_GC_PROTECT, Obj)
-#define gc_protect_2_via_stack(Sc, X, Y) do {gc_protect_via_stack(Sc, X); set_stack_protected2(Sc, Y);} while (0) /* often X and Y are fx_calls, so push X, then set Y */
-#define gc_protect_2_via_stack_no_let(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); set_stack_protected2(Sc, Y);} while (0)
+#define gc_protect_2_via_stack(Sc, X, Y) do {gc_protect_via_stack(Sc, X); set_gc_protected2(Sc, Y);} while (0)
+ /* often X and Y are fx_calls, so push X, then set Y */
+#define gc_protect_2_via_stack_no_let(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); set_gc_protected2(Sc, Y);} while (0)
/* -------------------------------- symbols -------------------------------- */
@@ -8830,6 +8860,8 @@ s7_pointer s7_name_to_value(s7_scheme *sc, const char *name) {return(s7_symbol_v
/* -------------------------------- symbol->string -------------------------------- */
+static s7_pointer nil_string; /* permanent "" */
+
static Inline s7_pointer inline_make_string_with_length(s7_scheme *sc, const char *str, s7_int len)
{
s7_pointer x;
@@ -9076,7 +9108,7 @@ static inline void add_slot_unchecked(s7_scheme *sc, s7_pointer let, s7_pointer
symbol_set_local_slot(symbol, id, slot);
}
-static void add_slot_unchecked_no_local(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+static s7_pointer add_slot_unchecked_no_local_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
s7_pointer slot;
new_cell_no_check(sc, slot, T_SLOT);
@@ -9084,6 +9116,7 @@ static void add_slot_unchecked_no_local(s7_scheme *sc, s7_pointer let, s7_pointe
slot_set_next(slot, let_slots(let));
let_set_slots(let, slot);
set_local(symbol);
+ return(slot);
}
#define add_slot(Sc, Let, Symbol, Value) add_slot_unchecked(Sc, Let, Symbol, Value, let_id(Let))
@@ -9112,6 +9145,16 @@ static inline s7_pointer add_slot_checked_with_id(s7_scheme *sc, s7_pointer let,
return(slot);
}
+static inline s7_pointer add_slot_no_local(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) /* no symbol_set_local_slot, no set_local */
+{
+ s7_pointer slot;
+ new_cell(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ slot_set_next(slot, let_slots(let));
+ let_set_slots(let, slot);
+ return(slot);
+}
+
static s7_pointer add_slot_unchecked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
{
s7_pointer slot;
@@ -9181,30 +9224,6 @@ static inline void make_let_with_five_slots(s7_scheme *sc, s7_pointer func, s7_p
inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(cargs), val5);
}
-static s7_pointer reuse_as_let(s7_scheme *sc, s7_pointer let, s7_pointer next_let)
-{
-#if S7_DEBUGGING
- let->debugger_bits = 0;
- if (!in_heap(let)) {fprintf(stderr, "reusing an unheaped %s as a let?\n", s7_type_names[type(let)]); abort();}
-#endif
- set_full_type(T_Pair(let), T_LET | T_SAFE_PROCEDURE); /* we're reusing let here as a let -- it was a pair */
- let_set_slots(let, slot_end);
- let_set_outlet(let, next_let);
- let_set_id(let, ++sc->let_number);
- return(let);
-}
-
-static s7_pointer reuse_as_slot(s7_pointer slot, s7_pointer symbol, s7_pointer value)
-{
-#if S7_DEBUGGING
- slot->debugger_bits = 0;
- if (!in_heap(slot)) {fprintf(stderr, "reusing an unheaped %s as a slot?\n", s7_type_names[type(slot)]); abort();}
-#endif
- set_full_type(T_Pair(slot), T_SLOT);
- slot_set_symbol_and_value(slot, symbol, value);
- return(slot);
-}
-
#define update_slot(Slot, Val, Id) do {s7_pointer sym; slot_set_value(Slot, Val); sym = slot_symbol(Slot); symbol_set_local_slot_unincremented(sym, Id, Slot);} while (0)
static s7_pointer update_let_with_slot(s7_scheme *sc, s7_pointer let, s7_pointer val)
@@ -9420,7 +9439,7 @@ s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_poi
if ((!is_gensym(symbol)) &&
(initial_slot(symbol) == sc->undefined) &&
(!in_heap(value)) && /* else initial_slot value can be GC'd if symbol set! (initial != global, initial unprotected) */
- ((!sc->string_signature) || /* from init_signatures -- TODO: maybe need a boolean for this */
+ ((!sc->string_signature) || /* from init_signatures -- maybe need a boolean for this */
(is_c_function(value)))) /* || (is_syntax(value)) -- we need 'else as a special case? */
/* the string_signature business means only the initial rootlet c_functions take part in unlet. It would be neat if any
* cload library's c_functions could be there as well, but then (unlet) needs to know which envs are in the chain.
@@ -10135,6 +10154,8 @@ static s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args)
else
if (is_c_pointer(let))
let = c_pointer_info(let);
+ if (let == sc->rootlet) /* don't laboriously expand this! */
+ return(cons(sc, let, sc->nil));
if (!is_let(let))
sole_arg_wrong_type_error_nr(sc, sc->let_to_list_symbol, let, a_let_string);
}
@@ -10182,15 +10203,12 @@ static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer
return(call_let_ref_fallback(sc, let, symbol));
wrong_type_error_nr(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string);
}
-#if 0
- /* let-ref is currently immutable */
- if (!is_global(sc->let_ref_symbol)) check_method(sc, let, sc->let_ref_symbol, set_plist_2(sc, let, symbol));
/* a let-ref method is almost impossible to write without creating an infinite loop:
* any reference to the let will probably call let-ref somewhere, calling us again, and looping.
* This is not a problem in c-objects and funclets because c-object-ref and funclet-ref don't exist.
* After much wasted debugging, I decided to make let-ref and let-set! immutable.
*/
-#endif
+
if (is_keyword(symbol))
symbol = keyword_symbol(symbol);
@@ -10222,6 +10240,9 @@ static s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args)
{
#define H_let_ref "(let-ref let sym) returns the value of the symbol sym in the let"
#define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol)
+ if (!is_pair(cdr(args)))
+ error_nr(sc, sc->syntax_error_symbol,
+ set_elist_2(sc, wrap_string(sc, "let-ref: symbol missing: ~S", 27), set_ulist_1(sc, sc->let_ref_symbol, args)));
return(let_ref(sc, car(args), cadr(args)));
}
@@ -10970,7 +10991,7 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named)
{
s7_pointer mac, body, mac_name = NULL;
uint64_t typ;
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_80(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(sc->code));
switch (op)
{
case OP_DEFINE_MACRO: case OP_MACRO: typ = T_MACRO; break;
@@ -11826,7 +11847,7 @@ static s7_pointer copy_stack(s7_scheme *sc, s7_pointer new_v, s7_pointer old_v,
}
/* lst can be dotted or circular here. The circular list only happens in a case like:
* (dynamic-wind (lambda () (eq? (let ((lst (cons 1 2))) (set-cdr! lst lst) lst) (call/cc (lambda (k) k)))) (lambda () #f) (lambda () #f))
- * proper_list_reverse_in_place(sc->args) is one reason we need to copy, another reuse_as_let
+ * proper_list_reverse_in_place(sc->args) is one reason we need to copy
*/
else
if (is_counter(p)) /* these can only occur in this context (not in a list etc) */
@@ -11920,10 +11941,11 @@ static bool op_with_baffle_unchecked(s7_scheme *sc)
/* -------------------------------- call/cc -------------------------------- */
static void make_room_for_cc_stack(s7_scheme *sc)
{
- if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8)) /* we probably never need this much space */
- {
+ if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 32)) /* we probably never need this much space (8 becomes enormous, 512 seems ok) */
+ { /* but this doesn't seem to make much difference in timings */
+ /* fprintf(stderr, "%" ld64 " < %" ld64 "\n", (int64_t)(sc->free_heap_top - sc->free_heap), (int64_t)(sc->heap_size / 32)); */
call_gc(sc);
- if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8))
+ if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 32))
resize_heap(sc);
}
}
@@ -16576,6 +16598,8 @@ static s7_pointer g_angle(s7_scheme *sc, s7_pointer args)
}
}
+static s7_double angle_d_d(s7_double x) {return((is_NaN(x)) ? x : ((x < 0.0) ? M_PI : 0.0));}
+
/* -------------------------------- complex -------------------------------- */
@@ -17568,6 +17592,10 @@ static s7_pointer g_atan(s7_scheme *sc, s7_pointer args)
}}
y = cadr(args);
+ /* this is one place where s7 notices -0.0 != 0.0 -- this is apparently built into atan2, so I guess I'll leave it, but:
+ * (atan 0.0 0.0): 0.0, (atan 0.0 -0.0): pi, (atan 0 -0.0): pi, (atan 0 -0) 0.0, (atan 0 -0.0): pi.
+ * so you can sneak up on 0.0 from the left, but you can't fool 0??
+ */
switch (type(x))
{
case T_INTEGER: case T_RATIO: case T_REAL:
@@ -17610,6 +17638,7 @@ static s7_pointer g_atan(s7_scheme *sc, s7_pointer args)
#endif
}
+static s7_double atan_d_d(s7_double x) {return(atan(x));}
static s7_double atan_d_dd(s7_double x, s7_double y) {return(atan2(x, y));}
@@ -26004,7 +26033,7 @@ static s7_pointer integer_to_char_p_p(s7_scheme *sc, s7_pointer x)
return(method_or_bust_p(sc, x, sc->integer_to_char_symbol, sc->type_names[T_INTEGER]));
ind = s7_integer_clamped_if_gmp(sc, x);
if ((ind < 0) || (ind >= NUM_CHARS))
- sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, x, wrap_string(sc, "it doen't fit in an unsigned byte", 33));
+ sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, x, wrap_string(sc, "it doesn't fit in an unsigned byte", 34));
return(chars[(uint8_t)ind]);
}
@@ -26019,7 +26048,7 @@ static s7_pointer integer_to_char_p_i(s7_scheme *sc, s7_int ind)
{
if ((ind < 0) || (ind >= NUM_CHARS))
sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, wrap_integer(sc, ind),
- wrap_string(sc, "it doen't fit in an unsigned byte", 33)); /* int2 s7_out... uses 1 */
+ wrap_string(sc, "it doesn't fit in an unsigned byte", 34)); /* int2 s7_out... uses 1 */
return(chars[(uint8_t)ind]);
}
@@ -26726,8 +26755,6 @@ static s7_pointer g_is_string(s7_scheme *sc, s7_pointer args)
}
-static s7_pointer nil_string; /* permanent "" */
-
s7_int s7_string_length(s7_pointer str) {return(string_length(str));}
@@ -26768,7 +26795,11 @@ static Inline s7_pointer inline_make_empty_string(s7_scheme *sc, s7_int len, cha
static s7_pointer make_empty_string(s7_scheme *sc, s7_int len, char fill) {return(inline_make_empty_string(sc, len, fill));}
-s7_pointer s7_make_string(s7_scheme *sc, const char *str) {return((str) ? make_string_with_length(sc, str, safe_strlen(str)) : nil_string);}
+s7_pointer s7_make_string(s7_scheme *sc, const char *str)
+{
+ s7_int len = safe_strlen(str);
+ return((len > 0) ? make_string_with_length(sc, str, len) : nil_string);
+}
static char *make_semipermanent_c_string(s7_scheme *sc, const char *str) /* strcpy but avoid malloc */
{
@@ -26818,7 +26849,7 @@ s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str) /* keep s7_s
static void init_strings(void)
{
nil_string = make_permanent_string("", 0);
- nil_string->tf.u64_type = T_STRING | T_UNHEAP; /* turn off T_IMMUTABLE?? */
+ nil_string->tf.u64_type = T_STRING | T_UNHEAP; /* turn off T_IMMUTABLE? -- (copy str (make-string 0))! */
set_optimize_op(nil_string, OP_CONSTANT);
car_a_list_string = make_permanent_string("a pair whose car is also a pair", 31);
@@ -26982,7 +27013,7 @@ static s7_pointer g_string_downcase(s7_scheme *sc, s7_pointer args)
if (!is_string(p))
return(method_or_bust_p(sc, p, sc->string_downcase_symbol, sc->type_names[T_STRING]));
len = string_length(p);
- newstr = make_empty_string(sc, len, 0);
+ newstr = make_empty_string(sc, len, '\0');
ostr = (const uint8_t *)string_value(p);
nstr = (uint8_t *)string_value(newstr);
@@ -27011,7 +27042,7 @@ static s7_pointer g_string_upcase(s7_scheme *sc, s7_pointer args)
if (!is_string(p))
return(method_or_bust_p(sc, p, sc->string_upcase_symbol, sc->type_names[T_STRING]));
len = string_length(p);
- newstr = make_empty_string(sc, len, 0);
+ newstr = make_empty_string(sc, len, '\0');
ostr = (const uint8_t *)string_value(p);
nstr = (uint8_t *)string_value(newstr);
@@ -27268,7 +27299,7 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer c
unstack_gc_protect(sc);
return(s7_apply_function(sc, func, x)); /* not args (string-append "" "" ...) */
}
- newstr = make_empty_string(sc, len, 0);
+ newstr = make_empty_string(sc, len, '\0');
string_append_2(sc, newstr, args, x, caller);
unstack_gc_protect(sc);
return(s7_apply_function(sc, func, set_ulist_1(sc, newstr, x)));
@@ -27299,7 +27330,7 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer c
set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70),
caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length)));
}
- newstr = inline_make_empty_string(sc, len, 0);
+ newstr = inline_make_empty_string(sc, len, '\0');
if (just_strings)
{
x = args;
@@ -27331,7 +27362,7 @@ static inline s7_pointer string_append_1(s7_scheme *sc, s7_pointer s1, s7_pointe
error_nr(sc, sc->out_of_range_symbol,
set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70),
sc->string_append_symbol, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length)));
- newstr = make_empty_string(sc, len, 0); /* len+1 0-terminated */
+ newstr = make_empty_string(sc, len, '\0'); /* len+1 0-terminated */
memcpy(string_value(newstr), string_value(s1), pos);
memcpy((char *)(string_value(newstr) + pos), string_value(s2), string_length(s2));
return(newstr);
@@ -27483,8 +27514,10 @@ static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args)
if (!is_string(source))
return(method_or_bust(sc, source, sc->string_copy_symbol, args, sc->type_names[T_STRING], 1));
if (is_null(cdr(args)))
- return(make_string_with_length(sc, string_value(source), string_length(source)));
-
+ {
+ if (string_length(source) == 0) return(nil_string);
+ return(make_string_with_length(sc, string_value(source), string_length(source)));
+ }
dest = cadr(args);
if (!is_string(dest))
wrong_type_error_nr(sc, sc->string_copy_symbol, 2, dest, sc->type_names[T_STRING]);
@@ -28018,7 +28051,7 @@ static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
s7_pointer y;
if (len == 0)
return(s7_apply_function(sc, func, args));
- newstr = make_empty_string(sc, len, 0);
+ newstr = make_empty_string(sc, len, '\0');
str = string_value(newstr);
for (i = 0, y = args; y != x; i++, y = cdr(y))
str[i] = character(car(y));
@@ -28030,7 +28063,7 @@ static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
error_nr(sc, sc->out_of_range_symbol,
set_elist_4(sc, wrap_string(sc, "~S result string is too large (> ~D ~D) (*s7* 'max-string-length)", 65),
sym, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length)));
- newstr = inline_make_empty_string(sc, len, 0);
+ newstr = inline_make_empty_string(sc, len, '\0');
str = string_value(newstr);
for (i = 0, x = args; is_not_null(x); i++, x = cdr(x))
str[i] = character(car(x));
@@ -28050,7 +28083,7 @@ static s7_pointer g_string_c1(s7_scheme *sc, s7_pointer args)
/* no multiple values here because no pairs below */
if (!is_character(c))
return(method_or_bust(sc, c, sc->string_symbol, args, sc->type_names[T_CHARACTER], 1));
- str = inline_make_empty_string(sc, 1, 0); /* can't put character(c) here because null is handled specially */
+ str = inline_make_empty_string(sc, 1, '\0'); /* can't put character(c) here because null is handled specially */
string_value(str)[0] = character(c);
return(str);
}
@@ -28064,7 +28097,7 @@ static s7_pointer string_p_p(s7_scheme *sc, s7_pointer p)
{
s7_pointer str;
if (!is_character(p)) return(g_string_1(sc, set_plist_1(sc, p), sc->string_symbol));
- str = inline_make_empty_string(sc, 1, 0);
+ str = inline_make_empty_string(sc, 1, '\0');
string_value(str)[0] = character(p);
return(str);
}
@@ -28176,6 +28209,90 @@ static bool is_port_closed_b_7p(s7_scheme *sc, s7_pointer x)
}
+/* -------------------------------- port-string -------------------------------- */
+static s7_pointer g_port_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_port_string "(port-string port) returns the port data as a string"
+ #define Q_port_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol))
+
+ s7_pointer port = car(args);
+ if ((!is_input_port(port)) && (!is_output_port(port)))
+ return(method_or_bust_p(sc, port, sc->port_string_symbol, wrap_string(sc, "a port", 6)));
+ if (!is_string_port(port))
+ wrong_type_error_nr(sc, wrap_string(sc, "port-string", 11), 1, port, wrap_string(sc, "a string port", 13));
+ if ((port_is_closed(port)) || (is_function_port(port)))
+ return(nil_string);
+ if (is_output_port(port))
+ return(s7_output_string(sc, port)); /* both here and below we copy the data, so the returned value can be mutated */
+ return(make_string_with_length(sc, (const char *)port_data(port), port_data_size(port))); /* max_string_length? */
+}
+
+static void resize_port_data_for_port_string(s7_scheme *sc, s7_pointer pt, s7_int new_size)
+{
+ s7_int loc = port_data_size(pt);
+ block_t *nb;
+
+ if (new_size < loc) return;
+ if (new_size > sc->max_port_data_size)
+ error_nr(sc, make_symbol(sc, "port-too-big", 12),
+ set_elist_1(sc, wrap_string(sc, "port data size has grown past (*s7* 'max-port-data-size)", 56)));
+ liberate(sc, port_data_block(pt)); /* reallocate has an irrelevant memcpy */
+ nb = inline_mallocate(sc, new_size);
+ port_data_block(pt) = nb;
+ port_data(pt) = (uint8_t *)(block_data(nb));
+ port_data_size(pt) = new_size;
+}
+
+
+static s7_pointer set_input_port_string(s7_scheme *sc, s7_pointer port, s7_pointer str)
+{ /*assume port is an input string port */
+ s7_int str_len;
+ if ((S7_DEBUGGING) && ((!is_input_port(port)) || (!is_string_port(port))))
+ fprintf(stderr, "%s[%d]: %s should be an input string port\n", __func__, __LINE__, display(port));
+ if (port_is_closed(port))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "an open port", 12));
+ str_len = string_length(str);
+ port_data(port) = (uint8_t *)string_value(str);
+ port_data(port)[str_len] = '\0';
+ port_data_size(port) = str_len;
+ port_position(port) = 0;
+ port_set_string_or_function(port, str);
+ return(str);
+}
+
+static s7_pointer set_output_port_string(s7_scheme *sc, s7_pointer port, s7_pointer str)
+{ /*assume port is an output string port */
+ s7_int str_len;
+ if ((S7_DEBUGGING) && ((!is_output_port(port)) || (!is_string_port(port))))
+ fprintf(stderr, "%s[%d]: %s should be an output string port\n", __func__, __LINE__, display(port));
+ if (port_is_closed(port))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "an open port", 12));
+ str_len = string_length(str);
+ if (port_data_size(port) <= str_len) /* sc->initial_string_port_length is 128 */
+ resize_port_data_for_port_string(sc, port, str_len * 2);
+ memcpy((void *)port_data(port), (const void *)string_value(str), str_len);
+ port_position(port) = str_len;
+ port_data(port)[str_len] = '\0';
+ return(str);
+}
+
+static s7_pointer g_set_port_string(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer port = car(args), str;
+ if ((!is_input_port(port)) && (!is_output_port(port)))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "an input or output port", 23));
+ if (!is_string_port(port))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "a string port", 13));
+ str = cadr(args);
+ if (!is_string(str))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 2, str, sc->type_names[T_STRING]);
+ if (is_input_port(port))
+ set_input_port_string(sc, port, str);
+ else set_output_port_string(sc, port, str);
+ return(str);
+}
+
+
/* -------------------------------- port-position -------------------------------- */
static s7_pointer g_port_position(s7_scheme *sc, s7_pointer args)
{
@@ -28840,10 +28957,13 @@ static s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol
const char *cur = (const char *)strchr(start, (int)'\n'); /* this can run off the end making valgrind unhappy, but I think it's innocuous */
if (cur)
{
+ s7_int len;
port_line_number(port)++;
i = cur - port_str;
port_position(port) = i + 1;
- return(inline_make_string_with_length(sc, start, ((with_eol) ? i + 1 : i) - port_start));
+ len = ((with_eol) ? i + 1 : i) - port_start;
+ if (len == 0) return(nil_string);
+ return(inline_make_string_with_length(sc, start, len));
}
i = port_data_size(port);
port_position(port) = i;
@@ -28864,7 +28984,6 @@ static void resize_port_data(s7_scheme *sc, s7_pointer pt, s7_int new_size)
if (new_size > sc->max_port_data_size)
error_nr(sc, make_symbol(sc, "port-too-big", 12),
set_elist_1(sc, wrap_string(sc, "port data size has grown past (*s7* 'max-port-data-size)", 56)));
-
nb = reallocate(sc, port_data_block(pt), new_size);
port_data_block(pt) = nb;
port_data(pt) = (uint8_t *)(block_data(nb));
@@ -29736,6 +29855,11 @@ static const port_functions_t input_string_functions =
static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_int len)
{
s7_pointer x;
+ /* we could look for free entry in sc->input_string_ports and reuse it, but that takes longer than it saves,
+ * mainly because ports are marked free by the GC, so free entries happen once-in-a-long-while (while the list grows),
+ * and free_cell can't be used (freeze_t protecting the block). Perhaps free_frozen_cell (just sets type=T_FREE +(?) clears T_GC_MARKED),
+ * but how to recognize such cases (see tio.scm). Maybe a way in scheme to reuse such a port? (set! (port-string p) "asdf")?
+ */
block_t *b = mallocate_port(sc);
new_cell(sc, x, T_INPUT_PORT);
port_block(x) = b;
@@ -29767,7 +29891,7 @@ static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_
return(x);
}
-static /* inline */ s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str) /* why inline here? */
+static /* inline */ s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str)
{
s7_pointer p = open_input_string(sc, string_value(str), string_length(str));
port_set_string_or_function(p, str);
@@ -29843,6 +29967,7 @@ const char *s7_get_output_string(s7_scheme *sc, s7_pointer p)
s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p)
{
port_data(p)[port_position(p)] = '\0';
+ if (port_position(p) == 0) return(nil_string);
return(make_string_with_length(sc, (const char *)port_data(p), port_position(p)));
}
@@ -29862,7 +29987,7 @@ static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer p)
static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args)
{
- #define H_get_output_string "(get-output-string port clear-port) returns the output accumulated in port. \
+ #define H_get_output_string "(get-output-string port (clear-port #f)) returns the output accumulated in port. \
If the optional 'clear-port' is #t, the current string is flushed."
#define Q_get_output_string s7_make_signature(sc, 3, sc->is_string_symbol, \
s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_boolean_symbol)
@@ -29899,6 +30024,7 @@ If the optional 'clear-port' is #t, the current string is flushed."
port_data(p)[0] = '\0';
return(result);
}
+ if (port_position(p) == 0) return(nil_string);
return(make_string_with_length(sc, (const char *)port_data(p), port_position(p)));
}
@@ -29909,10 +30035,11 @@ static void op_get_output_string(s7_scheme *sc)
wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, port, wrap_string(sc, "an open string output port", 26));
check_get_output_string_port(sc, port);
+ /* nil_string here is tricky (need liberate etc) */
if (port_position(port) >= port_data_size(port)) /* can the > part happen? */
sc->value = block_to_string(sc, reallocate(sc, port_data_block(port), port_position(port) + 1), port_position(port));
else sc->value = block_to_string(sc, port_data_block(port), port_position(port));
-
+ /* block_to_string attaches the port's data_block to the string for later free */
port_data(port) = NULL;
port_data_size(port) = 0;
port_data_block(port) = NULL;
@@ -29929,6 +30056,7 @@ static s7_pointer g_get_output_string_uncopied(s7_scheme *sc, s7_pointer args)
}
check_get_output_string_port(sc, p);
port_data(p)[port_position(p)] = '\0'; /* wrap_string can't do this, and (for example) open_input_string wants terminated strings */
+ if (port_position(p) == 0) return(nil_string);
return(wrap_string(sc, (const char *)port_data(p), port_position(p)));
}
@@ -30372,7 +30500,7 @@ static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args)
if (port_is_closed(port))
wrong_type_error_nr(sc, sc->read_string_symbol, 2, port, an_open_input_port_string);
- s = make_empty_string(sc, nchars, 0);
+ s = make_empty_string(sc, nchars, '\0');
if (nchars == 0) return(s);
str = (uint8_t *)string_value(s);
if (is_string_port(port))
@@ -30698,7 +30826,7 @@ static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointe
if (is_pair(init_args))
{
p = ((dl_func_with_args)init_func)(sc, init_args);
- set_stack_protected2(sc, p);
+ set_gc_protected2(sc, p);
}
/* if caller includes init_args, but init_func is actually a dl_func, it seems to be ok,
* but the returned value is whatever was last computed in the init_func.
@@ -32115,6 +32243,8 @@ static s7_pointer g_iterator_sequence(s7_scheme *sc, s7_pointer args)
return(iterator_sequence(iter));
}
+/* iterator-length and iterator-position run up against the function iterator */
+
/* -------- cycles -------- */
@@ -32867,7 +32997,7 @@ static char *multivector_indices_to_string(s7_scheme *sc, s7_int index, s7_point
return(str);
}
-#define NOT_P_DISPLAY(Choice) ((Choice == P_DISPLAY) ? P_WRITE : Choice)
+#define not_p_display(Choice) ((Choice == P_DISPLAY) ? P_WRITE : Choice)
static int32_t multivector_to_port_1(s7_scheme *sc, s7_pointer vec, s7_pointer port,
int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, bool *last,
@@ -32885,7 +33015,7 @@ static int32_t multivector_to_port_1(s7_scheme *sc, s7_pointer vec, s7_pointer p
{
if (flat_ref < out_len)
{
- object_to_port_with_circle_check(sc, vector_getter(vec)(sc, vec, flat_ref), port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port_with_circle_check(sc, vector_getter(vec)(sc, vec, flat_ref), port, not_p_display(use_write), ci);
if (use_write == P_READABLE)
port_write_string(port)(sc, ") ", 2, port);
@@ -32902,7 +33032,7 @@ static int32_t multivector_to_port_1(s7_scheme *sc, s7_pointer vec, s7_pointer p
}
else
if (flat_ref < out_len)
- flat_ref = multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension + 1, dimensions, last, NOT_P_DISPLAY(use_write), ci);
+ flat_ref = multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension + 1, dimensions, last, not_p_display(use_write), ci);
else
{
port_write_string(port)(sc, "...)", 4, port);
@@ -33174,10 +33304,10 @@ static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_
port_write_string(port)(sc, "#(", 2, port);
for (i = 0; i < len - 1; i++)
{
- object_to_port_with_circle_check(sc, vector_element(vect, i), port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port_with_circle_check(sc, vector_element(vect, i), port, not_p_display(use_write), ci);
port_write_character(port)(sc, ' ', port);
}
- object_to_port_with_circle_check(sc, vector_element(vect, i), port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port_with_circle_check(sc, vector_element(vect, i), port, not_p_display(use_write), ci);
if (too_long)
port_write_string(port)(sc, " ...)", 5, port);
@@ -33763,7 +33893,7 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri
port_write_string(port)(sc, " ...)", 5, port);
return;
}
- object_to_port_with_circle_check(sc, car(x), port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port_with_circle_check(sc, car(x), port, not_p_display(use_write), ci);
if (i < (len - 1))
port_write_character(port)(sc, ' ', port);
}
@@ -33777,7 +33907,7 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri
(i == len))
port_write_string(port)(sc, " . ", 3, port);
else port_write_string(port)(sc, ". ", 2, port);
- object_to_port_with_circle_check(sc, x, port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port_with_circle_check(sc, x, port, not_p_display(use_write), ci);
}}
port_write_character(port)(sc, ')', port);
}
@@ -33788,7 +33918,7 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri
{
for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x))
{
- object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port(sc, car(x), port, not_p_display(use_write), ci);
if (port_position(port) >= sc->objstr_max_len)
return;
if (port_position(port) >= port_data_size(port))
@@ -33798,12 +33928,12 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri
else
for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x))
{
- object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); /* lst free here if unprotected */
+ object_to_port(sc, car(x), port, not_p_display(use_write), ci); /* lst free here if unprotected */
port_write_character(port)(sc, ' ', port);
}
if (is_pair(x))
{
- object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port(sc, car(x), port, not_p_display(use_write), ci);
x = cdr(x);
}
if (is_not_null(x))
@@ -33813,7 +33943,7 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri
else
{
port_write_string(port)(sc, ". ", 2, port);
- object_to_port(sc, x, port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port(sc, x, port, not_p_display(use_write), ci);
}}
port_write_character(port)(sc, ')', port);
}}
@@ -34051,12 +34181,13 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port,
for (s7_int i = 0; i < len; i++)
{
s7_pointer key_val = hash_table_iterate(sc, iterator);
+ if (key_val == eof_object) break; /* key_val can be #<eof> if hash is a weak-hash-table, and a GC happens during this loop */
port_write_character(port)(sc, ' ', port);
if ((use_write != P_READABLE) && (use_write != P_CODE) && (is_normal_symbol(car(key_val))))
port_write_character(port)(sc, '\'', port);
- object_to_port_with_circle_check(sc, car(key_val), port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port_with_circle_check(sc, car(key_val), port, not_p_display(use_write), ci);
port_write_character(port)(sc, ' ', port);
- object_to_port_with_circle_check(sc, cdr(key_val), port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port_with_circle_check(sc, cdr(key_val), port, not_p_display(use_write), ci);
}
if (use_write != P_READABLE)
{
@@ -34574,7 +34705,7 @@ static s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b)
{
s7_pointer np;
tp = list_1(sc, car(a));
- set_stack_protected2(sc, tp);
+ set_gc_protected2(sc, tp);
for (np = tp; is_pair(p); p = cdr(p), np = cdr(np))
set_cdr(np, list_1(sc, car(p)));
set_cdr(np, b);
@@ -35333,7 +35464,7 @@ static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer vr, s7_
char *p = pos_int_to_str(sc, (s7_int)ref, &len, '=');
*--p = '#';
port_write_string(port)(sc, p, len, port);
- object_to_port(sc, vr, port, NOT_P_DISPLAY(use_write), ci);
+ object_to_port(sc, vr, port, not_p_display(use_write), ci);
}}
else
if (use_write == P_READABLE)
@@ -35453,6 +35584,9 @@ static s7_pointer new_format_port(s7_scheme *sc)
port_position(x) = 0;
port_needs_free(x) = false;
port_port(x)->pf = &output_string_functions;
+#if S7_DEBUGGING
+ sc->format_ports_allocated++;
+#endif
return(x);
}
@@ -36089,7 +36223,7 @@ static s7_int format_n_arg(s7_scheme *sc, const char *str, format_data_t *fdat,
if (n > sc->max_format_length)
format_error_nr(sc, "~~N value is too big", 20, str, args, fdat);
- fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for *vector-print-length* etc */
+ fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for (*s7* 'print-length) etc */
return(n);
}
@@ -36673,16 +36807,20 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s
}
if (port_position(port) < port_data_size(port))
{
- block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH);
- result = inline_block_to_string(sc, port_data_block(port), port_position(port));
- port_data_size(port) = FORMAT_PORT_LENGTH;
- port_data_block(port) = block;
- port_data(port) = (uint8_t *)(block_data(block));
- port_data(port)[0] = '\0';
- port_position(port) = 0;
- }
- else result = make_string_with_length(sc, (char *)port_data(port), port_position(port));
- close_format_port(sc, port);
+ if (port_position(port) == 0)
+ result = nil_string;
+ else
+ {
+ block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH); /* for format port after turning current format block into a string */
+ result = inline_block_to_string(sc, port_data_block(port), port_position(port));
+ port_data_size(port) = FORMAT_PORT_LENGTH;
+ port_data_block(port) = block;
+ port_data(port) = (uint8_t *)(block_data(block));
+ port_data(port)[0] = '\0';
+ port_position(port) = 0;
+ }}
+ else result = make_string_with_length(sc, (char *)port_data(port), port_position(port)); /* this can happen (s7test, pos/size=128) */
+ close_format_port(sc, port); /* i.e. return it to the fdat free list */
fdat->port = NULL;
return(result);
}
@@ -37427,13 +37565,13 @@ static s7_pointer tree_set_memq_syms_direct(s7_scheme *sc, s7_pointer syms, s7_p
if (!is_list(tree))
wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 2, tree, a_list_string);
if (is_null(tree)) return(sc->F);
+ if (is_quote(car(tree))) return(sc->F);
if ((sc->safety > NO_SAFETY) &&
(tree_is_cyclic(sc, tree)))
error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree));
clear_symbol_list(sc);
for (s7_pointer p = syms; is_pair(p); p = cdr(p))
add_symbol_to_list(sc, car(p));
- if (is_quote(car(tree))) return(sc->F);
return(make_boolean(sc, pair_set_memq(sc, tree)));
}
@@ -39369,7 +39507,7 @@ static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer ls
s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...)
{
va_list ap;
- s7_pointer p;
+ s7_pointer p, old_sw = sc->w;
if (num_values == 0)
return(sc->nil);
sc->w = make_list(sc, num_values, sc->unused);
@@ -39381,7 +39519,7 @@ s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...)
if (sc->safety > NO_SAFETY)
check_list_validity(sc, __func__, sc->w);
p = sc->w;
- sc->w = sc->unused;
+ sc->w = old_sw;
return(p);
}
@@ -40155,7 +40293,7 @@ static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args)
static s7_pointer vector_append_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
{
s7_pointer val;
- sc->temp7 = list_2(sc, p1, p2); /* ideally this list would be stack_protected, avoiding temp7 (method call above) */
+ sc->temp7 = list_2(sc, p1, p2); /* ideally this list would be gc_protected, avoiding temp7 (method call above) */
val = g_vector_append(sc, sc->temp7);
sc->temp7 = sc->unused;
return(val);
@@ -40417,7 +40555,7 @@ static s7_pointer g_byte_vector_to_string(s7_scheme *sc, s7_pointer args)
error_nr(sc, sc->out_of_range_symbol,
set_elist_3(sc, wrap_string(sc, "byte-vector->string byte-vector is too large: (> ~D ~D) (*s7* 'max-string-length)", 81),
wrap_integer(sc, byte_vector_length(v)), wrap_integer(sc, sc->max_string_length)));
- return(s7_copy_1(sc, sc->byte_vector_to_string_symbol, set_plist_2(sc, v, make_empty_string(sc, byte_vector_length(v), 0))));
+ return(s7_copy_1(sc, sc->byte_vector_to_string_symbol, set_plist_2(sc, v, make_empty_string(sc, byte_vector_length(v), '\0'))));
}
@@ -40686,7 +40824,6 @@ static s7_pointer g_subvector_position(s7_scheme *sc, s7_pointer args)
{
/* we can't use vector_elements(sv) - vector_elements(subvector_vector(sv)) because that assumes we're looking at s7_pointer*,
* so a subvector of a byte_vector gets a bogus position (0 if position is less than 8 etc).
- * Since we currently let the user reset s7_int and s7_double, all four cases have to be handled explicitly.
*/
switch (type(sv))
{
@@ -40733,6 +40870,7 @@ static s7_pointer subvector(s7_scheme *sc, s7_pointer vect, s7_int skip_dims, s7
vector_set_dimension_info(x, NULL);
subvector_set_vector(x, vect);
}
+
if (is_t_vector(vect))
mark_function[T_VECTOR] = mark_vector_possibly_shared;
else mark_function[type(vect)] = mark_int_or_float_vector_possibly_shared;
@@ -44098,7 +44236,7 @@ static hash_entry_t *hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key
if (string_hash(key) == 0)
string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key));
- hash = string_hash(key); /* keep uint64_t (not s7_int from hash_map_string) TODO: can this work?? */
+ hash = string_hash(key); /* keep uint64_t (not s7_int from hash_map_string) */
if (key_len <= 8)
{
@@ -45700,13 +45838,6 @@ static s7_pointer g_is_procedure(s7_scheme *sc, s7_pointer args)
return(make_boolean(sc, is_procedure(car(args))));
}
-
-static void s7_function_set_setter(s7_scheme *sc, s7_pointer getter, s7_pointer setter)
-{
- /* this is internal, used only with c_function setters, so we don't need to worry about the GC mark choice */
- c_function_set_setter(global_value(getter), global_value(setter));
-}
-
s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_body(p) : sc->nil);}
s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->rootlet);}
s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_args(p) : sc->nil);}
@@ -46522,7 +46653,7 @@ static void op_unwind_input(s7_scheme *sc)
static bool op_dynamic_wind(s7_scheme *sc)
{
s7_pointer dwind = T_Dyn(sc->code);
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_80(dwind));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(dwind));
if (dynamic_wind_state(dwind) == DWIND_INIT)
{
dynamic_wind_state(dwind) = DWIND_BODY;
@@ -47160,7 +47291,7 @@ static bool is_sequence_b(s7_pointer p) {return(is_simple_sequence(p));}
/* -------------------------------- setter ------------------------------------------------ */
-static s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args)
+static s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args) /* see bool_defun -> define_bool_function */
{
if (type(cadr(args)) != typer)
error_nr(sc, sc->wrong_type_arg_symbol,
@@ -47169,6 +47300,8 @@ static s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args)
return(cadr(args));
}
+/* these are for the simplified setter designation: (let ((x 1)) (set! (setter 'x) integer?) (set! x 3.14)) -> error */
+
static s7_pointer b_is_symbol_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_SYMBOL, args));}
static s7_pointer b_is_syntax_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_SYNTAX, args));}
static s7_pointer b_is_let_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_LET, args));}
@@ -47373,7 +47506,7 @@ static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer ar
if (is_pair(cddr(args)))
{
- s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */
+ s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))): args is (x (inlet 'x 1) #<lambda (s v ...)>) */
func = caddr(args);
if (e == sc->rootlet)
slot = global_slot(sym);
@@ -47385,7 +47518,7 @@ static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer ar
}}
else
{
- slot = s7_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)) */
+ slot = s7_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)): args is: (x #<lambda (s v)>) */
func = cadr(args);
}
if (!is_slot(slot))
@@ -49095,6 +49228,7 @@ static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer source, s7_point
switch (type(source))
{
case T_STRING:
+ if (string_length(source) == 0) return(nil_string);
return(make_string_with_length(sc, string_value(source), string_length(source)));
case T_C_OBJECT:
@@ -49405,13 +49539,13 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot))
if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) &&
(slot_symbol(slot) != sc->let_set_fallback_symbol))
- add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot));
+ add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot));
}
else
/* this copies reversing the order -- if shadowing, this unshadows, tmp has in-order copy code, but it's too much effort */
/* it also ignores possible slot setters */
for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot))
- add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot));
+ add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot));
return(dest);
}
end = let_length(sc, source);
@@ -49560,8 +49694,12 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
els[j] = car(p);
}
else
- for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p))
- set(sc, dest, j, car(p));
+ {
+ gc_protect_via_stack(sc, source);
+ for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p))
+ set(sc, dest, j, car(p));
+ unstack_gc_protect(sc);
+ }
return(dest);
}
@@ -49617,11 +49755,11 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot))
if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) &&
(slot_symbol(slot) != sc->let_set_fallback_symbol))
- add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot));
+ add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot));
}
else
for (i = start; i < end; i++, slot = next_slot(slot))
- add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot));
+ add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot));
}
else
if (is_hash_table(dest))
@@ -49678,7 +49816,7 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
set_elist_4(sc, wrap_string(sc, "~A into ~A: ~A is a constant", 28), caller, dest, symbol));
if ((symbol != sc->let_ref_fallback_symbol) &&
(symbol != sc->let_set_fallback_symbol))
- add_slot_checked_with_id(sc, dest, symbol, hash_entry_value(x)); /* ...unchecked... if size ok */
+ add_slot_no_local(sc, dest, symbol, hash_entry_value(x)); /* ...unchecked... if size ok */
x = hash_entry_next(x);
}}
else
@@ -50390,7 +50528,7 @@ static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_
}
new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? FILLED : NOT_FILLED, typ); /* might hit GC in loop below so we can't use NOT_FILLED here (??) */
typed = (typ == T_VECTOR);
- set_stack_protected2(sc, new_vec);
+ set_gc_protected2(sc, new_vec);
add_vector(sc, new_vec);
if (len == 0)
{
@@ -50409,7 +50547,7 @@ static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_
pargs = list_2(sc, sc->F, new_vec); /* car set below */
/* push_stack_no_let(sc, OP_GC_PROTECT, new_vec, pargs); */
- set_stack_protected3(sc, pargs);
+ set_gc_protected3(sc, pargs);
for (i = 0, p = args; is_pair(p); p = cdr(p)) /* in-place copy by goofing (temporarily) with new_vec's elements pointer */
{
s7_pointer x = car(p);
@@ -50468,7 +50606,7 @@ static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args)
gc_protect_via_stack(sc, args);
check_stack_size(sc);
new_hash = s7_make_hash_table(sc, sc->default_hash_table_length);
- set_stack_protected2(sc, new_hash);
+ set_gc_protected2(sc, new_hash);
for (s7_pointer p = args; is_pair(p); p = cdr(p))
{
s7_pointer seq = car(p);
@@ -50513,7 +50651,7 @@ static s7_pointer let_append(s7_scheme *sc, s7_pointer args)
check_method(sc, e, sc->append_symbol, args);
gc_protect_via_stack(sc, args);
new_let = make_let(sc, sc->rootlet);
- set_stack_protected2(sc, new_let);
+ set_gc_protected2(sc, new_let);
for (s7_pointer p = args; is_pair(p); p = cdr(p))
if (!sequence_is_empty(sc, car(p)))
s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(p), new_let));
@@ -51094,7 +51232,7 @@ static s7_pointer port_to_let(s7_scheme *sc, s7_pointer obj) /* note the underba
* both valgrind and lib*san complain about the uninitialized data during strlen.
*/
s7_varlet(sc, let, sc->data_symbol,
- make_string_with_length(sc, (const char *)port_data(obj), ((port_position(obj)) > 16) ? 16 : port_position(obj)));
+ make_string_with_length(sc, (const char *)port_data(obj), ((port_position(obj)) > 16) ? 16 : port_position(obj))); /* sc->print_length? */
}
if (is_function_port(obj))
s7_varlet(sc, let, sc->function_symbol, port_string_or_function(obj));
@@ -51898,24 +52036,21 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
#define Q_catch s7_make_signature(sc, 4, sc->values_symbol, \
s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_boolean_symbol), \
sc->is_procedure_symbol, sc->is_procedure_symbol)
- s7_pointer p, proc = cadr(args), err = caddr(args);
+ s7_pointer p, proc, err;
/* Guile sets up the catch before looking for arg errors: (catch #t log (lambda args "hiho")) -> "hiho"
* which is consistent in that (catch #t (lambda () (log))...) should probably be the same as (catch #t log ...)
* but what if the error handler arg is messed up? Seems weird to handle args in reverse order with an intervening let etc.
+ * I think log as the second arg is an outer error (we don't wait until the catch is called, then fall into
+ * the local error handler).
*/
- /* if (is_let(err)) check_method(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */
-
+ /* if ((is_let(err)) && (is_openlet(err))) check_method(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */
if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]\n", __func__, __LINE__);
- new_cell(sc, p, T_CATCH);
- catch_tag(p) = car(args);
- catch_goto_loc(p) = stack_top(sc);
- catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack);
- catch_set_handler(p, err);
- catch_cstack(p) = sc->goto_start;
- push_stack(sc, (intptr_t)((is_any_macro(err)) ? OP_CATCH_2 : OP_CATCH), args, p);
- /* not sure about these error checks -- they can be omitted */
+ if (!is_pair(cdr(args))) /* (let ((mlet (openlet (inlet 'abs catch)))) (abs mlet)) -- this is a special case, avoid calling this everywhere */
+ error_nr(sc, sc->syntax_error_symbol,
+ set_elist_2(sc, wrap_string(sc, "catch: function missing: ~S", 27), set_ulist_1(sc, sc->catch_symbol, args)));
+ proc = cadr(args);
if (!is_thunk(sc, proc))
{
if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */
@@ -51926,12 +52061,24 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
}
else wrong_type_error_nr(sc, sc->catch_symbol, 2, proc, a_thunk_string);
}
+ if (!is_pair(cddr(args)))
+ error_nr(sc, sc->syntax_error_symbol,
+ set_elist_2(sc, wrap_string(sc, "catch: error handler missing: ~S", 32), set_ulist_1(sc, sc->catch_symbol, args)));
+ err = caddr(args);
if (!is_applicable(err))
wrong_type_error_nr(sc, sc->catch_symbol, 3, err, something_applicable_string);
-
/* should we check here for (aritable? err 2)? (catch #t (lambda () 1) "hiho") -> 1
* currently this is checked only if the error handler is called
*/
+
+ new_cell(sc, p, T_CATCH);
+ catch_tag(p) = car(args);
+ catch_goto_loc(p) = stack_top(sc);
+ catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack);
+ catch_set_handler(p, err);
+ catch_cstack(p) = sc->goto_start;
+ push_stack(sc, (intptr_t)((is_any_macro(err)) ? OP_CATCH_2 : OP_CATCH), args, p);
+
if (is_closure(proc)) /* not also lambda* here because we need to handle the arg defaults */
{
/* is_thunk above checks is_aritable(proc, 0), but if it's (lambda args ...) we have to set up the let with args=()
@@ -51971,7 +52118,7 @@ s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7
if (jump_loc == NO_JUMP)
{
catch_cstack(p) = &new_goto_start;
- if (SHOW_EVAL_OPS) fprintf(stderr, " longjmp call %s\n", display_80(body));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " longjmp call %s\n", display_truncated(body));
push_stack(sc, OP_CATCH, error_handler, p);
result = s7_call(sc, body, sc->nil);
if (stack_top_op(sc) == OP_CATCH) sc->stack_end -= 4;
@@ -52080,7 +52227,7 @@ static s7_pointer cull_history(s7_scheme *sc, s7_pointer code)
}
#endif
-static s7_pointer g_owlet(s7_scheme *sc, s7_pointer unused_args)
+static s7_pointer g_owlet(s7_scheme *sc, s7_pointer args)
{
#if WITH_HISTORY
#define H_owlet "(owlet) returns the environment at the point of the last error. \
@@ -52094,6 +52241,8 @@ It has the additional local variables: error-type, error-data, error-code, error
s7_pointer e;
bool old_gc = sc->gc_off;
+ if (is_pair(args))
+ error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->owlet_symbol, args));
#if WITH_HISTORY
slot_set_value(sc->error_history, cull_history(sc, slot_value(sc->error_history)));
#endif
@@ -52442,7 +52591,7 @@ static bool catch_let_temp_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_p
{
s7_pointer slot = stack_code(sc->stack, catch_loc);
s7_pointer val = stack_args(sc->stack, catch_loc);
- if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s, unwind setting %s to %s\n", __func__, display_80(slot), display_80(val));
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s, unwind setting %s to %s\n", __func__, display_truncated(slot), display_truncated(val));
if (is_immutable_slot(slot)) /* we're already in an error/throw situation, so raising an error here leads to an infinite loop */
s7_warn(sc, 512, "let-temporarily can't reset %s to %s: it is immutable!", symbol_name(slot_symbol(slot)), display(val));
else slot_set_value(slot, val);
@@ -52729,7 +52878,7 @@ static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info)
if (is_string(slot_value(sc->error_file)))
{
s7_newline(sc, current_error_port(sc));
- format_to_error_port(sc, "; ~A\n", set_plist_1(sc, object_to_truncated_string(sc, cur_code, 40)), 8);
+ format_to_error_port(sc, "; ~A\n", set_plist_1(sc, object_to_string_truncated(sc, cur_code)), 8);
format_to_error_port(sc, "; ~A, line ~D, position: ~D\n",
set_plist_3(sc, slot_value(sc->error_file), slot_value(sc->error_line), slot_value(sc->error_position)), 31);
}
@@ -52953,18 +53102,16 @@ static char *truncate_string(char *form, s7_int len, use_write_t use_write)
return(form);
}
-static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int len)
+static s7_pointer object_to_string_truncated(s7_scheme *sc, s7_pointer p)
{
- char *s;
- s7_int s_len;
s7_pointer strp;
+ s7_int len = sc->print_length;
+ s7_int old_max_len = sc->objstr_max_len;
sc->objstr_max_len = len + 2;
strp = s7_object_to_string(sc, p, false);
- s = string_value(strp);
- sc->objstr_max_len = S7_INT64_MAX;
- s_len = string_length(strp);
- if (s_len > len)
- truncate_string(s, len, P_DISPLAY);
+ sc->objstr_max_len = old_max_len;
+ if (string_length(strp) > len)
+ truncate_string(string_value(strp), len, P_DISPLAY); /* only use of truncate_string */
return(strp);
}
@@ -53017,7 +53164,7 @@ static noreturn void missing_close_paren_error_nr(s7_scheme *sc)
if ((p) && (is_pair(p)) &&
(has_location(p)))
{
- s7_pointer strp = object_to_truncated_string(sc, p, 40);
+ s7_pointer strp = object_to_string_truncated(sc, p);
char *form = string_value(strp);
s7_int form_len = string_length(strp);
s7_int msg_len = form_len + 128;
@@ -53677,7 +53824,7 @@ s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args)
declare_jump_info();
TRACK(sc);
set_current_code(sc, history_cons(sc, func, args));
- if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display_80(func), display_80(args)));
+ if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display_truncated(func), display_truncated(args)));
sc->temp4 = T_App(func); /* this is feeble GC protection */
sc->temp2 = T_Lst(args); /* only use of temp2 */
@@ -55680,9 +55827,9 @@ static s7_pointer fx_cons_opuq_t(s7_scheme *sc, s7_pointer arg)
#define fx_c_opsq_cs_any(Name, Lookup1, Lookup2) \
static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
{ \
- set_car(sc->t3_1, fn_proc(cadr(arg))(sc, with_list_t1(Lookup1(sc, opt3_sym(cdr(arg)), arg)))); /* cadadr(arg); */ \
+ set_car(sc->t3_1, fn_proc(cadr(arg))(sc, with_list_t1(Lookup1(sc, opt3_sym(cdr(arg)), arg)))); /* cadadr(arg) */ \
set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadaddr(arg) */ \
- set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg); */ \
+ set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \
return(fn_proc(arg)(sc, sc->t3_1)); \
}
@@ -55965,7 +56112,7 @@ static s7_pointer fx_not_op_optq_sq(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer largs = opt3_pair(arg); /* caddr(arg); */
+ s7_pointer largs = opt3_pair(arg); /* caddr(arg) */
set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs)))));
set_car(sc->t2_1, cadr(arg));
return(fn_proc(arg)(sc, sc->t2_1));
@@ -55984,7 +56131,7 @@ static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg)
gc_protect_via_stack(sc, fn_proc(car(largs))(sc, with_list_t1(lookup(sc, cadar(largs)))));
largs = cadr(largs);
set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs)))));
- set_car(sc->t2_1, stack_protected1(sc));
+ set_car(sc->t2_1, gc_protected1(sc));
unstack_gc_protect(sc);
return(fn_proc(arg)(sc, sc->t2_1));
}
@@ -56040,7 +56187,7 @@ static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer arg)
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); /* caddr(largs) */
set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1));
- set_car(sc->t2_1, stack_protected1(sc));
+ set_car(sc->t2_1, gc_protected1(sc));
unstack_gc_protect(sc);
return(fn_proc(arg)(sc, sc->t2_1));
}
@@ -56081,7 +56228,7 @@ static s7_pointer fx_c_opssq_opsq(s7_scheme *sc, s7_pointer arg)
gc_protect_via_stack(sc, fn_proc(car(largs))(sc, sc->t2_1));
largs = cadr(largs);
set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs)))));
- set_car(sc->t2_1, stack_protected1(sc));
+ set_car(sc->t2_1, gc_protected1(sc));
unstack_gc_protect(sc);
return(fn_proc(arg)(sc, sc->t2_1));
}
@@ -56096,14 +56243,14 @@ static s7_pointer fx_c_opssq_opssq(s7_scheme *sc, s7_pointer arg)
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs))));
set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1));
- set_car(sc->t2_1, stack_protected1(sc));
+ set_car(sc->t2_1, gc_protected1(sc));
unstack_gc_protect(sc);
return(fn_proc(arg)(sc, sc->t2_1));
}
static s7_pointer fx_sub_mul_mul(s7_scheme *sc, s7_pointer arg) /* (- (* s1 s2) (* s3 s4)) */
{
- s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
+ s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg) */
s7_pointer s1 = lookup(sc, car(a1));
s7_pointer s2 = lookup(sc, cadr(a1));
s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ /* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */
@@ -56117,7 +56264,7 @@ static s7_pointer fx_sub_mul_mul(s7_scheme *sc, s7_pointer arg) /* (- (* s1 s2)
static s7_pointer fx_add_mul_mul(s7_scheme *sc, s7_pointer arg) /* (+ (* s1 s2) (* s3 s4)) */
{
- s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
+ s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg) */
s7_pointer s1 = lookup(sc, car(a1));
s7_pointer s2 = lookup(sc, cadr(a1));
s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */
@@ -56131,7 +56278,7 @@ static s7_pointer fx_add_mul_mul(s7_scheme *sc, s7_pointer arg) /* (+ (* s1 s2)
static s7_pointer fx_mul_sub_sub(s7_scheme *sc, s7_pointer arg) /* (* (- s1 s2) (- s3 s4)) */
{
- s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
+ s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg) */
s7_pointer s1 = lookup(sc, car(a1));
s7_pointer s2 = lookup(sc, cadr(a1));
s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */
@@ -56145,7 +56292,7 @@ static s7_pointer fx_mul_sub_sub(s7_scheme *sc, s7_pointer arg) /* (* (- s1 s2)
static s7_pointer fx_lt_sub2(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
+ s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg) */
sc->temp5 = subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1)));
a1 = opt1_pair(cdr(arg)); /* cdadr(arg) */
return(lt_p_pp(sc, subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->temp5));
@@ -56156,7 +56303,7 @@ static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg)
s7_pointer a1 = cdadr(arg);
s7_pointer v1 = lookup(sc, car(a1));
s7_pointer p1 = lookup(sc, cadr(a1));
- s7_pointer p2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg)); */
+ s7_pointer p2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg) */
if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_t_vector(v1)) && (vector_rank(v1) == 1)))
{
s7_int i1 = integer(p1), i2 = integer(p2);
@@ -56200,7 +56347,7 @@ static s7_pointer fx_c_saa(s7_scheme *sc, s7_pointer arg)
gc_protect_via_stack(sc, fx_call(sc, opt3_pair(arg))); /* opt3_pair=cddr */
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
set_car(sc->t3_1, lookup(sc, cadr(arg)));
- set_car(sc->t3_2, stack_protected1(sc));
+ set_car(sc->t3_2, gc_protected1(sc));
res = fn_proc(arg)(sc, sc->t3_1);
unstack_gc_protect(sc);
return(res);
@@ -56285,8 +56432,8 @@ static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer arg)
s7_pointer res;
/* check_stack_size(sc); */
gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* opt3_pair = cddr(arg) */
- set_car(sc->t2_1, T_Ext(stack_protected1(sc)));
- set_car(sc->t2_2, stack_protected2(sc));
+ set_car(sc->t2_1, T_Ext(gc_protected1(sc)));
+ set_car(sc->t2_2, gc_protected2(sc));
res = fn_proc(arg)(sc, sc->t2_1);
unstack_gc_protect(sc);
return(res);
@@ -56448,8 +56595,8 @@ static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg)
/* check_stack_size(sc); */
gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg)));
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
- set_car(sc->t3_2, stack_protected2(sc));
- set_car(sc->t3_1, stack_protected1(sc));
+ set_car(sc->t3_2, gc_protected2(sc));
+ set_car(sc->t3_1, gc_protected1(sc));
res = fn_proc(arg)(sc, sc->t3_1);
unstack_gc_protect(sc);
return(res);
@@ -56472,7 +56619,7 @@ static s7_pointer fx_c_opaq_s(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_c_s_opaq(s7_scheme *sc, s7_pointer arg)
{
- set_car(sc->t2_2, fn_proc(caddr(arg))(sc, with_list_t1(fx_call(sc, opt3_pair(arg))))); /* cdaddr(arg); */
+ set_car(sc->t2_2, fn_proc(caddr(arg))(sc, with_list_t1(fx_call(sc, opt3_pair(arg))))); /* cdaddr(arg) */
set_car(sc->t2_1, lookup_checked(sc, cadr(arg)));
return(fn_proc(arg)(sc, sc->t2_1));
}
@@ -56490,9 +56637,9 @@ static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg)
/* check_stack_size(sc); */
gc_protect_via_stack(sc, fx_call(sc, cdr(p)));
set_car(sc->t2_2, fx_call(sc, cddr(p)));
- set_car(sc->t2_1, stack_protected1(sc));
+ set_car(sc->t2_1, gc_protected1(sc));
res = fn_proc(p)(sc, sc->t2_1);
- set_stack_protected2(sc, res); /* might be a big list etc (see s7test.scm fx_c_opaaq test) */
+ set_gc_protected2(sc, res); /* might be a big list etc (see s7test.scm fx_c_opaaq test) */
res = fn_proc(arg)(sc, with_list_t1(res));
unstack_gc_protect(sc);
return(res);
@@ -56511,8 +56658,8 @@ static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer code)
s7_pointer arg = cadr(code), res;
gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */
set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
- set_car(sc->t3_1, stack_protected1(sc));
- set_car(sc->t3_2, stack_protected2(sc));
+ set_car(sc->t3_1, gc_protected1(sc));
+ set_car(sc->t3_2, gc_protected2(sc));
res = fn_proc(code)(sc, with_list_t1(fn_proc(arg)(sc, sc->t3_1)));
unstack_gc_protect(sc);
return(res);
@@ -56523,7 +56670,7 @@ static s7_pointer fx_c_s_opaaq(s7_scheme *sc, s7_pointer code)
s7_pointer arg = caddr(code), res;
gc_protect_via_stack(sc, fx_call(sc, cdr(arg)));
set_car(sc->t2_2, fx_call(sc, cddr(arg)));
- set_car(sc->t2_1, stack_protected1(sc));
+ set_car(sc->t2_1, gc_protected1(sc));
set_car(sc->t2_2, fn_proc(arg)(sc, sc->t2_1));
set_car(sc->t2_1, lookup(sc, cadr(code)));
res = fn_proc(code)(sc, sc->t2_1);
@@ -56537,11 +56684,11 @@ static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code)
check_stack_size(sc); /* t718 pp cycles #f */
gc_protect_2_via_stack(sc, fx_call(sc, res), fx_call(sc, cdr(res)));
res = cddr(res);
- set_stack_protected3(sc, fx_call(sc, res));
+ set_gc_protected3(sc, fx_call(sc, res));
set_car(sc->t3_3, fx_call(sc, cdr(res)));
- set_car(sc->t3_2, stack_protected3(sc));
- set_car(sc->t3_1, stack_protected2(sc));
- set_car(sc->t4_1, stack_protected1(sc));
+ set_car(sc->t3_2, gc_protected3(sc));
+ set_car(sc->t3_1, gc_protected2(sc));
+ set_car(sc->t4_1, gc_protected1(sc));
res = fn_proc(code)(sc, sc->t4_1);
unstack_gc_protect(sc);
set_car(sc->t4_1, sc->F);
@@ -56648,7 +56795,6 @@ static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code)
/* as in let, we need to call the var inits before making the new let, but a simpler equivalent is to make the new let
* but don't set its id yet, and don't set local_slot until end either because fx_call might refer to same-name symbol in outer let.
* That is, symbol_id=outer_let_id so lookup->local_slot, so we better not set local_slot ahead of time here.
- * As far as I can tell, this is the only place we do fx_call at the time of new_slot with new let id unset.
*/
for (s7_pointer x = cdr(code); is_pair(x); x = cddr(x))
{
@@ -56661,10 +56807,7 @@ static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code)
}
value = fx_call(sc, cdr(x)); /* it's necessary to do this first, before add_slot_unchecked */
if (!sp)
- {
- add_slot_unchecked_no_local(sc, new_e, symbol, value);
- sp = let_slots(new_e);
- }
+ sp = add_slot_unchecked_no_local_slot(sc, new_e, symbol, value);
else sp = add_slot_at_end_no_local(sc, sp, symbol, value);
}
id = ++sc->let_number;
@@ -56829,14 +56972,14 @@ static s7_pointer fx_or_2a(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_or_s_2(s7_scheme *sc, s7_pointer arg)
{
/* the "s" is looked up once here -- not obvious how to use fx_call anyway */
- s7_pointer x = fn_proc(cadr(arg))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(arg))))); /* cadadr(arg); */
+ s7_pointer x = fn_proc(cadr(arg))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(arg))))); /* cadadr(arg) */
return((x != sc->F) ? x : fn_proc(caddr(arg))(sc, sc->t1_1));
}
static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer x = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg)); */
- return(make_boolean(sc, (type(x) == opt3_int(arg)) || (type(x) == opt2_int(cdr(arg)))));
+ int32_t x = type(lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg)) */
+ return(make_boolean(sc, (x == opt3_int(arg)) || (x == opt2_int(cdr(arg)))));
}
static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer arg)
@@ -56850,7 +56993,7 @@ static s7_pointer fx_or_and_2a(s7_scheme *sc, s7_pointer arg)
s7_pointer p = cdr(arg);
s7_pointer val = fx_call(sc, p);
if (val != sc->F) return(val);
- p = opt3_pair(arg); /* cdadr(p); */
+ p = opt3_pair(arg); /* cdadr(p) */
val = fx_call(sc, p);
return((val == sc->F) ? val : fx_call(sc, cdr(p)));
}
@@ -56860,7 +57003,7 @@ static s7_pointer fx_or_and_3a(s7_scheme *sc, s7_pointer arg)
s7_pointer p = cdr(arg);
s7_pointer val = fx_call(sc, p);
if (val != sc->F) return(val);
- p = opt3_pair(arg); /* cdadr(p); */
+ p = opt3_pair(arg); /* cdadr(p) */
val = fx_call(sc, p);
if (val == sc->F) return(val);
p = cdr(p);
@@ -56906,7 +57049,7 @@ static s7_pointer fx_safe_thunk_a(s7_scheme *sc, s7_pointer code)
gc_protect_via_stack(sc, sc->curlet); /* we do need to GC protect curlet here and below (not just remember it) */
set_curlet(sc, closure_let(f));
result = fx_call(sc, closure_body(f));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -56917,7 +57060,7 @@ static s7_pointer fx_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also ca
gc_protect_via_stack(sc, sc->curlet);
set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))));
result = fx_call(sc, closure_body(opt1_lambda(code)));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -56934,7 +57077,7 @@ static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code)
gc_protect_via_stack(sc, sc->curlet);
set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), t_lookup(sc, opt2_sym(code), code)));
result = fx_call(sc, closure_body(opt1_lambda(code)));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -56994,7 +57137,7 @@ static s7_pointer fx_safe_closure_s_and_2a(s7_scheme *sc, s7_pointer code) /* sa
result = fx_call(sc, code); /* have to unwind the stack so this can't return */
if (result != sc->F)
result = fx_call(sc, cdr(code));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -57006,7 +57149,7 @@ static s7_pointer fx_safe_closure_s_and_pair(s7_scheme *sc, s7_pointer code) /*
set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))));
code = cdar(closure_body(opt1_lambda(code)));
result = (is_pair(t_lookup(sc, cadar(code), code))) ? fx_call(sc, cdr(code)) : sc->F; /* pair? arg = func par, pair? is global, symbol_id=0 */
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -57017,7 +57160,7 @@ static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer code)
gc_protect_via_stack(sc, sc->curlet);
set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))));
result = fx_call(sc, closure_body(opt1_lambda(code)));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -57039,7 +57182,7 @@ static s7_pointer fx_safe_closure_a_and_2a(s7_scheme *sc, s7_pointer code)
set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))));
result = fx_call(sc, and_arg);
if (result != sc->F) result = fx_call(sc, cdr(and_arg));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -57050,7 +57193,7 @@ static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code)
gc_protect_via_stack(sc, sc->curlet);
set_curlet(sc, update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code))));
result = fx_call(sc, closure_body(opt1_lambda(code)));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -57067,7 +57210,7 @@ static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code)
gc_protect_via_stack(sc, sc->curlet);
set_curlet(sc, update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))));
result = fx_call(sc, closure_body(opt1_lambda(code)));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -57084,9 +57227,9 @@ static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code)
s7_pointer f = opt1_lambda(code);
check_stack_size(sc); /* lint+s7test.scm can overflow here */
gc_protect_2_via_stack(sc, sc->curlet, fx_call(sc, cdr(p))); /* this is needed even if one of the args is a symbol */
- set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), stack_protected2(sc)));
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), gc_protected2(sc)));
p = fx_call(sc, closure_body(f));
- set_curlet(sc, stack_protected1(sc));
+ set_curlet(sc, gc_protected1(sc));
unstack_gc_protect(sc);
return(p);
}
@@ -57129,7 +57272,7 @@ static int32_t fx_count(s7_scheme *sc, s7_pointer x)
return(count);
}
-static bool is_code_constant(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? (is_quote(car(p))) : is_constant(sc, p));}
+static bool is_code_constant(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? (is_quote(car(p))) : (!is_normal_symbol(p)));}
static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code);
@@ -57903,11 +58046,6 @@ static bool o_var_ok(const s7_pointer p, const s7_pointer var1, const s7_pointer
static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, const s7_pointer var1, const s7_pointer var2, const s7_pointer var3, bool unused_more_vars)
{
s7_pointer p = car(tree);
-#if 0
- if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p))))
- fprintf(stderr, "%s[%d] %s %s %s %d %d: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "",
- has_fx(tree), unused_more_vars, display(p));
-#endif
if (is_symbol(p))
{
if ((fx_proc(tree) == fx_s) || (fx_proc(tree) == fx_o))
@@ -57974,11 +58112,6 @@ static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, const s7_pointer var1, c
else
if ((fx_proc(tree) == fx_add_sqr_s) && (cadadr(p) == var1)) return(with_fx(tree, fx_add_sqr_T));
}}
-#if 0
- if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p))))
- fprintf(stderr, "%s[%d] %s %s %s %d %d: %s %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "",
- has_fx(tree), unused_more_vars, display(p), op_names[optimize_op(p)]);
-#endif
return(false);
}
@@ -57997,11 +58130,6 @@ static void fx_tree_outer(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_po
static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars)
{
s7_pointer p = car(tree);
-#if 0
- /* if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p)))) */
- fprintf(stderr, "fx_tree_in %s %s %s %s: %s, treed: %d\n", op_names[optimize_op(p)],
- display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", display_80(p), is_fx_treed(tree));
-#endif
if (is_symbol(p))
{
if (fx_proc(tree) == fx_s)
@@ -58657,11 +58785,6 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
}
break;
}
-#if 0
- if ((var3) && ((s7_tree_memq(sc, var1, car(tree))) || ((var2) && (s7_tree_memq(sc, var2, car(tree)))) || ((var3) && (s7_tree_memq(sc, var3, car(tree))))))
- fprintf(stderr, "fx_tree_in %s %s %s: %s %s\n",
- display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", display_80(car(tree)), op_names[optimize_op(car(tree))]);
-#endif
return(false);
}
@@ -58933,7 +59056,7 @@ static opt_info *alloc_opt_info(s7_scheme *sc)
static bool return_false_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line)
{
if (expr)
- fprintf(stderr, " %s[%d]: %s\n", func, line, display_80(expr));
+ fprintf(stderr, " %s[%d]: %s\n", func, line, display_truncated(expr));
else fprintf(stderr, " %s[%d]: false\n", func, line);
return(false);
}
@@ -58942,7 +59065,7 @@ static bool return_false_1(s7_scheme *sc, s7_pointer expr, const char *func, int
static bool return_true_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line)
{
if (expr)
- fprintf(stderr, " %s%s[%d]%s: %s\n", bold_text blue_text, func, line, unbold_text uncolor_text, display_80(expr));
+ fprintf(stderr, " %s%s[%d]%s: %s\n", bold_text blue_text, func, line, unbold_text uncolor_text, display_truncated(expr));
else fprintf(stderr, " %s%s[%d]%s: true\n", blue_text, func, line, uncolor_text);
return(true);
}
@@ -58957,7 +59080,7 @@ static s7_pfunc return_success_1(s7_scheme *sc, s7_pfunc p, s7_pointer expr, con
#define return_null(Sc, Expr) return(return_null_1(Sc, Expr, __func__, __LINE__))
static s7_pfunc return_null_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line)
{
- fprintf(stderr, " %s%s[%d]%s: %s\n %sfailure%s\n", bold_text, func, line, unbold_text, display_80(expr), bold_text red_text, unbold_text uncolor_text);
+ fprintf(stderr, " %s%s[%d]%s: %s\n %sfailure%s\n", bold_text, func, line, unbold_text, display_truncated(expr), bold_text red_text, unbold_text uncolor_text);
return(NULL);
}
#else
@@ -59664,7 +59787,7 @@ static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s
opc->v[0].fi = opt_i_piii_sssf_ivset_unchecked;
return_true(sc, NULL);
}}
- return_false(sc, NULL);
+ return_false(sc, valp);
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, indexp1))
@@ -59717,7 +59840,7 @@ static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_p
return_true(sc, NULL);
}
if (!int_optimize(sc, valp))
- return_false(sc, NULL);
+ return_false(sc, valp);
opc->v[0].fi = (opc->v[3].i_7pii_f == int_vector_set_i_7pii_direct) ? opt_i_7pii_ssf_vset : opt_i_7pii_ssf;
opc->v[4].o1 = sc->opts[start];
opc->v[5].fi = sc->opts[start]->v[0].fi;
@@ -59739,7 +59862,7 @@ static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_p
else opc->v[0].fi = opt_i_7pii_sff;
return_true(sc, NULL);
}}
- return_false(sc, NULL);
+ return_false(sc, valp);
}
if ((indexp2) &&
(vector_rank(vect) == 2))
@@ -60952,19 +61075,18 @@ static s7_double opt_d_dd_ff_o4(opt_info *o)
static s7_double opt_d_dd_ff_mul4(opt_info *o) {return(o->v[2].d_v_f(o->v[1].obj) * o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));}
-static s7_double opt_d_7pii_sss(opt_info *o);
-static s7_double opt_d_dd_ff_mul_sss(opt_info *o)
+static s7_double opt_d_dd_ff_mul_sss_unchecked(opt_info *o)
{
opt_info *o1 = o->v[8].o1;
s7_pointer v = slot_value(o1->v[1].p);
s7_int i1 = integer(slot_value(o1->v[2].p));
s7_int i2 = integer(slot_value(o1->v[3].p));
- s7_double x1 = float_vector_ref_d_7pii(o1->sc, v, i1, i2);
+ s7_double x1 = float_vector(v, (i1 * vector_offset(v, 0)) + i2);
o1 = o->v[10].o1;
v = slot_value(o1->v[1].p);
i1 = integer(slot_value(o1->v[2].p)); /* in (* (A i j) (B j k)) we could reuse i2->i1 (flipping args below) */
i2 = integer(slot_value(o1->v[3].p));
- return(x1 * float_vector_ref_d_7pii(o1->sc, v, i1, i2));
+ return(x1 * float_vector(v, (i1 * vector_offset(v, 0)) + i2));
}
static bool finish_dd_fso(opt_info *opc, opt_info *o1, opt_info *o2)
@@ -61110,6 +61232,8 @@ static bool d_dd_call_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
}
static s7_double opt_d_7pii_scs(opt_info *o);
+static s7_double opt_d_7pii_sss(opt_info *o);
+static s7_double opt_d_7pii_sss_unchecked(opt_info *o);
static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -61285,9 +61409,9 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (arg1 == arg2)
opc->v[0].fd = opt_d_dd_ff_square;
else
- if ((opc->v[9].fd == opt_d_7pii_sss) && (opc->v[11].fd == opt_d_7pii_sss) &&
- (o1->v[4].d_7pii_f == float_vector_ref_d_7pii)) /* currently redundant */
- opc->v[0].fd = opt_d_dd_ff_mul_sss;
+ if ((opc->v[9].fd == opt_d_7pii_sss_unchecked) && (opc->v[11].fd == opt_d_7pii_sss_unchecked) &&
+ (o1->v[4].d_7pii_f == float_vector_ref_d_7pii))
+ opc->v[0].fd = opt_d_dd_ff_mul_sss_unchecked;
else opc->v[0].fd = opt_d_dd_ff_mul;
return_true(sc, car_x);
}
@@ -61881,7 +62005,7 @@ static bool d_7piiid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin
if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_set_symbol))
return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x), cdr(cddddr(car_x))));
}
- return(false);
+ return_false(sc, car_x);
}
static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer indexp3, s7_pointer valp)
@@ -61894,7 +62018,7 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_
int32_t start = sc->pc;
opc->v[1].p = settee;
if (!is_float_vector(vect))
- return_false(sc, NULL);
+ return_false(sc, vect);
opc->v[10].o1 = sc->opts[start];
if ((!indexp2) &&
(vector_rank(vect) == 1))
@@ -61939,7 +62063,7 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_
opc->v[9].fd = opc->v[8].o1->v[0].fd;
return_true(sc, NULL);
}}
- return_false(sc, NULL);
+ return_false(sc, indexp1);
}
if ((indexp2) && (!indexp3) &&
(vector_rank(vect) == 2))
@@ -61955,7 +62079,7 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_
if (is_t_integer(car(indexp1)))
{
if (!float_optimize(sc, valp))
- return_false(sc, NULL);
+ return_false(sc, valp);
opc->v[0].fd = opt_d_7piid_scsf;
opc->v[2].i = integer(car(indexp1));
opc->v[11].fd = opc->v[10].o1->v[0].fd;
@@ -61998,7 +62122,7 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_
opc->v[4].fd = opc->v[3].o1->v[0].fd;
return_true(sc, NULL);
}}}
- return_false(sc, NULL);
+ return_false(sc, indexp1);
}
if ((indexp3) &&
(vector_rank(vect) == 3))
@@ -62782,13 +62906,6 @@ static void check_b_types(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po
opc->v[0].fb = fb;
opc->v[3].b_pp_f = s7_b_pp_unchecked_function(s_func);
}}
-#if 0
- if ((arg2_type == sc->is_integer_symbol) && s7_b_pi_function(s_func))
- {
- /* opc->v[0].fb = opt_b_pi */
- fprintf(stderr, " pi: %s\n", display(car_x));
- }
-#endif
}
static s7_pointer opt_p_c(opt_info *o);
@@ -63267,6 +63384,9 @@ static s7_pointer opt_p_p_s_iterate(opt_info *o) {return(iterate_p_p(o->sc, slot
static s7_pointer opt_p_p_f_iterate(opt_info *o) {return(iterate_p_p(o->sc, o->v[4].fp(o->v[3].o1)));}
static s7_pointer opt_p_p_f_string_to_number(opt_info *o) {return(string_to_number_p_p(o->sc, o->v[4].fp(o->v[3].o1)));}
static s7_pointer opt_p_p_s_iterate_unchecked(opt_info *o) {s7_pointer iter = slot_value(o->v[1].p); return(iterator_next(iter)(o->sc, iter));}
+/* string_iterate built-in here if iterator_sequence is a string is about 12% faster, but currently we can have an unchecked iterator
+ * that changes sequence type (via (set! L1 L2) where L1 and L2 are both iterators)
+ */
static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o);
static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o);
@@ -63804,7 +63924,7 @@ static s7_pointer opt_p_pp_ff(opt_info *o)
s7_scheme *sc = o->sc;
s7_pointer result;
gc_protect_2_via_stack_no_let(sc, o->v[11].fp(o->v[10].o1), o->v[9].fp(o->v[8].o1)); /* we do need to protect both */
- result = o->v[3].p_pp_f(sc, stack_protected1(sc), stack_protected2(sc));
+ result = o->v[3].p_pp_f(sc, gc_protected1(sc), gc_protected2(sc));
unstack_gc_protect(sc);
return(result);
}
@@ -63830,10 +63950,10 @@ static s7_pointer opt_p_pp_ff_add_mul_mul_1(opt_info *o, bool add_case) /* (+|-
gc_protect_via_stack_no_let(sc, f2);
f4 = o2->v[5].fp(o2->v[4].o1);
}
- set_stack_protected2(sc, f4);
- set_stack_protected2(sc, multiply_p_pp(sc, s3, f4));
- set_stack_protected1(sc, multiply_p_pp(sc, s1, f2));
- s3 = (add_case) ? add_p_pp(sc, stack_protected1(sc), stack_protected2(sc)) : subtract_p_pp(sc, stack_protected1(sc), stack_protected2(sc));
+ set_gc_protected2(sc, f4);
+ set_gc_protected2(sc, multiply_p_pp(sc, s3, f4));
+ set_gc_protected1(sc, multiply_p_pp(sc, s1, f2));
+ s3 = (add_case) ? add_p_pp(sc, gc_protected1(sc), gc_protected2(sc)) : subtract_p_pp(sc, gc_protected1(sc), gc_protected2(sc));
unstack_gc_protect(sc);
return(s3);
}
@@ -64040,7 +64160,7 @@ static s7_pointer opt_p_call_ff(opt_info *o)
s7_scheme *sc = o->sc;
gc_protect_via_stack_no_let(sc, o->v[11].fp(o->v[10].o1));
po2 = o->v[9].fp(o->v[8].o1);
- po2 = o->v[3].call(sc, set_plist_2(sc, stack_protected1(sc), po2));
+ po2 = o->v[3].call(sc, set_plist_2(sc, gc_protected1(sc), po2));
unstack_gc_protect(sc);
return(po2);
}
@@ -64415,7 +64535,7 @@ static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_po
opc->v[0].fp = opt_p_piip_sfff;
return_true(sc, NULL);
}}}
- return_false(sc, NULL);
+ return_false(sc, indexp1);
}
static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
@@ -64552,7 +64672,7 @@ static s7_pointer opt_p_ppp_sff(opt_info *o)
s7_pointer res;
s7_scheme *sc = o->sc;
gc_protect_2_via_stack_no_let(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1)));
- res = o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), stack_protected1(sc), stack_protected2(sc));
+ res = o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), gc_protected1(sc), gc_protected2(sc));
unstack_gc_protect(sc);
return(res);
}
@@ -64562,7 +64682,7 @@ static s7_pointer opt_p_ppp_fff(opt_info *o)
s7_pointer res;
s7_scheme *sc = o->sc;
gc_protect_2_via_stack_no_let(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1)));
- res = o->v[3].p_ppp_f(sc, stack_protected1(sc), stack_protected2(sc), o->v[5].fp(o->v[4].o1));
+ res = o->v[3].p_ppp_f(sc, gc_protected1(sc), gc_protected2(sc), o->v[5].fp(o->v[4].o1));
unstack_gc_protect(sc);
return(res);
}
@@ -64805,7 +64925,7 @@ static s7_pointer opt_p_call_ppp(opt_info *o)
s7_scheme *sc = o->sc;
gc_protect_2_via_stack_no_let(sc, o->v[4].fp(o->v[3].o1), o->v[6].fp(o->v[5].o1));
res = o->v[11].fp(o->v[10].o1); /* not combinable into next */
- res = o->v[2].call(sc, set_plist_3(sc, stack_protected1(sc), stack_protected2(sc), res));
+ res = o->v[2].call(sc, set_plist_3(sc, gc_protected1(sc), gc_protected2(sc), res));
unstack_gc_protect(sc);
return(res);
}
@@ -65179,6 +65299,24 @@ static s7_pointer opt_set_p_p_f_with_setter(opt_info *o)
return(x);
}
+static s7_pointer opt_set_input_port_string_p_p_f(opt_info *o)
+{
+ s7_pointer x = o->v[4].fp(o->v[3].o1); /* the string */
+ s7_pointer port = slot_value(o->v[2].p);
+ if (!is_input_port(port)) wrong_type_error_nr(o->sc, o->sc->port_string_symbol, 1, port, an_input_port_string);
+ set_input_port_string(o->sc, port, x);
+ return(x);
+}
+
+static s7_pointer opt_set_output_port_string_p_p_f(opt_info *o)
+{
+ s7_pointer x = o->v[4].fp(o->v[3].o1); /* the string */
+ s7_pointer port = slot_value(o->v[2].p);
+ if (!is_output_port(port)) wrong_type_error_nr(o->sc, o->sc->port_string_symbol, 1, port, an_input_port_string);
+ set_output_port_string(o->sc, port, x);
+ return(x);
+}
+
static s7_pointer opt_set_p_i_s(opt_info *o)
{
s7_pointer val = slot_value(o->v[2].p);
@@ -65416,7 +65554,7 @@ static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer
return_false(sc, car_x);
}
-static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_syntax) */
+static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_syntax_ok) */
{
opt_info *opc = alloc_opt_info(sc);
s7_pointer target = cadr(car_x);
@@ -65543,8 +65681,29 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
obj = slot_value(s_slot);
opc->v[1].p = s_slot;
+
if (!is_mutable_sequence(obj))
- return_false(sc, car_x);
+ {
+ /* a ridiculous experiment... */
+ if ((car(target) == sc->port_string_symbol) &&
+ (obj == initial_value(car(target))) &&
+ (is_normal_symbol(cadr(target))) &&
+ (opt_arg_type(sc, cddr(car_x)) == sc->is_string_symbol))
+ {
+ s7_pointer port_type = opt_arg_type(sc, cdr(target));
+ if ((port_type == sc->is_input_port_symbol) || (port_type == sc->is_output_port_symbol))
+ {
+ int32_t start_pc = sc->pc;
+ opc->v[2].p = s7_slot(sc, cadr(target));
+ if ((is_slot(opc->v[2].p)) && (is_string_port(slot_value(opc->v[2].p))) && (cell_optimize(sc, cddr(car_x))))
+ {
+ opc->v[3].o1 = sc->opts[start_pc];
+ opc->v[4].fp = sc->opts[start_pc]->v[0].fp;
+ opc->v[0].fp = (port_type == sc->is_input_port_symbol) ? opt_set_input_port_string_p_p_f : opt_set_output_port_string_p_p_f;
+ return_true(sc, car_x);
+ }}}
+ return_false(sc, car_x);
+ }
index = cadr(target);
index_type = opt_arg_type(sc, cdr(target));
@@ -67519,7 +67678,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
return_true(sc, car_x);
}
-static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len)
+static bool p_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
s7_pointer func = lookup_global(sc, car(car_x));
opcode_t op;
@@ -67873,7 +68032,7 @@ static bool cell_optimize_1(s7_scheme *sc, s7_pointer expr)
{
if ((is_syntactic_symbol(head)) ||
(is_syntactic_pair(car_x))) /* this can be wrong! */
- return(p_syntax(sc, car_x, len));
+ return(p_syntax_ok(sc, car_x, len));
s_slot = s7_slot(sc, head);
if (!is_slot(s_slot)) return_false(sc, car_x);
@@ -68057,9 +68216,9 @@ static bool bool_optimize(s7_scheme *sc, s7_pointer expr)
sc->pc = start;
wrapper = sc->opts[start];
if (!cell_optimize(sc, expr))
- return_false(sc, NULL);
+ return_false(sc, expr);
if (wrapper->v[O_WRAP].fp) /* (when (+ i 1) ...) */
- return_false(sc, NULL);
+ return_false(sc, expr);
wrapper->v[O_WRAP].fp = wrapper->v[0].fp;
wrapper->v[0].fb = p_to_b;
return_true(sc, expr);
@@ -68080,19 +68239,19 @@ s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr)
sc->pc = 0;
if ((float_optimize(sc, expr)) && (sc->pc < OPTS_SIZE))
return(opt_float_any);
- return(NULL);
+ return(NULL); /* can't return_null(sc, expr) here due to type mismatch (s7_pfunc vs s7_float_function) */
}
static s7_pfunc s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nv)
{
if (WITH_GMP) return(NULL);
if ((!is_pair(expr)) || (no_cell_opt(expr)) || (sc->debug != 0))
- return(NULL);
+ return_null(sc, expr);
sc->pc = 0;
if (!no_int_opt(expr))
{
if (int_optimize(sc, expr))
- return((nv) ? opt_int_any_nv : opt_make_int);
+ return_success(sc, (nv) ? opt_int_any_nv : opt_make_int, expr);
sc->pc = 0;
set_no_int_opt(expr);
}
@@ -68116,7 +68275,7 @@ static s7_pfunc s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nv)
return_null(sc, expr);
}
-s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, false));}
+s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, false));}
static s7_pfunc s7_optimize_nv(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, true));}
static s7_pointer g_optimize(s7_scheme *sc, s7_pointer args)
@@ -68290,7 +68449,7 @@ static void fb_annotate(s7_scheme *sc, s7_pointer form, s7_pointer fx_expr, opco
/* fb_annotate additions? [these currently require new "B" ops] */
else
{
- fprintf(stderr, "fx: %s %s\n", ((is_pair(fx_expr)) && (is_pair(car(fx_expr)))) ? op_names[optimize_op(car(fx_expr))] : "", display_80(fx_expr));
+ fprintf(stderr, "fx: %s %s\n", ((is_pair(fx_expr)) && (is_pair(car(fx_expr)))) ? op_names[optimize_op(car(fx_expr))] : "", display_truncated(fx_expr));
if (caar(fx_expr) == sc->num_eq_symbol) abort();
/* [fx_leq_ti] fx_lt_t0 fx_gt_ti fx_num_eq_u0 */
}
@@ -68490,7 +68649,7 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq
if (!is_mappable(seq))
wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string);
seq = s7_make_iterator(sc, seq);
- set_stack_protected2_with(sc, seq, OP_MAP_UNWIND); /* GC protect new iterator */
+ set_map_iterator(sc, seq); /* GC protect new iterator */
}
/* push_stack_no_let(sc, OP_GC_PROTECT, seq, f); */
if (func == opt_cell_any_nv)
@@ -68559,7 +68718,7 @@ static void map_or_for_each_closure_pair_2(s7_scheme *sc, s7_pfunc func, s7_poin
{
s7_pointer val = func(sc);
if (val != sc->no_value)
- set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); /* see map_closure_2 below -- stack_protected3 is our temp */
+ set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); /* see map_closure_2 below -- gc_protected3 is our temp */
}
if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2))))
{
@@ -68575,7 +68734,7 @@ static void map_or_for_each_closure_pair_2(s7_scheme *sc, s7_pfunc func, s7_poin
{
s7_pointer val = func(sc);
if (val != sc->no_value)
- set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND);
+ set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc)));
}}}
}
@@ -68593,7 +68752,7 @@ static void map_or_for_each_closure_vector_2(s7_scheme *sc, s7_pfunc func, s7_po
{
s7_pointer val = func(sc);
if (val != sc->no_value)
- set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND);
+ set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc)));
}}
}
@@ -68612,7 +68771,7 @@ static void map_or_for_each_closure_string_2(s7_scheme *sc, s7_pfunc func, s7_po
{
s7_pointer val = func(sc);
if (val != sc->no_value)
- set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND);
+ set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc)));
}}
}
@@ -68983,77 +69142,77 @@ static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /*
sc->map_call_ctr++;
if (is_pair(seq))
{
- set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND);
+ set_map_unwind_list(sc, sc->nil);
for (s7_pointer fast = seq, slow = seq; is_pair(fast); fast = cdr(fast), slow = cdr(slow))
{
slot_set_value(slot, car(fast));
z = func(sc);
- if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND);
+ if (z != sc->no_value) set_map_unwind_list(sc, cons(sc, z, map_unwind_list(sc)));
if (is_pair(cdr(fast)))
{
fast = cdr(fast);
if (fast == slow) break;
slot_set_value(slot, car(fast));
z = func(sc);
- if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND);
+ if (z != sc->no_value) set_map_unwind_list(sc, cons(sc, z, map_unwind_list(sc)));
}}
- res = proper_list_reverse_in_place(sc, stack_protected3(sc));
+ res = proper_list_reverse_in_place(sc, map_unwind_list(sc));
}
else
if (is_float_vector(seq))
{
s7_double *vals = float_vector_floats(seq);
s7_int len = vector_length(seq);
- set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND);
+ set_map_unwind_list(sc, sc->nil);
for (s7_int i = 0; i < len; i++)
{
slot_set_value(slot, make_real(sc, vals[i]));
z = func(sc);
- if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND);
+ if (z != sc->no_value) set_map_unwind_list(sc, cons(sc, z, map_unwind_list(sc)));
}
- res = proper_list_reverse_in_place(sc, stack_protected3(sc));
+ res = proper_list_reverse_in_place(sc, map_unwind_list(sc));
}
else
if (is_int_vector(seq))
{
s7_int *vals = int_vector_ints(seq);
s7_int len = vector_length(seq);
- set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND);
+ set_map_unwind_list(sc, sc->nil);
for (s7_int i = 0; i < len; i++)
{
slot_set_value(slot, make_integer(sc, vals[i]));
z = func(sc);
- if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND);
+ if (z != sc->no_value) set_map_unwind_list(sc, cons(sc, z, map_unwind_list(sc)));
}
- res = proper_list_reverse_in_place(sc, stack_protected3(sc));
+ res = proper_list_reverse_in_place(sc, map_unwind_list(sc));
}
else
if (is_t_vector(seq))
{
s7_pointer *vals = vector_elements(seq);
s7_int len = vector_length(seq);
- set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND);
+ set_map_unwind_list(sc, sc->nil);
for (s7_int i = 0; i < len; i++)
{
slot_set_value(slot, vals[i]);
z = func(sc);
- if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND);
+ if (z != sc->no_value) set_map_unwind_list(sc, cons(sc, z, map_unwind_list(sc)));
}
- res = proper_list_reverse_in_place(sc, stack_protected3(sc));
+ res = proper_list_reverse_in_place(sc, map_unwind_list(sc));
}
else
if (is_string(seq))
{
s7_int len = string_length(seq);
const char *str = string_value(seq);
- set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND);
+ set_map_unwind_list(sc, sc->nil);
for (s7_int i = 0; i < len; i++)
{
slot_set_value(slot, chars[(uint8_t)(str[i])]);
z = func(sc);
- if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND);
+ if (z != sc->no_value) set_map_unwind_list(sc, cons(sc, z, map_unwind_list(sc)));
}
- res = proper_list_reverse_in_place(sc, stack_protected3(sc));
+ res = proper_list_reverse_in_place(sc, map_unwind_list(sc));
}
sc->map_call_ctr--;
unstack_with(sc, OP_MAP_UNWIND);
@@ -69121,23 +69280,23 @@ static s7_pointer g_map_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1,
sc->map_call_ctr++;
if ((is_pair(seq1)) && (is_pair(seq2)))
{
- set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND);
- map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, false); /* builds result on stack_protected3 */
- res = proper_list_reverse_in_place(sc, stack_protected3(sc));
+ set_map_unwind_list(sc, sc->nil);
+ map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, false); /* builds result on gc_protected3 */
+ res = proper_list_reverse_in_place(sc, map_unwind_list(sc));
}
else
if ((is_any_vector(seq1)) && (is_any_vector(seq2)))
{
- set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND);
+ set_map_unwind_list(sc, sc->nil);
map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, false);
- res = proper_list_reverse_in_place(sc, stack_protected3(sc));
+ res = proper_list_reverse_in_place(sc, map_unwind_list(sc));
}
else
if ((is_string(seq1)) && (is_string(seq2)))
{
- set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND);
+ set_map_unwind_list(sc, sc->nil);
map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, false);
- res = proper_list_reverse_in_place(sc, stack_protected3(sc));
+ res = proper_list_reverse_in_place(sc, map_unwind_list(sc));
}
sc->map_call_ctr--;
unstack_with(sc, OP_MAP_UNWIND);
@@ -69361,7 +69520,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table
if ((!is_pair(f)) &&
(!s7_is_aritable(sc, f, len)))
error_nr(sc, sc->wrong_number_of_args_symbol,
- set_elist_4(sc, wrap_string(sc, "map ~A: ~D argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len)));
+ set_elist_4(sc, wrap_string(sc, "map: ~D argument~P for ~A?", 26), wrap_integer(sc, len), wrap_integer(sc, len), f));
if (got_nil) return(sc->nil);
break;
}
@@ -69738,7 +69897,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
s7_pointer x;
if (SHOW_EVAL_OPS)
safe_print(fprintf(stderr, " %s[%d]: splice %s %s\n", __func__, __LINE__,
- (sc->stack_end > sc->stack_start) ? op_names[stack_top_op(sc)] : "no stack!", display_80(args)));
+ (sc->stack_end > sc->stack_start) ? op_names[stack_top_op(sc)] : "no stack!", display_truncated(args)));
if ((S7_DEBUGGING) && ((is_null(args)) || (is_null(cdr(args))))) fprintf(stderr, "%s: %s\n", __func__, display(args));
switch (unchecked_stack_top_op(sc)) /* unchecked for C s7_values call at top-level -- see ffitest.c */
@@ -69960,7 +70119,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
opcode_t s_op = stack_top4_op(sc);
if ((S7_DEBUGGING) && (SHOW_EVAL_OPS))
fprintf(stderr, " eval_macro_mv splice %s with %s, code: %s, args: %s, value: %s\n",
- display_80(args), op_names[s_op], display_80(sc->code), display_80(sc->args), display_80(sc->value));
+ display_truncated(args), op_names[s_op], display_truncated(sc->code), display_truncated(sc->args), display_truncated(sc->value));
if ((s_op == OP_DO_STEP) || (s_op == OP_DEACTIVATE_GOTO) || (s_op == OP_LET1))
return(args); /* tricky reader-cond as macro in do body returning values... or call-with-exit */
@@ -69976,8 +70135,8 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
sc->w = sc->unused;
if (SHOW_EVAL_OPS)
fprintf(stderr, " eval_macro splice %s with %s, code: %s, args: %s, value: %s -> %s %s\n",
- display_80(args), op_names[s_op], display_80(sc->code), display_80(sc->args),
- display_80(sc->value), display_80(stack_top4_args(sc)), display_80(car(x)));
+ display_truncated(args), op_names[s_op], display_truncated(sc->code), display_truncated(sc->args),
+ display_truncated(sc->value), display_truncated(stack_top4_args(sc)), display_truncated(car(x)));
return(car(x));
}
/* else fall through */
@@ -69996,7 +70155,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
*/
if (SHOW_EVAL_OPS)
fprintf(stderr, " %s[%d]: %s stack top: %" ld64 ", op: %s, args: %s\n", __func__, __LINE__,
- op_names[stack_top_op(sc)], (s7_int)(intptr_t)stack_top(sc), op_names[stack_top4_op(sc)], display_80(args));
+ op_names[stack_top_op(sc)], (s7_int)(intptr_t)stack_top(sc), op_names[stack_top4_op(sc)], display_truncated(args));
if (stack_top4_op(sc) == OP_LOAD_RETURN_IF_EOF)
{
/* expansion at top-level returned values, eval args in order */
@@ -70901,7 +71060,8 @@ static void fx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e)
static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e)
{
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, e: %s\n", __func__, __LINE__, display_80(expr), display(func), hop, display_80(e));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, e: %s\n",
+ __func__, __LINE__, display_truncated(expr), display(func), hop, display_truncated(e));
if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) hop = 1;
if ((is_closure(func)) || (is_closure_star(func)))
@@ -71236,7 +71396,7 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin
s7_pointer arg1 = cadr(expr);
bool func_is_safe = is_safe_procedure(func);
if (hop == 0) hop = hop_if_constant(sc, car(expr));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %d %d\n", __func__, __LINE__, display_80(expr), func_is_safe, pairs);
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %d %d\n", __func__, __LINE__, display_truncated(expr), func_is_safe, pairs);
if (pairs == 0)
{
if (func_is_safe) /* safe c function */
@@ -71552,7 +71712,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu
{
s7_pointer arg1;
if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad_pairs: %d, e: %s\n",
- __func__, __LINE__, display_80(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_80(e));
+ __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(e));
/* very often, expr is already optimized, quoted stuff is counted under "bad_pairs"! as well as quotes */
if (quotes > 0)
{
@@ -71753,7 +71913,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad_pairs: %d, e: %s\n",
- __func__, __LINE__, display_80(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_80(e));
+ __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(e));
if (quotes > 0)
{
if (direct_memq(sc->quote_symbol, e))
@@ -73014,7 +73174,8 @@ static bool vars_syntax_ok(s7_pointer vars)
s7_pointer var = car(p);
if ((!is_pair(var)) ||
(!is_symbol(car(var))) ||
- (!is_pair(cdr(var))))
+ (!is_pair(cdr(var))) ||
+ (is_pair(cddr(var))))
return(false);
}
return(true);
@@ -73026,14 +73187,24 @@ static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer
{
for (s7_pointer p = vars; is_pair(p); p = cdr(p))
{
+#if 0
s7_pointer var = car(p);
s7_pointer init = cadr(var);
/* if ((is_slot(global_slot(car(var)))) && (is_c_function(global_value(car(var))))) return(false); */ /* too draconian (see snd-test) */
if ((is_normal_symbol(car(var))) && (is_global(car(var)))) /* (define (f) (let ((+ -)) (with-let (curlet) (#_integer? (+))))) (f) */
{
+ /* fprintf(stderr, "set %s local in %s\n", display(car(var)), display_truncated(vars)); */
set_local(car(var));
return(false);
}
+ /* also too draconian (tall for example) but +/- above is broken now (returns #t)
+ * perhaps set_local could be undone upon leaving the let if there's no capture possible:
+ * for each here, save full type, add to list, set_local, then when let opt is done, reset to outside type
+ * would need lists of such lists following the let chain
+ */
+#else
+ s7_pointer init = cadar(p);
+#endif
if ((is_pair(init)) &&
(!is_checked(init)) &&
(optimize_expression(sc, init, hop, e, false) == OPT_OOPS))
@@ -73047,7 +73218,7 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
opcode_t op = syntax_opcode(func);
s7_pointer body = cdr(expr), vars;
bool body_export_ok = true;
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_80(expr));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(expr));
sc->w = e;
switch (op)
@@ -73534,7 +73705,7 @@ static opt_t optimize_funcs(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
{
int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0;
s7_pointer p;
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, func: %s\n", __func__, __LINE__, display_80(expr), display(func));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, func: %s\n", __func__, __LINE__, display_truncated(expr), display(func));
for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the args (the calling expression) */
{
s7_pointer car_p = car(p);
@@ -75557,7 +75728,7 @@ static void mark_fx_treeable(s7_scheme *sc, s7_pointer body)
static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer args, s7_pointer body)
{ /* func is either sc->unused or a symbol */
s7_int len = s7_list_length(sc, body);
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_80(body));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(body));
if (len < 0) /* (define (hi) 1 . 2) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "~A: function body messed up, ~A", 31),
@@ -75782,14 +75953,14 @@ static s7_pointer check_case(s7_scheme *sc)
s7_pointer y, car_x;
if (!is_pair(car(x)))
error_nr(sc, sc->syntax_error_symbol,
- set_elist_3(sc, wrap_string(sc, "case clause ~S messed up in ~A", 30),
- x, object_to_truncated_string(sc, form, 80)));
+ set_elist_3(sc, wrap_string(sc, "case clause ~S messed up in ~A", sc->print_length),
+ x, object_to_string_truncated(sc, form)));
car_x = car(x);
if (!is_list(cdr(car_x))) /* (case 1 ((1))) */
error_nr(sc, sc->syntax_error_symbol,
- set_elist_3(sc, wrap_string(sc, "case clause result ~S is messed up in ~A", 40),
- car_x, object_to_truncated_string(sc, form, 80)));
+ set_elist_3(sc, wrap_string(sc, "case clause result ~S is messed up in ~A", sc->print_length),
+ car_x, object_to_string_truncated(sc, form)));
if ((bodies_simple) &&
((is_null(cdr(car_x))) || (!is_null(cddr(car_x)))))
bodies_simple = false;
@@ -75803,7 +75974,7 @@ static s7_pointer check_case(s7_scheme *sc)
(s7_symbol_value(sc, y) != sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) ... */
error_nr(sc, sc->syntax_error_symbol,
set_elist_4(sc, wrap_string(sc, "case clause key-list ~S in ~S is not a proper list or 'else', in ~A", 67),
- y, car_x, object_to_truncated_string(sc, form, 80)));
+ y, car_x, object_to_string_truncated(sc, form)));
has_else = true;
if (is_not_null(cdr(x))) /* (case 1 (else 1) ((2) 1)) */
syntax_error_nr(sc, "case 'else' clause is not the last clause: ~S", 45, x);
@@ -75841,24 +76012,24 @@ static s7_pointer check_case(s7_scheme *sc)
if (!is_null(y)) /* (case () ((1 . 2) . hi) . hi) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "case key list ~S is improper, in ~A", 35),
- car_x, object_to_truncated_string(sc, form, 80)));
+ car_x, object_to_string_truncated(sc, form)));
}
y = car_x;
if (!s7_is_proper_list(sc, cdr(y))) /* (case 2 ((1 2) 1 . 2)) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "case: stray dot? ~S in ~A", 25),
- y, object_to_truncated_string(sc, form, 80)));
+ y, object_to_string_truncated(sc, form)));
if ((is_pair(cdr(y))) && (is_undefined_feed_to(sc, cadr(y))))
{
has_feed_to = true;
if (!is_pair(cddr(y))) /* (case 1 (else =>)) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "case: '=>' target missing: ~S in ~A", 35),
- y, object_to_truncated_string(sc, form, 80)));
+ y, object_to_string_truncated(sc, form)));
if (is_pair(cdddr(y))) /* (case 1 (else => + - *)) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "case: '=>' has too many targets: ~S in ~A", 41),
- y, object_to_truncated_string(sc, form, 80)));
+ y, object_to_string_truncated(sc, form)));
}}
if (is_not_null(x)) /* (case x ((1 2)) . 1) */
syntax_error_nr(sc, "case: stray dot? ~S", 19, form);
@@ -76386,17 +76557,17 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */
if ((!is_pair(carx)) || (is_null(cdr(carx)))) /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "let variable declaration, but no value?: ~A in ~A", 49),
- x, object_to_truncated_string(sc, form, 80)));
+ x, object_to_string_truncated(sc, form)));
if (!(is_pair(cdr(carx)))) /* (let ((x . 1))...) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, is not a proper list in ~A", 56),
- x, object_to_truncated_string(sc, form, 80)));
+ x, object_to_string_truncated(sc, form)));
if (is_not_null(cddr(carx))) /* (let ((x 1 2 3)) ...) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, has more than one value in ~A", 59),
- x, object_to_truncated_string(sc, form, 80)));
+ x, object_to_string_truncated(sc, form)));
y = car(carx);
if (!(is_symbol(y)))
{
@@ -76410,7 +76581,7 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */
error_nr(sc, sc->syntax_error_symbol,
set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let (it is ~A, not a symbol) in ~A", 58),
y, object_type_name(sc, y),
- object_to_truncated_string(sc, form, 80)));
+ object_to_string_truncated(sc, form)));
}
if (is_constant_symbol(sc, y))
error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, x));
@@ -76514,10 +76685,14 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */
return(code);
}
-static bool op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in decl order */
-{
+/* rather than two lists (pars and code+vals), build let+slot list + original form in par order? (need let for GC)
+ * keep let + form on stack (and form locally)
+ */
+
+static void op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in decl order */
+{ /* sc->code = (name vars . body), args = vals in decl order */
s7_pointer body = cddr(sc->code), x;
- s7_int n = opt2_int(sc->code);
+ s7_int n = opt2_int(sc->code); /* num pars, see check_named_let called in check_let */
for (x = cadr(sc->code), sc->w = sc->nil; is_pair(x); x = cdr(x))
{
sc->w = cons(sc, caar(x), sc->w);
@@ -76525,108 +76700,77 @@ static bool op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in dec
if (!is_pair(x)) break;
sc->w = cons_unchecked(sc, caar(x), sc->w);
}
- sc->w = proper_list_reverse_in_place(sc, sc->w); /* init values (args) are also in "reversed" order */
+ sc->w = proper_list_reverse_in_place(sc, sc->w); /* needed for closure_args list as well as inner let names */
set_curlet(sc, make_let(sc, sc->curlet));
- sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, n);
+ sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, n); /* n = num pars */
add_slot(sc, sc->curlet, car(sc->code), sc->x);
set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */
- for (x = sc->w; is_not_null(args); x = cdr(x)) /* reuse the value cells as the new let slots */
- {
- s7_pointer sym = car(x), new_args = cdr(args);
- reuse_as_slot(args, sym, unchecked_car(args)); /* args=slot, sym=symbol, car(args)=value */
- slot_set_next(args, let_slots(sc->curlet));
- let_set_slots(sc->curlet, args);
- symbol_set_local_slot(sym, let_id(sc->curlet), args);
- args = new_args;
- }
+ for (x = sc->w; is_not_null(args); x = cdr(x), args = cdr(args))
+ add_slot_unchecked_with_id(sc, sc->curlet, car(x), unchecked_car(args));
+
closure_set_let(sc->x, sc->curlet);
let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet)));
sc->x = sc->unused;
sc->code = T_Pair(body);
sc->w = sc->unused;
- return(true);
}
-static bool op_let1(s7_scheme *sc)
-{
- s7_pointer x, y, e;
- uint64_t id;
- /* building a list, then reusing it below as the let/slots seems stupid, but if we make the let first, and
- * add slots, there are other problems. The let/slot ids (and symbol_set_local_slot) need to wait
- * until the args are evaluated, if an arg invokes call/cc, the let on the stack needs to be copied
- * including let_dox_code if it is used to save sc->code (there are 3 things that need to be protected),
- * (we win currently because copy_stack copies the list), and make-circular-iterator if called twice (s7test)
- * hangs -- I can't see why! Otherwise, the let/slots approach is slightly faster (less than 1% however).
+#define NEWLET 0
+#define NEWLET_PRINT 0
+
+static bool op_let_1(s7_scheme *sc)
+{ /* op_let form: (let ((i 0) (j 1)) (+ i j)), code: ((i 0) (j 1)), value: (((i 0) (j 1)) (+ i j)), args: ()
+ * op_named_let: (let loop ((i 0)) (if (< i 3) (loop (+ i 1)) i)), code: ((i 0)), value: (loop ((i 0)) (if (< i 3) (loop (+ i 1)) i)), args: ()
+ * eval->op_let_unchecked: (let ((i (catch #t (lambda () 1) (lambda (t i) 'error))) (j 2)) (+ i j))) (in a function),
+ * code: ((j 2)), value: 1, args: ((((i (catch #t (lambda () 1) (lambda (t i) 'error))) (j 2)) (+ i j)))
*/
+ s7_pointer y;
+ uint64_t id;
while (true)
{
sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code))
{
- x = cdar(sc->code);
+ s7_pointer x = cdar(sc->code);
if (has_fx(x))
- {
-#if S7_DEBUGGING
- s7_pointer old_args = sc->args;
-#endif
- sc->value = fx_call(sc, x);
-#if S7_DEBUGGING
- if (sc->args != old_args)
- {
- fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(old_args), display(sc->args));
- gdb_break();
- }
-#endif
- }
+ sc->value = fx_call(sc, x);
else
{
check_stack_size(sc);
push_stack(sc, OP_LET1, sc->args, cdr(sc->code));
sc->code = car(x);
- return(false);
+ return(false); /* goto EVAL */
}
sc->code = cdr(sc->code);
}
else break;
}
- x = proper_list_reverse_in_place(sc, sc->args);
- sc->code = car(x); /* restore the original form */
- y = cdr(x); /* use sc->args as the new let */
+
+ sc->args = proper_list_reverse_in_place(sc, sc->args);
+ sc->code = car(sc->args); /* restore the original form */
+ y = cdr(sc->args);
sc->temp8 = y;
- set_curlet(sc, reuse_as_let(sc, x, T_Let(sc->curlet)));
+ free_cell(sc, sc->args);
+ set_curlet(sc, make_let(sc, T_Let(sc->curlet)));
if (is_symbol(car(sc->code)))
- return(op_named_let_1(sc, y)); /* inner let here */
+ {
+ op_named_let_1(sc, y); /* inner let here */
+ return(true);
+ }
- e = sc->curlet;
- id = let_id(e);
+ id = let_id(sc->curlet);
if (is_pair(y))
{
- s7_pointer sym, args = cdr(y), sp;
- x = car(sc->code);
- sym = caar(x);
- reuse_as_slot(y, sym, unchecked_car(y)); /* if car(y) is a multiple value, should we clear it? How did it get there? */
- symbol_set_local_slot(sym, id, y);
- let_set_slots(e, y);
- sp = y;
- y = args;
-
- for (x = cdr(x); is_not_null(y); x = cdr(x))
- {
- sym = caar(x);
- args = cdr(args);
- reuse_as_slot(y, sym, unchecked_car(y));
- symbol_set_local_slot(sym, id, y);
- slot_set_next(sp, y);
- sp = y;
- y = args;
- }
- slot_set_next(sp, slot_end);
+ s7_pointer args = cdr(y), last_slot, x = car(sc->code);
+ last_slot = add_slot_unchecked_with_id(sc, sc->curlet, caar(x), unchecked_car(y));
+ for (x = cdr(x), y = args; is_not_null(y); x = cdr(x), y = cdr(y))
+ last_slot = inline_add_slot_at_end(sc, id, last_slot, caar(x), unchecked_car(y));
}
sc->code = T_Pair(cdr(sc->code));
sc->temp8 = sc->unused;
- return(true);
+ return(true); /* goto BEGIN */
}
static bool op_let(s7_scheme *sc)
@@ -76658,17 +76802,22 @@ static bool op_let(s7_scheme *sc)
sc->x = sc->unused;
}
else sc->code = T_Pair(cdr(sc->code));
- return(true);
+ return(true); /* goto BEGIN */
}
sc->args = sc->nil;
- return(op_let1(sc));
+ /* if (NEWLET_PRINT) fprintf(stderr, "%s[%d]: value: %s, code: %s\n", __func__, __LINE__, display(sc->value), display(sc->code)); */
+ /* make_let here */
+ return(op_let_1(sc)); /* sc->code == vars */
}
-static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */
+static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars, called from eval if looping via op_let->op_let_1 + unopt'd args */
{
s7_pointer code = cadr(sc->code);
- s7_pointer x = cdar(code);
- sc->args = list_1(sc, cdr(sc->code));
+ s7_pointer x = cdar(code); /* next arg */
+ /* value: 0, code: ((radix (+ 2 (random 15)))) from (do ((i 0 (+ i 1))) ((= i 2)) (let ((j 0) (radix (+ 2 (random 15)))) (+ j radix))) on second iteration (i == 1) */
+ /* no make_let here */
+
+ sc->args = list_1(sc, cdr(sc->code)); /* as if sc->value were this, then absorbed into sc->args */
if (has_fx(x))
sc->value = fx_call(sc, x);
else
@@ -76678,59 +76827,68 @@ static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */
return(false); /* goto EVAL */
}
sc->code = cdr(code);
- return(op_let1(sc));
+ /* if (NEWLET_PRINT) fprintf(stderr, "%s[%d]: value: %s, code: %s\n", __func__, __LINE__, display(sc->value), display(sc->code)); */
+ return(op_let_1(sc));
}
static bool op_named_let(s7_scheme *sc)
-{
+{ /* from eval */
sc->args = sc->nil;
sc->value = cdr(sc->code);
sc->code = cadr(sc->value);
- return(op_let1(sc));
+ /* if (NEWLET_PRINT) fprintf(stderr, "%s[%d]: value: %s, code: %s\n", __func__, __LINE__, display(sc->value), display(sc->code)); */
+ /* make_let here */
+ return(op_let_1(sc));
}
static void op_named_let_no_vars(s7_scheme *sc)
-{
- s7_pointer arg = cadr(sc->code);
- sc->code = opt1_pair(sc->code); /* cdddr(sc->code) */
+{ /* sc->code is full form (let name () ...) */
+ s7_pointer name = cadr(sc->code);
+ sc->code = opt1_pair(sc->code); /* cdddr(sc->code) == body */
set_curlet(sc, inline_make_let(sc, sc->curlet));
- sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); /* sc->args is a temp here */
- add_slot_checked(sc, sc->curlet, arg, sc->args);
- set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */
+ sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0);
+ add_slot_checked(sc, sc->curlet, name, sc->args); /* sc->args is a temp here */
+ set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */
+ /* goto BEGIN */
}
static void op_named_let_a(s7_scheme *sc)
-{
- s7_pointer args = cdr(sc->code);
- sc->code = cddr(args);
- sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) */
- set_curlet(sc, make_let(sc, sc->curlet));
- sc->w = list_1_unchecked(sc, car(opt1_pair(args))); /* caaadr(args), subsequent calls will need a normal list of pars in closure_args */
+{ /* sc->code is the full form (let name vars...), par pointers are preset in opt1|3(cdr(sc->code)) */
+ s7_pointer data = cdr(sc->code);
+ s7_pointer par1 = opt1_pair(data); /* cdaadr(args) == first par */
+ sc->code = cddr(data); /* (vars ...) */
+ sc->args = fx_call(sc, cdr(par1));
+ set_curlet(sc, make_let(sc, sc->curlet)); /* funclet(?) */
+ sc->w = list_1_unchecked(sc, car(par1)); /* (list sym1), subsequent calls will need a normal list of pars in closure_args */
sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 1); /* picks up curlet (this is the funclet?) */
- add_slot(sc, sc->curlet, car(args), sc->x); /* the function */
+ add_slot(sc, sc->curlet, car(data), sc->x); /* car(data) == the function name */
set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(sc->w), sc->args)); /* inner let */
closure_set_let(sc->x, sc->curlet);
sc->x = sc->unused;
sc->w = sc->unused;
+ /* goto BEGIN */
}
static void op_named_let_aa(s7_scheme *sc)
-{
- s7_pointer args = cdr(sc->code);
- sc->code = cddr(args);
- sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) == init val of first par */
- sc->value = fx_call(sc, cdr(opt3_pair(args))); /* cdadadr = init val of second */
- set_curlet(sc, make_let(sc, sc->curlet));
- sc->w = list_2_unchecked(sc, car(opt1_pair(args)), car(opt3_pair(args))); /* subsequent calls will need a normal list of pars in closure_args */
+{ /* sc->code is the full form (let name vars...), par pointers are preset in opt1|3(cdr(sc->code)) */
+ s7_pointer data = cdr(sc->code);
+ s7_pointer par1 = opt1_pair(data); /* cdaadr(data) == first par */
+ s7_pointer par2 = opt3_pair(data); /* cdadadr == second */
+ sc->code = cddr(data); /* (vars ...) */
+ sc->args = fx_call(sc, cdr(par1));
+ sc->value = fx_call(sc, cdr(par2));
+ set_curlet(sc, make_let(sc, sc->curlet)); /* funclet below I think */
+ sc->w = list_2_unchecked(sc, car(par1), car(par2)); /* (list sym1 sym2): subsequent calls will need a normal list of pars in closure_args */
sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 2); /* picks up curlet (this is the funclet?) */
- add_slot(sc, sc->curlet, car(args), sc->x); /* the function */
+ add_slot(sc, sc->curlet, car(data), sc->x); /* car(data) == the function name */
set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(sc->w), sc->args, cadr(sc->w), sc->value)); /* inner let */
closure_set_let(sc->x, sc->curlet);
sc->x = sc->unused;
sc->w = sc->unused;
+ /* goto BEGIN */
}
-static bool op_named_let_na(s7_scheme *sc)
+static void op_named_let_na(s7_scheme *sc)
{
sc->code = cdr(sc->code);
sc->args = sc->nil;
@@ -76742,7 +76900,8 @@ static bool op_named_let_na(s7_scheme *sc)
sc->args = cons_unchecked(sc, sc->value = fx_call(sc, cdar(p)), sc->args);
}
sc->args = proper_list_reverse_in_place(sc, sc->args);
- return(op_named_let_1(sc, sc->args)); /* sc->code = (name vars . body), args = vals in decl order, op_named_let_1 handles inner let */
+ op_named_let_1(sc, sc->args); /* sc->code = (name vars . body), args = vals in decl order, op_named_let_1 handles inner let */
+ /* goto BEGIN */
}
static void op_let_no_vars(s7_scheme *sc)
@@ -76954,9 +77113,9 @@ static void op_let_3a_new(s7_scheme *sc) /* 3 vars, 1 expr in body */
s7_pointer a2 = opt1_pair(code); /* cadar */
s7_pointer a3 = opt2_pair(code); /* caddar */
gc_protect_via_stack(sc, fx_call(sc, cdr(a1))); /* fx_call might be fx_car_t (etc) so it needs to precede the new let */
- set_stack_protected2(sc, fx_call(sc, cdr(a2)));
- set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(a2), stack_protected2(sc), car(a3), fx_call(sc, cdr(a3))));
- add_slot(sc, sc->curlet, car(a1), stack_protected1(sc));
+ set_gc_protected2(sc, fx_call(sc, cdr(a2)));
+ set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(a2), gc_protected2(sc), car(a3), fx_call(sc, cdr(a3))));
+ add_slot(sc, sc->curlet, car(a1), gc_protected1(sc));
unstack_gc_protect(sc);
sc->code = cadr(code);
}
@@ -77009,29 +77168,29 @@ static bool check_let_star(s7_scheme *sc)
if (!is_pair(var_and_val)) /* (let* (3) ... */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "let* variable list, ~A, is messed up in ~A", 42),
- var_and_val, object_to_truncated_string(sc, form, 80)));
+ var_and_val, object_to_string_truncated(sc, form)));
if (!(is_pair(cdr(var_and_val)))) /* (let* ((x . 1))...) */
{
if (is_null(cdr(var_and_val)))
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "let* variable declaration, but no value?: ~A in ~A", 50),
- var_and_val, object_to_truncated_string(sc, form, 80)));
+ var_and_val, object_to_string_truncated(sc, form)));
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "let* variable declaration is not a proper list: ~A in ~A", 56),
- var_and_val, object_to_truncated_string(sc, form, 80)));
+ var_and_val, object_to_string_truncated(sc, form)));
}
if (!is_null(cddr(var_and_val))) /* (let* ((c 1 2)) ...) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "let* variable declaration has more than one value?: ~A in ~A", 60),
- var_and_val, object_to_truncated_string(sc, form, 80)));
+ var_and_val, object_to_string_truncated(sc, form)));
var = car(var_and_val);
if (!(is_symbol(var))) /* (let* ((3 1)) 1) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let* (it is ~A, not a symbol) in ~A", 59),
var, object_type_name(sc, var),
- object_to_truncated_string(sc, form, 80)));
+ object_to_string_truncated(sc, form)));
if (is_constant_symbol(sc, var)) /* (let* ((pi 3)) ...) */
error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, var_and_val));
@@ -77039,7 +77198,7 @@ static bool check_let_star(s7_scheme *sc)
if ((named_let) && (symbol_is_in_arg_list(var, cdr(vars)))) /* (let* loop ((a 1) (a 2)) ...) -- added 2-Dec-19 */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "named let* parameter, ~A, is used twice in the parameter list in ~A", 67),
- var, object_to_truncated_string(sc, form, 80)));
+ var, object_to_string_truncated(sc, form)));
/* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error */
if (symbol_is_in_list(sc, var)) shadowing = true;
@@ -77049,7 +77208,7 @@ static bool check_let_star(s7_scheme *sc)
if (!is_null(vars))
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "let* variable list is not a proper list: ~A in ~A", 49),
- vars, object_to_truncated_string(sc, form, 80)));
+ vars, object_to_string_truncated(sc, form)));
if (!s7_is_proper_list(sc, cdr(code)))
syntax_error_nr(sc, "stray dot in let* body: ~S", 26, cdr(code));
@@ -77312,7 +77471,7 @@ static void check_letrec(s7_scheme *sc, bool letrec)
error_nr(sc, sc->syntax_error_symbol,
set_elist_5(sc, wrap_string(sc, "bad variable name ~W in ~A (it is ~A, not a symbol) in ~A", 57),
y, caller, object_type_name(sc, y),
- object_to_truncated_string(sc, sc->code, 80)));
+ object_to_string_truncated(sc, sc->code)));
if (is_constant_symbol(sc, y))
error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, caller, x));
@@ -78555,7 +78714,15 @@ static bool op_begin(s7_scheme *sc, s7_pointer code)
static s7_pointer print_truncate(s7_scheme *sc, s7_pointer code)
{
if (tree_len(sc, code) > sc->print_length)
- return(object_to_truncated_string(sc, code, sc->print_length * 10));
+ {
+ s7_pointer obj;
+ s7_int old_len;
+ old_len = sc->print_length;
+ sc->print_length = old_len * 10;
+ obj = object_to_string_truncated(sc, code);
+ sc->print_length = old_len;
+ return(obj);
+ }
return(code);
}
@@ -78595,7 +78762,7 @@ static void check_define(s7_scheme *sc)
if (is_syntactic_symbol(func)) /* (define and a) */
{
if (sc->safety > NO_SAFETY)
- s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_80(sc->code));
+ s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_truncated(sc->code));
set_local(func);
}
@@ -78625,7 +78792,7 @@ static void check_define(s7_scheme *sc)
if (is_syntactic_symbol(func)) /* (define (and a) a) */
{
if (sc->safety > NO_SAFETY)
- s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_80(sc->code));
+ s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_truncated(sc->code));
set_local(func);
}
if ((is_global(func)) && (is_slot(global_slot(func))) &&
@@ -78883,7 +79050,7 @@ static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op, s7_pointer form
if (is_syntactic_symbol(mac_name))
{
if (sc->safety > NO_SAFETY)
- s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(mac_name), display_80(sc->code));
+ s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(mac_name), display_truncated(sc->code));
set_local(mac_name);
}
if (is_constant_symbol(sc, mac_name))
@@ -79179,7 +79346,7 @@ 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 (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: op: %s, value: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)], display_80(sc->value));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: op: %s, value: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)], display_truncated(sc->value));
if (sc->value == sc->no_value)
{
if (stack_top_op(sc) != OP_LOAD_RETURN_IF_EOF) /* latter op if empty expansion at top-level */
@@ -79202,8 +79369,8 @@ static void check_with_let(s7_scheme *sc)
if (!is_pair(form)) /* (with-let . "hi") */
syntax_error_nr(sc, "with-let takes an environment argument: ~A", 42, sc->code);
- if (!is_pair(cdr(form))) /* (with-let e) -> an error? */
- syntax_error_nr(sc, "with-let body is messed up: ~A", 30, sc->code);
+ if (is_null(cdr(form))) /* (with-let e) */
+ syntax_error_nr(sc, "with-let has no body: ~A", 24, sc->code);
if (!s7_is_proper_list(sc, cdr(form))) /* (with-let e . 3) */
syntax_error_nr(sc, "stray dot in with-let body: ~S", 30, sc->code);
@@ -79287,14 +79454,14 @@ static void check_cond(s7_scheme *sc)
if (!is_pair(car(x))) /* (cond 1) or (cond (#t 1) 3) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "every clause in cond must be a pair: ~S in ~A", 45),
- car(x), object_to_truncated_string(sc, form, 80)));
+ car(x), object_to_string_truncated(sc, form)));
else
{
s7_pointer y = car(x);
if (!s7_is_proper_list(sc, cdr(y))) /* (cond (xxx . 1)) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "stray dot? ~S in ~A", 19),
- y, object_to_truncated_string(sc, form, 80)));
+ y, object_to_string_truncated(sc, form)));
if (is_pair(cdr(y)))
{
if (is_pair(cddr(y))) result_single = false;
@@ -79304,11 +79471,11 @@ static void check_cond(s7_scheme *sc)
if (!is_pair(cddr(y))) /* (cond (#t =>)) or (cond (#t => . 1)) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "cond: '=>' target missing? ~S in ~A", 36),
- x, object_to_truncated_string(sc, form, 80)));
+ x, object_to_string_truncated(sc, form)));
if (is_pair(cdddr(y))) /* (cond (1 => + abs)) */
error_nr(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "cond: '=>' has too many targets: ~S in ~A", 41),
- x, object_to_truncated_string(sc, form, 80)));
+ x, object_to_string_truncated(sc, form)));
}}
else result_single = false;
}
@@ -79796,7 +79963,8 @@ static void check_set(s7_scheme *sc)
if ((is_slot(slot)) &&
(!slot_has_setter(slot)) &&
(!is_immutable(slot)) &&
- (!is_syntactic_symbol(settee)))
+ (!is_syntactic_symbol(settee)) &&
+ (!s7_tree_memq(sc, sc->setter_symbol, value))) /* (set! x (set! (setter 'x) ...) ...)! */
{
if (is_normal_symbol(value))
{
@@ -79923,7 +80091,7 @@ static void op_set_s_p(s7_scheme *sc)
sc->code = caddr(sc->code);
}
-static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check for immutable slot */
+static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check for immutable slot, but no setter */
{
s7_pointer slot = s7_slot(sc, sc->code);
if (is_slot(slot))
@@ -79997,7 +80165,7 @@ static noreturn void no_setter_error_nr(s7_scheme *sc, s7_pointer obj)
set_elist_5(sc, wrap_string(sc, "~A (~A) does not have a setter: (set! ~S ~S)", 44),
caar(sc->code), sc->type_names[typ],
(is_pair(car(sc->code))) ? copy_any_list(sc, car(sc->code)) : car(sc->code),
- (is_pair(cadr(sc->code))) ? copy_any_list(sc, cadr(sc->code)) : cadr(sc->code)));
+ (is_pair(cadr(sc->code))) ? sc->z = copy_any_list(sc, cadr(sc->code)) : cadr(sc->code)));
/* copy is necessary due to the way quoted lists|symbols are handled in op_set_with_let_1|2 and copy_tree
* copy_proper_list can fail: (let ((x #f)) (map set! `((set! x (+ x 1)) (* x 2)) (hash-table 'a 1)))
*/
@@ -80170,14 +80338,14 @@ static bool op_set_opsaq_a(s7_scheme *sc) /* (set! (symbol fxable) fxable
{
sc->code = setf;
sc->args = pair_append(sc, cdar(code), cdr(code));
- return(true);
+ return(true); /* goto APPLY */
}}
value = fx_call(sc, cdr(code));
gc_protect_via_stack(sc, value);
if (dont_eval_args(obj)) /* this check is expensive, 8 in tstar, similar lg, but it's faster than is_any_macro */
index = cadar(code); /* if obj is a c_macro, surely we don't want to evaluate cdar(code)? */
else index = fx_call(sc, cdar(code));
- set_stack_protected2(sc, index);
+ set_gc_protected2(sc, index);
result = set_pair3(sc, obj, index, value);
unstack_gc_protect(sc);
return(result);
@@ -80200,11 +80368,11 @@ static inline bool op_set_opsaq_p(s7_scheme *sc)
{
sc->code = setf;
sc->args = pair_append(sc, cdar(code), cdr(code));
- return(true);
+ return(true); /* goto APPLY */
}}
push_stack(sc, OP_SET_opSAq_P_1, obj, code);
sc->code = cadr(code);
- return(false);
+ return(false); /* goto EVAL */
}
static inline bool op_set_opsaq_p_1(s7_scheme *sc)
@@ -80318,7 +80486,7 @@ static bool op_set_opsaaq_a(s7_scheme *sc) /* (set! (symbol fxable fxable
value = fx_call(sc, cdr(code));
gc_protect_via_stack(sc, value);
index1 = fx_call(sc, cdar(code));
- set_stack_protected2(sc, index1);
+ set_gc_protected2(sc, index1);
result = set_pair4(sc, obj, index1, fx_call(sc, cddar(code)), value);
unstack_gc_protect(sc);
return(result);
@@ -80581,7 +80749,7 @@ static bool op_implicit_vector_ref_aa(s7_scheme *sc) /* if Inline 70 in concorda
x = fx_call(sc, code);
gc_protect_via_stack(sc, x);
y = fx_call(sc, cdr(code));
- set_stack_protected2(sc, y);
+ set_gc_protected2(sc, y);
if ((s7_is_integer(x)) && (s7_is_integer(y)) &&
(vector_rank(v) == 2))
{
@@ -82366,7 +82534,8 @@ static goto_t op_dox(s7_scheme *sc)
/* any number of steppers using dox exprs, end also dox, body and end result arbitrary.
* since all these exprs are local, we don't need to jump until the body
*/
- int64_t id, steppers = 0;
+ int64_t id;
+ int32_t steppers = 0;
s7_pointer code, end, endp, stepper = NULL, form = sc->code, slots;
s7_function endf;
#if WITH_GMP
@@ -83660,12 +83829,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool loo
}
if (fd == opt_set_d_d_fm)
clear_mutable_number(slot_value(o->v[1].p));
- }
- else
- { /* TODO: remove this dead code (we've hit all cases cell/int/float), maybe leave a warning here? */
- if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: other case %d: %s\n", __func__, __LINE__, is_mutable_integer(step_val), display(scc));
- while (step < stop) {func(sc); step = ++integer(step_val);}
}}
+ /* there aren't any other possibilities */
sc->value = sc->T;
sc->code = cdadr(scc);
return(true);
@@ -84181,12 +84346,26 @@ static goto_t op_dotimes_p(s7_scheme *sc)
}
static bool op_do_init_1(s7_scheme *sc)
-{
- s7_pointer y, z;
- while (true) /* at start, first value is the loop (for GC protection?), returning sc->value is the next value */
+{
+ while (true)
{
s7_pointer init;
- sc->args = cons(sc, sc->value, sc->args); /* code will be last element (first after reverse), these cons's will be used below for the new let/slots */
+ s7_pointer sp = gc_protected2(sc);
+ if (sp == sc->F)
+ {
+ sp = sc->T;
+ set_gc_protected2(sc, sc->T);
+ }
+ else
+ {
+ if (sp == sc->T)
+ sp = add_slot_unchecked_no_local_slot(sc, gc_protected1(sc), caar(sc->code), sc->value);
+ else sp = add_slot_at_end_no_local(sc, sp, caar(sc->code), sc->value);
+ if (is_pair(cddar(sc->code))) /* else no incr expr, so ignore it henceforth */
+ slot_set_expression(sp, cddar(sc->code));
+ set_gc_protected2(sc, sp);
+ sc->code = cdr(sc->code);
+ }
if (!is_pair(sc->code)) break;
/* here sc->code is a list like: ((i 0 (+ i 1)) ...) so cadar gets the init value */
init = cdar(sc->code);
@@ -84197,46 +84376,34 @@ static bool op_do_init_1(s7_scheme *sc)
init = car(init);
if (is_pair(init))
{
- push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */
+ push_stack_direct(sc, OP_DO_INIT); /* OP_DO_INIT only used here */
sc->code = init;
- return(true); /* goto eval */
+ return(true); /* goto EVAL */
}
sc->value = (is_symbol(init)) ? lookup_checked(sc, init) : init;
- }
- sc->code = cdr(sc->code);
- }
- /* all the initial values are now in the args list */
- sc->args = proper_list_reverse_in_place(sc, sc->args);
- sc->code = car(sc->args); /* saved at the start */
- z = sc->args;
- sc->args = cdr(sc->args); /* init values */
-
- /* sc->args was cons'd above, so it should be safe to reuse it as the new let */
- set_curlet(sc, reuse_as_let(sc, z, T_Let(sc->curlet))); /* set_curlet(sc, make_let(sc, sc->curlet)); */
-
- /* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->curlet, also reuse sc->args as the new let slots */
- sc->value = sc->nil;
- y = sc->args;
- for (s7_pointer x = car(sc->code); is_not_null(y); x = cdr(x))
- {
- s7_pointer sym = caar(x), args = cdr(y);
- reuse_as_slot(y, sym, unchecked_car(y));
- slot_set_next(y, let_slots(sc->curlet));
- let_set_slots(sc->curlet, y);
- symbol_set_local_slot(sym, let_id(sc->curlet), y);
- if (is_pair(cddar(x))) /* else no incr expr, so ignore it henceforth */
- {
- slot_set_expression(y, cddar(x));
- sc->value = cons_unchecked(sc, y, sc->value);
- }
- y = args;
- }
- sc->args = cons(sc, sc->value = proper_list_reverse_in_place(sc, sc->value), cadr(sc->code));
+ }}
+ {
+ int64_t id = ++sc->let_number;
+ s7_pointer new_let = gc_protected1(sc);
+ let_set_id(new_let, id);
+ set_curlet(sc, new_let);
+ sc->value = sc->nil;
+ for (s7_pointer x = let_slots(new_let); tis_slot(x); x = next_slot(x))
+ {
+ symbol_set_local_slot_unincremented(slot_symbol(x), id, x); /* was symbol_set_id(slot_symbol(x), id) */
+ if (slot_has_expression(x))
+ sc->value = cons_unchecked(sc, x, sc->value);
+ }
+ sc->code = gc_protected3(sc);
+ unstack_gc_protect(sc);
+ }
+ sc->args = cons(sc, sc->value = proper_list_reverse_in_place(sc, sc->value), cadr(sc->code)); /* TODO: use the let, not this list (all need changes?) */
+ /* ((#<slot: i 0> #<slot: j 1>) (= i 3)) */
sc->code = cddr(sc->code);
return(false); /* fall through */
}
-static bool op_do_init(s7_scheme *sc)
+static bool op_do_init(s7_scheme *sc) /* looping through inits via eval */
{
if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */
error_nr(sc, sc->wrong_type_arg_symbol,
@@ -84253,6 +84420,7 @@ static void op_do_unchecked(s7_scheme *sc)
static bool do_unchecked(s7_scheme *sc)
{
+ s7_pointer new_let;
if (is_null(car(sc->code))) /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */
{
set_curlet(sc, make_let(sc, sc->curlet));
@@ -84260,16 +84428,18 @@ static bool do_unchecked(s7_scheme *sc)
sc->code = cddr(sc->code);
return(false);
}
- /* eval each init value, then set up the new let (like let, not let*) */
- sc->args = sc->nil; /* the evaluated var-data */
- sc->value = sc->code; /* protect it */
+ new_let = inline_make_let(sc, sc->curlet);
+ new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE);
+ let_set_slots(new_let, slot_end); /* needed by add_slot_unchecked */
+ let_set_outlet(new_let, sc->curlet);
+ gc_protect_2_via_stack(sc, new_let, sc->F);
+ set_gc_protected3(sc, sc->code);
sc->code = car(sc->code); /* the vars */
return(op_do_init_1(sc));
}
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)))
@@ -84548,7 +84718,7 @@ static void op_f_a(s7_scheme *sc) /* sc->code: ((lambda (x) (+ x 1)) i) -> (le
static void op_f_aa(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) i j) -> (let ((x i) (y j)) (+ x y)) */
{
gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code)));
- set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, opt3_sym(cdr(sc->code)), stack_protected1(sc), cadadr(car(sc->code)), fx_call(sc, cddr(sc->code))));
+ set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, opt3_sym(cdr(sc->code)), gc_protected1(sc), cadadr(car(sc->code)), fx_call(sc, cddr(sc->code))));
unstack_gc_protect(sc);
sc->code = opt3_pair(sc->code);
}
@@ -84569,8 +84739,7 @@ static void op_f_np(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) (value
set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: ((lambda ~S ...)~{~^ ~S~})", 61),
car(pars), cadar(sc->code), cdr(sc->code)));
- add_slot_unchecked_no_local(sc, e, car(pars), sc->undefined);
- last_slot = let_slots(e);
+ last_slot = add_slot_unchecked_no_local_slot(sc, e, car(pars), sc->undefined);
for (pars = cdr(pars); is_pair(pars); pars = cdr(pars))
last_slot = add_slot_at_end_no_local(sc, last_slot, car(pars), sc->undefined);
/* last par might be rest par (dotted) */
@@ -84588,7 +84757,7 @@ static void op_f_np(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) (value
static bool op_f_np_1(s7_scheme *sc)
{
- s7_pointer e, slot = stack_protected1(sc), arg = stack_protected2(sc);
+ s7_pointer e, slot = gc_protected1(sc), arg = gc_protected2(sc);
if (is_multiple_value(sc->value))
{
s7_pointer p, oslot = slot;
@@ -84622,8 +84791,8 @@ static bool op_f_np_1(s7_scheme *sc)
error_nr(sc, sc->wrong_number_of_args_symbol,
set_elist_3(sc, wrap_string(sc, "too many arguments: ((lambda ~S ...)~{~^ ~S~})", 46),
cadar(sc->code), cdr(sc->code)));
- set_stack_protected1(sc, (is_rest_slot(slot)) ? slot : next_slot(slot));
- set_stack_protected2(sc, cdr(arg));
+ set_gc_protected1(sc, (is_rest_slot(slot)) ? slot : next_slot(slot));
+ set_gc_protected2(sc, cdr(arg));
push_stack_direct(sc, OP_F_NP_1); /* sc->args=e, sc->code from start */
sc->code = car(arg);
return(true);
@@ -85141,7 +85310,7 @@ static bool op_safe_closure_star_aaa(s7_scheme *sc, s7_pointer code)
s7_pointer arg1 = fx_call(sc, cdr(code));
gc_protect_via_stack(sc, arg1);
arg2 = fx_call(sc, cddr(code));
- set_stack_protected2(sc, arg2);
+ set_gc_protected2(sc, arg2);
arg3 = fx_call(sc, cdddr(code));
if ((is_symbol_and_keyword(arg1)) || (is_symbol_and_keyword(arg2)) || (is_symbol_and_keyword(arg3)))
{
@@ -85427,7 +85596,7 @@ static void check_for_cyclic_code(s7_scheme *sc, s7_pointer code)
{
if (tree_is_cyclic(sc, code))
{
- sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2)));
+ /* sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2))); */
syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, code);
}
resize_stack(sc); /* we've already checked that resize_stack is needed */
@@ -85712,7 +85881,7 @@ static void op_any_closure_3p(s7_scheme *sc)
stack_end_args(sc) = sc->args; /* stack[args] == arg1 to closure) */
stack_end_op(sc) = (s7_pointer)(opcode_t)(OP_ANY_CLOSURE_3P_3);
sc->stack_end += 4;
- set_stack_protected3_with(sc, fx_call(sc, p), OP_ANY_CLOSURE_3P_3);
+ set_stack_protected3(sc, fx_call(sc, p), OP_ANY_CLOSURE_3P_3); /* set stack_let */
/* (i.e. stack[curlet] == arg2 of closure), fx_call might push_stack gc_protect etc, so push_stack via +4 before it */
sc->code = cadr(p);
}
@@ -85734,16 +85903,16 @@ static bool closure_3p_end(s7_scheme *sc, s7_pointer p)
{
s7_pointer func = opt1_lambda(sc->code);
gc_protect_2_via_stack(sc, sc->args, sc->value); /* sc->args == arg1, sc->value == arg2 */
- set_stack_protected3(sc, fx_call(sc, p));
+ set_gc_protected3(sc, fx_call(sc, p));
if (is_safe_closure(func))
- set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc)));
- else make_let_with_three_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc));
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc)));
+ else make_let_with_three_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_protected3(sc));
unstack_gc_protect(sc);
sc->code = T_Pair(closure_body(func));
return(true);
}
push_stack_direct(sc, OP_ANY_CLOSURE_3P_3);
- set_stack_protected3_with(sc, sc->value, OP_ANY_CLOSURE_3P_3); /* arg2 == curlet stack loc */
+ set_stack_protected3(sc, sc->value, OP_ANY_CLOSURE_3P_3); /* set stack_let, arg2 == curlet stack loc */
sc->code = car(p);
return(false);
}
@@ -85784,11 +85953,11 @@ static void op_any_closure_4p(s7_scheme *sc)
p = cdr(p);
if (has_fx(p))
{
- set_stack_protected2(sc, fx_call(sc, p));
+ set_gc_protected2(sc, fx_call(sc, p));
p = cdr(p);
if (has_fx(p))
{
- set_stack_protected3(sc, fx_call(sc, p));
+ set_gc_protected3(sc, fx_call(sc, p));
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4);
sc->code = cadr(p);
}
@@ -85817,8 +85986,8 @@ static bool closure_4p_end(s7_scheme *sc, s7_pointer p)
s7_pointer func = opt1_lambda(sc->code);
sc->args = fx_call(sc, p);
if (is_safe_closure(func))
- set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args));
- else make_let_with_four_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args);
+ set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->args));
+ else make_let_with_four_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->args);
sc->code = T_Pair(closure_body(func));
unstack_gc_protect(sc);
return(true);
@@ -85834,11 +86003,11 @@ static bool op_any_closure_4p_1(s7_scheme *sc)
gc_protect_via_stack(sc, sc->value);
if (has_fx(p))
{
- set_stack_protected2(sc, fx_call(sc, p));
+ set_gc_protected2(sc, fx_call(sc, p));
p = cdr(p);
if (has_fx(p))
{
- set_stack_protected3(sc, fx_call(sc, p));
+ set_gc_protected3(sc, fx_call(sc, p));
return(closure_4p_end(sc, cdr(p)));
}
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3);
@@ -85855,10 +86024,10 @@ static bool op_any_closure_4p_1(s7_scheme *sc)
static bool op_any_closure_4p_2(s7_scheme *sc)
{
s7_pointer p = cdddr(sc->code);
- set_stack_protected2(sc, sc->value);
+ set_gc_protected2(sc, sc->value);
if (has_fx(p))
{
- set_stack_protected3(sc, fx_call(sc, p));
+ set_gc_protected3(sc, fx_call(sc, p));
return(closure_4p_end(sc, cdr(p)));
}
push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3);
@@ -85868,7 +86037,7 @@ static bool op_any_closure_4p_2(s7_scheme *sc)
static bool op_any_closure_4p_3(s7_scheme *sc)
{
- set_stack_protected3(sc, sc->value);
+ set_gc_protected3(sc, sc->value);
return(closure_4p_end(sc, cddddr(sc->code)));
}
@@ -85876,8 +86045,8 @@ static inline void op_any_closure_4p_4(s7_scheme *sc)
{
s7_pointer func = opt1_lambda(sc->code);
if (is_safe_closure(func))
- set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->value));
- else make_let_with_four_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->value);
+ set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->value));
+ else make_let_with_four_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->value);
sc->code = T_Pair(closure_body(func));
unstack_gc_protect(sc);
}
@@ -86054,10 +86223,10 @@ static Inline void inline_op_closure_aa_o(s7_scheme *sc) /* called once in eval,
static /* inline */ void op_closure_fa(s7_scheme *sc) /* "inline" matters perhaps in texit.scm */
{
s7_pointer new_clo, code = sc->code;
- s7_pointer farg = opt2_pair(code); /* cdadr(code), '((a . b) (cons a b)) for (lambda (a . b) (cons a b)) */
+ s7_pointer farg = opt2_pair(code); /* cdadr(code), '((a . b) (cons a b)) for (lambda (a . b) (cons a b)) */
s7_pointer aarg = fx_call(sc, cddr(code));
- s7_pointer func = opt1_lambda(code); /* outer func */
- s7_pointer func_args = closure_args(func); /* outer func args (not the arglist of the applied func) */
+ s7_pointer func = opt1_lambda(code); /* outer func */
+ s7_pointer func_args = closure_args(func); /* outer func args (not the arglist of the applied func) */
sc->value = inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), sc->F, cadr(func_args), aarg);
new_clo = make_closure_unchecked(sc, car(farg), cdr(farg), T_CLOSURE | ((!s7_is_proper_list(sc, car(farg))) ? T_COPY_ARGS : 0), CLOSURE_ARITY_NOT_SET);
/* this is checking the called closure arglist (see op_lambda), arity<0 probably not usable since "f" in "fa" is a parameter */
@@ -86191,7 +86360,7 @@ static inline void op_closure_3a(s7_scheme *sc) /* if inlined, tlist -60 */
s7_pointer args = cdr(sc->code);
s7_pointer f = opt1_lambda(sc->code);
gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cdr(args)));
- make_let_with_three_slots(sc, f, stack_protected1(sc), stack_protected2(sc), fx_call(sc, cddr(args)));
+ make_let_with_three_slots(sc, f, gc_protected1(sc), gc_protected2(sc), fx_call(sc, cddr(args)));
unstack_gc_protect(sc);
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
@@ -86203,8 +86372,8 @@ static void op_closure_4a(s7_scheme *sc) /* sass */
s7_pointer f = opt1_lambda(sc->code);
gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cddr(args)));
args = cdr(args);
- set_stack_protected3(sc, fx_call(sc, args));
- make_let_with_four_slots(sc, f, stack_protected1(sc), stack_protected3(sc), stack_protected2(sc), fx_call(sc, cddr(args)));
+ set_gc_protected3(sc, fx_call(sc, args));
+ make_let_with_four_slots(sc, f, gc_protected1(sc), gc_protected3(sc), gc_protected2(sc), fx_call(sc, cddr(args)));
unstack_gc_protect(sc);
sc->code = T_Pair(closure_body(f));
if_pair_set_up_begin(sc);
@@ -86282,7 +86451,7 @@ static void op_any_closure_sym(s7_scheme *sc) /* for (lambda a ...) */
sc->args = fx_call(sc, cdr(old_args));
set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_args(func),
((is_safe_closure(func)) && (!sc->debug_or_profile)) ?
- set_plist_2(sc, stack_protected1(sc), sc->args) : list_2(sc, stack_protected1(sc), sc->args)));
+ set_plist_2(sc, gc_protected1(sc), sc->args) : list_2(sc, gc_protected1(sc), sc->args)));
unstack_gc_protect(sc);
}
else
@@ -86312,7 +86481,7 @@ static void op_any_closure_a_sym(s7_scheme *sc) /* for (lambda (a . b) ...) */
if (num_args == 2)
{
sc->args = fx_call(sc, cdr(old_args));
- set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), list_1(sc, sc->args)));
+ set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), gc_protected1(sc), cdr(func_args), list_1(sc, sc->args)));
}
else
{
@@ -86320,7 +86489,7 @@ static void op_any_closure_a_sym(s7_scheme *sc) /* for (lambda (a . b) ...) */
old_args = cdr(old_args);
for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args))
set_car(p, fx_call(sc, old_args));
- set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), sc->args));
+ set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(func_args), gc_protected1(sc), cdr(func_args), sc->args));
}
unstack_gc_protect(sc);
}
@@ -89318,7 +89487,7 @@ static inline void op_cl_aa(s7_scheme *sc)
{
gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code)));
set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
- set_car(sc->t2_1, T_Ext(stack_protected1(sc)));
+ set_car(sc->t2_1, T_Ext(gc_protected1(sc)));
unstack_gc_protect(sc);
sc->value = fn_proc(sc->code)(sc, sc->t2_1);
}
@@ -89462,7 +89631,7 @@ static void op_safe_c_3p_3(s7_scheme *sc)
{
set_car(sc->t3_3, sc->value);
set_car(sc->t3_1, sc->args);
- set_car(sc->t3_2, stack_protected1(sc));
+ set_car(sc->t3_2, gc_protected1(sc));
unstack_gc_protect(sc);
sc->value = fn_proc(sc->code)(sc, sc->t3_1);
}
@@ -89471,7 +89640,7 @@ static void op_safe_c_3p_3_mv(s7_scheme *sc)
{
s7_pointer p;
s7_pointer p1 = ((is_pair(sc->args)) && (car(sc->args) == sc->unused)) ? cdr(sc->args) : list_1(sc, sc->args);
- s7_pointer ps1 = stack_protected1(sc);
+ s7_pointer ps1 = gc_protected1(sc);
s7_pointer p2 = ((is_pair(ps1)) && (car(ps1) == sc->unused)) ? cdr(ps1) : list_1(sc, ps1);
s7_pointer p3 = ((is_pair(sc->value)) && (car(sc->value) == sc->unused)) ? cdr(sc->value) : list_1(sc, sc->value);
unstack_gc_protect(sc);
@@ -89705,8 +89874,8 @@ static void op_c_ap(s7_scheme *sc)
static void op_c_aa(s7_scheme *sc)
{
gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code)));
- set_stack_protected2(sc, fx_call(sc, cddr(sc->code)));
- sc->value = list_2(sc, stack_protected1(sc), stack_protected2(sc));
+ set_gc_protected2(sc, fx_call(sc, cddr(sc->code)));
+ sc->value = list_2(sc, gc_protected1(sc), gc_protected2(sc));
unstack_gc_protect(sc); /* fn_proc here is unsafe so clear stack first */
sc->value = fn_proc(sc->code)(sc, sc->value);
}
@@ -89752,9 +89921,9 @@ static bool op_pair_pair(s7_scheme *sc)
clear_optimize_op(sc->code);
return(false);
}
- if (sc->stack_end >= (sc->stack_resize_trigger - 8))
- check_for_cyclic_code(sc, sc->code); /* calls resize_stack */
- push_stack_no_args_direct(sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */
+ if (sc->stack_end >= sc->stack_resize_trigger - 8) /* -8 so the next two push_stacks don't hit the resize_trigger before we can check for cyclic code */
+ check_for_cyclic_code(sc, sc->code); /* calls resize_stack */
+ push_stack_no_args_direct(sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */
/* don't put check_stack_size here! */
push_stack_no_args(sc, OP_EVAL_ARGS, car(sc->code));
sc->code = caar(sc->code);
@@ -90051,7 +90220,7 @@ static bool eval_car_pair(s7_scheme *sc)
static goto_t trailers(s7_scheme *sc)
{
s7_pointer code = T_Ext(sc->code);
- if (SHOW_EVAL_OPS) fprintf(stderr, " trailers %s\n", display_80(code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " trailers %s\n", display_truncated(code));
set_current_code(sc, code);
if (is_pair(code))
{
@@ -90863,7 +91032,7 @@ static bool pop_read_list(s7_scheme *sc)
static bool op_load_return_if_eof(s7_scheme *sc)
{
- if (SHOW_EVAL_OPS) fprintf(stderr, " op_load_return_if_eof: value: %s\n", display_80(sc->value));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " op_load_return_if_eof: value: %s\n", display_truncated(sc->value));
if (sc->tok != TOKEN_EOF)
{
push_stack_op_let(sc, OP_LOAD_RETURN_IF_EOF);
@@ -91024,7 +91193,7 @@ static bool op_unknown(s7_scheme *sc)
s7_pointer code = sc->code, f = sc->last_function;
if (!f) /* can be NULL if unbound variable */
unbound_variable_error_nr(sc, car(sc->code));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s %s\n", __func__, display_80(f), s7_type_names[type(f)]);
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s %s\n", __func__, display_truncated(f), s7_type_names[type(f)]);
switch (type(f))
{
@@ -91162,7 +91331,7 @@ static bool op_unknown_s(s7_scheme *sc)
s7_pointer code = sc->code, f = sc->last_function;
if (!f) unbound_variable_error_nr(sc, car(sc->code));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_80(f));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
if ((S7_DEBUGGING) && (!is_normal_symbol(cadr(code)))) fprintf(stderr, "%s[%d]: not a symbol: %s\n", __func__, __LINE__, display(code));
if ((!is_any_macro(f)) && /* if f is a macro, its argument can be unbound legitimately */
@@ -91253,7 +91422,7 @@ static bool op_unknown_a(s7_scheme *sc)
{
s7_pointer code = sc->code, f = sc->last_function;
if (!f) unbound_variable_error_nr(sc, car(sc->code));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_80(f));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
switch (type(f))
{
@@ -91333,7 +91502,7 @@ static bool op_unknown_gg(s7_scheme *sc)
bool s1, s2;
s7_pointer code = sc->code, f = sc->last_function;
if (!f) unbound_variable_error_nr(sc, car(sc->code));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_80(f));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
s1 = is_normal_symbol(cadr(code));
s2 = is_normal_symbol(caddr(code));
@@ -91470,7 +91639,7 @@ static bool op_unknown_ns(s7_scheme *sc)
int32_t num_args = opt3_arglen(cdr(code));
if (!f) unbound_variable_error_nr(sc, car(sc->code));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_80(f));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
for (s7_pointer arg = cdr(code); is_pair(arg); arg = cdr(arg))
if (!is_slot(s7_slot(sc, car(arg))))
@@ -91542,7 +91711,7 @@ static bool op_unknown_aa(s7_scheme *sc)
s7_pointer code = sc->code, f = sc->last_function;
if (!f) unbound_variable_error_nr(sc, car(sc->code));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_80(f));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
switch (type(f))
{
@@ -91630,7 +91799,7 @@ static bool op_unknown_na(s7_scheme *sc)
int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0;
if (!f) unbound_variable_error_nr(sc, car(sc->code));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s\n", __func__, __LINE__, display_80(f), display_80(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s\n", __func__, __LINE__, display_truncated(f), display_truncated(sc->code));
if (num_args == 0) return(fixup_unknown_op(sc, code, f, OP_S)); /* via op_closure*-fx where original had 0 args, safe case -> op_safe_closure*_0 */
switch (type(f))
@@ -91748,7 +91917,8 @@ static bool op_unknown_np(s7_scheme *sc)
int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0;
if (!f) unbound_variable_error_nr(sc, car(sc->code));
- if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s %s\n", __func__, __LINE__, display_80(f), type_name(sc, f, NO_ARTICLE), display_80(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s %s\n",
+ __func__, __LINE__, display_truncated(f), type_name(sc, f, NO_ARTICLE), display_truncated(sc->code));
switch (type(f))
{
@@ -91967,7 +92137,8 @@ static noreturn void eval_apply_error_nr(s7_scheme *sc)
/* ---------------- eval ---------------- */
static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
- if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], display_80(sc->code), display_80(sc->args)));
+ if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " eval[%d]:, %s %s %s\n",
+ __LINE__, op_names[first_op], display_truncated(sc->code), display_truncated(sc->args)));
sc->cur_op = first_op;
goto TOP_NO_POP;
@@ -91988,7 +92159,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_bits) */
TOP_NO_POP:
- if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_80(sc->code)));
+ if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_truncated(sc->code)));
/* it is only slightly faster to use labels as values (computed gotos) here. In my timing tests (June-2018), the best case speedup was in titer.scm
* callgrind numbers 4808 to 4669; another good case was tread.scm: 2410 to 2386. Most timings were a draw. computed-gotos-s7.c has the code,
@@ -92870,7 +93041,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
APPLY:
case OP_APPLY:
if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s[%d]: op_apply %s (%s) to %s\n", __func__, __LINE__,
- display_80(sc->code), s7_type_names[type(sc->code)], display_80(sc->args)));
+ display_truncated(sc->code), s7_type_names[type(sc->code)], display_truncated(sc->args)));
switch (type(sc->code))
{
case T_C_FUNCTION: sc->value = apply_c_function(sc, sc->code, sc->args); continue;
@@ -93013,7 +93184,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; /* looping if need eval for init */
case OP_DO:
if (is_null(check_do(sc)))
@@ -93399,7 +93570,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
goto OR_P;
}
if (is_pair(cdr(sc->code)))
- push_stack_no_args(sc, OP_OR_P1, cdr(sc->code));
+ push_stack_no_args(sc, OP_OR_P1, cdr(sc->code)); /* might need to check stack size here */
sc->code = car(sc->code);
goto EVAL;
@@ -93421,11 +93592,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_NAMED_LET: if (op_named_let(sc)) goto BEGIN; goto EVAL;
case OP_NAMED_LET_A: op_named_let_a(sc); goto BEGIN;
case OP_NAMED_LET_AA: op_named_let_aa(sc); goto BEGIN;
- case OP_NAMED_LET_NA: if (op_named_let_na(sc)) goto BEGIN; goto EVAL;
+ case OP_NAMED_LET_NA: op_named_let_na(sc); goto BEGIN;
case OP_LET: if (op_let(sc)) goto BEGIN; goto EVAL;
case OP_LET_UNCHECKED: if (op_let_unchecked(sc)) goto BEGIN; goto EVAL;
- case OP_LET1: if (op_let1(sc)) goto BEGIN; goto EVAL;
+ case OP_LET1: if (op_let_1(sc)) goto BEGIN; goto EVAL;
case OP_LET_NO_VARS: op_let_no_vars(sc); goto BEGIN;
case OP_LET_A_A_OLD: op_let_a_a_old(sc); continue;
@@ -94037,17 +94208,11 @@ void s7_heap_analyze(s7_scheme *sc)
mark_holdee(NULL, opt1_any(s1), "opt1_funcs");
}}
-#if 0
- if (sc->current_safe_list > 0)
- for (s7_pointer p = sc->safe_lists[sc->current_safe_list]; is_pair(p); p = cdr(p))
- mark_holdee(NULL, car(p), "safe_lists");
-#else
for (int32_t i = 1; i < NUM_SAFE_LISTS; i++)
if ((is_pair(sc->safe_lists[i])) &&
(list_is_in_use(sc->safe_lists[i])))
for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p))
mark_holdee(NULL, car(p), "safe_lists");
-#endif
for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "wrong-type-arg");
for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple wrong-type-arg");
@@ -94080,17 +94245,17 @@ void s7_heap_scan(s7_scheme *sc, int32_t typ)
{
found_one = true;
if (obj->holders == 0)
- fprintf(stderr, "%s found no holder (alloc: %s[%d])\n", display_80(obj), obj->alloc_func, obj->alloc_line);
+ fprintf(stderr, "%s found no holder (alloc: %s[%d])\n", display_truncated(obj), obj->alloc_func, obj->alloc_line);
else
if (!obj->holder)
- fprintf(stderr, "%s has built-in holder (holders: %d, alloc: %s[%d])\n", display_80(obj), obj->holders, obj->alloc_func, obj->alloc_line);
+ fprintf(stderr, "%s has built-in holder (holders: %d, alloc: %s[%d])\n", display_truncated(obj), obj->holders, obj->alloc_func, obj->alloc_line);
else
if (obj->root)
fprintf(stderr, "%s from %s alloc: %s[%d] (%d holder%s, alloc: %s[%d])\n",
- display_80(obj), obj->root, obj->alloc_func, obj->alloc_line,
+ display_truncated(obj), obj->root, obj->alloc_func, obj->alloc_line,
obj->holders, (obj->holders != 1) ? "s" : "", obj->holder->alloc_func, obj->holder->alloc_line);
else fprintf(stderr, "%s (%s, alloc: %s[%d], holder%s: %d %p %s alloc: %s[%d])\n",
- display_80(obj), s7_type_names[unchecked_type(obj->holder)], obj->alloc_func, obj->alloc_line,
+ display_truncated(obj), s7_type_names[unchecked_type(obj->holder)], obj->alloc_func, obj->alloc_line,
(obj->holders != 1) ? "s" : "", obj->holders, obj->holder, display(obj->holder), obj->holder->alloc_func, obj->holder->alloc_line);
}}
if (!found_one)
@@ -94478,11 +94643,13 @@ static s7_pointer memory_usage(s7_scheme *sc)
hlen += (hash_table_entries(v) * sizeof(hash_entry_t));
}
all_len += all_len;
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "hash-tables", 11),
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "hash-tables", 11),
cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, hlen)));
}
/* ports */
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-port-stack", 16),
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "input-port-stack", 16),
cons(sc, make_integer(sc, sc->input_port_stack_loc), make_integer(sc, sc->input_port_stack_size)));
gp = sc->input_ports;
for (i = 0, len = 0; i < gp->loc; i++)
@@ -94490,7 +94657,8 @@ static s7_pointer memory_usage(s7_scheme *sc)
s7_pointer v = gp->list[i];
if (port_data(v)) len += port_data_size(v);
}
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-ports", 11),
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "input-ports", 11),
cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, len)));
gp = sc->input_string_ports;
@@ -94499,7 +94667,8 @@ static s7_pointer memory_usage(s7_scheme *sc)
s7_pointer v = gp->list[i];
if (port_data(v)) len += port_data_size(v);
}
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-string-ports", 18),
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "input-string-ports", 18),
cons(sc, make_integer(sc, sc->input_string_ports->loc), make_integer(sc, len)));
gp = sc->output_ports;
@@ -94508,26 +94677,31 @@ static s7_pointer memory_usage(s7_scheme *sc)
s7_pointer v = gp->list[i];
if (port_data(v)) len += port_data_size(v);
}
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "output-ports", 12),
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "output-ports", 12),
cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len)));
-
+#if S7_DEBUGGING
i = 0;
for (s7_pointer p = sc->format_ports; p; i++, p = (s7_pointer)port_next(p));
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "format-ports", 12), make_integer(sc, i));
-
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "format-ports-allocated/free/inuse", 33),
+ list_3(sc, make_integer(sc, sc->format_ports_allocated), make_integer(sc, i), make_integer(sc, sc->format_ports_allocated - i)));
+#endif
/* continuations (sketchy!) */
gp = sc->continuations;
for (i = 0, len = 0; i < gp->loc; i++)
if (is_continuation(gp->list[i]))
len += continuation_stack_size(gp->list[i]);
if (len > 0)
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "continuations", 13),
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "continuations", 13),
cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, len * sizeof(s7_pointer))));
/* c-objects */
if (sc->c_objects->loc > 0)
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-objects", 9), make_integer(sc, sc->c_objects->loc));
if (sc->num_c_object_types > 0)
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-types", 7),
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "c-types", 7),
cons(sc, make_integer(sc, sc->num_c_object_types),
make_integer(sc, (sc->c_object_types_size * sizeof(c_object_t *)) + (sc->num_c_object_types * sizeof(c_object_t)))));
/* we're ignoring c_type->scheme_name: make_permanent_string(sc, name) */
@@ -94546,7 +94720,7 @@ static s7_pointer memory_usage(s7_scheme *sc)
#endif
for (i = 0, len = 0, sc->w = sc->nil; i < TOP_BLOCK_LIST; i++)
{
- for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++);
+ for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++); /* these are the free blocks awaiting mallocate */
sc->w = cons(sc, make_integer(sc, k), sc->w);
len += ((sizeof(block_t) + (1LL << i)) * k);
#if S7_DEBUGGING
@@ -94558,8 +94732,9 @@ static s7_pointer memory_usage(s7_scheme *sc)
sc->w = cons(sc, make_integer(sc, k), sc->w);
#if S7_DEBUGGING
num_blocks += k;
- add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "blocks-allocated", 16),
- cons(sc, make_integer(sc, num_blocks), make_integer(sc, sc->blocks_allocated)));
+ add_slot_unchecked_with_id(sc, mu_let,
+ make_symbol(sc, "blocks-allocated/available/in-use", 33),
+ list_3(sc, make_integer(sc, sc->blocks_allocated), make_integer(sc, num_blocks), make_integer(sc, sc->blocks_allocated - num_blocks)));
#endif
add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10),
s7_inlet(sc, list_2(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)),
@@ -95138,7 +95313,7 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val
case SL_OUTPUT_FILE_PORT_DATA_SIZE:
sc->output_file_port_data_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
return(val);
- case SL_PRINT_LENGTH:
+ case SL_PRINT_LENGTH: /* for pairs and vectors this affects how many elements are printed -- confusing */
sc->print_length = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val));
return(val);
@@ -95368,7 +95543,7 @@ const char *s7_decode_bt(s7_scheme *sc)
i = k - 1;
if (s7_is_valid(sc, p))
{
- s7_pointer strp = object_to_truncated_string(sc, p, 80);
+ s7_pointer strp = object_to_string_truncated(sc, p);
if (dname) fprintf(stdout, " ");
fprintf(stdout, "%s%s%s", bold_text, string_value(strp), unbold_text);
if ((is_pair(p)) &&
@@ -95713,6 +95888,7 @@ static void init_opt_functions(s7_scheme *sc)
s7_set_d_d_function(sc, global_value(sc->magnitude_symbol), magnitude_d_d);
s7_set_p_p_function(sc, global_value(sc->magnitude_symbol), magnitude_p_p);
+ s7_set_d_d_function(sc, global_value(sc->angle_symbol), angle_d_d);
s7_set_p_d_function(sc, global_value(sc->sin_symbol), sin_p_d);
s7_set_p_p_function(sc, global_value(sc->sin_symbol), sin_p_p);
s7_set_p_d_function(sc, global_value(sc->cos_symbol), cos_p_d);
@@ -95794,6 +95970,7 @@ static void init_opt_functions(s7_scheme *sc)
s7_set_i_i_function(sc, global_value(sc->truncate_symbol), truncate_i_i);
s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d);
+ s7_set_d_d_function(sc, global_value(sc->atan_symbol), atan_d_d);
s7_set_d_dd_function(sc, global_value(sc->atan_symbol), atan_d_dd);
s7_set_d_d_function(sc, global_value(sc->tanh_symbol), tanh_d_d);
s7_set_p_p_function(sc, global_value(sc->exp_symbol), exp_p_p);
@@ -96365,30 +96542,32 @@ static void init_setters(s7_scheme *sc)
#else
set_is_setter(sc->set_current_input_port_symbol);
set_is_setter(sc->set_current_output_port_symbol);
- s7_function_set_setter(sc, sc->current_input_port_symbol, sc->set_current_input_port_symbol);
- s7_function_set_setter(sc, sc->current_output_port_symbol, sc->set_current_output_port_symbol);
+ c_function_set_setter(global_value(sc->current_input_port_symbol), global_value(sc->set_current_input_port_symbol));
+ c_function_set_setter(global_value(sc->current_output_port_symbol), global_value(sc->set_current_output_port_symbol));
#endif
set_is_setter(sc->set_current_error_port_symbol);
- s7_function_set_setter(sc, sc->current_error_port_symbol, sc->set_current_error_port_symbol);
+ c_function_set_setter(global_value(sc->current_error_port_symbol), global_value(sc->set_current_error_port_symbol));
/* despite the similar names, current-error-port is different from the other two, and a setter is needed
* in scheme because error and warn send output to it by default. It is not a "dynamic variable".
*/
- s7_function_set_setter(sc, sc->car_symbol, sc->set_car_symbol);
- s7_function_set_setter(sc, sc->cdr_symbol, sc->set_cdr_symbol);
- s7_function_set_setter(sc, sc->hash_table_ref_symbol, sc->hash_table_set_symbol);
- s7_function_set_setter(sc, sc->vector_ref_symbol, sc->vector_set_symbol);
- s7_function_set_setter(sc, sc->float_vector_ref_symbol, sc->float_vector_set_symbol);
- s7_function_set_setter(sc, sc->int_vector_ref_symbol, sc->int_vector_set_symbol);
- s7_function_set_setter(sc, sc->byte_vector_ref_symbol, sc->byte_vector_set_symbol);
- s7_function_set_setter(sc, sc->list_ref_symbol, sc->list_set_symbol);
- s7_function_set_setter(sc, sc->let_ref_symbol, sc->let_set_symbol);
- s7_function_set_setter(sc, sc->string_ref_symbol, sc->string_set_symbol);
+ c_function_set_setter(global_value(sc->car_symbol), global_value(sc->set_car_symbol));
+ c_function_set_setter(global_value(sc->cdr_symbol), global_value(sc->set_cdr_symbol));
+ c_function_set_setter(global_value(sc->hash_table_ref_symbol), global_value(sc->hash_table_set_symbol));
+ c_function_set_setter(global_value(sc->vector_ref_symbol), global_value(sc->vector_set_symbol));
+ c_function_set_setter(global_value(sc->float_vector_ref_symbol), global_value(sc->float_vector_set_symbol));
+ c_function_set_setter(global_value(sc->int_vector_ref_symbol), global_value(sc->int_vector_set_symbol));
+ c_function_set_setter(global_value(sc->byte_vector_ref_symbol), global_value(sc->byte_vector_set_symbol));
+ c_function_set_setter(global_value(sc->list_ref_symbol), global_value(sc->list_set_symbol));
+ c_function_set_setter(global_value(sc->let_ref_symbol), global_value(sc->let_set_symbol));
+ c_function_set_setter(global_value(sc->string_ref_symbol), global_value(sc->string_set_symbol));
c_function_set_setter(global_value(sc->outlet_symbol),
s7_make_safe_function(sc, "#<set-outlet>", g_set_outlet, 2, 0, false, "outlet setter"));
c_function_set_setter(global_value(sc->port_line_number_symbol),
s7_make_safe_function(sc, "#<set-port-line-number>", g_set_port_line_number, 1, 1, false, "port-line setter"));
+ c_function_set_setter(global_value(sc->port_string_symbol),
+ s7_make_safe_function(sc, "#<set-port-string>", g_set_port_string, 2, 0, false, "port-string setter"));
c_function_set_setter(global_value(sc->port_position_symbol),
s7_make_safe_function(sc, "#<set-port-position>", g_set_port_position, 2, 0, false, "port-position setter"));
c_function_set_setter(global_value(sc->vector_typer_symbol),
@@ -96677,7 +96856,12 @@ static void init_rootlet(s7_scheme *sc)
sc->inlet_symbol = defun("inlet", inlet, 0, 0, true);
sc->owlet_symbol = defun("owlet", owlet, 0, 0, false);
sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false);
- sc->openlet_symbol = defun("openlet", openlet, 1, 0, false);
+ sc->openlet_symbol = unsafe_defun("openlet", openlet, 1, 0, false);
+ /* unsafe here because otherwise it can be optimized, whereupon our gc_protect_via_stack becomes unreliable:
+ * we can't assume the current top-of-stack is the gc_protect in fx_c_aa (for example): if fn_proc hits an openlet method redirect to map or for-each,
+ * the stack will have that operator awaiting the next spin through eval: (define (f) (write (vector 1.0) (openlet (inlet 'write for-each)))) (f)
+ * the "f" function is needed to get the optimizer to call fx_c_aa. This affects fx/opt cases throughout!
+ */
sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false);
set_immutable(sc->let_ref_symbol); /* 16-Sep-19 */
set_immutable_slot(global_slot(sc->let_ref_symbol));
@@ -96705,6 +96889,7 @@ static void init_rootlet(s7_scheme *sc)
sc->c_pointer_weak2_symbol = defun("c-pointer-weak2", c_pointer_weak2, 1, 0, false);
sc->c_pointer_to_list_symbol = defun("c-pointer->list", c_pointer_to_list, 1, 0, false);
+ sc->port_string_symbol = defun("port-string", port_string, 1, 0, false);
sc->port_file_symbol = defun("port-file", port_file, 1, 0, false);
sc->port_position_symbol = defun("port-position", port_position, 1, 0, false);
sc->port_line_number_symbol = defun("port-line-number", port_line_number, 0, 1, false);
@@ -97467,8 +97652,11 @@ s7_scheme *s7_init(void)
/* if not_filled, segfault in gc_mark in mark_stack_1 after size check? probably unfilled OP_BARRIER etc? */
sc->stack_start = vector_elements(sc->stack); /* stack type set below */
sc->stack_end = sc->stack_start;
- sc->stack_size = INITIAL_STACK_SIZE;
+ if (STACK_RESIZE_TRIGGER <= (INITIAL_STACK_SIZE / 2))
+ sc->stack_size = INITIAL_STACK_SIZE;
+ else sc->stack_size = STACK_RESIZE_TRIGGER * 2;
sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (INITIAL_STACK_SIZE - STACK_RESIZE_TRIGGER));
+
set_full_type(sc->stack, T_STACK);
sc->max_stack_size = (1 << 30);
stack_clear_flags(sc->stack);
@@ -97786,7 +97974,8 @@ s7_scheme *s7_init(void)
* (begin 23 (cond-expand (surreals 1) (foonly 2))) should evaluate to 23.
*/
/* make-polar, call-with-values, make-hook, hook-functions, multiple-value-bind, cond-expand, and reader-cond can't
- * set the initial_value to the global_value so that #_... can be used because the global_value is not semipremanent.
+ * set the initial_value to the global_value so that #_... can be used because the global_value is not semipermanent.
+ * but could it be made so?
*/
#endif
@@ -97796,6 +97985,7 @@ s7_scheme *s7_init(void)
if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]);
if (NUM_OPS != 927) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info));
/* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */
+ gdb_break();
#endif
return(sc);
}
@@ -98171,56 +98361,56 @@ int main(int argc, char **argv)
* --------------------------------------------------------------
* tpeak 148 115 114 108 105 102 102
* tref 1081 691 687 463 459 464 410
- * index 1026 1016 973 967 972 973
+ * index 1026 1016 973 967 972 970
* tmock 1177 1165 1057 1019 1032 1029
* tvect 3408 2519 2464 1772 1669 1497 1454
* tauto 2562 2048 1729 1707
- * texit 1884 1930 1950 1778 1741 1770 1769
- * s7test 1873 1831 1818 1829 1830 1857
- * lt 2222 2187 2172 2150 2185 1950 1952
- * thook 7651 2590 2030 2046 2011
- * dup 3805 3788 2492 2239 2097 2031
- * tcopy 8035 5546 2539 2375 2386 2387
+ * texit 1884 1930 1950 1778 1741 1770 1768
+ * s7test 1873 1831 1818 1829 1830 1870
+ * lt 2222 2187 2172 2150 2185 1950 1950
+ * dup 3805 3788 2492 2239 2097 1996
+ * thook 7651 2590 2030 2046 2015
+ * tcopy 8035 5546 2539 2375 2386 2370 2343 [add_slot_no_local]
* tread 2440 2421 2419 2408 2405 2256
* titer 3657 2865 2842 2641 2509 2449 2446
* trclo 8031 2735 2574 2454 2445 2449 2470
- * tload 3046 2404 2566 2537
+ * tmat 3065 3042 2524 2578 2590 2512
+ * tload 3046 2404 2566 2546
* fbench 2933 2688 2583 2460 2430 2478 2562
- * tmat 3065 3042 2524 2578 2590 2578
* tsort 3683 3105 3104 2856 2804 2858 2858
- * tobj 4016 3970 3828 3577 3508 3518
- * teq 4068 4045 3536 3486 3544 3527
- * tio 3816 3752 3683 3620 3583 3601
+ * tio 3816 3752 3683 3620 3583 3128 3132 [set_output_port_string]
+ * tobj 4016 3970 3828 3577 3508 3453
+ * teq 4068 4045 3536 3486 3544 3507
* tmac 3950 3873 3033 3677 3677 3683
* tclo 6362 4787 4735 4390 4384 4474 4337
- * tcase 4960 4793 4439 4430 4439 4446
- * tlet 9166 7775 5640 4450 4427 4457 4481
+ * tcase 4960 4793 4439 4430 4439 4433
+ * tlet 9166 7775 5640 4450 4427 4457 4492
* tfft 7820 7729 4755 4476 4536 4542
- * tstar 6139 5923 5519 4449 4550 4578
+ * tstar 6139 5923 5519 4449 4550 4584
* tmap 8869 8774 4489 4541 4586 4593
- * tshoot 5525 5447 5183 5055 5034 5052
- * tform 5357 5348 5307 5316 5084 5087
- * tstr 10.0 6880 6342 5488 5162 5180 5205
- * tnum 6348 6013 5433 5396 5409 5432
+ * tshoot 5525 5447 5183 5055 5034 5055
+ * tform 5357 5348 5307 5316 5084 5098
+ * tstr 10.0 6880 6342 5488 5162 5180 5211 5275 [op_let1]
+ * tnum 6348 6013 5433 5396 5409 5434 5452
* tgsl 8485 7802 6373 6282 6208 6181
- * tari 15.0 13.0 12.7 6827 6543 6278 6274
- * tlist 9219 7896 7546 6558 6240 6300 6305
- * tset 6260 6364 6394
+ * tari 15.0 13.0 12.7 6827 6543 6278 6184
+ * tlist 9219 7896 7546 6558 6240 6300 6306
+ * tset 6260 6364 6377
* trec 19.5 6936 6922 6521 6588 6583 6584
- * tleft 11.1 10.4 10.2 7657 7479 7627 7612
- * tmisc 8142 7631 7673
- * tlamb 8003 7941 7948
- * tgc 11.9 11.1 8177 7857 7986 8014
+ * tleft 11.1 10.4 10.2 7657 7479 7627 7613
+ * tmisc 8142 7631 7679
+ * tlamb 8003 7941 7940 7950
+ * tgc 11.9 11.1 8177 7857 7986 7959 8015 [op_let1]
* thash 11.8 11.7 9734 9479 9526 9254
- * cb 12.9 11.2 11.0 9658 9564 9609 9641
+ * cb 12.9 11.2 11.0 9658 9564 9609 9639 9670 [op_named_let_1, gc]
* tmap-hash 1671.0 1467.0 10.3
* tmv 16.0 15.4 14.7 14.5 14.4 11.9
- * tgen 11.2 11.4 12.0 12.1 12.2 12.3
+ * tgen 11.2 11.4 12.0 12.1 12.2 12.3 12.4 [op_let1, gc]
* tall 15.9 15.6 15.6 15.6 15.6 15.1 15.1
- * timp 25.4 24.4 20.0 19.6 19.7 15.6
- * calls 36.7 37.5 37.0 37.5 37.1 37.1
- * sg 55.9 55.8 55.4 55.2
- * tbig 177.4 175.8 156.5 148.1 146.2 146.2
+ * timp 25.4 24.4 20.0 19.6 19.7 15.7
+ * calls 36.7 37.5 37.0 37.5 37.1 37.0 37.2 [op_let1, gc]
+ * sg 55.9 55.8 55.4 55.2 55.4 same
+ * tbig 177.4 175.8 156.5 148.1 146.2 146.1
* --------------------------------------------------------------
*
* snd-region|select: (since we can't check for consistency when set), should there be more elaborate writable checks for default-output-header|sample-type?
@@ -98229,4 +98419,26 @@ int main(int argc, char **argv)
* (define print-length (list 1 2)) (define (f) (with-let *s7* (+ print-length 1))) (display (f)) (newline) -- need a placeholder-let (or actual let) for *s7*?
* so (with-let *s7* ...) would make a let with whatever *s7* entries are needed? -> (let ((print-length (*s7* 'print-length))) ...)
* currently sc->s7_starlet is a let (make_s7_starlet) using g_s7_let_ref_fallback, so it assumes print-length above is undefined
+ * need some print-length/print-elements distinction for vector/pair etc [which to choose if both set?]
+ * 73150 vars_opt_ok problem
+ * weak-hash_iterate #<eof> in loops elsewhere? (iterator seq) -- a better name than make-iterator?
+ * values feeding safe func -- can't this be opt'd? (values 1) at least
+ * perhaps fx_simple_catch? (if #t is error type, stack should end up ok?)
+ * if closure sig, add some way to have arg types checked by s7? (*s7* :check-signature?)
+ * can set_locals in add_slots be omitted? if add_slot_checked_with_id (as in copy) it looks redundant (symbol is already local?) [add_slot_no_local -- check for others)
+ * check let/do -- redundant slot? op_let_1 et al
+ * 0/1/2-arg-func types? [esp closure-args -- why save a list if let can recreate it? (defines?) but this can be changed in any case]
+ * need some counts here (eval:apply etc)
+ * #_ extended to anything that might be captured? #_make-rectangular|polar i.e. ((rootlet) :make-polar)? see comment line 97936
+ * similarly #_ for any c_function (libraries), or variable etc
+ * or perhaps better, user-defined way to create #_ refs: (define #_x x) where existing #_x blocks the definition in its context? (define #<x> x) might be better
+ * (define #<L> L) then (#<L> :x) can't be captured? Currently #<L> is t_undefined, and #_L looks in unlet. Here #<L> is the inlet itself.
+ * (define (f x) x) (define-constant #<f> f) (#<f> 1) [or maybe #_f but will that confuse the reader?]
+ * can this fix the let-fallback-ref|set problem, with-let and others?
+ * does define-constant itself handle this (define-constant F f)
+ * see also comment 97974 -- if vals are not semipermanent, can be GC'd
+ * s7_set_initial_slot, (set! #<asdf> 32)
+ * need counts for block_list[index] of allocs/frees + lines + total-sizes
+ * :blocks-allocated/available/in-use (668672 652001 16671): maybe break up large blocks?
+ * why doesn't #symbol<a b c> work in let-temp, can we use these (t692) as par names etc?
*/
diff --git a/s7.h b/s7.h
index e08e0c3..2b3a9ca 100644
--- a/s7.h
+++ b/s7.h
@@ -1,10 +1,10 @@
#ifndef S7_H
#define S7_H
-#define S7_VERSION "10.8"
-#define S7_DATE "14-Apr-2024"
+#define S7_VERSION "10.9"
+#define S7_DATE "17-May-2024"
#define S7_MAJOR_VERSION 10
-#define S7_MINOR_VERSION 8
+#define S7_MINOR_VERSION 9
#include <stdint.h> /* for int64_t */
@@ -904,7 +904,8 @@ bool s7_is_bignum(s7_pointer obj);
/* --------------------------------------------------------------------------------
*
* s7 changes
-
+ *
+ * 24-Apr: port-string.
* 8-Jan-23: s7_gc_protect_2_via_stack.
* --------
* 15-Nov: s7_make_c_pointer_wrapper_with_type.
diff --git a/s7.html b/s7.html
index 130ea0c..0c80026 100644
--- a/s7.html
+++ b/s7.html
@@ -763,6 +763,16 @@ have been evaluated (as in named let).
&gt; (foo x 1)
<em class="gray">1</em>
</pre>
+
+<p>Keywords (named arguments) also work in named let*:
+</p>
+<pre class="indented">
+&gt; (let* loop ((i 0) (j 0))
+ (if (> i 3)
+ (+ i j)
+ (loop :j 2 :i (+ i 1))))
+<em class="gray">6</em>
+</pre>
</div>
@@ -4093,10 +4103,10 @@ result = s7_call(s7, hook, s7_list(s7, 2, s7_make_integer(s7, 1), s7_make_intege
<pre class="indented">
-(<em class=def id="documentation">documentation</em> obj) ; old name: (procedure-documentation obj)
-(<em class=def id="signature">signature</em> obj) ; old: (procedure-signature obj)
-(<em class=def id="setter">setter</em> obj) ; old: (procedure-setter obj)
-(<em class=def id="arity">arity</em> obj) ; very old: (procedure-arity obj)
+(<em class=def id="documentation">documentation</em> obj)
+(<em class=def id="signature">signature</em> obj)
+(<em class=def id="setter">setter</em> obj)
+(<em class=def id="arity">arity</em> obj)
(<em class=def id="aritablep">aritable?</em> obj num-args)
(funclet proc)
(<em class=def id="proceduresource">procedure-source</em> proc)
@@ -4114,7 +4124,7 @@ a procedure's environment.
</pre>
<p>
-<b>setter</b> returns or sets the set function associated with a procedure (set-car! with car, for example).
+<b>setter</b> returns or sets the setter function associated with a procedure (set-car! with car, for example).
</p>
<p>
@@ -4157,7 +4167,7 @@ you can treat the initial string in the function's body as documentation.
</pre>
<p>
-<b>arity</b> takes any object and returns either #f if it is not applicable,
+<b>arity</b> takes any object and returns either #f if that object is not applicable,
or a cons containing the minimum and maximum number of arguments acceptable. If the maximum reported
is a really big number, that means any number of arguments is ok.
<b>aritable?</b> takes two arguments, an object and an integer, and returns #t if the object can be
@@ -4201,11 +4211,14 @@ argument types. #t means any type is possible, and 'values means the function r
</pre>
<p>which says that the first argument to char-position can be a string or a character,
-and the return type can be either boolean or an integer. If we know a function returns
-multiple values, the return type (first element of the signature) can contain a list
-describing each such value: <code>(define (f x) (values (floor x) (ceiling x)))</code>
-could be <code>(((integer?) (integer?)) real?)</code>.
+and the return type can be either boolean or an integer. To specify the types returned
+if multiple values are returned, use (values type1 ..). So the function:
+</p>
+<code>(define (f int) (case ((0) (values 0 1)) ((1) ((values 'a 1)) (else 0))))</code>
+<p>could declare its signature to be
</p>
+<code>(((values integer? integer?) (values symbol? integer?) integer?) integer?)</code>
+;; or would it be better to omit the 'values and just have a list of types?
<p>
If the function is defined in scheme, its signature is the value of the '+signature+ variable
in its closure:
@@ -4223,7 +4236,7 @@ in its closure:
<em class="gray">(boolean? real?)</em>
</pre>
-<p>We could do the same thing using methods:
+<p>We can do the same thing using methods:
</p>
<pre class="indented">
@@ -4238,7 +4251,7 @@ in its closure:
<em class="gray">(boolean? real?)</em>
</pre>
-<p>signature could also be used to implement CL's 'the:
+<p>signature can also be used to implement CL's 'the:
</p>
<pre class="indented">
(define-macro (the value-type form)
@@ -4384,12 +4397,14 @@ Other functions:
<li><em class=def id="portfilename">port-filename</em> and
<em class=def id="portlinenumber">port-line-number</em> (input ports)
<li><em class=def id="portposition">port-position</em> (input port, settable)
+<li><em class=def id="portstring">port-string</em> (string port, settable)
<li><em class=def id="portfile">port-file</em>
</ul>
<p>Use length to get the length in bytes of an input port's file or string.
port-line-number is settable (for fancy *#readers*).
<b>port-position</b> is the position in bytes of the reader in the port. It is settable.
+<b>port-string</b> is the string contents of a string port. It is also settable.
<b>port-file</b> is intended for use with the *libc* library. It returns a c-pointer
containing the FILE* pointer associated with the file port (except in Windows):
</p>
@@ -6283,11 +6298,11 @@ This is consistent with, for example,
The standard says "the empty list is a special object of its own type", so surely either choice is
acceptable in that regard (but, sigh, the standard stupidly goes on to deny that () can evaluate to itself).
(I'm told that "is an error" means "is not portable" in the standard's weasely abuse of English; if
-they mean "is not portable" why not say so?).
+they mean "is not portable" why not say that?).
Some of the confusion appears to be caused by the word "list". I would describe the evaluator: "if it gets a
constant (and () is a constant) it returns that constant; if a symbol, it returns the value
associated with that symbol; if a pair, it looks at the pair's
-car to decide what to do". It's kinda looney to insist on looking at the car of a list when you know () has no car!
+car to decide what to do".
</p>
<!--
@@ -6566,8 +6581,26 @@ This output is readable, and does not eat up perfectly good
characters like vertical bar, but it means we can't easily use
variable names like "| e t c |". We could allow a name to
contain any characters if it starts and ends with "|",
-but then one vertical bar is trouble.
+but then one vertical bar is trouble. We can define a reader
+that turns <code>#symbol&lt;...&gt;</code> into <code>(symbol "...")</code>,
+making it possible to use odd names more widely:
</p>
+
+<pre class="indented">
+(set! *#readers*
+ (list (cons #\s
+ (lambda (str)
+ (and (string=? (substring str 0 7) "symbol<")
+ (do ((sym (substring str 7))
+ (c (read-char) (read-char)))
+ ((memq c (list #\&gt; #&lt;eof&gt;))
+ (string->symbol sym))
+ (set! sym (string-append sym (string c)))))))))
+
+&gt; (let ((#symbol&lt;a b c&gt; 32)) (+ #symbol&lt;a b c&gt; 1))
+<em class="gray">33</em>
+</pre>
+
<p>
The symbol function
accepts any number of string arguments which it concatenates
diff --git a/s7test.scm b/s7test.scm
index cc3a13d..4e59523 100644
--- a/s7test.scm
+++ b/s7test.scm
@@ -699,19 +699,28 @@ static s7_pointer g_cycle_ref(s7_scheme *sc, s7_pointer args)
g_cycle *g;
if (s7_list_length(sc, args) != 1)
return(s7_wrong_number_of_args_error(sc, \"cycle-ref takes 1 argument: ~~S\", args));
- g = (g_cycle *)s7_c_object_value(s7_car(args));
+ g = (g_cycle *)s7_c_object_value_checked(s7_car(args), g_cycle_type);
+ if (!g)
+ s7_error(sc, s7_make_symbol(sc, \"wrong-type-arg\"),
+ s7_list(sc, 1, s7_make_string_wrapper(sc, \"object passed to cycle-ref is not a cycle object\")));
return(g->obj);
}
static s7_pointer g_cycle_to_list(s7_scheme *sc, s7_pointer args)
{
- g_cycle *g = (g_cycle *)s7_c_object_value(s7_car(args));
+ g_cycle *g = (g_cycle *)s7_c_object_value_checked(s7_car(args), g_cycle_type);
+ if (!g)
+ s7_error(sc, s7_make_symbol(sc, \"wrong-type-arg\"),
+ s7_list(sc, 1, s7_make_string_wrapper(sc, \"object passed to cycle->list is not a cycle object\")));
return(s7_cons(sc, g->obj, s7_nil(sc)));
}
static s7_pointer g_cycle_set(s7_scheme *sc, s7_pointer args)
{
- g_cycle *g = (g_cycle *)s7_c_object_value(s7_car(args));
+ g_cycle *g = (g_cycle *)s7_c_object_value_checked(s7_car(args), g_cycle_type);
+ if (!g)
+ s7_error(sc, s7_make_symbol(sc, \"wrong-type-arg\"),
+ s7_list(sc, 1, s7_make_string_wrapper(sc, \"object passed to cycle-set! is not a cycle object\")));
g->obj = s7_cadr(args);
return(g->obj);
}
@@ -723,7 +732,10 @@ static s7_pointer g_cycle_implicit_set(s7_scheme *sc, s7_pointer args)
s7_int index;
if (s7_list_length(sc, args) != 3)
return(s7_wrong_number_of_args_error(sc, \"cycle-set! takes 3 arguments: ~~S\", args));
- g = (g_cycle *)s7_c_object_value(s7_car(args));
+ g = (g_cycle *)s7_c_object_value_checked(s7_car(args), g_cycle_type);
+ if (!g)
+ s7_error(sc, s7_make_symbol(sc, \"wrong-type-arg\"),
+ s7_list(sc, 1, s7_make_string_wrapper(sc, \"object passed to implicit cycle-set! is not a cycle object\")));
if ((!s7_is_integer(s7_cadr(args))) ||
(s7_integer(s7_cadr(args)) != 0))
return(s7_out_of_range_error(sc, \"implicit cycle-set!\", 2, s7_cadr(args), \"it should be 0\"));
@@ -735,9 +747,8 @@ static s7_pointer g_cycle_copy(s7_scheme *sc, s7_pointer args)
{
s7_pointer obj = s7_car(args);
g_cycle *g;
- if (s7_c_object_type(obj) != g_cycle_type) /* obj might not be a cycle object if destination is one */
- return(s7_f(sc));
- g = (g_cycle *)s7_c_object_value(s7_car(args));
+ g = (g_cycle *)s7_c_object_value_checked(s7_car(args), g_cycle_type);
+ if (!g) return(s7_f(sc)); /* obj might not be a cycle object if destination is one */
return(g_make_cycle(sc, s7_list(sc, 1, g->obj)));
}
@@ -808,7 +819,7 @@ static char *g_block_display(s7_scheme *sc, void *value)
old_len = s7_integer(s7_starlet_ref(sc, pl));
if (len > old_len) len = old_len;
buf = (char *)malloc((len + 1) * 64);
- if (!buf) s7_error(sc, oom, s7_list(sc, 1, s7_make_string(sc, \"unable to allocate string to display block\")));
+ if (!buf) s7_error(sc, oom, s7_list(sc, 1, s7_make_string_wrapper(sc, \"unable to allocate string to display block\")));
buf[0] = (char)0;
loc = snprintf(buf, (len + 1) * 64, \"(block\");
for (i = 0; i < len; i++)
@@ -923,10 +934,12 @@ static s7_pointer block_ref_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer ind)
{
g_block *g;
size_t index;
- s7_int typ = s7_c_object_type(obj);
- if ((typ != g_block_type) && (typ != g_simple_block_type))
- return(s7_wrong_type_arg_error(sc, \"block-ref\", 1, obj, \"a block\"));
- g = (g_block *)s7_c_object_value(obj);
+ g = (g_block *)s7_c_object_value_checked(obj, g_block_type);
+ if (!g)
+ {
+ g = (g_block *)s7_c_object_value_checked(obj, g_simple_block_type);
+ if (!g) s7_wrong_type_arg_error(sc, \"block-ref\", 1, obj, \"a block\");
+ }
if (s7_is_integer(ind))
index = (size_t)s7_integer(ind);
else
@@ -956,10 +969,12 @@ static s7_pointer g_block_ref(s7_scheme *sc, s7_pointer args)
static s7_double block_ref_d_7pi(s7_scheme *sc, s7_pointer p, s7_int index)
{
g_block *g;
- s7_int typ = s7_c_object_type(p); /* currently d_7pi_ok only checks float-vector-ref, so we need to check block-ref here */
- if ((typ != g_block_type) && (typ != g_simple_block_type))
- s7_wrong_type_arg_error(sc, \"block-ref\", 1, p, \"a block\");
- g = (g_block *)s7_c_object_value(p);
+ g = (g_block *)s7_c_object_value_checked(p, g_block_type);
+ if (!g)
+ {
+ g = (g_block *)s7_c_object_value_checked(p, g_simple_block_type);
+ if (!g) s7_wrong_type_arg_error(sc, \"block-ref\", 1, p, \"a block\");
+ }
if ((index < 0) || (index >= g->size))
s7_out_of_range_error(sc, \"block-ref\", 2, s7_make_integer(sc, index), (index >= 0) ? \"it should be less than block length\" : \"it should be non-negative\");
return(g->data[index]);
@@ -969,14 +984,16 @@ static s7_pointer block_set_p_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer ind,
{
g_block *g;
s7_int index;
- s7_int typ = s7_c_object_type(obj);
- if ((typ != g_block_type) && (typ != g_simple_block_type))
- return(s7_wrong_type_arg_error(sc, \"block-set!\", 1, obj, \"a block\"));
if (s7_is_immutable(obj))
return(s7_wrong_type_arg_error(sc, \"block-set!\", 1, obj, \"a mutable block\"));
+ g = (g_block *)s7_c_object_value_checked(obj, g_block_type);
+ if (!g)
+ {
+ g = (g_block *)s7_c_object_value_checked(obj, g_simple_block_type);
+ if (!g) s7_wrong_type_arg_error(sc, \"block-ref\", 1, obj, \"a block\");
+ }
if (!s7_is_integer(ind))
return(s7_wrong_type_arg_error(sc, \"block-set!\", 2, ind, \"an integer\"));
- g = (g_block *)s7_c_object_value(obj);
index = s7_integer(ind);
if ((index >= 0) && (index < g->size))
{
@@ -1000,14 +1017,16 @@ static s7_pointer g_block_set(s7_scheme *sc, s7_pointer args)
static s7_double block_set_d_7pid(s7_scheme *sc, s7_pointer p, s7_int index, s7_double x)
{
g_block *g;
- s7_int typ = s7_c_object_type(p);
- if ((typ != g_block_type) && (typ != g_simple_block_type))
- s7_wrong_type_arg_error(sc, \"block-set!\", 1, p, \"a block\");
- g = (g_block *)s7_c_object_value(p);
- if ((index < 0) || (index >= g->size))
- s7_out_of_range_error(sc, \"block-set!\", 2, s7_make_integer(sc, index), (index >= 0) ? \"it should be less than block length\" : \"it should be non-negative\");
if (s7_is_immutable(p))
s7_wrong_type_arg_error(sc, \"block-set!\", 1, p, \"a mutable block\");
+ g = (g_block *)s7_c_object_value_checked(p, g_block_type);
+ if (!g)
+ {
+ g = (g_block *)s7_c_object_value_checked(p, g_simple_block_type);
+ if (!g) s7_wrong_type_arg_error(sc, \"block-ref\", 1, p, \"a block\");
+ }
+ if ((index < 0) || (index >= g->size))
+ s7_out_of_range_error(sc, \"block-set!\", 2, s7_make_integer(sc, index), (index >= 0) ? \"it should be less than block length\" : \"it should be non-negative\");
g->data[index] = x;
return(x);
}
@@ -1110,12 +1129,11 @@ static s7_pointer g_blocks_are_equivalent(s7_scheme *sc, s7_pointer args)
return(s7_f(sc));
if (arg1 == arg2)
return(s7_make_boolean(sc, true));
- if (s7_is_let(arg1)) /* (block-let (block)) */
+ if (s7_is_let(arg1)) /* (block-let (block)) */
return(s7_make_boolean(sc, false)); /* checked == above */
g1 = (g_block *)s7_c_object_value(arg1);
- if (s7_c_object_type(arg2) != g_block_type)
- return(s7_make_boolean(sc, false));
- g2 = (g_block *)s7_c_object_value(arg2);
+ g2 = (g_block *)s7_c_object_value_checked(arg2, g_block_type);
+ if (!g2) return(s7_make_boolean(sc, false));
len = g1->size;
if (len != g2->size)
return(s7_make_boolean(sc, false));
@@ -1139,9 +1157,8 @@ static s7_pointer g_block_append(s7_scheme *sc, s7_pointer args)
for (i = 1, p = args; s7_is_pair(p); p = s7_cdr(p), i++)
{
g_block *g1;
- if (s7_c_object_type(s7_car(p)) != g_block_type)
- return(s7_wrong_type_arg_error(sc, \"block-append\", i, s7_car(p), \"a block\"));
- g1 = (g_block *)s7_c_object_value(s7_car(p));
+ g1 = (g_block *)s7_c_object_value_checked(s7_car(p), g_block_type);
+ if (!g1) return(s7_wrong_type_arg_error(sc, \"block-append\", i, s7_car(p), \"a block\"));
len += g1->size;
}
new_g = make_block_raw(sc, len);
@@ -1190,11 +1207,10 @@ static s7_pointer g_block_reverse_in_place(s7_scheme *sc, s7_pointer args) /* Ve
g_block *g;
double *d1, *d2;
s7_pointer obj = s7_car(args);
- if (s7_c_object_type(obj) != g_block_type)
- return(s7_wrong_type_arg_error(sc, \"block-reverse!\", 0, obj, \"a block\"));
if (s7_is_immutable(obj))
return(s7_wrong_type_arg_error(sc, \"block-reverse!\", 0, obj, \"a mutable block\"));
- g = (g_block *)s7_c_object_value(obj);
+ g = (g_block *)s7_c_object_value_checked(obj, g_block_type);
+ if (!g) return(s7_wrong_type_arg_error(sc, \"block-reverse!\", 0, obj, \"a block\"));
if (g->size < 2) return(obj);
d1 = g->data;
d2 = (double *)(d1 + g->size - 1);
@@ -1281,9 +1297,8 @@ static s7_pointer g_subblock(s7_scheme *sc, s7_pointer args)
s7_pointer obj = s7_car(args);
s7_int start = 0, new_len, i;
g_block *g, *g1;
- if (s7_c_object_type(obj) != g_block_type)
- return(s7_wrong_type_arg_error(sc, \"subblock\", 1, obj, \"a block\"));
- g = (g_block *)s7_c_object_value(obj);
+ g = (g_block *)s7_c_object_value_checked(obj, g_block_type);
+ if (!g) return(s7_wrong_type_arg_error(sc, \"subblock\", 1, obj, \"a block\"));
new_len = get_start_and_end(sc, args, &start, g->size);
new_g = make_block_raw(sc, new_len);
g1 = (g_block *)s7_c_object_value(new_g);
@@ -1357,9 +1372,9 @@ static s7_pointer finput(s7_scheme *sc, s7_read_t peek, s7_pointer port)
case S7_IS_CHAR_READY:
return(s7_make_boolean(sc, fin_loc < fin_size));
case S7_READ:
- return(s7_error(sc, s7_make_symbol(sc, \"read-error\"), s7_make_string(sc, \"can't read yet!\")));
+ return(s7_error(sc, s7_make_symbol(sc, \"read-error\"), s7_make_string_wrapper(sc, \"can't read yet!\")));
default:
- return(s7_error(sc, s7_make_symbol(sc, \"read-error\"), s7_make_string(sc, \"unknown s7_input_function choice\")));
+ return(s7_error(sc, s7_make_symbol(sc, \"read-error\"), s7_make_string_wrapper(sc, \"unknown s7_input_function choice\")));
}
}
@@ -2265,6 +2280,7 @@ void block_init(s7_scheme *sc)
(set! (<3> 0) <1>)
(set! (<2> 1) <1>)
(c-pointer 1 <4> #f))")))
+ (test (let->list (make-cycle 1)) (list (rootlet)))
(let ((b (make-c-tag)))
(test (eq? b b) #t)
@@ -8110,7 +8126,11 @@ i" (lambda (p) (eval (read p)))) pi)
(let () (define (func) (do () (#t (with-let (block 1.0 2.0 3.0) (subsequence 0-i 0-i abs))))) (test (func) 'error))
(let () (define (func) (do () (#t (with-let (block 1.0 2.0 3.0) (subsequence 0-i abs 0-i))))) (test (func) 'error))
(let () (define (func) (do () (#t (with-let (block 1.0 2.0 3.0) (subsequence abs 0-i 0-i))))) (test (func) 'error))
-)
+
+ (let ()
+ (define-constant imb12 (immutable! (block 0.0 1.0 2.0)))
+ (define (func) (do ((var #f) (i 0 (+ i 1))) ((= i 1) var) (set! var (symbol->value :allow-other-keys imb12))))
+ (test (func) :allow-other-keys)))
;;; --------------------------------------------------------------------------------
@@ -10651,9 +10671,8 @@ i" (lambda (p) (eval (read p)))) pi)
'((1 . 1) (3/4 . 2) (23 . 3)) '((a . 1) (1 . 2) (#(1) . 4) (23 . 3))
'((1 . 1) ("hi" . 2) (23 . 3))))
-(test (catch #t (lambda () (assoc 1 (list (list 3 2) (list 2)) (lambda (a b) (catch #t 1 cons)))) (lambda args 'error)) '(3 2))
-(test (catch #t (lambda () (member 1 (list 3 2) (lambda (a b) (catch #t 1 cons)))) (lambda args 'error)) '(3 2))
-;;; are those correct?? at least it doesn't die.
+(test (catch #t (lambda () (assoc 1 (list (list 3 2) (list 2)) (lambda (a b) (catch #t 1 cons)))) (lambda args 'error)) 'error)
+(test (catch #t (lambda () (member 1 (list 3 2) (lambda (a b) (catch #t 1 cons)))) (lambda args 'error)) 'error)
;;; --------------------------------------------------------------------------------
@@ -12997,6 +13016,20 @@ i" (lambda (p) (eval (read p)))) pi)
(define (func) (do ((i 0 (+ i 1))) ((= i 100)) (sym6 (values 1.0 letrec* (cons i i) (log 1.0) (log 2.0) (log 3.0) (log 4.0) (log 5.0) (make-list 512)))))
(func))
#t)
+
+ (let () ;elist_5 protect copy_any_list in no_setter_error_nr
+ (define (_fnc12_ x) (- x 1))
+ (define (f)
+ (do ((i 0 (+ i 1)))
+ ((= i 50)) ; doesn't hit the error in this context even with 1000!
+ (catch #t (lambda ()
+ (define (func)
+ ((lambda (a) #f)
+ (set! (values 512 0 0 1 1 0 0 0 0 1 0 0 0 1 0 0 1 0 0 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 1 0 0 1 1 1 0 1 0 0 0 0 1 1 1 0 0 1 0 0 1 1 0 0 1 0 0 0 1 0 1 1 1 0 1 0 0 1 0 0 1 0 0 0 0 0 1 1 0 0 1 0 1 0 0 0 0 1 0 0 0 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 0 0 0 0 0 0 1 1 1 0 0 1 0 0 0 0 1 0 0 0 1 0 1 0 0 0 0 0 0 0 0 0 0 1 0 1 0 1 1 0 0 1 1 1 0 0 1 0 1 1 0 0 1 0 1 0 0 1 1 1 0 1 0 0 1 0 0 1 0 0 0 1 0 1 1 0 0 0 1 1 1 0 0 0 0 1 1 1 0 1 0 0 1 1 0 1 0 0 0 0 0 0 1 0 0 0 1 1 0 1 0 1 0 0 0 0 1 1 1 0 0 0 0 0 0 0 1 0 1 1 0 0 1 0 0 0 1 0 1 0 0 1 1 1 0 0 1 0 1 1 1 1 0 1 1 1 1 0 0 1 0 0 1 0 0 1 1 1 1 0 0 1 1 1 1 0 0 0 1 0 0 0 1 1 1 0 0 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 0 0 0 1 0 0 1 0 1 0 1 1 1 1 0 0 1 0 0 1 1 0 1 0 1 1 0 0 0 1 0 1 1 0 0 1 1 1 0 0 1 0 0 1 1 1 1 0 0 1 0 1 1 1 1 1 1 1 0 0 0 1 0 1 1 1 0 1 0 1 1 1 1 0 1 0 1 0 1 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 1 0 1 1 0 1 0 1 1 0 0 1 1 0 0 0 1 0 0 1 1 0 0 0 0 1 0 0 0 0 1 1 0 0 0 0 1 0 1 0 0 1 0 0 0 0 0 0 0 1 0 0 1 0 1 0 1 1 0 1 1 1 0 0 1 1 1 1 1 0 0 0 0 1 1 0 0 0 0 1 1 1 0 1 0 1 0 0 1 0 0 1 0 0 1 1 1 0 0 0 0 0 1 0 1)
+ (_fnc12_))))
+ (func))
+ (lambda args #f))))
+ (test (f) #t))
)
@@ -13561,6 +13594,15 @@ i" (lambda (p) (eval (read p)))) pi)
(set! sum (+ sum (v6 i 0 0))))))
(test (f6) 10))
+;;; some error checks
+(let ((arr (make-vector '(2 3 4) #f)))
+ (test (vector-ref arr 1 1 4) 'error)
+ (test (vector-ref arr 1 3 1) 'error)
+ (test (vector-ref arr 2 0 0) 'error)
+ (test (vector-set! arr 1 1 4 #t) 'error)
+ (test (vector-set! arr 1 3 1 #t) 'error)
+ (test (vector-set! arr 2 0 0 #t) 'error))
+
;;; --------------------------------------------------------------------------------
;;; vector-set!
@@ -14294,6 +14336,7 @@ i" (lambda (p) (eval (read p)))) pi)
((12) "#2d((#3d(((1 2 3) (3 4 5)) ((5 6 1) (7 8 2))) #2d((1 2 3 4 5 6) (7 8 9 10 11 12)) #(1 2 3 4 5 6 7 8 9 10 11 12 ...)) (#3d(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))) #(1 2 3) #2d()))")
((13) "#2d((#3d(((1 2 3) (3 4 5)) ((5 6 1) (7 8 2))) #2d((1 2 3 4 5 6) (7 8 9 10 11 12)) #(1 2 3 4 5 6 7 8 9 10 11 12 13 ...)) (#3d(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))) #(1 2 3) #2d()))")
((14) "#2d((#3d(((1 2 3) (3 4 5)) ((5 6 1) (7 8 2))) #2d((1 2 3 4 5 6) (7 8 9 10 11 12)) #(1 2 3 4 5 6 7 8 9 10 11 12 13 14)) (#3d(((1 2) (3 4) (5 6)) ((7 8) (9 10) (11 12))) #(1 2 3) #2d()))"))))))))
+(set! (*s7* 'print-length) 32)
(test (object->string (make-int-vector 3 0)) "#i(0 0 0)")
@@ -15488,9 +15531,9 @@ i" (lambda (p) (eval (read p)))) pi)
(lambda (f)
(set! body (list f body)))
(reverse (X-marks-the-spot () path)))
- (let ((getter (apply lambda '(lst) body ()))
- (setter (apply lambda '(lst val) `(set! ,body val) ())))
- (dilambda getter setter))))
+ (let ((getr (apply lambda '(lst) body ()))
+ (setr (apply lambda '(lst val) `(set! ,body val) ())))
+ (dilambda getr setr))))
(let ((body '(if (not (pair? (cdr lst))) lst (begin (set! lst (cdr lst)) X)))) ; X is where we jump back to the start
(let ((recurse (fc?r body)))
@@ -20769,6 +20812,108 @@ i" (lambda (p) (eval (read p)))) pi)
(test (let-temporarily (((current-output-port) #f)) (port-closed? (current-output-port))) #f)
+;;; port-string
+(test (port-string) 'error)
+(let ((P (open-input-string "asdf")))
+ (test (port-string P) "asdf")
+ (test (port-string P #f) 'error)
+ (close-input-port P))
+(for-each
+ (lambda (arg)
+ (test (port-string arg) 'error))
+ (list "hi" () '(1 2) -1 #\a 1 'a-symbol (make-vector 3) abs _ht_ _undef_ _null_ _c_obj_ quasiquote macroexpand 1/0 (log 0)
+ 3.14 3/4 1.0+1.0i #f #t (if #f #f) #<undefined> (lambda (a) (+ a 1))))
+(test (call-with-input-string "0123456789" (lambda (p) (port-string p))) "0123456789")
+
+(let ((P (open-input-string "asdf")))
+ (test (port-string P) "asdf")
+ (set! (port-string P) "123")
+ (test (port-string P) "123")
+ (test (read-char P) #\1)
+ (test (read-char P) #\2)
+ (test (read-char P) #\3)
+ (test (read-char P) #<eof>)
+ (set! (port-string P) "0123456789")
+ (test (port-string P) "0123456789")
+ (test (read-char P) #\0)
+ (close-input-port P))
+
+(let ((P (open-output-string)))
+ (test (port-string P) "")
+ (display "asdf" P)
+ (test (port-string P) "asdf")
+ (set! (port-string P) "12345")
+ (test (get-output-string P) "12345")
+ (set! (port-string P) (make-string 512 #\a))
+ (test (string=? (get-output-string P) (make-string 512 #\a)) #t) ; force reallocate?
+ (close-output-port P))
+
+(let ((ssize 3))
+ (define (call-wis1)
+ (let ((p (open-input-string "asdf")))
+ (do ((i 0 (+ i 1))) ((= i ssize))
+ (set! (port-string p) "asdf")
+ (unless (char=? (read-char p) #\a) (format *stderr* "read-char trouble 1\n"))
+ (set! p 123))
+ (close-input-port p)))
+ (test (call-wis1) 'error) ; set! port-string first argument, 123, is an integer but should be an input or output port
+
+ (define (call-wis2)
+ (let ((p (open-input-string "asdf")))
+ (do ((i 0 (+ i 1))) ((= i ssize))
+ (set! (port-string p) "asdf")
+ (unless (char=? (read-char p) #\a) (format *stderr* "read-char trouble 4\n"))
+ (set! p (open-output-string)))
+ (close-output-port p)))
+ (test (call-wis2) 'error) ; read-char argument, #<output-string-port>, is an output port but should be an input port
+
+ (define (call-wis21) ; this is dangerous! if error check is omitted in set_port_string, the file will be clobbered
+ (let ((p (open-input-string "asdf")))
+ (do ((i 0 (+ i 1))) ((= i ssize))
+ (set! (port-string p) "asdf")
+ (unless (char=? (read-char p) #\a) (format *stderr* "read-char trouble 4\n"))
+ (set! p (open-output-file tmp-output-file)))
+ (close-output-port p)))
+ (test (call-wis21) 'error)
+
+ (define (call-wis3)
+ (let ((p (open-input-string "asdf")))
+ (do ((i 0 (+ i 1))) ((= i ssize))
+ (set! (port-string p) "asdf")
+ (unless (char=? (read-char p) #\a) (format *stderr* "read-char trouble 7\n"))
+ (close-input-port p))))
+ (test (call-wis3) 'error) ; set! port-string first argument, #<input-string-port :closed>, is an input port but should be an open port
+
+ (define (call-wis4)
+ (let ((str "asdf"))
+ (let ((p (open-input-string str)))
+ (do ((i 0 (+ i 1))) ((= i ssize) str)
+ (set! (port-string p) "asdf")
+ (unless (char=? (read-char p) #\a) (format *stderr* "read-char trouble 13\n")))
+ (close-input-port p))))
+ (test (call-wis4) #<unspecified>) ; from close-input-port
+
+ (define (call-wis5)
+ (let ((str "asdf"))
+ (let ((p (open-input-string str)))
+ (do ((i 0 (+ i 1))) ((= i ssize))
+ (set! (port-string p) str)
+ (unless (char=? (read-char p) #\a) (format *stderr* "read-char trouble 16\n"))
+ (set! str 123))
+ (close-input-port p))))
+ (test (call-wis5) 'error) ; set! port-string second argument, 123, is an integer but should be a string
+
+ (define (call-wis7)
+ (let ((str "asdf"))
+ (let ((p (open-input-string str)))
+ (do ((i 0 (+ i 1))) ((= i ssize))
+ (set! (port-string p) str)
+ (unless (char=? (read-char p) #\a) (format *stderr* "read-char trouble 19\n"))
+ (set! p (open-input-function (lambda (choice) #\a))))
+ (close-input-port p))))
+ (test (call-wis6) 'error) ; set! port-string first argument, #<input-function-port>, is an input port but should be a string port
+ )
+
;;; port-position
(test (port-position) 'error)
(test (port-position (current-output-port)) 'error)
@@ -22840,6 +22985,9 @@ a2" 3) "132")
(test (format #f "~{~^~S ~}" (make-iterator (let ((lst (list 1))) (set-cdr! lst lst)))) "1 ")
(test (format #f "~{~^~S ~}" (make-iterator "")) "")
(test (format #f "~{~^~S ~}" (make-iterator #(1 2 3))) "1 2 3 ")
+(test (format #f "~{~{~{~{~{~A~^ ~}~^ ~}~}~}~}" '(((((1 2) (3 4)))))) "1 2 3 4")
+(test (format #f "~{~{~{~{~{~{~{~{~A~^ ~}~^ ~}~}~}~}~}~}~}" '((((((((1 2) (3 4))))))))) "1 2 3 4")
+(test (format #f "~{~{~{~{~{~{~{~{~{~{~{~A~^ ~}~^ ~}~}~}~}~}~}~}~}~}~}" '(((((((((((1 2) (3 4)))))))))))) "1 2 3 4")
(test (format #f "~10,'-T") "---------")
(test (format #f "~10,'\\T") "\\\\\\\\\\\\\\\\\\")
@@ -23097,15 +23245,17 @@ a2" 3) "132")
(let ((eof (read-line p #t)))
(test (eof-object? eof) #t)))))
-(let ((res #f))
+(let ((res1 #f)
+ (res2 #f))
(let ((this-file (open-output-string)))
(format this-file "this ~A ~C test ~D" "is" #\a 3)
- (set! res (get-output-string this-file))
+ (set! res1 (get-output-string this-file))
+ (set! res2 (port-string this-file))
(close-output-port this-file))
- (if (not (string=? res "this is a test 3"))
- (begin
- (display "open-output-string + format ... expected \"this is a test 3\", but got \"")
- (display res) (display "\"?") (newline))))
+ (unless (string=? res1 "this is a test 3")
+ (format #t "open-output-string + format + get-output-string expected ~S but got ~S\n" "this is a test 3" res1))
+ (unless (string=? res2 "this is a test 3")
+ (format #t "open-output-string + format + port-string expected ~S but got ~S\n" "this is a test 3" res2)))
(test (with-output-to-string (lambda () (display 123) (flush-output-port))) "123")
(test (with-output-to-string (lambda () (display 123) (flush-output-port) (display 124))) "123124")
@@ -29438,6 +29588,35 @@ in s7:
(define (f) (let ((iter (make-iterator "asdf"))) (do ((i 0 (+ i 1))) ((= i 1) (iter)) (iterate (car (list iter))))))
(test (f) #\s))
+(let ()
+ (define (f1)
+ (let ((L1 (make-iterator "asdfasdf"))
+ (L2 (make-iterator #(1 2 3 4)))
+ (V1 (make-vector 4)))
+ (do ((L L1 L2)
+ (i 0 (+ i 1)))
+ ((= i 4) V1)
+ (vector-set! V1 i (iterate L))))) ; fx_c_opsq -> g_display(g_iterate)
+ (test (f1) #(#\a 1 2 3))
+
+ (define (f2)
+ (let ((L1 (make-iterator "asdfasdf"))
+ (V1 (make-vector 4)))
+ (do ((i 0 (+ i 1)))
+ ((= i 4) V1)
+ (vector-set! V1 i (iterate L1))))) ; opt_p_p_s_iterate_unchecked from opt_p_p_f
+ (test (f2) #(#\a #\s #\d #\f))
+
+ (define (f5)
+ (let ((L1 (make-iterator "asdfasdf"))
+ (L2 (make-iterator #(0 1 2 3 4)))
+ (V1 (make-vector 4)))
+ (do ((i 0 (+ i 1)))
+ ((= i 4) V1)
+ (vector-set! V1 i (iterate L1)) ; opt_p_p_s_iterate_unchecked
+ (set! L1 L2))))
+ (test (f5) #(#\a 0 1 2)))
+
;;; --------------------------------------------------------------------------------
;;; do
@@ -31540,6 +31719,7 @@ in s7:
(test (cond ((or arg) => (lambda (x) x))) arg))
(list "hi" -1 #\a 1 'a-symbol #(1 2 3) 3.14 3/4 1.0+1.0i #t (list 1 2 3) '(1 . 2)))
+(set! (*s7* 'print-length) (max (*s7* 'print-length) 40))
(test (catch #t (lambda () (cond () #f)) (lambda (t i) (apply format #f i))) "every clause in cond must be a pair: () in (cond () #f)")
(test (cond ((< 2 1)) ((= 1 2)) (else #f)) (or (< 2 1) (= 1 2))) ; (cond (A) (B) (else #f)) is (or A B)
@@ -31813,6 +31993,14 @@ in s7:
2)
(test (let ()
(cond-expand
+ ((and unlikely-feature (error 'oops "oops\n"))
+ (define (hi a) a))
+ (else
+ (define (hi a) (+ a 1))))
+ (hi 1))
+ 2)
+(test (let ()
+ (cond-expand
((and s7 (not s7)) 'oops)
(else 1)))
1)
@@ -36809,6 +36997,9 @@ yow...
(test (letrec ((x)) 1) 'error)
(test (letrec ((v (vector v))) v) #(#<undefined>)) ; Guile returns #(#<unspecified>) -- isn't this a reference to v which r7rs claims is an error? Chicken gives an error.
(test (letrec* ((v1 (vector v2)) (v2 (vector v1))) (list v1 v2)) (list #(#<undefined>) #(#(#<undefined>)))) ; same as above?
+(test (let ((i (catch #t (lambda () 1) (lambda (t i) 'error))) (j 2)) (+ i j)) 3)
+(test (let ((j 2) (i (catch #t (lambda () 1) (lambda (t i) 'error)))) (+ i j)) 3)
+(test (let* loop ((i 0) (j 0)) (if (> i 3) (+ i j) (loop :j 2 :i (+ i 1)))) 6)
;;; srfi 245 example
(let ((x 0))
@@ -37860,6 +38051,35 @@ yow...
(y-factorial 3))
6)
+(let () ; more silliness
+ ;; from The Evolution of a Scheme Programmer
+ (define factorial-1
+ ((lambda (f)
+ ((lambda (g)
+ (f (lambda (x)
+ ((g g) x))))
+ (lambda (g)
+ (f (lambda (x)
+ ((g g) x))))))
+ (lambda (f)
+ (lambda (n)
+ (if (zero? n)
+ 1
+ (* n (f (- n 1))))))))
+ (test (factorial-1 6) 720)
+
+ (define (factorial-2 n)
+ (letrec ((f (lambda (n k)
+ (if (= n 1)
+ (k 1)
+ (f (- n 1)
+ (lambda (ret)
+ (k (* n ret))))))))
+ (call-with-current-continuation
+ (lambda (k)
+ (f n k)))))
+ (test (factorial-2 6) 720))
+
(test (let ((x 1)) (let ((x 0) (y x)) (cons x y))) '(0 . 1))
(test (let ((x 1)) (let* ((x 0) (y x)) (cons x y))) '(0 . 0))
(test (let ((x 1)) (letrec ((x 0) (y x)) (cons x y))) '(0 . #<undefined>))
@@ -38568,15 +38788,15 @@ yow...
(test (call/cc (lambda (c) (0 (c 1)))) 1)
-(test (let ((member (lambda (x ls)
+(test (let ((membr (lambda (x ls)
(call/cc
(lambda (return)
(do ((ls ls (cdr ls)))
((null? ls) #f)
(if (equal? x (car ls))
(return ls))))))))
- (list (member 'd '(a b c))
- (member 'b '(a b c))))
+ (list (membr 'd '(a b c))
+ (membr 'b '(a b c))))
'(#f (b c)))
(test (list-values (values) (call/cc (lambda (return) (let ((x 1) (y 2)) (return x y))))) '(1 2))
@@ -41331,6 +41551,9 @@ who says the continuation has to restart the map from the top?
(test (keyword->symbol (string->keyword (string #\"))) (symbol "\""))
)
+(test (symbol->keyword (symbol "a b c")) (symbol ":a b c"))
+(test (keyword? (symbol->keyword (symbol "a b c"))) #t)
+(test (keyword? (symbol ":a b c")) #t)
(test (string->keyword "a b") (symbol ":a b"))
(test (keyword? : asdf) 'error)
(test (keyword? asdf :) 'error)
@@ -42678,7 +42901,7 @@ who says the continuation has to restart the map from the top?
(test (catch #t f3 f2) 1)
(test (catch #t f4 f2) 1)
(define (f5 a) a)
- (test (catch #t f5 (lambda args 'local-error)) 'local-error))
+ (test (catch #t f5 (lambda args 'local-error)) 'error))
(test (let () (define-macro (m) `(+ 1 2)) (catch #t m (lambda any any))) 3)
;(test (let () (define-macro (m) `(define __asdf__ 3)) (catch #t m (lambda any "__asdf__ must be a constant?"))) '__asdf__) ;25-Jul-14
@@ -42866,7 +43089,7 @@ who says the continuation has to restart the map from the top?
(for-each
(lambda (tag)
- (test (catch #t tag (lambda args 'local-error)) 'local-error)
+ (test (catch #t tag (lambda args 'local-error)) 'error)
(test (catch #t (lambda () #f) tag) 'error))
(list :hi () #<eof> #f #t #<unspecified> #\a 32 9/2)) ;'(1 2 3) '(1 . 2) #(1 2 3) #()
@@ -45439,6 +45662,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (arity port-file) '(1 . 1))
(test (arity port-filename) '(0 . 1))
(test (arity port-line-number) '(0 . 1))
+(test (arity port-string) '(1 . 1))
(test (arity port-position) '(1 . 1))
(test (arity positive?) '(1 . 1))
(test (arity procedure-source) '(1 . 1))
@@ -45961,6 +46185,14 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (set! (< 3 2) 3) #f)
(test (set! (< 1) 2) #t))
+(let ((x 1)) ; let-temp = (set! x new) ... (set! x old) so setter is called twice
+ (set! (setter 'x) (lambda (s v) (+ (symbol->value s) v))) ; x = x + v, x is 1, v is 3 below
+ (let ((res (let-temporarily ((x 3)) x))) ; x = 1 + 3, then on exit from let-temp, x = 4 + 1 ! (let-temp is trying to set x back to 1)
+ (set! (setter 'x) #f)
+ (test x 5)))
+
+(test (with-let (inlet 'a 1) (set! (setter 'a) (lambda (s v) 123)) (set! a 2) a) 123) ; won't work with *s7*
+
(let ((old-setter (setter abs))) ; check gc protection
(set! (setter abs) (define-macro (_m1_ x y) `(+ ,x 1)))
(define-macro (_m1_ x) `(- ,x 1))
@@ -46251,6 +46483,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(let ((x :a)) (set! (setter 'x) keyword?) (test x :a) (test (set! x 3.14) 'error) (test x :a))
(let ((x #f)) (set! (setter 'x) boolean?) (test (set! x 3.14) 'error) (test x #f))
(let ((x ())) (set! (setter 'x) proper-list?) (test (set! x 3.14) 'error) (test x ()))
+(unless with-bignums (let ((x (random-state 1234 4321))) (set! (setter 'x) random-state?) (test (set! x 123) 'error)))
(test (let ((a (make-vector 3 'a symbol?))) (let ((b (copy a))) (vector-set! b 0 32))) 'error)
(test (let ((a (let ((i 0)) (set! (setter 'i) integer?) (curlet)))) (let ((b (copy a))) (set! (b 'i) #\a))) 'error)
@@ -46738,6 +46971,31 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (let ((x #f)) (define (f) (set! x (set! (setter 'x) values))) (f)) 'error)
(test (let ((x #f)) (define (g . args) (apply values args)) (set! x (set! (setter 'x) g))) 'error) ; splice_in_values etc
+(let ()
+ (define (f)
+ (let ((x 0))
+ (set! x (set! (setter 'x) (lambda a (copy a))))))
+
+ (test (list? (f)) #t) ; #1=(x #<lambda a> (inlet 'x #1#)) -- new setter is called upon outer set! = copy args = (s v e)
+ (test (list? (f)) #t) ; same
+
+ (define (f1)
+ (let ((x 0))
+ (set! x (set! (setter 'x) (lambda a (copy a))))
+ (setter 'x)))
+
+ (test (procedure? (f1)) #t) ; #<lambda a>
+ (test (procedure? (f1)) #t) ; same
+
+ (define (f2)
+ (let ((x 0))
+ (set! x (set! (setter 'x) (lambda a (copy a))))
+ x))
+
+ (test (list? (f2)) #t) ; #1=(x #<lambda a> (inlet 'x #1#))
+ (test (list? (f2)) #t) ; same
+ )
+
;; -------- set! + setter + values --------
(define a2 0)
@@ -47397,6 +47655,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (signature port-file) '(c-pointer? (input-port? output-port?)))
(test (signature port-filename) '(string? (input-port? output-port?)))
(test (signature port-line-number) '(integer? input-port?))
+(test (signature port-string) '(string? (input-port? output-port?)))
(test (signature port-position) '(integer? input-port?))
(test (signature positive?) '(boolean? real?))
(test (signature documentation) '(string? #t))
@@ -49420,6 +49679,21 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (read) #<eof>))))
+(set! *#readers* (list (cons #\s
+ (lambda (str)
+ (and (string=? (substring str 0 7) "symbol<")
+ (do ((sym (substring str 7))
+ (c (read-char) (read-char)))
+ ((memq c (list #\> #<eof>))
+ (string->symbol sym))
+ (set! sym (string-append sym (string c)))))))))
+
+(test (let ((#symbol<a b c> 32)) (+ #symbol<a b c> 1)) 33)
+(test (let ((#symbol<ab cd> 32)) #symbol<ab cd>) 32)
+
+(set! *#readers* *old-#readers*)
+
+
;;; --------------------------------------------------------------------------------
(begin
@@ -51148,6 +51422,16 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (let ((L (inlet 'a 1)) (V (make-vector 8 'a symbol?))) (define (f) (do ((i 0 (+ i 1))) ((= i 2)) (let-set! L V (append)))) (f)) 'error)
(test (let ((imb (block 0.0 1.0 2.0))) (define (f) (do ((i 0 (+ i 1))) ((= i 2)) (hash-table? (memq imb `(+ x 1))))) (f)) #t)
(test (let ((clet (inlet 'a 1))) (define (f) (do ((i 0 (+ i 1))) ((= i 3)) (let? (inlet 'value clet)))) (f)) #t)
+(if with-block (test (let ((mlet (openlet (inlet 'abs cycle-ref)))) (abs mlet)) 'error)) ; wrong-type-arg "object passed to cycle-ref is not a cycle object"
+(test (let ((mlet (openlet (inlet 'abs list)))) (abs mlet)) (list (inlet 'abs list)))
+(test (let ((mlet (openlet (inlet 'abs with-let)))) (abs mlet)) 'error) ; with-let has no body
+(test (let ((mlet (openlet (inlet 'abs #<undefined>)))) (abs mlet)) 'error) ; abs method is not defined in openlet
+(test (let ((mlet (openlet (inlet 'abs catch)))) (abs mlet)) 'error) ; catch: function missing: (catch (inlet 'abs catch))
+(test (let ((mlet (openlet (inlet 'abs string-ref)))) (abs mlet)) 'error) ; string-ref method is not defined in openlet? (inlet 'abs string-ref)
+(test (let ((mlet (openlet (inlet 'abs let-ref)))) (abs mlet)) 'error) ; let-ref: symbol missing: (let-ref (inlet 'abs let-ref))
+(test (let ((mlet (openlet (inlet 'abs owlet)))) (abs mlet)) 'error) ; owlet: too many arguments: ((inlet 'abs owlet))
+;; (let ((mlet (openlet (inlet 'abs abs)))) (abs mlet)) ; infinite loop in find_and_apply_method
+(test (let ((mlet (openlet (inlet 'abs map)))) (abs mlet)) 'error) ; map: 0 arguments for (inlet 'abs map)?
(test (equivalent? (sublet (inlet) 'a 1 (inlet 'b 2)) (inlet 'b 2 'a 1)) #t)
(test (equivalent? (sublet (inlet) (inlet 'b 2)) (inlet 'b 2)) #t)
@@ -51165,7 +51449,6 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(test (g (f 'sam)) 'sam)
(test (g (f (g (f (f 'sym))))) 'sam))
-
(let ((f (inlet :a 1 :b 2)))
(test (length f) 2)
(fill! f #<undefined>)
@@ -54293,7 +54576,7 @@ hi6: (string-app...
(test (eq? (copy 1) 1) #f)
(test (eq? (copy 1.0) 1.0) #f)
(test (eq? (copy 2/3) 2/3) #f)
-(test (eq? (copy "") "") #f)
+;(test (eq? (copy "") "") #f) ; 23-Apr-24 these might both be nil_string
(test (copy #u(101 102) (vector 1 2)) #(101 102))
(if with-block (test (copy (block 1.0) (immutable! (block 2.0))) 'error))
(test (pair? (copy *s7* (make-list (length *s7*)))) #t)
@@ -54425,7 +54708,8 @@ hi6: (string-app...
(test (let ((e (inlet 'a 1 'b 2 'c 3)) (f (inlet 'd 4))) (copy e f 1 2)) (inlet 'd 4 'b 2))
(test (let ((e (inlet 'a 1 'b 2 'c 3)) (f (inlet 'd 4))) (copy f e)) (inlet 'a 1 'b 2 'c 3 'd 4))
;; printout is confusing (is this a reversal in this slot list, or a let-id side-effect?)
-(test (let ((e (inlet 'a 1 'b 2 'c 3)) (f (inlet 'a 100 'b 200 'c 300 'd 400))) ((copy e f) 'a)) 1)
+(test (let ((e (inlet 'a 1 'b 2 'c 3)) (f (inlet 'a 100 'b 200 'c 300 'd 400))) ((copy e f) 'a)) 100) ; this is a bad test -- depends on order whereas let should not
+(test (let ((f (inlet 'a 100 'b 200 'c 300 'd 400)) (e (inlet 'a 1 'b 2 'c 3))) ((copy e f) 'a)) 1)
(test (let ((e (inlet 'a 1 'b 2 'c 3)) (f (inlet 'a 100 'b 200 'c 300 'd 400))) (copy e f)) (inlet 'c 3 'b 2 'a 1 'a 100 'b 200 'c 300 'd 400))
(test (weak-hash-table? (copy (weak-hash-table))) #t)
@@ -76571,25 +76855,25 @@ gmp:
(list "hi" () (integer->char 65) #f #t '(1 2) _ht_ _undef_ _null_ _c_obj_ 'a-symbol (cons 1 2) (make-vector 3) abs
#<eof> '(1 2 3) #\newline (lambda (a) (+ a 1)) #<unspecified> #<undefined>))
-(let* ((angle 0.0)
- (z 1.18)
- (result (* z (cos angle))))
- (do ((k 0 (+ 1 k)))
- ((= k 1000))
- (set! result (* z (cos result))))
- ;;result: 0.81194462369499
- ;;(let ((x 0.0))
- ;; (do ((i 0 (+ 1 i)))
- ;; ((= i 10000))
- ;; (set! x (+ x (* (expt -1 i)
- ;; (/ (bes-jn (+ 1 (* 2 i)) (* z (+ 1 (* 2 i))))
- ;; (+ 1 (* 2 i)))))))
- ;; (* 2 x))
- ;; 0.81194498071946
- (let ((x (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos 0.0))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
- ;; 47? calls here so we're at around .812 (oscillating around .8119)
- (test (< (abs (- x result)) .001) #t)))
-
+(unless (provided? 'osx) ; why does this cause a segfault on a mac -- can't run gdb, and lldb crashes
+ (let* ((angle 0.0)
+ (z 1.18)
+ (result (* z (cos angle))))
+ (do ((k 0 (+ 1 k)))
+ ((= k 1000))
+ (set! result (* z (cos result))))
+ ;; result: 0.81194462369499
+ ;; (let ((x 0.0))
+ ;; (do ((i 0 (+ 1 i)))
+ ;; ((= i 10000))
+ ;; (set! x (+ x (* (expt -1 i)
+ ;; (/ (bes-jn (+ 1 (* 2 i)) (* z (+ 1 (* 2 i))))
+ ;; (+ 1 (* 2 i)))))))
+ ;; (* 2 x))
+ ;; 0.81194498071946
+ (let ((x (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos (* z (cos 0.0))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+ ;; 47? calls here so we're at around .812 (oscillating around .8119)
+ (test (< (abs (- x result)) .001) #t))))
(when full-s7test
(let () ; this is trying to cause a stack overflow
@@ -109625,6 +109909,10 @@ etc
;;; --------------------------------------------------------------------------------
+(test (let () (define (f) (write (vector 1.0) (openlet (inlet 'write for-each)))) (f)) 'error) ; fx_c_aa unstack gc_protect bug
+;; gets error "vector-ref second argument, (write . for-each), is a pair but should be an integer" because it's iterating over the let
+(test (write (vector 1.0) (openlet (inlet 'write for-each))) 'error) ; same as above without the fx_c_aa call but pointless since 'write is no longer global
+
(define _x3x3_ with-baffle)
(test (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (vector) (_x3x3_ (reverse (caaar (+ i 1)))))) (func)) 'error) ; fx_c_optcq bug
@@ -110027,6 +110315,7 @@ etc
(let () (define-macro (q x) `(symbol? ',x)) (let ((quote "Friends, Romans, countrymen")) (test (q 123) #f))) ; an error in Guile ("Friends..." is applied to 123)
;; if 123 -> quote, returns #t
+(let ((quote "Friends, Romans, countrymen")) (test 'x 'x))
(test (let ((quote 32)) (+ quote 1)) 33)
(test (let (' 32) (+ quote 1)) 'error)
@@ -110501,6 +110790,7 @@ etc
;(display integer?) (newline) (display (eq? integer? #_integer?)) (newline) ; integer? #t
;(let () (define (func1) (let ((+ -)) (with-let (curlet) (integer? (+))))) 'error) ; "-: not enough arguments"
;(let () (define (func2) (let ((+ -)) (with-let (curlet) (#_integer? (+))))) (test (func2) #t)) ; this looks like a bug
+ ;; see s7.c ca 73050 -- this has a big effect on tall/snd-test etc -- need to track where it affects +->local
)
#|
diff --git a/snd-test.scm b/snd-test.scm
index 6eadbf2..3c418e9 100644
--- a/snd-test.scm
+++ b/snd-test.scm
@@ -8964,11 +8964,6 @@ EDITS: 2
(lambda () (jet-colormap))
(lambda args (car args)))))
(if (not (eq? tag 'wrong-number-of-args)) (snd-display "colormap-apply nil: ~A" tag)))
- (let ((tag (catch #t
- jet-colormap
- (lambda args (car args)))))
- (if (not (eq? tag 'wrong-type-arg)) ; arg2 to catch not a thunk => wrong type
- (format *stderr* "colormap-apply nil: ~A" tag)))
(for-each
(lambda (n err)
diff --git a/snd.h b/snd.h
index 4ef9daf..eb078af 100644
--- a/snd.h
+++ b/snd.h
@@ -47,11 +47,11 @@
#include "snd-strings.h"
-#define SND_DATE "14-Apr-24"
+#define SND_DATE "17-May-24"
#ifndef SND_VERSION
-#define SND_VERSION "24.3"
+#define SND_VERSION "24.4"
#endif
#define SND_MAJOR_VERSION "24"
-#define SND_MINOR_VERSION "3"
+#define SND_MINOR_VERSION "4"
#endif
diff --git a/tools/auto-tester.scm b/tools/auto-tester.scm
index e70d1bf..3a7c19b 100644
--- a/tools/auto-tester.scm
+++ b/tools/auto-tester.scm
@@ -1,8 +1,5 @@
;;; this is an extension of tauto.scm, an auto-tester
-(define-constant stable (symbol-table))
-(define-constant stable-len (length stable))
-
(define with-mock-data #f)
;(set! (*s7* 'profile) 1)
(when (provided? 'number-separator) (set! (*s7* 'number-separator) #\,))
@@ -688,19 +685,6 @@
(lambda (t i)
'error)))
-(define last-stable-f #f)
-(define-constant (_stable1_ . args)
- (let ((f (stable (random stable-len))))
- ;(format *stderr* "~S ~S~%" f args)
- (set! last-stable-f f)
- (f (apply f args))))
-
-(define-constant (_stable2_ . args)
- (let* ((f last-stable-f)
- (val (apply f args)))
- (f val)))
-
-
(define-constant ims (immutable! (string #\a #\b #\c)))
(define-constant imbv (immutable! (byte-vector 0 1 2)))
(define-constant imbv2 (immutable! #u2d((1 2 3) (4 5 6))))
@@ -738,6 +722,19 @@
(define-constant vvvi (let ((v (make-vector '(2 2)))) (set! (v 0 0) "asd") (set! (v 0 1) #r(4 5 6)) (set! (v 1 0) '(1 2 3)) (set! (v 1 1) 32) (immutable! v)))
(define-constant vvvf (immutable! (vector abs log sin)))
+(define big-let (let ((e (inlet)))
+ (let-temporarily (((*s7* 'print-length) 80))
+ (do ((i 0 (+ i 1)))
+ ((= i 100))
+ (varlet e (symbol "abc" (number->string i)) i)))
+ e))
+(define big-hash (let ((e (hash-table)))
+ (let-temporarily (((*s7* 'print-length) 80))
+ (do ((i 0 (+ i 1)))
+ ((= i 100))
+ (hash-table-set! e (symbol "abc" (number->string i)) i)))
+ e))
+
(define-constant a1 (immutable! (let ((H (make-hash-table 8 #f (cons real? integer?)))) (set! (H +nan.0) 1) H)))
(define-constant a2 (immutable! (inlet :a (hash-table 'b 1))))
(define-constant a3 (openlet (immutable! (inlet :a 1))))
@@ -858,7 +855,7 @@
'sublet 'inlet
'call-with-input-string 'documentation
- 'continuation? 'hash-table? 'port-closed? 'port-position 'port-file
+ 'continuation? 'hash-table? 'port-closed? 'port-position 'port-file 'port-string
'output-port? 'input-port?
;'provide
'call-with-output-string
@@ -1246,8 +1243,8 @@
"(let ((lst (list '+ 1))) (set-cdr! (cdr lst) (cdr lst)) (apply lambda* () lst ()))"
"(gensym \"g_123\")"
- "(make-list 256 1)"
- "(make-list 512 '(1))"
+ "(make-list 256 1)" "(make-list 512 '(1))" "big-let" "big-hash"
+ "(make-vector 256 #f)" "(make-byte-vector 256 0)" "(make-float-vector 256 0.0)" "(make-int-vector 256 0)"
"(make-vector '(2 3) 1)" "(make-vector '(12 14) #<undefined>)"
"(make-byte-vector '(2 3) 1)" "(make-byte-vector '(4 32) 255)"
"(make-string 256 #\\1)" "(make-string 64 #\\a)"
@@ -1274,6 +1271,8 @@
"(make-hash-table 8 #f (cons (lambda (x) #f) (lambda (x) #f)))" ; same
"(make-vector 3 #f (let ((calls 0)) (lambda (x) (set! calls (+ calls 1)) (= calls 1))))" ; 2 calls = error I hope
+ ;"(write (vector 1.0) (openlet (inlet 'write for-each)))"
+
"(immutable! #(1 2))" "(immutable! #r(1 2))" "(immutable! \"asdf\")" "(immutable! '(1 2))" "(immutable! (hash-table 'a 1))"
;"(immutable! 'x)"
"(immutable! 'asdf)"
@@ -1470,10 +1469,6 @@
(lambda (s) (string-append "(list (let ((old #f)) (dynamic-wind (lambda () (set! old (*s7* 'openlets)) (set! (*s7* 'openlets) #f)) (lambda () " s ") (lambda () (set! (*s7* 'openlets) old)))))")))
(list (lambda (s) (string-append "(list (let () (let-temporarily (((*s7* 'safety) 1)) " s ")))"))
(lambda (s) (string-append "(list (let ((old #f)) (dynamic-wind (lambda () (set! old (*s7* 'safety))) (lambda () " s ") (lambda () (set! (*s7* 'safety) old)))))")))
-
- (list (lambda (s) (string-append "(_stable1_ " s ")"))
- (lambda (s) (string-append "(_stable2_ " s ")")))
-
;; perhaps function port (see _rd3_ for open-input-string), gmp?
))
@@ -1907,7 +1902,22 @@
(set! n (+ n 1))
(when (= n 8)
(set! n 0)
- (format *stderr* " ~A " (daytime)))
+ (format *stderr* " ~A " (daytime))
+
+ ;; these two tend to become seriously bloated
+ (set! big-let (let ((e (inlet)))
+ (let-temporarily (((*s7* 'print-length) 80))
+ (do ((i 0 (+ i 1)))
+ ((= i 100))
+ (varlet e (symbol "abc" (number->string i)) i)))
+ e))
+ (set! big-hash (let ((e (hash-table)))
+ (let-temporarily (((*s7* 'print-length) 80))
+ (do ((i 0 (+ i 1)))
+ ((= i 100))
+ (hash-table-set! e (symbol "abc" (number->string i)) i)))
+ e))
+ )
(format *stderr* "~A" (vector-ref dots n)))
(catch #t
diff --git a/tools/dup.scm b/tools/dup.scm
index 78ce5cc..987f086 100644
--- a/tools/dup.scm
+++ b/tools/dup.scm
@@ -126,6 +126,8 @@
(format *stderr* "~%")))))))))))))
)
+(set! (*s7* 'heap-size) 4096000)
+
(dup 16 "s7.c" 110000)
;(dup 12 "s7.c" 110000)
;(dup 8 "s7.c" 110000)
diff --git a/tools/fbench.scm b/tools/fbench.scm
index d436b32..5fa7696 100644
--- a/tools/fbench.scm
+++ b/tools/fbench.scm
@@ -21,7 +21,7 @@
;;; Ported from the C language implementation in September 2005
;;; by John Walker.
;;;
-;;; Ported to s7 (and Guile) 20-May-2019
+;;; Ported to s7 20-May-2019
;; Wavelengths of standard spectral lines in Angstroms
(define spectral-line
diff --git a/tools/ffitest.c b/tools/ffitest.c
index e3a40d6..575dbf0 100644
--- a/tools/ffitest.c
+++ b/tools/ffitest.c
@@ -375,9 +375,8 @@ static s7_pointer g_blocks_are_equivalent(s7_scheme *sc, s7_pointer args)
return(s7_make_boolean(sc, true));
if (s7_is_let(arg1)) /* (block-let (block)) */
return(s7_make_boolean(sc, false)); /* checked == above */
- g1 = (g_block *)s7_c_object_value(arg1);
- if (s7_c_object_type(arg2) != g_block_type)
- return(s7_make_boolean(sc, false));
+ g1 = (g_block *)s7_c_object_value_checked(arg1, g_block_type);
+ if (!g1) return(s7_f(sc));
g2 = (g_block *)s7_c_object_value(arg2);
len = g1->size;
if (len != g2->size)
@@ -480,6 +479,12 @@ static bool symbol_func_1(const char *symbol_name, void *data)
return(false);
}
+static s7_pointer our_abs(s7_scheme *sc, s7_pointer args)
+{
+ return(s7_make_real(sc, (s7_Double)(1.0 + s7_number_to_real(sc, s7_car(args)))));
+}
+
+
static s7_scheme *cur_sc;
static const char *pretty_print(s7_scheme *sc, s7_pointer obj) /* (pretty-print obj) */
@@ -2625,7 +2630,7 @@ int main(int argc, char **argv)
}
{
- s7_define_function(sc, "wd-test-fn", wd_test_fn, 1, 0, false, "call the inner test");
+ s7_define_function(sc, "wd-test-fn", wd_test_fn, 0, 1, false, "call the inner test");
s7_define_function(sc, "wd-inner-test", wd_inner_test, 0, 0, false, "throw");
s7_define_function(sc, "wd-inner-test-handler", wd_inner_test_handler, 2, 0, false, "do nothing");
s7_eval_c_string(sc, "(wd-test-fn #f)");
@@ -2823,6 +2828,15 @@ int main(int argc, char **argv)
s7_set_current_input_port(sc, old_port);
}
+ {
+ s7_pointer res;
+ s7_define_function(sc, "abs", our_abs, 1, 0, false, "abs replacement"); /* make sure #_abs is not touched */
+ res = s7_eval_c_string(sc, "(#_abs -1.0)");
+ if (s7_real(res) != 1.0) {fprintf(stderr, "#_abs: %s?\n", s1 = TO_STR(res)); free(s1);}
+ res = s7_eval_c_string(sc, "(abs -1.0)");
+ if (s7_real(res) != 0.0) {fprintf(stderr, "(our_)abs: %s?\n", s1 = TO_STR(res)); free(s1);}
+ }
+
{ /* check realloc'd large block handling in s7_free */
int i;
s7_int addrs[20000];
diff --git a/tools/sam.c b/tools/sam.c
index 100faef..af909aa 100644
--- a/tools/sam.c
+++ b/tools/sam.c
@@ -4,7 +4,7 @@
* not an exact replica of the Samson box output. The latter used 12, 14, 20, 24, 28, and 30-bit
* fractional and integer fields, which are a pain to deal with when we would rather use doubles.
*
- * gcc sam.c -o sam -lm -O2 -Wall
+ * gcc sam.c -o sam -lm -O2 -Wall -Wextra
* sam TEST.SAM
* -> TEST.wav ("wav" or "riff" header, quad, little-endian float data at box srate)
*
@@ -32,9 +32,9 @@
(map-channel (lambda (y) (* y scl)) 0 (frames snd) new-snd 0)
(map-channel (lambda (y) (* y scl)) 0 (frames snd) new-snd 1)))))
*
- * Thanks to Michael McNabb for bug fixes and enhancements.
- * And thanks to Peter Samson for going back to the schematics to answer our questions.
- * Thanks also to David Jaffe for onepole and onezero changes.
+ * Thanks to Michael McNabb for bug fixes and enhancements!
+ * And thanks to Peter Samson for going back to the schematics to answer our questions!
+ * Thanks also to David Jaffe for onepole and onezero changes!
*/
#include <stdlib.h>
@@ -52,6 +52,13 @@
#define FLUSH_BAD_COMMANDS false
#define FLUSH_TRAILING_LINGERS true
#define DAJ_FIXES false /* bugfixes involving onepole (see code for discussion) and onezero */
+#define MULTIPLE_SRATES false /* srate change in mid-stream, so close current file, start up the next (from DAJ) */
+
+#if MULTIPLE_SRATES
+#warning "Multiple sample rate support enabled"
+/* we always generate one bogus "0"-numbered file, due to extra tick command at start of file */
+static int fileCounter = 0;
+#endif
static bool describe_commands = DEFAULT_DESCRIBE_COMMANDS;
static int start_describing = -1, stop_describing = -1;
@@ -184,11 +191,15 @@ static void all_done(void)
header_info[0] = samples * 4 * 4;
fwrite((void *)header_info, 4, 1, snd_file);
fclose(snd_file);
-
+#if MULTIPLE_SRATES
+ snd_file = NULL;
+#endif
fprintf(stderr, "%s: %dHz, %d samples, %.4f secs", output_filename, srate, samples, (double)samples / (double)srate); /* mmm */
fprintf(stderr, ", maxamps: %.3f %.3f %.3f %.3f\n", dac_out_peak[0], dac_out_peak[1], dac_out_peak[2], dac_out_peak[3]);
}
+#if (!MULTIPLE_SRATES)
exit(0);
+#endif
}
@@ -607,7 +618,9 @@ static void process_gen(int gen)
if (read_data_file)
{
float read_data_value;
- fread((void *)(&read_data_value), 4, 1, read_data_file);
+ size_t ret;
+ ret = fread((void *)(&read_data_value), 4, 1, read_data_file);
+ if (ret != 1) fprintf(stderr, "fread: %zu floats read\n", ret);
gen_outs[OutSum6] = OscOut13 + read_data_value; /* was * 2 */
/*
"If the run mode
@@ -958,11 +971,7 @@ static void process_mod(int mod)
tmp0 = m->f_L1 * m->f_M1;
tmp1 = m->f_L0 * m->f_M0;
m->f_L0 = m->f_L1;
-#if DAJ_FIXES
m->f_L1 = A;
-#else
- m->f_L1 = A / 1024.0;
-#endif
mod_write(m->MSUM, tmp0 + tmp1);
break;
@@ -1490,7 +1499,12 @@ static void ticks_command(int cmd)
processing_ticks = data + 1; /* mmm - data is highest numbered processing tick per pass, so processing_ticks is 1 greater. */
else
{
+#if MULTIPLE_SRATES
+ if (srate > 1) /* Not sure if this check needed, but seems to work */
+ all_done(); /* Finish previous file. Doesn't exit */
+#else
if (srate <= 1)
+#endif
{
/* mmm - srate can now be set from the command line in certain cases. I had some weird tick settings for some reason.
* mmm - highest_tick_per_pass is actually being set here to the max *number* of ticks per pass, including overhead
@@ -1511,10 +1525,12 @@ static void ticks_command(int cmd)
srate = (int)(1000000000.0 / (double)(highest_tick_per_pass * 195));
}
+#if (!MULTIPLE_SRATES)
else
{
highest_tick_per_pass = (1000000000.0 / (double)srate / 195.0);
}
+#endif
}
}
@@ -1550,7 +1566,12 @@ static void ticks_command(int cmd)
char *dot = NULL;
int i, len;
len = strlen(filename);
+#if MULTIPLE_SRATES
+ if (output_filename) free(output_filename);
+ output_filename = (char *)malloc(len + 4); /* Leave room for 999 files! */
+#else
output_filename = (char *)malloc(len + 1);
+#endif
strcpy(output_filename, filename);
/* dot = strchr(output_filename, '.');
* can be confused by ../test/TEST.SAM
@@ -1561,7 +1582,14 @@ static void ticks_command(int cmd)
dot = (char *)(output_filename + i);
break;
}
+#if MULTIPLE_SRATES
+ if (!dot)
+ dot = output_filename + strlen(output_filename); /* In case it's missing the extension */
+ sprintf(dot, "%d.wav", fileCounter++);
+ fprintf(stderr, "OPENING %s\n",output_filename);
+#else
strcpy(dot + 1, "wav");
+#endif
snd_file = fopen(output_filename, "w");
}
@@ -2824,9 +2852,8 @@ int main(int argc, char **argv)
}
else
{
- size_t bytes;
+ size_t i, bytes;
unsigned char *command;
- int i;
if (argc > 2)
{
diff --git a/tools/tari.scm b/tools/tari.scm
index 4088520..f9e68a1 100644
--- a/tools/tari.scm
+++ b/tools/tari.scm
@@ -6,7 +6,6 @@
(define int-limit 1000000)
(define float-limit 1000.0)
-
(define (make-ivals)
(let ((v (make-int-vector size))
(lim (* 2 int-limit)))
@@ -23,7 +22,6 @@
(vector-set! v i (- (random lim) int-limit)))))
(define ivals1 (make-ivals1))
-
(define (make-fvals)
(let ((v (make-float-vector size))
(lim (* 2.0 float-limit)))
@@ -40,7 +38,6 @@
(vector-set! v i (- (random lim) float-limit)))))
(define fvals1 (make-fvals1))
-
(define (make-ratvals)
(let ((v (make-vector size))
(lim (* 2 int-limit)))
@@ -49,7 +46,6 @@
(vector-set! v i (/ (- (random lim) int-limit) (+ 1 (random int-limit)))))))
(define ratvals (make-ratvals))
-
(define (make-cvals)
(let ((v (make-vector size))
(lim (* 2.0 float-limit)))
@@ -246,43 +242,51 @@
;;; -------- sin etc --------
-(define (trigs)
+(define (trigs1) ; this division into *_d_d here and *_p_p below doesn't save much -- most time is in libm */
(let ((fv (make-float-vector 1)))
(do ((i 0 (+ i 1)))
((= i size))
(sin (fvals i))
- (sin (cvals i))
(float-vector-set! fv 0 (sin (fvals i)))
(cos (fvals i))
- (cos (cvals i))
(float-vector-set! fv 0 (cos (fvals i)))
(tan (fvals i))
- (tan (cvals i))
(float-vector-set! fv 0 (tan (fvals i)))
+ (atan (fvals i))
+ (float-vector-set! fv 0 (atan (fvals i) (fvals i)))
+ (tanh (fvals i))
+ (sinh (fvals i))
+ (float-vector-set! fv 0 (sinh (fvals i)))
+ (cosh (fvals i))
+ (float-vector-set! fv 0 (cosh (fvals i)))
+ (angle (fvals i))
+ )))
+
+(trigs1)
+
+(define (trigs2)
+ (let ((fv (make-float-vector 1)))
+ (do ((i 0 (+ i 1)))
+ ((= i size))
+ (sin (cvals i))
+ (cos (cvals i))
+ (tan (cvals i))
(asin (fvals i))
(asin (cvals i))
(acos (fvals i))
(acos (cvals i))
- (atan (fvals i))
(atan (cvals i))
- (float-vector-set! fv 0 (atan (fvals i) (fvals i)))
- (sinh (fvals i))
(sinh (cvals i))
- (float-vector-set! fv 0 (sinh (fvals i)))
- (cosh (fvals i))
(cosh (cvals i))
- (float-vector-set! fv 0 (cosh (fvals i)))
- (tanh (fvals i))
(tanh (cvals i))
(asinh (fvals i))
(asinh (cvals i))
(acosh (fvals i))
(acosh (cvals i))
(atanh (fvals i))
- (atanh (cvals i))
- (angle (fvals i)))))
+ (atanh (cvals i)))))
-(trigs)
+(trigs2)
;;; -------- lognot etc --------
diff --git a/tools/timp.scm b/tools/timp.scm
index 24b2668..d97a576 100644
--- a/tools/timp.scm
+++ b/tools/timp.scm
@@ -453,7 +453,7 @@
(lambda ()
(do ((i 0 (+ i 1)))
((= i len) (+ 1 L 2))
- (unless (= (+ 1 L 2) 6)
+ (unless (= (+ 1 L 2) 6) ; g_add_3 -> add_p_ppp -> 2 add_p_pp with a method call
(display "f4 oops\n"))))))
;(f4)
diff --git a/tools/tio.scm b/tools/tio.scm
index 9d18319..e104e8b 100644
--- a/tools/tio.scm
+++ b/tools/tio.scm
@@ -2,41 +2,110 @@
(define fsize 100000)
(define ssize 500000)
-
-(define (wis)
- (with-input-from-string "asdf"
- (lambda ()
- (unless (char=? (read-char) #\a)
- (format *stderr* "read-char trouble\n"))
- (unless (char=? (read-char) #\s)
- (format *stderr* "read-char trouble\n"))
- (unless (char=? (read-char (current-input-port)) #\d)
- (format *stderr* "current-input-port trouble\n")))))
-
-(define (call-wis)
- (do ((i 0 (+ i 1)))
- ((= i ssize))
- (wis)))
-
-(define cwis
- (let ((a (char->integer #\a))
- (s (char->integer #\s)))
- (lambda ()
- (call-with-input-string "asdf"
- (lambda (p)
- (if (port-closed? p)
- (format *stderr* "cwis port closed\n"))
- (unless (= (read-byte p) a)
- (format *stderr* "call read-char trouble\n"))
- (unless (= (read-byte p) s)
- (format *stderr* "call read-char trouble\n"))
- (unless (= (port-position p) 2)
- (format *stderr* "cwis position: ~A~%" (port-position p))))))))
-
-(define (call-cwis)
- (do ((i 0 (+ i 1)))
- ((= i ssize))
- (cwis)))
+(define ssize/2 250000)
+
+(if (or (> (*s7* 'major-version) 10)
+ (and (= (*s7* 'major-version) 10) (>= (*s7* 'minor-version) 9)))
+ (begin
+ (define (call-new-wis)
+ (let ((p (open-input-string "asdf")))
+ (do ((i 0 (+ i 1)))
+ ((= i ssize/2))
+ (set! (port-string p) "asdf")
+ (unless (char=? (read-char p) #\a)
+ (format *stderr* "read-char trouble\n"))
+ (unless (char=? (read-char p) #\s)
+ (format *stderr* "read-char trouble\n"))
+ (unless (char=? (read-char p) #\d)
+ (format *stderr* "read-char trouble\n")))
+ (close-input-port p)))
+
+ (define (call-new-cwis)
+ (let ((p (open-input-string "asdf"))
+ (a (char->integer #\a))
+ (s (char->integer #\s)))
+ (do ((i 0 (+ i 1)))
+ ((= i ssize/2))
+ (set! (port-string p) "asdf")
+ (unless (= (read-byte p) a)
+ (format *stderr* "call read-char trouble\n"))
+ (unless (= (read-byte p) s)
+ (format *stderr* "call read-char trouble\n"))
+ (unless (= (port-position p) 2)
+ (format *stderr* "cwis position: ~A~%" (port-position p))))
+ (close-input-port p)))
+
+ ;; include the old cases
+ (define (wis)
+ (with-input-from-string "asdf"
+ (lambda ()
+ (unless (char=? (read-char) #\a)
+ (format *stderr* "read-char trouble\n"))
+ (unless (char=? (read-char) #\s)
+ (format *stderr* "read-char trouble\n"))
+ (unless (char=? (read-char (current-input-port)) #\d)
+ (format *stderr* "current-input-port trouble\n")))))
+
+ (define (call-wis)
+ (do ((i 0 (+ i 1)))
+ ((= i ssize/2))
+ (wis)))
+
+ (define cwis
+ (let ((a (char->integer #\a))
+ (s (char->integer #\s)))
+ (lambda ()
+ (call-with-input-string "asdf"
+ (lambda (p)
+ (if (port-closed? p)
+ (format *stderr* "cwis port closed\n"))
+ (unless (= (read-byte p) a)
+ (format *stderr* "call read-char trouble\n"))
+ (unless (= (read-byte p) s)
+ (format *stderr* "call read-char trouble\n"))
+ (unless (= (port-position p) 2)
+ (format *stderr* "cwis position: ~A~%" (port-position p))))))))
+
+ (define (call-cwis)
+ (do ((i 0 (+ i 1)))
+ ((= i ssize/2))
+ (cwis))))
+
+ (begin
+ (define (wis)
+ (with-input-from-string "asdf"
+ (lambda ()
+ (unless (char=? (read-char) #\a)
+ (format *stderr* "read-char trouble\n"))
+ (unless (char=? (read-char) #\s)
+ (format *stderr* "read-char trouble\n"))
+ (unless (char=? (read-char (current-input-port)) #\d)
+ (format *stderr* "current-input-port trouble\n")))))
+
+ (define (call-wis)
+ (do ((i 0 (+ i 1)))
+ ((= i ssize))
+ (wis)))
+
+ (define cwis
+ (let ((a (char->integer #\a))
+ (s (char->integer #\s)))
+ (lambda ()
+ (call-with-input-string "asdf"
+ (lambda (p)
+ (if (port-closed? p)
+ (format *stderr* "cwis port closed\n"))
+ (unless (= (read-byte p) a)
+ (format *stderr* "call read-char trouble\n"))
+ (unless (= (read-byte p) s)
+ (format *stderr* "call read-char trouble\n"))
+ (unless (= (port-position p) 2)
+ (format *stderr* "cwis position: ~A~%" (port-position p))))))))
+
+ (define (call-cwis)
+ (do ((i 0 (+ i 1)))
+ ((= i ssize))
+ (cwis)))))
(define (wif)
(with-input-from-file "t923.scm"
@@ -67,32 +136,79 @@
(cwif)))
-(define (wos)
- (with-output-to-string
- (lambda ()
- (write-char #\a)
- (write-char #\b)
- (flush-output-port (current-output-port))
- (unless (string=? (get-output-string (current-output-port)) "ab")
- (format *stderr* "write-char trouble\n")))))
-
-(define (call-wos)
- (do ((i 0 (+ i 1)))
- ((= i ssize))
- (wos)))
-
-(define (cwos)
- (call-with-output-string
- (lambda (p)
- (write-string "asdf" p)
- (flush-output-port p)
- (unless (string=? (get-output-string p) "asdf")
- (format *stderr* "call write-string trouble\n")))))
-
-(define (call-cwos)
- (do ((i 0 (+ i 1)))
- ((= i ssize))
- (cwos)))
+(if (or (> (*s7* 'major-version) 10)
+ (and (= (*s7* 'major-version) 10) (>= (*s7* 'minor-version) 9)))
+ (begin
+ (define (call-new-wos)
+ (let ((p (open-output-string)))
+ (do ((i 0 (+ i 1)))
+ ((= i ssize/2))
+ (set! (port-string p) "ab")
+ (unless (string=? (get-output-string p) "ab")
+ (format *stderr* "write-char trouble\n")))
+ (close-output-port p)))
+
+ (define (call-new-cwos)
+ (let ((p (open-output-string)))
+ (do ((i 0 (+ i 1)))
+ ((= i ssize/2))
+ (set! (port-string p) "asdf")
+ (unless (string=? (get-output-string p) "asdf")
+ (format *stderr* "call write-string trouble\n")))))
+
+ (define (wos)
+ (with-output-to-string
+ (lambda ()
+ (write-char #\a)
+ (write-char #\b)
+ (flush-output-port (current-output-port))
+ (unless (string=? (get-output-string (current-output-port)) "ab")
+ (format *stderr* "write-char trouble\n")))))
+
+ (define (call-wos)
+ (do ((i 0 (+ i 1)))
+ ((= i ssize/2))
+ (wos)))
+
+ (define (cwos)
+ (call-with-output-string
+ (lambda (p)
+ (write-string "asdf" p)
+ (flush-output-port p)
+ (unless (string=? (get-output-string p) "asdf")
+ (format *stderr* "call write-string trouble\n")))))
+
+ (define (call-cwos)
+ (do ((i 0 (+ i 1)))
+ ((= i ssize/2))
+ (cwos))))
+ (begin
+ (define (wos)
+ (with-output-to-string
+ (lambda ()
+ (write-char #\a)
+ (write-char #\b)
+ (flush-output-port (current-output-port))
+ (unless (string=? (get-output-string (current-output-port)) "ab")
+ (format *stderr* "write-char trouble\n")))))
+
+ (define (call-wos)
+ (do ((i 0 (+ i 1)))
+ ((= i ssize))
+ (wos)))
+
+ (define (cwos)
+ (call-with-output-string
+ (lambda (p)
+ (write-string "asdf" p)
+ (flush-output-port p)
+ (unless (string=? (get-output-string p) "asdf")
+ (format *stderr* "call write-string trouble\n")))))
+
+ (define (call-cwos)
+ (do ((i 0 (+ i 1)))
+ ((= i ssize))
+ (cwos)))))
(define (wof)
(with-output-to-file "/dev/null"
@@ -216,6 +332,13 @@
(call-wof)
(call-cwof)
+(when (or (> (*s7* 'major-version) 10)
+ (and (= (*s7* 'major-version) 10) (>= (*s7* 'minor-version) 9)))
+ (call-new-wis)
+ (call-new-cwis)
+ (call-new-wos)
+ (call-new-cwos))
+
(call-with-output-file "t923.scm"
(lambda (p)
(display "asdf\n" p)
diff --git a/tools/valcall.scm b/tools/valcall.scm
index 0f8563b..8e65b5d 100644
--- a/tools/valcall.scm
+++ b/tools/valcall.scm
@@ -94,19 +94,19 @@
(list "repl" "texit.scm")
(list "repl" "s7test.scm")
(list "repl" "lt.scm")
- (list "repl" "thook.scm")
(list "repl" "dup.scm")
+ (list "repl" "thook.scm")
(list "repl" "tcopy.scm")
(list "repl" "tread.scm")
(list "repl" "titer.scm")
(list "repl" "trclo.scm")
+ (list "repl" "tmat.scm")
(list "repl" "tload.scm")
(list "repl" "fbench.scm")
- (list "repl" "tmat.scm")
(list "repl" "tsort.scm")
+ (list "repl" "tio.scm")
(list "repl" "tobj.scm")
(list "repl" "teq.scm")
- (list "repl" "tio.scm")
(list "repl" "tmac.scm")
(list "repl" "tclo.scm")
(list "repl" "tcase.scm")