diff options
| author | IOhannes m zmölnig <zmoelnig@umlautT.umlaeute.mur.at> | 2024-02-02 08:32:51 +0100 |
|---|---|---|
| committer | IOhannes m zmölnig <zmoelnig@umlautT.umlaeute.mur.at> | 2024-02-02 08:32:51 +0100 |
| commit | 780055c393aadacd178cee2222ed9cb06e79f7d7 (patch) | |
| tree | a8c4d205e759a2598772052d0989a87a307259cd | |
| parent | 3f63d1045748990e96ed5f5fc93c8389c639a302 (diff) | |
New upstream version 24.1
| -rw-r--r-- | HISTORY.Snd | 3 | ||||
| -rw-r--r-- | NEWS | 14 | ||||
| -rw-r--r-- | clm2xen.c | 8 | ||||
| -rw-r--r-- | cload.scm | 3 | ||||
| -rwxr-xr-x | configure | 20 | ||||
| -rw-r--r-- | configure.ac | 4 | ||||
| -rw-r--r-- | extsnd.html | 12 | ||||
| -rw-r--r-- | libarb_s7.c | 8 | ||||
| -rw-r--r-- | libc.scm | 10 | ||||
| -rw-r--r-- | libgsl.scm | 6 | ||||
| -rw-r--r-- | pvoc.scm | 2 | ||||
| -rw-r--r-- | s7.c | 2055 | ||||
| -rw-r--r-- | s7.h | 11 | ||||
| -rw-r--r-- | s7.html | 20 | ||||
| -rw-r--r-- | s7test.scm | 374 | ||||
| -rw-r--r-- | snd-chn.c | 18 | ||||
| -rw-r--r-- | snd-dac.c | 1 | ||||
| -rw-r--r-- | snd-edits.c | 31 | ||||
| -rw-r--r-- | snd-help.c | 10 | ||||
| -rw-r--r-- | snd-select.c | 1 | ||||
| -rw-r--r-- | snd-snd.c | 65 | ||||
| -rw-r--r-- | snd-test.scm | 14 | ||||
| -rw-r--r-- | snd.h | 6 | ||||
| -rw-r--r-- | sndlib2xen.c | 3 | ||||
| -rw-r--r-- | stuff.scm | 2 | ||||
| -rw-r--r-- | tools/auto-tester.scm | 30 | ||||
| -rw-r--r-- | tools/dup.scm | 5 | ||||
| -rw-r--r-- | tools/ffitest.c | 28 | ||||
| -rw-r--r-- | tools/tclo.scm | 22 | ||||
| -rwxr-xr-x | tools/tests7 | 24 | ||||
| -rw-r--r-- | tools/tfft.scm | 10 | ||||
| -rw-r--r-- | tools/tgsl.scm | 908 | ||||
| -rw-r--r-- | tools/thash.scm | 8 | ||||
| -rw-r--r-- | tools/tmisc.scm | 2 | ||||
| -rw-r--r-- | tools/tshoot.scm | 2 | ||||
| -rw-r--r-- | tools/valcall.scm | 4 | ||||
| -rw-r--r-- | write.scm | 249 |
37 files changed, 2269 insertions, 1724 deletions
diff --git a/HISTORY.Snd b/HISTORY.Snd index b6d1a91..308a3b3 100644 --- a/HISTORY.Snd +++ b/HISTORY.Snd @@ -1,6 +1,9 @@ Snd change log + 2-Feb: Snd 24.1. + 1-Jan-24: Snd 24.0. + 2024 ---------------------------------------------------------------- 25-Nov: Snd 23.9. @@ -1,10 +1,8 @@ -Snd 23.9: +Snd 24.1 -s7: added optional let argument to immutable? and immutable! - finally added error checks to the tree-* functions - see lint.scm for the previous versions - s7_make_c_pointer_wrapper_with_type - ' (apostrophe) now is (#_quote ...) and similarly - for the quasiquote helpers, apply-values, and list-values. +More optimizations, minor bug fixes, and rewrites. + +checked: sbcl 2.4.1 + +Thanks!: Norman Gray, Andreas Enge -Thanks!: Norman Gray @@ -1348,7 +1348,8 @@ static s7_pointer s7_mus_xen_free(s7_scheme *sc, s7_pointer obj) static s7_pointer mus_generator_to_string(s7_scheme *sc, s7_pointer args) { - s7_pointer g; + s7_pointer g, res; + char *desc; g = s7_car(args); if (s7_is_pair(s7_cdr(args))) { @@ -1357,7 +1358,10 @@ static s7_pointer mus_generator_to_string(s7_scheme *sc, s7_pointer args) if (choice == kw_readable) s7_error(sc, s7_make_symbol(sc, "out-of-range"), s7_list(sc, 1, s7_make_string(sc, "can't write a clm generator readably"))); } - return(s7_make_string(sc, mus_describe(((mus_xen *)s7_c_object_value(g))->gen))); + desc = mus_describe(((mus_xen *)s7_c_object_value(g))->gen); + res = s7_make_string(sc, desc); + if (desc) free(desc); + return(res); } static s7_pointer s7_mus_xen_is_equal(s7_scheme *sc, s7_pointer args) @@ -450,7 +450,7 @@ (format pp "static s7_double ~A~A(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(~A(x1, x2, x3, x4));}~%" func-name local-name func-name))) (set! double-funcs (cons (list func-name scheme-name local-name) double-funcs)))) - + (when (and (memq return-type '(int size_t)) ; int (f int|double|void) (not (defined? (symbol scheme-name) (rootlet))) ; see below, int-funcs entry not used if already defined (or ;(= num-args 0) @@ -487,6 +487,7 @@ ;; other possibilities: d_7pi|pii p=double* etc piid=checks in s7 (assumes float-vector) ;; d_pd [lots of d_pdd, d_p, p_i and i_p] ;; but how to recognize the "p" portions? (d_7pi with p="s7_pointer" gets no hits in libgsl) + ;; libgsl: d_i: 15, d_ii: 5, [handled: d_id: 32], d_iid: 7, d_ddi: 4, d_idd: 10, d_idi: 6, i_ddd i_iii: 1, i_dddd: 4 (format pp "~%") (set! functions (cons (list scheme-name base-name @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for snd 24.0. +# Generated by GNU Autoconf 2.71 for snd 24.1. # # 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.0' -PACKAGE_STRING='snd 24.0' +PACKAGE_VERSION='24.1' +PACKAGE_STRING='snd 24.1' 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.0 to adapt to many kinds of systems. +\`configure' configures snd 24.1 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.0:";; + short | recursive ) echo "Configuration of snd 24.1:";; 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.0 +snd configure 24.1 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.0, which was +It was created by snd $as_me 24.1, 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.0 +VERSION=24.1 #-------------------------------------------------------------------------------- # configuration options @@ -7432,7 +7432,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.0, which was +This file was extended by snd $as_me 24.1, which was generated by GNU Autoconf 2.71. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -7496,7 +7496,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.0 +snd config.status 24.1 configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index 39f5097..65bd983 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ # gmp, mpfr, and mpc deliberately have none! -AC_INIT(snd, 24.0, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-24.tar.gz) +AC_INIT(snd, 24.1, 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.0 +VERSION=24.1 #-------------------------------------------------------------------------------- # configuration options diff --git a/extsnd.html b/extsnd.html index d02e996..326ff45 100644 --- a/extsnd.html +++ b/extsnd.html @@ -11367,8 +11367,8 @@ Functions such as color-orientation-dialog normally create and start the dialog (color-orientation-dialog) puts the color/orientation dialog on the screen. If you're trying instead to customize the dialog in some way (in your initialization file, for example), you want the dialog to be created (so that the various widget children exist), but don't want it to pop -up on the screen ('managed' in X jargon). So, most of the dialog functions have a 'managed' argument -that defaults to #t. If #f, the dialog is created, if need be, but not started. +up on the screen ('managed' in X jargon). So, most of the dialog functions have a 'managed' argument. +If it is #f, the dialog is created, if need be, but not started. install-searcher-with-colors in snd-motif.scm, which adds customized file filtering code to the File:Open dialog, first makes sure the dialog exists with (open-file-dialog #f). </p> @@ -11563,7 +11563,7 @@ Snd menus are numbered from 0 ('File') to 4 ('Help'). If the label and callback <em class=def id="colororientationdialog">color-orientation-dialog</em> managed </pre> -<p>This creates and (if 'managed' which defaults to #t) activates the Color/Orientation dialog; it returns the dialog widget. +<p>This creates and (if 'managed') activates the Color/Orientation dialog; it returns the dialog widget. </p> <div class="spacer"></div> @@ -12355,7 +12355,7 @@ this is a test <em class=def id="transformdialog">transform-dialog</em> managed </pre> -<p>This creates and (if 'managed' which defaults to #t) activates the Options:Transform dialog, returning the dialog widget. +<p>This creates and (if 'managed') activates the Options:Transform dialog, returning the dialog widget. </p> <div class="spacer"></div> @@ -12385,7 +12385,7 @@ this is a test <em class=def id="viewfilesdialog">view-files-dialog</em> managed [Motif only] </pre> -<p>This creates and (if 'managed' which defaults to #t) activates a +<p>This creates and (if 'managed') activates a View:Files <a href="snd.html#viewfiles">dialog</a> and returns the dialog widget. </p> <div class="spacer"></div> @@ -14106,7 +14106,7 @@ float-vectors), and displays it in any channel's time domain graph using its cur <em class=def id="sndcolor">snd-color</em> choice </pre> -<p>snd-color returns a Snd built-in color (as a Pixel/GdkPixel); it simplifies +<p>snd-color returns a Snd built-in color (as a Pixel); it simplifies code that wants to follow whatever the current Snd color choices are. The choices are: </p> diff --git a/libarb_s7.c b/libarb_s7.c index 7413ccc..d9e0084 100644 --- a/libarb_s7.c +++ b/libarb_s7.c @@ -6,10 +6,10 @@ #include <mpfr.h> #include <mpc.h> -#include <arb.h> -#include <acb.h> -#include <acb_hypgeom.h> -#include <acb_elliptic.h> +#include <flint/arb.h> +#include <flint/acb.h> +#include <flint/acb_hypgeom.h> +#include <flint/acb_elliptic.h> #define WITH_GMP 1 #include "s7.h" @@ -19,14 +19,17 @@ (with-let (unlet) (set! *cload-library-name* "*libc*") + (set! *libraries* (cons (cons "libc.scm" (curlet)) *libraries*)) ;; -------- stddef.h -------- (define NULL (c-pointer 0 'void*)) - (define (c-null? p) (and (c-pointer? p) (zero? (car (c-pointer->list p))))) + ;(define (c-null? p) (and (c-pointer? p) (zero? (car (c-pointer->list p))))) ;; -------- stdbool.h -------- - (define false #f) - (define true #t) + ;(define false #f) + ;(define true #t) + ;scheme objects like false or c-null in *libc* will not appear in *libc* normally: no s7_define -> shadow_rootlet, + ; and this file itself is not loaded except when libc_s7.c is written (when libc_s7.so is out of date) ;; -------- iso646.h -------- ;; spelled-out names for & = bitand et al @@ -45,7 +48,6 @@ (#t (values)))) (define (hiho a) (assert (> a 2)) (+ a 1)) |# - (set! *libraries* (cons (cons "libc.scm" (curlet)) *libraries*)) ;; -------- setjmp.h -------- ;; longjmp etc @@ -800,6 +800,11 @@ { return(s7_make_c_pointer_with_type(sc, (void *)calloc(1, sizeof(gsl_sf_result)), gsl_sf_result__symbol, s7_f(sc))); } + static s7_pointer g_gsl_sf_result_free(s7_scheme *sc, s7_pointer args) + { + free(s7_c_pointer(s7_car(args))); + return(s7_f(sc)); + } static s7_pointer g_gsl_sf_result_val(s7_scheme *sc, s7_pointer args) { return(s7_make_real(sc, ((gsl_sf_result *)s7_c_pointer_with_type(sc, s7_car(args), gsl_sf_result__symbol, __func__, 1))->val)); @@ -827,6 +832,7 @@ ") (C-function ("gsl_sf_result.make" g_gsl_sf_result_make "" 0)) + (C-function ("gsl_sf_result.free" g_gsl_sf_result_free "" 1)) (C-function ("gsl_sf_result_e10.make" g_gsl_sf_result_e10_make "" 0)) (C-function ("gsl_sf_result.val" g_gsl_sf_result_val "" 1)) (C-function ("gsl_sf_result.err" g_gsl_sf_result_err "" 1)) @@ -247,7 +247,7 @@ (obank (make-oscil-bank lastfreq (make-float-vector N2) lastamp)) (filptr 0) (D (floor (/ fftsize overlap))) - (syngate (if (= 0.0 gate) ; take a resynthesis gate specificed in dB, convert to linear amplitude + (syngate (if (= 0.0 gate) ; take a resynthesis gate specified in dB, convert to linear amplitude 0.0000 (expt 10 (/ (- (abs gate)) 20)))) (poffset (hz->radians hoffset)) @@ -281,6 +281,7 @@ #define HAVE_GMP typo! #define SHOW_EVAL_OPS 0 + #ifndef _GNU_SOURCE #define _GNU_SOURCE /* for qsort_r, grumble... */ #endif @@ -342,7 +343,7 @@ #ifndef S7_ALIGNED #define S7_ALIGNED 0 - /* memclr, local_strcmp and local_memset */ + /* memclr and local_memset */ #endif #include <stdio.h> @@ -451,7 +452,7 @@ #define WRITE_REAL_PRECISION 16 #ifdef __TINYC__ - typedef double long_double; /* (- .1 1) -> 0.9! and others similarly: (- double long_double) is broken) */ + typedef double long_double; /* (- .1 1) -> 0.9! and others similarly: (- double long_double) is broken */ #else typedef long double long_double; #endif @@ -751,6 +752,7 @@ typedef union { bool (*fb)(opt_info *o); s7_pointer (*fp)(opt_info *o); } vunion; +/* libgsl 15 d_i */ #define NUM_VUNIONS 15 struct opt_info { @@ -1125,10 +1127,9 @@ struct s7_scheme { s7_pointer no_value; /* the (values) value */ s7_pointer unused; /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */ - s7_pointer symbol_table; /* symbol table */ - s7_pointer rootlet, shadow_rootlet; /* rootlet */ - s7_int rootlet_entries; - s7_pointer unlet; /* original bindings of predefined functions */ + s7_pointer symbol_table; + s7_pointer rootlet, rootlet_slots, shadow_rootlet; + s7_pointer unlet_slots; /* original bindings of predefined functions */ s7_pointer input_port; /* current-input-port */ s7_pointer *input_port_stack; /* input port stack (load and read internally) */ @@ -1401,7 +1402,7 @@ struct s7_scheme { s7_pointer wrong_type_arg_info, out_of_range_info, sole_arg_wrong_type_info, sole_arg_out_of_range_info; #define NUM_SAFE_PRELISTS 8 - #define NUM_SAFE_LISTS 64 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test */ + #define NUM_SAFE_LISTS 32 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test, > 16 doesn't happen much */ s7_pointer safe_lists[NUM_SAFE_LISTS]; int32_t current_safe_list; @@ -1922,85 +1923,84 @@ static void init_types(void) #if S7_DEBUGGING static void print_gc_info(s7_scheme *sc, s7_pointer obj, int32_t line); - static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2); - static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref16(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref16a(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref19(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref19a(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_one(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2); + static s7_pointer check_ref_num(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_app(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_ext(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_out(s7_pointer p, const char *func, int32_t line); + static s7_pointer check_ref_sln(s7_pointer p, const char *func, int32_t line); static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line); static s7_pointer check_opcode(s7_pointer p, const char *func, int32_t line); static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, int32_t line); - #define unchecked_type(p) ((p)->tf.type_field) #if WITH_GCC #define type(p) ({uint8_t _t_; _t_ = (p)->tf.type_field; if ((!cur_sc->printing_gc_info) && ((_t_ == T_FREE) || (_t_ >= NUM_TYPES))) print_gc_info(cur_sc, p, __LINE__); _t_;}) #else #define type(p) (p)->tf.type_field #endif + #define set_full_type(p, f) set_type_1(p, f, __func__, __LINE__) /* these check most s7_cell field references (and many type bits) for consistency */ - #define T_App(P) check_ref11(P, __func__, __LINE__) /* applicable or #f */ - #define T_Arg(P) check_ref10(P, __func__, __LINE__) /* closure arg (list, symbol) */ - #define T_BVc(P) check_ref(P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Bgf(P) check_ref(P, T_BIG_RATIO, __func__, __LINE__, "sweep", NULL) - #define T_Bgi(P) check_ref(P, T_BIG_INTEGER, __func__, __LINE__, "sweep", NULL) - #define T_Bgr(P) check_ref(P, T_BIG_REAL, __func__, __LINE__, "sweep", NULL) - #define T_Bgz(P) check_ref(P, T_BIG_COMPLEX, __func__, __LINE__, "sweep", NULL) - #define T_CMac(P) check_ref(P, T_C_MACRO, __func__, __LINE__, NULL, NULL) - #define T_Cat(P) check_ref(P, T_CATCH, __func__, __LINE__, NULL, NULL) - #define T_Chr(P) check_ref(P, T_CHARACTER, __func__, __LINE__, NULL, NULL) - #define T_Clo(P) check_ref5(P, __func__, __LINE__) /* has closure let */ - #define T_Cmp(P) check_ref(P, T_COMPLEX, __func__, __LINE__, NULL, NULL) - #define T_Con(P) check_ref(P, T_CONTINUATION, __func__, __LINE__, "sweep", "process_continuation") - #define T_Ctr(P) check_ref(P, T_COUNTER, __func__, __LINE__, NULL, NULL) - #define T_Dyn(P) check_ref(P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL) - #define T_Eof(P) check_ref(P, T_EOF, __func__, __LINE__, "sweep", NULL) - #define T_Exs(P) check_ref19a(P, __func__, __LINE__) /* not an internal type, but #<unused> and slot are ok */ - #define T_Ext(P) check_ref19(P, __func__, __LINE__) /* not an internal type */ - #define T_Fnc(P) check_ref6(P, __func__, __LINE__) /* any c_function|c_macro */ - #define T_Frc(P) check_ref2(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL) - #define T_Fst(P) check_ref(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL) - #define T_Fvc(P) check_ref(P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Got(P) check_ref(P, T_GOTO, __func__, __LINE__, NULL, NULL) - #define T_Hsh(P) check_ref(P, T_HASH_TABLE, __func__, __LINE__, "sweep", "free_hash_table") - #define T_Int(P) check_ref(P, T_INTEGER, __func__, __LINE__, NULL, NULL) - #define T_Itr(P) check_ref(P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator") - #define T_Ivc(P) check_ref(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Key(P) check_ref18(P, __func__, __LINE__) /* keyword */ - #define T_Let(P) check_ref(P, T_LET, __func__, __LINE__, NULL, NULL) /* let+rootlet but not nil */ - #define T_Lid(P) check_ref16(P, __func__, __LINE__) /* let/nil but not rootlet */ - #define T_Lsd(P) check_ref16a(P, __func__, __LINE__) /* let but not nil or rootlet */ - #define T_Lst(P) check_ref2(P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL) - #define T_Mac(P) check_ref17(P, __func__, __LINE__) /* a non-C macro */ - #define T_Met(P) check_ref9(P, __func__, __LINE__) /* anything that might contain a method */ - #define T_Nmv(P) check_ref15(P, __func__, __LINE__) /* not multiple-value, not free, only affects slot values */ - #define T_Num(P) check_ref7(P, __func__, __LINE__) /* any number (not bignums) */ - #define T_Nvc(P) check_ref(P, T_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Obj(P) check_ref(P, T_C_OBJECT, __func__, __LINE__, "sweep", "s7_c_object_value") - #define T_Op(P) check_opcode(P, __func__, __LINE__) - #define T_Pair(P) check_ref(P, T_PAIR, __func__, __LINE__, NULL, NULL) - #define T_Pcs(P) check_ref2(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL) - #define T_Pos(P) check_nref(P, __func__, __LINE__) /* not free */ - #define T_Prc(P) check_ref14(P, __func__, __LINE__) /* any procedure (3-arg setters) or #f|#t */ - #define T_Pri(P) check_ref3i(P, __func__, __LINE__) /* input_port or #f */ - #define T_Pro(P) check_ref3o(P, __func__, __LINE__) /* output_port or #f */ - #define T_Prt(P) check_ref3(P, __func__, __LINE__) /* input|output_port */ - #define T_Ptr(P) check_ref(P, T_C_POINTER, __func__, __LINE__, NULL, NULL) - #define T_Ran(P) check_ref(P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL) - #define T_Rel(P) check_ref(P, T_REAL, __func__, __LINE__, NULL, NULL) - #define T_Seq(P) check_ref8(P, __func__, __LINE__) /* any sequence or structure */ - #define T_Sld(P) check_ref2(P, T_SLOT, T_UNDEFINED,__func__, __LINE__, NULL, NULL) - #define T_Sln(P) check_ref12(P, __func__, __LINE__) /* slot or nil */ - #define T_Slt(P) check_ref(P, T_SLOT, __func__, __LINE__, NULL, NULL) - #define T_Stk(P) check_ref(P, T_STACK, __func__, __LINE__, NULL, NULL) - #define T_Str(P) check_ref(P, T_STRING, __func__, __LINE__, "sweep", NULL) - #define T_SVec(P) check_ref13(P, __func__, __LINE__) /* subvector */ - #define T_Sym(P) check_ref(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table") - #define T_Syn(P) check_ref(P, T_SYNTAX, __func__, __LINE__, NULL, NULL) - #define T_Undf(P) check_ref(P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL) - #define T_Vec(P) check_ref4(P, __func__, __LINE__) /* any vector */ + #define T_App(P) check_ref_app(P, __func__, __LINE__) /* applicable or #f */ + #define T_Arg(P) check_ref_arg(P, __func__, __LINE__) /* closure arg (list, symbol) */ + #define T_BVc(P) check_ref_one(P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_Bgf(P) check_ref_one(P, T_BIG_RATIO, __func__, __LINE__, "sweep", NULL) + #define T_Bgi(P) check_ref_one(P, T_BIG_INTEGER, __func__, __LINE__, "sweep", NULL) + #define T_Bgr(P) check_ref_one(P, T_BIG_REAL, __func__, __LINE__, "sweep", NULL) + #define T_Bgz(P) check_ref_one(P, T_BIG_COMPLEX, __func__, __LINE__, "sweep", NULL) + #define T_CMac(P) check_ref_one(P, T_C_MACRO, __func__, __LINE__, NULL, NULL) + #define T_Cat(P) check_ref_one(P, T_CATCH, __func__, __LINE__, NULL, NULL) + #define T_Chr(P) check_ref_one(P, T_CHARACTER, __func__, __LINE__, NULL, NULL) + #define T_Clo(P) check_ref_clo(P, __func__, __LINE__) /* has closure let */ + #define T_Cmp(P) check_ref_one(P, T_COMPLEX, __func__, __LINE__, NULL, NULL) + #define T_Con(P) check_ref_one(P, T_CONTINUATION, __func__, __LINE__, "sweep", "process_continuation") + #define T_Ctr(P) check_ref_one(P, T_COUNTER, __func__, __LINE__, NULL, NULL) + #define T_Dyn(P) check_ref_one(P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL) + #define T_Eof(P) check_ref_one(P, T_EOF, __func__, __LINE__, "sweep", NULL) + #define T_Exs(P) check_ref_exs(P, __func__, __LINE__) /* not an internal type, but #<unused> and slot are ok */ + #define T_Ext(P) check_ref_ext(P, __func__, __LINE__) /* not an internal type */ + #define T_Fnc(P) check_ref_fnc(P, __func__, __LINE__) /* any c_function|c_macro */ + #define T_Frc(P) check_ref_two(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL) + #define T_Fst(P) check_ref_one(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL) + #define T_Fvc(P) check_ref_one(P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_Got(P) check_ref_one(P, T_GOTO, __func__, __LINE__, NULL, NULL) + #define T_Hsh(P) check_ref_one(P, T_HASH_TABLE, __func__, __LINE__, "sweep", "free_hash_table") + #define T_Int(P) check_ref_one(P, T_INTEGER, __func__, __LINE__, NULL, NULL) + #define T_Itr(P) check_ref_one(P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator") + #define T_Ivc(P) check_ref_one(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_Key(P) check_ref_key(P, __func__, __LINE__) /* keyword */ + #define T_Let(P) check_ref_one(P, T_LET, __func__, __LINE__, NULL, NULL) /* let+rootlet but not nil */ + #define T_Lst(P) check_ref_two(P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL) + #define T_Mac(P) check_ref_mac(P, __func__, __LINE__) /* a non-C macro */ + #define T_Met(P) check_ref_met(P, __func__, __LINE__) /* anything that might contain a method */ + #define T_Nmv(P) check_ref_nmv(P, __func__, __LINE__) /* not multiple-value, not free, only affects slot values */ + #define T_Num(P) check_ref_num(P, __func__, __LINE__) /* any number (not bignums) */ + #define T_Nvc(P) check_ref_one(P, T_VECTOR, __func__, __LINE__, "sweep", NULL) + #define T_Obj(P) check_ref_one(P, T_C_OBJECT, __func__, __LINE__, "sweep", "s7_c_object_value") + #define T_Op(P) check_opcode(P, __func__, __LINE__) + #define T_Out(P) check_ref_out(P, __func__, __LINE__) /* let or NULL */ + #define T_Pair(P) check_ref_one(P, T_PAIR, __func__, __LINE__, NULL, NULL) + #define T_Pcs(P) check_ref_two(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL) + #define T_Pos(P) check_nref(P, __func__, __LINE__) /* not free */ + #define T_Prc(P) check_ref_prc(P, __func__, __LINE__) /* any procedure (3-arg setters) or #f|#t */ + #define T_Pri(P) check_ref_pri(P, __func__, __LINE__) /* input_port or #f */ + #define T_Pro(P) check_ref_pro(P, __func__, __LINE__) /* output_port or #f */ + #define T_Prt(P) check_ref_prt(P, __func__, __LINE__) /* input|output_port */ + #define T_Ptr(P) check_ref_one(P, T_C_POINTER, __func__, __LINE__, NULL, NULL) + #define T_Ran(P) check_ref_one(P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL) + #define T_Rel(P) check_ref_one(P, T_REAL, __func__, __LINE__, NULL, NULL) + #define T_Seq(P) check_ref_seq(P, __func__, __LINE__) /* any sequence or structure */ + #define T_Sld(P) check_ref_two(P, T_SLOT, T_UNDEFINED, __func__, __LINE__, NULL, NULL) + #define T_Sln(P) check_ref_sln(P, __func__, __LINE__) /* slot or nil or NULL */ + #define T_Slt(P) check_ref_one(P, T_SLOT, __func__, __LINE__, NULL, NULL) + #define T_Stk(P) check_ref_one(P, T_STACK, __func__, __LINE__, NULL, NULL) + #define T_Str(P) check_ref_one(P, T_STRING, __func__, __LINE__, "sweep", NULL) + #define T_SVec(P) check_ref_svec(P, __func__, __LINE__) /* subvector */ + #define T_Sym(P) check_ref_one(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table") + #define T_Syn(P) check_ref_one(P, T_SYNTAX, __func__, __LINE__, NULL, NULL) + #define T_Undf(P) check_ref_one(P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL) + #define T_Vec(P) check_ref_vec(P, __func__, __LINE__) /* any vector */ #else /* if not debugging, all those checks go away */ #define T_App(P) P @@ -2032,8 +2032,6 @@ static void init_types(void) #define T_Ivc(P) P #define T_Key(P) P #define T_Let(P) P - #define T_Lid(P) P - #define T_Lsd(P) P #define T_Lst(P) P #define T_Mac(P) P #define T_Met(P) P @@ -2042,6 +2040,7 @@ static void init_types(void) #define T_Nvc(P) P #define T_Obj(P) P #define T_Op(P) P + #define T_Out(P) P #define T_Pair(P) P #define T_Pcs(P) P #define T_Pos(P) P @@ -2069,6 +2068,7 @@ static void init_types(void) #define set_full_type(p, f) full_type(p) = f #endif #define signed_type(p) (p)->tf.s64_type +#define clear_type(p) full_type(p) = T_FREE #define is_number(P) t_number_p[type(P)] #define is_small_real(P) t_small_real_p[type(P)] @@ -2087,7 +2087,7 @@ static void init_types(void) #define is_boolean(p) (type(p) == T_BOOLEAN) #define is_free(p) (type(p) == T_FREE) -#define is_free_and_clear(p) (full_type(p) == T_FREE) +#define is_free_and_clear(p) (full_type(p) == T_FREE) /* protect against new_cell in-between states? */ #define is_simple(P) t_simple_p[type(P)] /* eq? */ #define has_structure(P) ((t_structure_p[type(P)]) && ((!is_t_vector(P)) || (!has_simple_elements(P)))) @@ -2141,10 +2141,6 @@ static void init_types(void) #define list_is_in_use(p) has_low_type_bit(T_Pair(p), T_LIST_IN_USE) #define set_list_in_use(p) set_low_type_bit(T_Pair(p), T_LIST_IN_USE) #define clear_list_in_use(p) do {clear_low_type_bit(T_Pair(p), T_LIST_IN_USE); sc->current_safe_list = 0;} while (0) -/* since the safe lists are not in the heap, if the list_in_use bit is off, the list won't be GC-protected even if - * it is gc_marked explicitly. This happens, for example, in copy_proper_list where we try to protect the original list - * by sc->temp5 = lst; then in the GC, gc_mark(sc->temp5); but the safe_list probably is already marked, so its contents are not protected. - */ #define T_ONE_FORM T_SIMPLE_ARG_DEFAULTS #define set_closure_has_one_form(p) set_low_type_bit(T_Clo(p), T_ONE_FORM) @@ -2241,8 +2237,8 @@ static void init_types(void) /* marks do-loops that resist optimization */ #define T_DOX_SLOT1 T_MID_GLOBAL -#define has_dox_slot1(p) has_mid_type_bit(T_Lsd(p), T_DOX_SLOT1) -#define set_has_dox_slot1(p) set_mid_type_bit(T_Lsd(p), T_DOX_SLOT1) +#define has_dox_slot1(p) has_mid_type_bit(T_Let(p), T_DOX_SLOT1) +#define set_has_dox_slot1(p) set_mid_type_bit(T_Let(p), T_DOX_SLOT1) /* marks a let that includes the dox_slot1 */ #define T_COLLECTED (1 << (16 + 1)) @@ -2275,8 +2271,8 @@ static void init_types(void) /* marks a slot that has a setter or symbol that might have a setter */ #define T_WITH_LET_LET T_MID_LOCATION -#define is_with_let_let(p) has_mid_type_bit(T_Lsd(p), T_WITH_LET_LET) -#define set_with_let_let(p) set_mid_type_bit(T_Lsd(p), T_WITH_LET_LET) +#define is_with_let_let(p) has_mid_type_bit(T_Let(p), T_WITH_LET_LET) +#define set_with_let_let(p) set_mid_type_bit(T_Let(p), T_WITH_LET_LET) /* marks a let that is the argument to with-let (but not rootlet in its uses) */ #define T_SIMPLE_DEFAULTS T_MID_LOCATION @@ -2337,15 +2333,15 @@ static void init_types(void) #define set_has_stepper(p) set_mid_type_bit(T_Slt(p), T_HAS_STEPPER) #define T_DOX_SLOT2 T_MID_UNSAFE -#define has_dox_slot2(p) has_mid_type_bit(T_Lsd(p), T_DOX_SLOT2) -#define set_has_dox_slot2(p) set_mid_type_bit(T_Lsd(p), T_DOX_SLOT2) +#define has_dox_slot2(p) has_mid_type_bit(T_Let(p), T_DOX_SLOT2) +#define set_has_dox_slot2(p) set_mid_type_bit(T_Let(p), T_DOX_SLOT2) /* marks a let that includes the dox_slot2 */ #define T_IMMUTABLE (1 << (16 + 8)) #define T_MID_IMMUTABLE (1 << 8) #define is_immutable(p) has_mid_type_bit(T_Exs(p), T_MID_IMMUTABLE) #define set_immutable(p) set_mid_type_bit(T_Exs(p), T_MID_IMMUTABLE) /* can be a slot, so not T_Ext */ -#define set_immutable_let(p) set_mid_type_bit(T_Lsd(p), T_MID_IMMUTABLE) +#define set_immutable_let(p) set_mid_type_bit(T_Let(p), T_MID_IMMUTABLE) #define set_immutable_slot(p) set_mid_type_bit(T_Slt(p), T_MID_IMMUTABLE) #define is_immutable_port(p) has_mid_type_bit(T_Prt(p), T_MID_IMMUTABLE) #define is_immutable_symbol(p) has_mid_type_bit(T_Sym(p), T_MID_IMMUTABLE) @@ -2373,8 +2369,8 @@ static void init_types(void) */ #define T_LET_REMOVED T_MID_SETTER -#define let_set_removed(p) set_mid_type_bit(T_Lsd(p), T_LET_REMOVED) -#define let_removed(p) has_mid_type_bit(T_Lsd(p), T_LET_REMOVED) +#define let_set_removed(p) set_mid_type_bit(T_Let(p), T_LET_REMOVED) +#define let_removed(p) has_mid_type_bit(T_Let(p), T_LET_REMOVED) /* mark lets that have been removed from the heap or checked for that possibility */ #define T_HAS_EXPRESSION T_MID_SETTER @@ -2473,8 +2469,8 @@ static void init_types(void) #define T_FUNCLET T_GENSYM #define T_MID_FUNCLET T_MID_GENSYM -#define is_funclet(p) has_mid_type_bit(T_Lsd(p), T_MID_FUNCLET) -#define set_funclet(p) set_mid_type_bit(T_Lsd(p), T_MID_FUNCLET) +#define is_funclet(p) has_mid_type_bit(T_Let(p), T_MID_FUNCLET) +#define set_funclet(p) set_mid_type_bit(T_Let(p), T_MID_FUNCLET) /* this marks a funclet */ #define T_HASH_CHOSEN T_MID_GENSYM @@ -2517,12 +2513,12 @@ static void init_types(void) #define T_MID_HAS_LET_SET_FALLBACK T_MID_SAFE_STEPPER #define T_HAS_LET_REF_FALLBACK T_MUTABLE #define T_MID_HAS_LET_REF_FALLBACK T_MID_MUTABLE -#define has_let_ref_fallback(p) ((mid_type(T_Lsd(p)) & (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) -#define has_let_set_fallback(p) ((mid_type(T_Lsd(p)) & (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) -#define set_has_let_ref_fallback(p) set_mid_type_bit(T_Lsd(p), T_MID_HAS_LET_REF_FALLBACK) -#define set_has_let_set_fallback(p) set_mid_type_bit(T_Lsd(p), T_MID_HAS_LET_SET_FALLBACK) -#define has_let_fallback(p) has_mid_type_bit(T_Lsd(p), (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) -#define set_all_methods(p, e) mid_type(T_Lsd(p)) |= (mid_type(e) & (T_MID_HAS_METHODS | T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) +#define has_let_ref_fallback(p) ((mid_type(T_Let(p)) & (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) +#define has_let_set_fallback(p) ((mid_type(T_Let(p)) & (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) +#define set_has_let_ref_fallback(p) set_mid_type_bit(T_Let(p), T_MID_HAS_LET_REF_FALLBACK) +#define set_has_let_set_fallback(p) set_mid_type_bit(T_Let(p), T_MID_HAS_LET_SET_FALLBACK) +#define has_let_fallback(p) has_mid_type_bit(T_Let(p), (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) +#define set_all_methods(p, e) mid_type(T_Let(p)) |= (mid_type(e) & (T_MID_HAS_METHODS | T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK)) #define T_ITER_OK (1LL << (16 + 15)) #define T_MID_ITER_OK (1 << 15) @@ -2544,8 +2540,7 @@ static void init_types(void) #define T_SYMBOL_FROM_SYMBOL T_MID_ITER_OK #define is_symbol_from_symbol(p) has_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) #define set_is_symbol_from_symbol(p) set_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) -#define clear_symbol_from_symbol(p) clear_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) /* was type1?? 20-Dec-23 */ -/* TODO: is this bit actually working? What did clear_high_type_bit here do?? high_type_bit should protest against >= 16 if s7_debugging (also 0 etc) */ +#define clear_symbol_from_symbol(p) clear_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) /* was high_type?? 20-Dec-23 */ /* -------- high type bits -------- */ @@ -2570,14 +2565,14 @@ static void init_types(void) #define set_is_int_optable(p) set_high_type_bit(T_Pair(p), T_INT_OPTABLE) #define T_UNLET T_SYMCONS -#define is_unlet(p) has_high_type_bit(T_Lsd(p), T_UNLET) -#define set_is_unlet(p) set_high_type_bit(T_Lsd(p), T_UNLET) +#define is_unlet(p) has_high_type_bit(T_Let(p), T_UNLET) +#define set_is_unlet(p) set_high_type_bit(T_Let(p), T_UNLET) #define T_FULL_HAS_LET_FILE (1LL << (48 + 1)) #define T_HAS_LET_FILE (1 << 1) -#define has_let_file(p) has_high_type_bit(T_Lsd(p), T_HAS_LET_FILE) -#define set_has_let_file(p) set_high_type_bit(T_Lsd(p), T_HAS_LET_FILE) -#define clear_has_let_file(p) clear_high_type_bit(T_Lsd(p), T_HAS_LET_FILE) +#define has_let_file(p) has_high_type_bit(T_Let(p), T_HAS_LET_FILE) +#define set_has_let_file(p) set_high_type_bit(T_Let(p), T_HAS_LET_FILE) +#define clear_has_let_file(p) clear_high_type_bit(T_Let(p), T_HAS_LET_FILE) #define T_TYPED_VECTOR T_HAS_LET_FILE #define is_typed_vector(p) has_high_type_bit(T_Nvc(p), T_TYPED_VECTOR) @@ -2615,8 +2610,8 @@ static void init_types(void) /* this marks "definers" like define and define-macro */ #define T_MACLET T_DEFINER -#define is_maclet(p) has_high_type_bit(T_Lsd(p), T_MACLET) -#define set_maclet(p) set_high_type_bit(T_Lsd(p), T_MACLET) +#define is_maclet(p) has_high_type_bit(T_Let(p), T_MACLET) +#define set_maclet(p) set_high_type_bit(T_Let(p), T_MACLET) /* this marks a maclet */ #define T_HAS_FX T_DEFINER @@ -2667,8 +2662,8 @@ static void init_types(void) #define set_very_safe_closure_body(p) set_high_type_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) #define T_BAFFLE_LET T_SHORT_VERY_SAFE_CLOSURE -#define is_baffle_let(p) has_high_type_bit(T_Lsd(p), T_BAFFLE_LET) -#define set_baffle_let(p) set_high_type_bit(T_Lsd(p), T_BAFFLE_LET) +#define is_baffle_let(p) has_high_type_bit(T_Let(p), T_BAFFLE_LET) +#define set_baffle_let(p) set_high_type_bit(T_Let(p), T_BAFFLE_LET) #define T_CYCLIC (1LL << (48 + 5)) #define T_SHORT_CYCLIC (1 << 5) @@ -2963,8 +2958,8 @@ static void init_types(void) #define set_opt3_pair(P, X) set_opt3(P, T_Pair(X), OPT3_AND) #define opt3_any(P) opt3(P, OPT3_ANY) #define set_opt3_any(P, X) set_opt3(P, X, OPT3_ANY) -#define opt3_let(P) T_Lid(opt3(P, OPT3_LET)) -#define set_opt3_let(P, X) set_opt3(P, T_Lid(X), OPT3_LET) +#define opt3_let(P) T_Let(opt3(P, OPT3_LET)) +#define set_opt3_let(P, X) set_opt3(P, T_Let(X), OPT3_LET) #define opt3_direct(P) opt3(P, OPT3_DIRECT) #define set_opt3_direct(P, X) set_opt3(P, (s7_pointer)(X), OPT3_DIRECT) @@ -3177,9 +3172,10 @@ static void symbol_set_id(s7_pointer p, s7_int id) #define slot_set_symbol(p, Sym) (T_Slt(p))->object.slt.sym = T_Sym(Sym) #define slot_value(p) T_Nmv((T_Slt(p))->object.slt.val) #if S7_DEBUGGING +/* how to see an unheaped and un-GC-checked slot with a heap value? Can't do it here because unheap=most rootlet slots */ #define slot_set_value(slot, value) \ do { \ - if (is_immutable_slot(slot)) {fprintf(stderr, "setting immutable slot %s\n", symbol_name(slot_symbol(slot))); if (cur_sc->stop_at_error) abort();} \ + if (is_immutable_slot(slot)) {fprintf(stderr, "%s[%d]: setting immutable slot %s\n", __func__, __LINE__, symbol_name(slot_symbol(slot))); if (cur_sc->stop_at_error) abort();} \ (T_Slt(slot))->object.slt.val = T_Nmv(value); \ } while (0) #else @@ -3205,12 +3201,12 @@ static s7_pointer slot_expression(s7_pointer p) \ #define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Ext(Val); slot_set_has_expression(p);} while (0) #define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Ext(Val) -#define slot_setter(p) (T_Slt(p)->object.slt.pending_value) -#define slot_set_setter_1(p, Val) (T_Slt(p))->object.slt.pending_value = Val +#define slot_setter(p) T_Prc((T_Slt(p)->object.slt.pending_value)) +#define slot_set_setter_1(p, Val) (T_Slt(p))->object.slt.pending_value = T_Prc(Val) #if S7_DEBUGGING #define tis_slot(p) ((p) && (T_Slt(p))) #else -#define tis_slot(p) (p) /* used for loop through let slots which end in nil, not for general slot recognition */ +#define tis_slot(p) (p) /* used for loop through let slots which end in null, not for general slot recognition */ #endif #define slot_end NULL #define is_slot_end(p) (!(p)) @@ -3227,38 +3223,28 @@ static s7_pointer slot_expression(s7_pointer p) \ #define symbol_syntax_op(p) syntax_opcode(global_value(p)) #define is_syntax_or_qq(p) ((is_syntax(p)) || ((p) == sc->quasiquote_function)) /* qq is from s7_define_macro -> T_C_MACRO */ -#define INITIAL_ROOTLET_SIZE 512 -#if S7_DEBUGGING /* let_id(rootlet) is not -1 */ -static s7_int let_id(s7_pointer p) {if (p == cur_sc->rootlet) {fprintf(stderr, "let_id(rootlet)?\n"); abort();} return((T_Lid(p))->object.envr.id);} -#else -#define let_id(p) (T_Lid(p))->object.envr.id -#endif -#define let_set_id(p, Id) (T_Lid(p))->object.envr.id = Id +#define let_id(p) (T_Let(p))->object.envr.id +#define let_set_id(p, Id) (T_Let(p))->object.envr.id = Id #define is_let(p) (type(p) == T_LET) #define is_let_unchecked(p) (unchecked_type(p) == T_LET) -#define let_slots(p) T_Sln((T_Lsd(p))->object.envr.slots) -#define let_outlet(p) T_Lid((T_Lsd(p))->object.envr.nxt) +#define let_slots(p) T_Sln((T_Let(p))->object.envr.slots) +#define let_outlet(p) T_Out((T_Let(p))->object.envr.nxt) +#define let_set_outlet(p, ol) (T_Let(p))->object.envr.nxt = T_Out(ol) #if S7_DEBUGGING -#define let_set_outlet(p, ol) do {if ((ol) == sc->rootlet) fprintf(stderr, "%s[%d]: set_outlet to rootlet\n", __func__, __LINE__); (T_Lsd(p))->object.envr.nxt = T_Lid(ol);} while (0) -#else -#define let_set_outlet(p, ol) (T_Lsd(p))->object.envr.nxt = T_Lid(ol) -#endif -#if S7_DEBUGGING - #define let_set_slots(p, Slot) do {if ((!in_heap(p)) && (Slot) && (in_heap(Slot))) fprintf(stderr, "%s[%d]: let+slot mismatch\n", __func__, __LINE__); \ - T_Lsd(p)->object.envr.slots = T_Sln(Slot);} while (0) + #define let_set_slots(p, Slot) check_let_set_slots(p, Slot, __func__, __LINE__) #define C_Let(p, role) check_let_ref(p, role, __func__, __LINE__) #define S_Let(p, role) check_let_set(p, role, __func__, __LINE__) #else - #define let_set_slots(p, Slot) (T_Lsd(p))->object.envr.slots = T_Sln(Slot) + #define let_set_slots(p, Slot) (T_Let(p))->object.envr.slots = T_Sln(Slot) #define C_Let(p, role) p #define S_Let(p, role) p #endif #define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.envr.edat.efnc.function) #define funclet_set_function(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.function = T_Sym(F) -#define set_curlet(Sc, P) Sc->curlet = T_Lid(P) +#define set_curlet(Sc, P) Sc->curlet = T_Let(P) -#define let_baffle_key(p) (T_Lsd(p))->object.envr.edat.key -#define set_let_baffle_key(p, K) (T_Lsd(p))->object.envr.edat.key = K +#define let_baffle_key(p) (T_Let(p))->object.envr.edat.key +#define set_let_baffle_key(p, K) (T_Let(p))->object.envr.edat.key = K #define let_line(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.line #define let_set_line(p, L) (S_Let(p, L_FUNC))->object.envr.edat.efnc.line = L @@ -3333,10 +3319,6 @@ static s7_int let_id(s7_pointer p) {if (p == cur_sc->rootlet) {fprintf(stderr, " #define subvector_vector(p) T_Vec(((vector_dimension_info(T_SVec(p))) ? vdims_original(vector_dimension_info(p)) : (p)->object.vector.block->nx.ksym)) #define subvector_set_vector(p, vect) (T_SVec(p))->object.vector.block->nx.ksym = T_Vec(vect) -#define rootlet_element(p, i) unchecked_vector_element(p, i) -#define rootlet_elements(p) unchecked_vector_elements(p) -#define rootlet_block(p) unchecked_vector_block(p) - #define stack_element(p, i) unchecked_vector_element(T_Stk(p), i) #define stack_elements(p) unchecked_vector_elements(T_Stk(p)) #define stack_block(p) unchecked_vector_block(T_Stk(p)) @@ -3535,8 +3517,8 @@ static s7_int let_id(s7_pointer p) {if (p == cur_sc->rootlet) {fprintf(stderr, " #define closure_set_args(p, Val) (T_Clo(p))->object.func.args = T_Arg(Val) #define closure_body(p) (T_Pair((T_Clo(p))->object.func.body)) #define closure_set_body(p, Val) (T_Clo(p))->object.func.body = T_Pair(Val) -#define closure_let(p) T_Lid((T_Clo(p))->object.func.env) -#define closure_set_let(p, L) (T_Clo(p))->object.func.env = T_Lid(L) +#define closure_let(p) T_Let((T_Clo(p))->object.func.env) +#define closure_set_let(p, L) (T_Clo(p))->object.func.env = T_Let(L) #define closure_arity(p) (T_Clo(p))->object.func.arity #define closure_set_arity(p, A) (T_Clo(p))->object.func.arity = A @@ -3571,8 +3553,8 @@ static s7_int let_id(s7_pointer p) {if (p == cur_sc->rootlet) {fprintf(stderr, " #define is_c_object(p) (type(p) == T_C_OBJECT) #define c_object_value(p) (T_Obj(p))->object.c_obj.value #define c_object_type(p) (T_Obj(p))->object.c_obj.type -#define c_object_let(p) T_Lid((T_Obj(p))->object.c_obj.e) -#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.e = T_Lid(L) +#define c_object_let(p) T_Let((T_Obj(p))->object.c_obj.e) +#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.e = T_Let(L) #define c_object_s7(p) (T_Obj(p))->object.c_obj.sc #define c_object_info(Sc, p) Sc->c_object_types[c_object_type(T_Obj(p))] @@ -3614,8 +3596,8 @@ static s7_int let_id(s7_pointer p) {if (p == cur_sc->rootlet) {fprintf(stderr, " #define counter_set_list(p, Val) (T_Ctr(p))->object.ctr.list = T_Ext(Val) #define counter_capture(p) (T_Ctr(p))->object.ctr.cap #define counter_set_capture(p, Val) (T_Ctr(p))->object.ctr.cap = Val -#define counter_let(p) T_Lid((T_Ctr(p))->object.ctr.env) -#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.env = T_Lid(L) +#define counter_let(p) T_Let((T_Ctr(p))->object.ctr.env) +#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.env = T_Let(L) #define counter_slots(p) T_Sln(T_Ctr(p)->object.ctr.slots) #define counter_set_slots(p, Val) (T_Ctr(p))->object.ctr.slots = T_Sln(Val) @@ -3637,7 +3619,9 @@ static s7_int let_id(s7_pointer p) {if (p == cur_sc->rootlet) {fprintf(stderr, " #define real(p) (T_Rel(p))->object.number.real_value #define set_real(p, x) real(p) = x #define numerator(p) (T_Frc(p))->object.number.fraction_value.numerator +#define set_numerator(p, x) numerator(p) = x #define denominator(p) (T_Frc(p))->object.number.fraction_value.denominator +#define set_denominator(p, x) denominator(p) = x #define fraction(p) (((long_double)numerator(p)) / ((long_double)denominator(p))) #define inverted_fraction(p) (((long_double)denominator(p)) / ((long_double)numerator(p))) #define real_part(p) (T_Cmp(p))->object.number.complex_value.rl @@ -3670,7 +3654,7 @@ const char *display(s7_pointer obj) const char *res; if (!has_methods(obj)) return(string_value(s7_object_to_string(cur_sc, obj, false))); - clear_type_bit(obj, T_HAS_METHODS); /* clear_has_methods calls T_Met -> check_ref9 */ + clear_type_bit(obj, T_HAS_METHODS); /* clear_has_methods calls T_Met -> check_ref_met */ res = string_value(s7_object_to_string(cur_sc, obj, false)); set_type_bit(obj, T_HAS_METHODS); /* same for set_has_methods */ return(res); @@ -3781,7 +3765,7 @@ static s7_pointer make_permanent_integer(s7_int i) { s7_pointer p = (s7_pointer)Calloc(1, sizeof(s7_cell)); /* Calloc to clear name */ full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; - integer(p) = i; + set_integer(p, i); return(p); } @@ -3813,7 +3797,7 @@ static void init_small_ints(void) small_ints[i] = &cells[i]; p = small_ints[i]; full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; - integer(p) = i; + set_integer(p, i); } for (int32_t i = 0; i < 10; i++) set_number_name(small_ints[i], ones[i], 1); @@ -3956,9 +3940,9 @@ static void try_to_call_gc(s7_scheme *sc); #if WITH_GCC #define make_integer(Sc, N) \ - ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) + ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); set_integer(_I_, _N_); _I_;}) ); }) #define make_integer_unchecked(Sc, N) \ - ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell_no_check(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) + ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell_no_check(Sc, _I_, T_INTEGER); set_integer(_I_, _N_); _I_;}) ); }) #define make_real(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) #define make_real_unchecked(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell_no_check(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) @@ -3989,9 +3973,16 @@ static void try_to_call_gc(s7_scheme *sc); #define rational_to_double(Sc, X) s7_number_to_real(Sc, X) #endif +#if S7_DEBUGGING + static char *describe_type_bits(s7_scheme *sc, s7_pointer obj); +#endif + static s7_pointer wrapped_integer(s7_scheme *sc) /* wrap_integer without small_int possibility -- usable as a mutable integer for example */ { s7_pointer p = car(sc->integer_wrappers); +#if S7_DEBUGGING + if ((full_type(p) & (~T_GC_MARK)) != (T_INTEGER | T_IMMUTABLE | T_UNHEAP | T_MUTABLE)) fprintf(stderr, "%s\n", describe_type_bits(sc, p)); +#endif sc->integer_wrappers = cdr(sc->integer_wrappers); return(p); } @@ -4001,7 +3992,10 @@ static s7_pointer wrap_integer(s7_scheme *sc, s7_int x) s7_pointer p; if (is_small_int(x)) return(small_int(x)); p = car(sc->integer_wrappers); - integer(p) = x; +#if S7_DEBUGGING + if ((full_type(p) & (~T_GC_MARK)) != (T_INTEGER | T_IMMUTABLE | T_UNHEAP | T_MUTABLE)) fprintf(stderr, "%s\n", describe_type_bits(sc, p)); +#endif + set_integer(p, x); sc->integer_wrappers = cdr(sc->integer_wrappers); return(p); } @@ -4011,7 +4005,10 @@ static s7_pointer wrap_integer(s7_scheme *sc, s7_int x) static s7_pointer wrap_real(s7_scheme *sc, s7_double x) { s7_pointer p = car(sc->real_wrappers); - real(p) = x; +#if S7_DEBUGGING + if ((full_type(p) & (~T_GC_MARK)) != (T_REAL | T_IMMUTABLE | T_UNHEAP | T_MUTABLE)) fprintf(stderr, "%s\n", describe_type_bits(sc, p)); +#endif + set_real(p, x); sc->real_wrappers = cdr(sc->real_wrappers); return(p); } @@ -4074,23 +4071,8 @@ static char *copy_string_with_length(const char *str, s7_int len) static char *copy_string(const char *str) {return(copy_string_with_length(str, safe_strlen(str)));} -#if 0 -static bool local_strcmp(const char *s1, const char *s2) -{ - while (true) - { - if (*s1 != *s2++) return(false); - if (*s1++ == 0) return(true); - } - return(true); -} -#else #define local_strcmp(S1, S2) (strcmp(S1, S2) == 0) -/* I think libc strcmp is much faster than it used to be, and beats the code above */ -#endif - -#define c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2)) -/* scheme strings can have embedded nulls */ +#define c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2)) /* scheme strings can have embedded nulls */ static bool safe_strcmp(const char *s1, const char *s2) { @@ -5087,7 +5069,7 @@ static bool has_odd_bits(s7_pointer obj) void s7_show_let(s7_scheme *sc); void s7_show_let(s7_scheme *sc) /* debugging convenience */ { - for (s7_pointer olet = sc->curlet; is_let(T_Lid(olet)); olet = let_outlet(olet)) + for (s7_pointer olet = sc->curlet; olet; olet = let_outlet(olet)) { if (olet == sc->owlet) fprintf(stderr, "(owlet): "); @@ -5187,10 +5169,13 @@ static char* show_debugger_bits(s7_pointer p) return(bits_str); } -static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2) +static s7_pointer check_ref_one(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2) { if (!p) - fprintf(stderr, "%s%s[%d]: null pointer passed to check_ref%s\n", bold_text, func, line, unbold_text); + { + fprintf(stderr, "%s%s[%d]: null pointer passed to check_ref_one%s\n", bold_text, func, line, unbold_text); + if (cur_sc->stop_at_error) abort(); + } else { uint8_t typ = unchecked_type(p); @@ -5214,9 +5199,20 @@ static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, const char *fun return(p); } +static void check_let_set_slots(s7_pointer p, s7_pointer slot, const char *func, int32_t line) +{ + if ((!in_heap(p)) && (slot) && (in_heap(slot))) fprintf(stderr, "%s[%d]: let+slot mismatch\n", func, line); + if ((p == cur_sc->rootlet) && (slot != slot_end)) + { + fprintf(stderr, "%s[%d]: setting rootlet slots!\n", func, line); + if (cur_sc->stop_at_error) abort(); + } + T_Let(p)->object.envr.slots = T_Sln(slot); +} + static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, int32_t line) { - check_ref(p, T_LET, func, line, NULL, NULL); + check_ref_one(p, T_LET, func, line, NULL, NULL); if ((p->debugger_bits & L_HIT) == 0) fprintf(stderr, "%s[%d]: let not set\n", func, line); if ((p->debugger_bits & L_MASK) != role) fprintf(stderr, "%s[%d]: let bad role\n", func, line); return(p); @@ -5224,26 +5220,26 @@ static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, i static s7_pointer check_let_set(s7_pointer p, uint64_t role, const char *func, int32_t line) { - check_ref(p, T_LET, func, line, NULL, NULL); + check_ref_one(p, T_LET, func, line, NULL, NULL); p->debugger_bits &= (~L_MASK); p->debugger_bits |= (L_HIT | role); return(p); } -static s7_pointer check_ref2(s7_pointer p, uint8_t expected_type, int32_t other_type, const char *func, int32_t line, const char *func1, const char *func2) +static s7_pointer check_ref_two(s7_pointer p, uint8_t expected_type, int32_t other_type, const char *func, int32_t line, const char *func1, const char *func2) { if (!p) - fprintf(stderr, "%s[%d]: null pointer passed to check_ref2\n", func, line); + fprintf(stderr, "%s[%d]: null pointer passed to check_ref_two\n", func, line); else { uint8_t typ = unchecked_type(p); if ((typ != expected_type) && (typ != other_type)) - return(check_ref(p, expected_type, func, line, func1, func2)); + return(check_ref_one(p, expected_type, func, line, func1, func2)); } return(p); } -static s7_pointer check_ref3(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_prt(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT) && (typ != T_FREE)) @@ -5251,7 +5247,7 @@ static s7_pointer check_ref3(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref3i(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_pri(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if ((typ != T_INPUT_PORT) && (p != cur_sc->F)) @@ -5259,7 +5255,7 @@ static s7_pointer check_ref3i(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref3o(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_pro(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if ((typ != T_OUTPUT_PORT) && (p != cur_sc->F)) @@ -5267,7 +5263,7 @@ static s7_pointer check_ref3o(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref4(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_vec(s7_pointer p, const char *func, int32_t line) { if ((strcmp(func, "sweep") != 0) && (strcmp(func, "process_multivector") != 0)) @@ -5278,21 +5274,21 @@ static s7_pointer check_ref4(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref5(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_clo(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if (!t_has_closure_let[typ]) complain("%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, line, typ); return(p); } -static s7_pointer check_ref6(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_fnc(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if (typ < T_C_MACRO) complain("%s%s[%d]: not a c function or macro (type < T_C_MACRO, from T_Fnc), but %s (%s)%s\n", p, func, line, typ); return(p); } -static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_num(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if ((typ < T_INTEGER) || (typ > T_COMPLEX)) @@ -5300,7 +5296,7 @@ static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref8(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_seq(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && (!is_any_closure(p))) /* closure as iterator -- see s7test */ @@ -5308,7 +5304,7 @@ static s7_pointer check_ref8(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref9(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_met(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure(p)) && (!is_any_macro(p)) && (typ != T_C_POINTER)) @@ -5316,7 +5312,7 @@ static s7_pointer check_ref9(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref10(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_arg(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL)) @@ -5324,7 +5320,7 @@ static s7_pointer check_ref10(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_app(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); if ((!t_applicable_p[typ]) && (p != cur_sc->F)) @@ -5332,7 +5328,7 @@ static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref12(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_sln(s7_pointer p, const char *func, int32_t line) { uint8_t typ; if (is_slot_end(p)) return(p); @@ -5342,14 +5338,24 @@ static s7_pointer check_ref12(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref13(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_out(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + if (!p) return(NULL); + typ = unchecked_type(p); + if (typ != T_LET) + complain("%s%s[%d]: outlet is %s (%s)%s?\n", p, func, line, typ); + return(p); +} + +static s7_pointer check_ref_svec(s7_pointer p, const char *func, int32_t line) { if (!is_any_vector(p)) complain("%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line, unchecked_type(p)); if (!is_subvector(p)) complain("%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, func, line, unchecked_type(p)); return(p); } -static s7_pointer check_ref14(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_prc(s7_pointer p, const char *func, int32_t line) { if ((!is_any_procedure(p)) && (!is_boolean(p))) complain("%s%s[%d]: setter is %s (%s)%s?\n", p, func, line, unchecked_type(p)); @@ -5407,7 +5413,7 @@ static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref15(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_nmv(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); check_nref(p, func, line); @@ -5424,39 +5430,13 @@ static s7_pointer check_ref15(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref16(s7_pointer p, const char *func, int32_t line) /* let or nil but not rootlet (mainly because let_id(rootlet) is not actually -1) */ -{ - uint8_t typ = unchecked_type(p); - check_nref(p, func, line); - if ((typ != T_LET) && (typ != T_NIL)) complain("%s%s[%d]: not a let or nil, but %s (%s)%s\n", p, func, line, typ); - if (p == cur_sc->rootlet) - { - fprintf(stderr, "%s%s[%d]: T_Lid(rootlet) %s?%s\n", bold_text, func, line, checked_type_name(cur_sc, type(p)), unbold_text); - if (cur_sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer check_ref16a(s7_pointer p, const char *func, int32_t line) /* let or nil but not rootlet (mainly because let_id(rootlet) is not actually -1) */ -{ - uint8_t typ = unchecked_type(p); - check_nref(p, func, line); - if (typ != T_LET) complain("%s%s[%d]: not a let, but %s (%s)%s\n", p, func, line, typ); - if (p == cur_sc->rootlet) - { - fprintf(stderr, "%s%s[%d]: T_Lsd(rootlet) %s?%s\n", bold_text, func, line, checked_type_name(cur_sc, type(p)), unbold_text); - if (cur_sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer check_ref17(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_mac(s7_pointer p, const char *func, int32_t line) { if ((!is_any_macro(p)) || (is_c_macro(p))) complain("%s%s[%d]: macro is %s (%s)%s?\n", p, func, line, unchecked_type(p)); return(p); } -static s7_pointer check_ref18(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_key(s7_pointer p, const char *func, int32_t line) { if (!is_symbol_and_keyword(p)) complain("%s%s[%d]: not a keyword: %s (%s)%s?\n", p, func, line, unchecked_type(p)); if (strcmp(func, "new_symbol") != 0) @@ -5475,7 +5455,7 @@ static s7_pointer check_ref18(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref19(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_ext(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); check_nref(p, func, line); @@ -5487,7 +5467,7 @@ static s7_pointer check_ref19(s7_pointer p, const char *func, int32_t line) return(p); } -static s7_pointer check_ref19a(s7_pointer p, const char *func, int32_t line) +static s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line) { uint8_t typ = unchecked_type(p); check_nref(p, func, line); @@ -5824,15 +5804,6 @@ static void set_opt3_len_1(s7_pointer p, uint64_t x) set_opt3_is_set(p); } -#if 0 -static void check_opt_bits(s7_pointer p, int bits) -{ - if (((bits & 1) != 0) && (opt1_is_set(p))) fprintf(stderr, "opt1 set "); - if (((bits & 2) != 0) && (opt2_is_set(p))) fprintf(stderr, "opt2 set "); - if (((bits & 4) != 0) && (opt3_is_set(p)) && (!has_type_bit(p, T_LOCATION))) fprintf(stderr, "opt3 set "); -} -#endif - static void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port) { /* show current state, current allocated state */ @@ -6125,6 +6096,12 @@ static s7_pointer find_let(s7_scheme *sc, s7_pointer obj) if ((is_let(c_pointer_info(obj))) && (c_pointer_info(obj) != sc->rootlet)) return(c_pointer_info(obj)); + case T_CONTINUATION: case T_GOTO: + case T_C_MACRO: case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: + return(sc->rootlet); + /* TODO: what about cload into local? + * (*libc* 'memcpy): memcpy, ((rootlet) 'memcpy): #<undefined>, (with-let (rootlet) memcpy): error (undefined), (with-let *libc* memcpy): memcpy + */ } return(sc->nil); } @@ -6332,6 +6309,7 @@ static s7_pointer find_and_apply_method(s7_scheme *sc, s7_pointer obj, s7_pointe s7_pointer func = find_method_with_let(sc, obj, sym); if (is_closure(func)) return(apply_method_closure(sc, func, args)); if (func == sc->undefined) missing_method_error_nr(sc, sym, obj); + if ((S7_DEBUGGING) && (func == global_value(sym))) fprintf(stderr, "loop in %s?\n", __func__); return(s7_apply_function(sc, func, args)); } @@ -6596,7 +6574,7 @@ static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) /* -------------------------------- GC -------------------------------- */ /* in most code, pairs, lets, and slots dominate the heap -- each about 25% to 40% of the * total cell allocations. In snd-test, reals are 50%. slots need not be in the heap, - * but moving them out to their own free list was actually slower because we need (in that + * but moving them out to their own free list was slower because we need (in that * case) to manage them in the sweep process by tracking lets. */ @@ -6610,6 +6588,7 @@ static s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line) already_warned = true; fprintf(stderr, "s7_gc_protect has protected more than 8192 values? (line: %d, code: %s, loc: %" ld64 ")\n", line, string_value(s7_object_to_string(sc, current_code(sc), false)), loc); + if ((S7_DEBUGGING) && (sc->stop_at_error)) abort(); } return(loc); } @@ -7143,7 +7122,7 @@ static inline void mark_slot(s7_pointer p) static void mark_let(s7_pointer let) { - for (s7_pointer x = let; is_let(x) && (!is_marked(x)); x = let_outlet(x)) /* let can be sc->nil, e.g. closure_let */ + for (s7_pointer x = let; (x) && (!is_marked(x)); x = let_outlet(x)) { set_mark(x); if (has_dox_slot1(x)) mark_slot(let_dox_slot1(x)); @@ -7411,11 +7390,19 @@ static void mark_output_port(s7_pointer p) gc_mark(port_string_or_function(p)); } -#define clear_type(p) full_type(p) = T_FREE +static void mark_free(s7_pointer p) +{ +#if S7_DEBUGGING + /* this can happen in make_room_for_cc_stack */ + /* fprintf(stderr, "%smark free: %p%s\n", bold_text, p, unbold_text); */ + /* if (cur_sc->stop_at_error) abort(); */ +#endif +} + static void init_mark_functions(void) { - mark_function[T_FREE] = mark_noop; + mark_function[T_FREE] = mark_free; mark_function[T_UNDEFINED] = just_mark; mark_function[T_EOF] = mark_noop; mark_function[T_UNSPECIFIED] = mark_noop; @@ -7483,12 +7470,8 @@ static void mark_input_port_stack(s7_scheme *sc) static void mark_rootlet(s7_scheme *sc) { - s7_pointer ge = sc->rootlet; - s7_pointer *tmp = rootlet_elements(ge); - s7_pointer *top = (s7_pointer *)(tmp + sc->rootlet_entries); - set_mark(ge); - while (tmp < top) - gc_mark(slot_value(*tmp++)); + for (s7_pointer y = sc->rootlet_slots; tis_slot(y); y = next_slot(y)) + gc_mark(slot_value(y)); /* slot is semipermanent? does this assume slot_value is not rootlet? or that rootlet is marked? */ /* slot_setter is handled below with an explicit list -- more code than its worth probably */ /* we're not marking slot_symbol above which makes me worry that a top-level gensym won't be protected * (apply define (gensym) '(32)), then try to get the GC to clobber {gensym}-0, @@ -7565,9 +7548,9 @@ static int64_t gc(s7_scheme *sc) mark_input_port_stack(sc); set_mark(current_output_port(sc)); set_mark(current_error_port(sc)); - gc_mark(sc->stacktrace_defaults); - gc_mark(sc->autoload_table); - gc_mark(sc->default_random_state); + mark_pair(sc->stacktrace_defaults); + gc_mark(sc->autoload_table); /* () or a hash-table */ + set_mark(sc->default_random_state); /* always a random_state object */ if (sc->let_temp_hook) gc_mark(sc->let_temp_hook); gc_mark(sc->w); @@ -7600,11 +7583,11 @@ static int64_t gc(s7_scheme *sc) gc_mark(sc->rec_p1); gc_mark(sc->rec_p2); - /* these probably don't need to be marked */ - for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); + /* these do need to be marked, at least protecting "info" for the duration of the error handler procedure */ + for (s7_pointer p = cdr(sc->wrong_type_arg_info); is_pair(p); p = cdr(p)) gc_mark(car(p)); + for (s7_pointer p = cdr(sc->sole_arg_wrong_type_info); is_pair(p); p = cdr(p)) gc_mark(car(p)); + for (s7_pointer p = cdr(sc->out_of_range_info); is_pair(p); p = cdr(p)) gc_mark(car(p)); + for (s7_pointer p = cdr(sc->sole_arg_out_of_range_info); is_pair(p); p = cdr(p)) gc_mark(car(p)); gc_mark(car(sc->elist_1)); gc_mark(car(sc->elist_2)); gc_mark(cadr(sc->elist_2)); @@ -7614,11 +7597,17 @@ static int64_t gc(s7_scheme *sc) gc_mark(car(sc->elist_6)); gc_mark(car(sc->elist_7)); - for (i = 1; i < NUM_SAFE_LISTS; i++) +#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]))) + (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])); @@ -7629,7 +7618,7 @@ static int64_t gc(s7_scheme *sc) if (sc->rec_stack) { - just_mark(sc->rec_stack); + set_mark(sc->rec_stack); for (i = 0; i < sc->rec_loc; i++) gc_mark(sc->rec_els[i]); } @@ -7688,12 +7677,12 @@ static int64_t gc(s7_scheme *sc) p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ if (has_odd_bits(p)) {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(sc, p)); free(s);} \ if (!in_heap(p)) {char *s; fprintf(stderr, "not in heap: %s\n", s = describe_type_bits(sc, p)); free(s);} \ - signed_type(p) = 0; \ + clear_type(p); \ (*fp++) = p; \ } \ else if (signed_type(p) < 0) clear_mark(p); #else - #define gc_object(Tp) p = (*Tp++); if (signed_type(p) > 0) {signed_type(p) = 0; (*fp++) = p;} else if (signed_type(p) < 0) clear_mark(p); + #define gc_object(Tp) p = (*Tp++); if (signed_type(p) > 0) {clear_type(p); (*fp++) = p;} else if (signed_type(p) < 0) clear_mark(p); /* this appears to be about 10% faster than the previous form * if the sign bit is on, but no other bits, this version will take no action (it thinks the cell is on the free list), but * it means we've marked a free cell as in-use: since types are set as soon as removed from the free list, this has to be a bug @@ -8209,7 +8198,7 @@ static void pop_stack_1(s7_scheme *sc, const char *func, int32_t line) * and are carried around as GC protection in other cases. */ sc->code = T_Pos(stack_end_code(sc)); - sc->curlet = stack_end_let(sc); /* not T_Lid|Pos, see op_any_closure_3p_end et al (stack used to pass args, not curlet) */ + sc->curlet = stack_end_let(sc); /* not T_Let|Pos, see op_any_closure_3p_end et al (stack used to pass args, not curlet) */ sc->args = stack_end_args(sc); sc->cur_op = (opcode_t)T_Op(stack_end_op(sc)); if ((sc->cur_op != OP_GC_PROTECT) && @@ -8228,9 +8217,9 @@ static void pop_stack_no_op_1(s7_scheme *sc, const char *func, int32_t line) if (sc->stop_at_error) abort(); } sc->code = T_Pos(stack_end_code(sc)); - if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(stack_end_let(sc))) && (!is_null(stack_end_let(sc)))) + if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(stack_end_let(sc)))) fprintf(stderr, "%s[%d]: curlet not a let\n", func, line); - sc->curlet = stack_end_let(sc); /* not T_Lid|Pos: gc_protect can set this directly (not through push_stack) to anything */ + sc->curlet = stack_end_let(sc); /* not T_Let|Pos: gc_protect can set this directly (not through push_stack) to anything */ sc->args = stack_end_args(sc); } @@ -8239,23 +8228,17 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer 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) { - fprintf(stderr, "%s%s[%d]: stack overflow, %" ld64 " > %u, trigger: %" ld64 " %s\n", + fprintf(stderr, "%s%s[%d]: stack overflow, %u > %u, trigger: %u %s\n", bold_text, func, line, - (s7_int)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, - (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), + (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, + (uint32_t)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), unbold_text); s7_show_stack(sc); if (sc->stop_at_error) abort(); } if (sc->stack_end >= sc->stack_resize_trigger) - { - fprintf(stderr, "%s%s[%d]: stack resize skipped%s\n", bold_text, func, line, unbold_text); - if (sc->stop_at_error) - { - /* this is pointless if we can't look around in gdb, so give us some room */ - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2))); - abort(); - }} + 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); if (sc->stack_end != end) fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func, line); if (op >= NUM_OPS) @@ -8264,7 +8247,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer if (sc->stop_at_error) abort(); } if (code) stack_end_code(sc) = T_Pos(code); - stack_end_let(sc) = T_Lid(sc->curlet); + stack_end_let(sc) = T_Let(sc->curlet); if ((args) && (unchecked_type(args) != T_FREE)) stack_end_args(sc) = T_Pos(args); stack_end_op(sc) = (s7_pointer)op; sc->stack_end += 4; @@ -8462,9 +8445,16 @@ s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x) return(x); } +s7_pointer s7_gc_protect_2_via_stack(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + check_stack_size(sc); + push_stack_no_let(sc, OP_GC_PROTECT, x, y); + return(x); +} + s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x) { - unstack_gc_protect(sc); + unstack_gc_protect(sc); /* this might not be related to 'x' -- something got unprotected */ return(x); } @@ -9336,7 +9326,10 @@ static s7_int let_length(s7_scheme *sc, s7_pointer e) s7_pointer p; if (e == sc->rootlet) - return(sc->rootlet_entries); + { + for (i = 0, p = sc->rootlet_slots; tis_slot(p); i++, p = next_slot(p)); + return(i); + } if (e == sc->s7_starlet) return(s7_starlet_length()); if (has_active_methods(sc, e)) @@ -9391,22 +9384,9 @@ static void remove_let_from_heap(s7_scheme *sc, s7_pointer lt) static void add_slot_to_rootlet(s7_scheme *sc, s7_pointer slot) { - s7_pointer ge = sc->rootlet; - rootlet_element(ge, sc->rootlet_entries++) = slot; set_in_rootlet(slot); - if (sc->rootlet_entries >= vector_length(ge)) - { - s7_int len; - block_t *ob, *nb; - vector_length(ge) *= 2; - len = vector_length(ge); - ob = rootlet_block(ge); - nb = reallocate(sc, ob, len * sizeof(s7_pointer)); - block_info(nb) = NULL; - rootlet_block(ge) = nb; - rootlet_elements(ge) = (s7_pointer *)block_data(nb); - for (s7_int i = sc->rootlet_entries; i < len; i++) rootlet_element(ge, i) = sc->nil; - } + slot_set_next(slot, sc->rootlet_slots); + sc->rootlet_slots = slot; } static void remove_function_from_heap(s7_scheme *sc, s7_pointer value) @@ -9430,6 +9410,9 @@ static void remove_function_from_heap(s7_scheme *sc, s7_pointer value) s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) { + /* if ((S7_DEBUGGING) && (!is_let(let))) {fprintf(stderr, "s7_make_slot let: %s\n", display(let)); abort();} */ + /* () as let if shadow_rootlet used but unset!?! */ + if ((!is_let(let)) || (let == sc->rootlet)) { @@ -9459,9 +9442,26 @@ 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->unlet) || /* init_unlet creates sc->unlet (includes syntax), after that initial_slot is for c_functions?? */ + ((!sc->string_signature) || /* from init_signatures -- TODO: maybe need a boolean for this */ (is_c_function(value)))) /* || (is_syntax(value)) -- we need 'else as a special case? */ - set_initial_slot(symbol, make_semipermanent_slot(sc, symbol, value)); + /* 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. + * The current shadow_rootlet could be saved in each initial_slot, these could be marked in some way, then the chain + * searched in (unlet) to get the currently active envs -- maybe too complex? We could also provide a way to overrule + * the string_signature check, but then symbol collisions would probably be resolved as the last loaded (which might not + * be in the active chain). + * Also, the c_function check is overly paranoid -- all we need is that the value is semipermanent (T_UNHEAP?). + */ + { + set_initial_slot(symbol, make_semipermanent_slot(sc, symbol, value)); + if ((!sc->string_signature) && ((is_c_function(value)) || (is_syntax(value)))) /* syntax probably can't happen here (handled explicitly in syntax procedure) */ + { + /* non-c_functions that are not set! (and therefore initial_slot GC) protected by default: make-hook hook-functions + * if these initial_slot values are added to unlet, they need explicit GC protection. + */ + slot_set_next(initial_slot(symbol), sc->unlet_slots); + sc->unlet_slots = initial_slot(symbol); + }} set_local_slot(symbol, slot); set_global(symbol); } @@ -9511,70 +9511,26 @@ static s7_pointer g_is_funclet(s7_scheme *sc, s7_pointer args) /* -------------------------------- unlet -------------------------------- */ -static s7_pointer t_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); -static s7_pointer t_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc); - -#define UNLET_ENTRIES 512 /* 397 if not --disable-deprecated etc */ - -static void init_unlet(s7_scheme *sc) -{ - int32_t k = 0; - s7_pointer *inits; - s7_pointer *els = vector_elements(sc->symbol_table); - block_t *block = mallocate(sc, UNLET_ENTRIES * sizeof(s7_pointer)); - sc->unlet = (s7_pointer)Calloc(1, sizeof(s7_cell)); /* freed explicitly in s7_free */ - set_full_type(sc->unlet, T_VECTOR | T_UNHEAP); - vector_length(sc->unlet) = UNLET_ENTRIES; - vector_block(sc->unlet) = block; - vector_elements(sc->unlet) = (s7_pointer *)block_data(block); - vector_set_dimension_info(sc->unlet, NULL); - vector_getter(sc->unlet) = t_vector_getter; - vector_setter(sc->unlet) = t_vector_setter; - inits = vector_elements(sc->unlet); - s7_vector_fill(sc, sc->unlet, sc->nil); - - inits[k++] = initial_slot(sc->else_symbol); - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = els[i]; is_pair(x); x = cdr(x)) - { - s7_pointer sym = car(x); - if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) - { - s7_pointer val = initial_value(sym); - if ((is_c_function(val)) || (is_syntax(val))) /* we assume the initial_slot value needs no GC protection */ - inits[k++] = initial_slot(sym); - /* non-c_functions that are not set! (and therefore initial_slot GC) protected by default: make-hook hook-functions - * if these initial_slot values are added to unlet, they need explicit GC protection. - */ - if ((S7_DEBUGGING) && (k >= UNLET_ENTRIES)) fprintf(stderr, "unlet overflow\n"); - }} -} - static s7_pointer g_unlet(s7_scheme *sc, s7_pointer unused_args) { /* add sc->unlet bindings to the current environment */ #define H_unlet "(unlet) returns a let that establishes the original bindings of all the predefined functions" #define Q_unlet s7_make_signature(sc, 1, sc->is_let_symbol) - s7_pointer *inits = vector_elements(sc->unlet); s7_pointer res; - sc->w = make_let(sc, sc->curlet); set_is_unlet(sc->w); if (global_value(sc->else_symbol) != sc->else_symbol) add_slot_checked_with_id(sc, sc->w, sc->else_symbol, initial_value(sc->else_symbol)); - for (int32_t i = 1; (i < UNLET_ENTRIES) && (is_slot(inits[i])); i++) + for (s7_pointer p = sc->unlet_slots; tis_slot(p); p = next_slot(p)) { - s7_pointer sym = slot_symbol(inits[i]); - s7_pointer x = slot_value(inits[i]); + s7_pointer sym = slot_symbol(p); + s7_pointer x = slot_value(p); if ((x != global_value(sym)) || /* it has been changed globally */ ((!is_global(sym)) && /* it might be shadowed locally */ (s7_symbol_local_value(sc, sym, sc->curlet) != global_value(sym)))) add_slot_checked_with_id(sc, sc->w, sym, x); } - /* if (set! + -) then + needs to be overridden, but the local bit isn't set, so we have to check the actual values in the non-local case. - * (define (f x) (with-let (unlet) (+ x 1))) - */ res = sc->w; sc->w = sc->unused; return(res); @@ -9609,12 +9565,14 @@ static s7_pointer g_openlet(s7_scheme *sc, s7_pointer args) s7_pointer e = car(args), elet, func; if (e == sc->nil) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet rootlet", 21))); + error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet nil", 17))); elet = find_let(sc, e); /* returns nil if no let found, so has to follow error check above */ if (!is_let(elet)) sole_arg_wrong_type_error_nr(sc, sc->openlet_symbol, e, a_let_string); if (elet == sc->rootlet) error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet rootlet", 21))); + if (is_unlet(elet)) /* protect against infinite loop: (let () (define + -) (with-let (unlet) (+ (openlet (unlet)) 2))) */ + error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet unlet", 19))); if ((has_active_methods(sc, e)) && ((func = find_method(sc, elet, sc->openlet_symbol)) != sc->undefined)) return(s7_apply_function(sc, func, args)); @@ -9632,7 +9590,8 @@ static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args) check_method(sc, e, sc->coverlet_symbol, set_plist_1(sc, e)); if ((e == sc->rootlet) || (e == sc->s7_starlet)) error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), e)); - + if ((is_let(e)) && (is_unlet(e))) + error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't coverlet unlet", 20))); if ((is_let(e)) || (has_closure_let(e)) || ((is_c_object(e)) && (c_object_let(e) != sc->nil)) || ((is_c_pointer(e)) && (is_let(c_pointer_info(e))))) @@ -9663,7 +9622,7 @@ static void append_let(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e) s7_pointer sym = slot_symbol(x), val = slot_value(x); if (is_slot(global_slot(sym))) slot_set_value(global_slot(sym), val); - else s7_make_slot(sc, new_e, sym, val); + else s7_make_slot(sc, sc->rootlet, sym, val); } else if (old_e == sc->s7_starlet) @@ -9709,7 +9668,7 @@ s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointe { if (is_slot(global_slot(symbol))) slot_set_value(global_slot(symbol), value); - else s7_make_slot(sc, let, symbol, value); + else s7_make_slot(sc, sc->rootlet, symbol, value); } else { @@ -9790,7 +9749,7 @@ to the let target-let, and returns target-let. (varlet (curlet) 'a 1) adds 'a t immutable_object_error_nr(sc, set_elist_5(sc, wrap_string(sc, "~S is immutable in (varlet ~S '~S ~S)", 37), sym, car(args), p, val)); slot_set_value_with_hook(global_slot(sym), val); } - else s7_make_slot(sc, e, sym, val); + else s7_make_slot(sc, sc->rootlet, sym, val); } else { @@ -9884,7 +9843,9 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) /* -------------------------------- sublet -------------------------------- */ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_pointer caller) { - s7_pointer new_e = make_let(sc, (e == sc->rootlet) ? sc->nil : e); + s7_pointer new_e; + if (e == sc->nil) e = sc->rootlet; /* backwards compatibility */ + new_e = make_let(sc, e); set_all_methods(new_e, e); if (!is_null(bindings)) @@ -9928,10 +9889,12 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_ if (is_constant_symbol(sc, sym)) wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), sym, a_non_constant_symbol_string); +#if 0 if ((is_slot(global_slot(sym))) && (is_syntax_or_qq(global_value(sym)))) wrong_type_error_nr(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic symbol", 22)); - + /* this is a local redefinition which we accept elsewhere: (let ((if 3)) if) -> 3 */ +#endif /* here we know new_e is a let and is not rootlet */ if (!sp) sp = add_slot_checked_with_id(sc, new_e, sym, val); @@ -9959,11 +9922,12 @@ static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args) if (is_null(e)) e = sc->rootlet; else - { - check_method(sc, e, sc->sublet_symbol, args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->sublet_symbol, 1, e, a_let_string); - } + if (e != sc->rootlet) + { + check_method(sc, e, sc->sublet_symbol, args); + if (!is_let(e)) + wrong_type_error_nr(sc, sc->sublet_symbol, 1, e, a_let_string); + } return(sublet_1(sc, e, cdr(args), sc->sublet_symbol)); } @@ -10004,7 +9968,7 @@ to a new let, and returns the new let. (inlet :a 1 :b 2) or (inlet '(a . 1) '(b static s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args) { /* here all args are paired with normal symbol/value, no fallbacks, no immutable symbols, no syntax, etc */ - s7_pointer new_e = make_let(sc, sc->nil); + s7_pointer new_e = make_let(sc, sc->rootlet); int64_t id = let_id(new_e); s7_pointer sp = NULL; @@ -10032,7 +9996,7 @@ static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) s7_pointer x; if (!is_symbol(symbol)) - return(sublet_1(sc, sc->nil, set_plist_2(sc, symbol, value), sc->inlet_symbol)); + return(sublet_1(sc, sc->rootlet, set_plist_2(sc, symbol, value), sc->inlet_symbol)); if (is_keyword(symbol)) symbol = keyword_symbol(symbol); if (is_constant_symbol(sc, symbol)) @@ -10044,7 +10008,7 @@ static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); sc->temp3 = x; let_set_id(x, ++sc->let_number); - let_set_outlet(x, sc->nil); + let_set_outlet(x, sc->rootlet); let_set_slots(x, slot_end); add_slot_unchecked(sc, x, symbol, value, let_id(x)); sc->temp3 = sc->unused; @@ -10054,7 +10018,7 @@ static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) { va_list ap; - s7_pointer new_e = make_let(sc, sc->nil); + s7_pointer new_e = make_let(sc, sc->rootlet); int64_t id = let_id(new_e); s7_pointer sp = NULL; @@ -10119,24 +10083,28 @@ static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_po /* -------------------------------- let->list -------------------------------- */ static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list); +static s7_pointer abbreviate_let(s7_scheme *sc, s7_pointer val) +{ + if (is_let(val)) + return(make_symbol(sc, "<inlet...>", 11)); + return(val); +} + s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) { s7_pointer x; sc->temp3 = sc->w; sc->w = sc->nil; + if (let == sc->rootlet) { - s7_int i, lim2 = sc->rootlet_entries; - s7_pointer *entries = rootlet_elements(let); - - if (lim2 & 1) lim2--; - for (i = 0; i < lim2; ) - { - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); i++; - sc->w = cons_unchecked(sc, cons_unchecked(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); i++; - } - if (lim2 < sc->rootlet_entries) - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); + for (s7_pointer lib = global_value(sc->libraries_symbol); is_pair(lib); lib = cdr(lib)) + sc->w = cons(sc, caar(lib), sc->w); + sc->w = cons(sc, cons(sc, sc->libraries_symbol, sc->w), sc->nil); + for (s7_pointer y = sc->rootlet_slots; tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) != sc->libraries_symbol) + sc->w = cons_unchecked(sc, cons(sc, slot_symbol(y), abbreviate_let(sc, slot_value(y))), sc->w); + sc->w = proper_list_reverse_in_place(sc, sc->w); } else { @@ -10251,13 +10219,13 @@ static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer if (is_keyword(symbol)) symbol = keyword_symbol(symbol); - if (let == sc->rootlet) /* almost never happens -- only if explicit (let-ref (rootlet) 'abs) */ + if (let == sc->rootlet) return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); if (let_id(let) == symbol_id(symbol)) return(local_value(symbol)); /* this has to follow the rootlet check(?) */ - for (s7_pointer x = let; is_let(x); x = let_outlet(x)) + for (s7_pointer x = let; x; x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) return(slot_value(y)); @@ -10292,7 +10260,7 @@ static s7_pointer slot_in_let(s7_scheme *sc, s7_pointer e, const s7_pointer sym) static s7_pointer lint_let_ref_p_pp(s7_scheme *sc, s7_pointer lt, s7_pointer sym) { - for (s7_pointer x = lt; is_let(x); x = let_outlet(x)) + for (s7_pointer x = lt; x; x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) return(slot_value(y)); @@ -10306,7 +10274,7 @@ static s7_pointer lint_let_ref_p_pp(s7_scheme *sc, s7_pointer lt, s7_pointer sym static inline s7_pointer g_lint_let_ref(s7_scheme *sc, s7_pointer args) { s7_pointer lt = car(args), sym = cadr(args); - if (!is_let(lt)) + if ((!is_let(lt)) || (lt == sc->rootlet)) wrong_type_error_nr(sc, sc->let_ref_symbol, 1, lt, a_let_string); for (s7_pointer y = let_slots(lt); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) @@ -10376,7 +10344,6 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 } if (is_unlet(let)) immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "unlet is immutable: (set! ((unlet) '~S) ~S)", 43), symbol, value)); - if (let_id(let) == symbol_id(symbol)) { s7_pointer slot = local_slot(symbol); @@ -10385,7 +10352,7 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 symbol_increment_ctr(symbol); return(checked_slot_set_value(sc, slot, value)); }} - for (s7_pointer x = let; is_let(x); x = let_outlet(x)) + for (s7_pointer x = let; x; x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) { @@ -10444,7 +10411,7 @@ static s7_pointer g_lint_let_set(s7_scheme *sc, s7_pointer args) wrong_type_error_nr(sc, sc->let_set_symbol, 1, lt, a_let_string); if (lt != sc->rootlet) { - for (s7_pointer x = lt; is_let(x); x = let_outlet(x)) + for (s7_pointer x = lt; x; x = let_outlet(x)) for (y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) { @@ -10572,7 +10539,7 @@ static s7_pointer g_curlet(s7_scheme *sc, s7_pointer unused_args) #define H_curlet "(curlet) returns the current definitions (symbol bindings)" #define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol) sc->capture_let_counter++; - return((is_let(sc->curlet)) ? sc->curlet : sc->rootlet); + return(sc->curlet); } static void update_symbol_ids(s7_scheme *sc, s7_pointer e) @@ -10589,7 +10556,7 @@ s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e) { s7_pointer old_e = sc->curlet; set_curlet(sc, e); - if ((is_let(e)) && (e != sc->rootlet) && (let_id(e) > 0)) /* might be () [id=-1] or rootlet [id meaningless] etc */ + if ((is_let(e)) && (let_id(e) > 0)) { let_set_id(e, ++sc->let_number); update_symbol_ids(sc, e); @@ -10601,8 +10568,6 @@ s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e) /* -------------------------------- outlet -------------------------------- */ s7_pointer s7_outlet(s7_scheme *sc, s7_pointer let) { - if ((let == sc->rootlet) || (is_null(let_outlet(let)))) - return(sc->rootlet); return(let_outlet(let)); } @@ -10610,9 +10575,7 @@ static s7_pointer outlet_p_p(s7_scheme *sc, s7_pointer let) { if (!is_let(let)) sole_arg_wrong_type_error_nr(sc, sc->outlet_symbol, let, a_let_string); /* not a method call here! */ - if ((let == sc->rootlet) || (is_null(let_outlet(let)))) - return(sc->rootlet); - return(let_outlet(let)); + return((let == sc->rootlet) ? sc->rootlet : let_outlet(let)); } static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args) @@ -10640,27 +10603,27 @@ static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args) if (let != sc->rootlet) { /* here it's possible to get cyclic let chains; maybe do this check only if safety>0 */ - for (s7_pointer lt = new_outer; (is_let(lt)) && (lt != sc->rootlet); lt = let_outlet(lt)) + for (s7_pointer lt = new_outer; lt; lt = let_outlet(lt)) if (let == lt) error_nr(sc, make_symbol(sc, "cyclic-let", 10), set_elist_2(sc, wrap_string(sc, "set! (outlet ~A) creates a cyclic let chain", 43), let)); - let_set_outlet(let, (new_outer == sc->rootlet) ? sc->nil : new_outer); /* outlet rootlet->() so that slot search can use is_let(outlet) I think */ + let_set_outlet(let, new_outer); } return(new_outer); } /* -------------------------------- symbol lookup -------------------------------- */ static Inline s7_pointer inline_lookup_from(s7_scheme *sc, const s7_pointer symbol, s7_pointer e) -{ /* splitting out the no-sc WITH_GCC case made no difference in speed */ +{ /* splitting out the no-sc WITH_GCC case made no difference in speed, same if using s7_int id = symbol_id(symbol) */ if (let_id(e) == symbol_id(symbol)) return(local_value(symbol)); - if (symbol_id(symbol) < let_id(e)) + if (let_id(e) > symbol_id(symbol)) /* let is newer so look back in the outlet chain */ { - do {e = let_outlet(e);} while (symbol_id(symbol) < let_id(e)); + do {e = let_outlet(e);} while (let_id(e) > symbol_id(symbol)); if (let_id(e) == symbol_id(symbol)) return(local_value(symbol)); } - for (; is_let(e); e = let_outlet(e)) + for (; e; e = let_outlet(e)) for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) return(slot_value(y)); @@ -10687,13 +10650,13 @@ static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) { if (let_id(e) == symbol_id(symbol)) return(local_slot(symbol)); - if (symbol_id(symbol) < let_id(e)) + if (let_id(e) > symbol_id(symbol)) { - do {e = let_outlet(e);} while (symbol_id(symbol) < let_id(e)); + do {e = let_outlet(e);} while (let_id(e) > symbol_id(symbol)); if (let_id(e) == symbol_id(symbol)) return(local_slot(symbol)); } - for (; is_let(e); e = let_outlet(e)) + for (; e; e = let_outlet(e)) for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) return(y); @@ -10701,7 +10664,7 @@ static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) } s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(lookup_slot_from(symbol, sc->curlet));} -static s7_pointer lookup_slot_with_let(s7_pointer symbol, s7_pointer let) {return(lookup_slot_from(symbol, let));} +static s7_pointer lookup_slot_with_let(s7_scheme *sc, s7_pointer symbol, s7_pointer let) {return(lookup_slot_from(symbol, let));} s7_pointer s7_slot_value(s7_pointer slot) {return(slot_value(slot));} @@ -10711,7 +10674,7 @@ void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value) {se static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer e) { - if (!is_let(e)) + if ((!is_let(e)) || (e == sc->rootlet)) /* e is () if from s7_define */ return(global_slot(symbol)); if (symbol_id(symbol) != 0) for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) @@ -10728,27 +10691,20 @@ s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym) s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer let) { - /* restrict the search to local let outward */ - if ((let == sc->rootlet) || (is_global(sym))) - return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); - - if (!is_let(let)) - return(s7_symbol_value(sc, sym)); - if (let_id(let) == symbol_id(sym)) return(local_value(sym)); - if (symbol_id(sym) < let_id(let)) + if (let_id(let) > symbol_id(sym)) { - do {let = let_outlet(let);} while (symbol_id(sym) < let_id(let)); + do {let = let_outlet(let);} while (let_id(let) > symbol_id(sym)); if (let_id(let) == symbol_id(sym)) return(local_value(sym)); } - for (; is_let(let); let = let_outlet(let)) + for (; let; let = let_outlet(let)) for (s7_pointer y = let_slots(let); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) return(slot_value(y)); - /* need to check rootlet before giving up */ + /* maybe let is local but sym is global but previously shadowed */ if (is_slot(global_slot(sym))) return(global_value(sym)); @@ -10766,15 +10722,20 @@ static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args) { #define H_symbol_to_value "(symbol->value sym (let (curlet))) returns the binding of (the value associated with) the \ symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32" - #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol) + #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, \ + s7_make_signature(sc, 6, sc->is_let_symbol, sc->is_procedure_symbol, sc->is_c_pointer_symbol, \ + sc->is_continuation_symbol, sc->is_goto_symbol, sc->is_macro_symbol)) /* kinda ridiculous */ /* (symbol->value 'x e) => (e 'x). But let? in sig is not quite right -- we accept closure -> closure-let etc */ s7_pointer sym = car(args); if (!is_symbol(sym)) return(method_or_bust(sc, sym, sc->symbol_to_value_symbol, args, sc->type_names[T_SYMBOL], 1)); if (is_keyword(sym)) - return(sym); /* TODO: need to see if local_let is clearly wrong and raise an error */ - + { + if ((is_pair(cdr(args))) && (!is_let(cadr(args))) && (!is_let(find_let(sc, cadr(args))))) + wrong_type_error_nr(sc, sc->symbol_to_value_symbol, 2, cadr(args), sc->type_names[T_LET]); + return(sym); + } if (is_not_null(cdr(args))) { s7_pointer local_let = cadr(args); @@ -10809,13 +10770,13 @@ s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val) /* -------------------------------- symbol->dynamic-value -------------------------------- */ static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer x, s7_pointer sym, int64_t *id) { - for (; symbol_id(sym) < let_id(x); x = let_outlet(x)); + for (; let_id(x) > symbol_id(sym); x = let_outlet(x)); if (let_id(x) == symbol_id(sym)) { (*id) = let_id(x); return(local_value(sym)); } - for (; (is_let(x)) && (let_id(x) > (*id)); x = let_outlet(x)) + for (; (x) && (let_id(x) > (*id)); x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) { @@ -10885,7 +10846,7 @@ static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) { if (is_slot(global_slot(sym))) return(true); - if ((is_null(e)) || (e == sc->rootlet)) + if (e == sc->rootlet) return(false); return((!is_with_let_let(e)) && (is_slot(s7_slot(sc, sym)))); } @@ -11024,8 +10985,8 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) case OP_DEFINE_MACRO_STAR: case OP_MACRO_STAR: typ = T_MACRO_STAR; break; case OP_DEFINE_BACRO: case OP_BACRO: typ = T_BACRO; break; case OP_DEFINE_BACRO_STAR: case OP_BACRO_STAR: typ = T_BACRO_STAR; break; - case OP_DEFINE_EXPANSION: typ = T_MACRO | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); break; /* local expansions are just normal macros */ - case OP_DEFINE_EXPANSION_STAR: typ = T_MACRO_STAR | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); break; + case OP_DEFINE_EXPANSION: typ = T_MACRO | ((sc->curlet != sc->rootlet) ? 0 : T_EXPANSION); break; /* local expansions are just normal macros */ + case OP_DEFINE_EXPANSION_STAR: typ = T_MACRO_STAR | ((sc->curlet != sc->rootlet) ? 0 : T_EXPANSION); break; default: if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, op_names[op]); typ = T_MACRO; @@ -11046,7 +11007,7 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) s7_pointer mac_slot; mac_name = caar(sc->code); if (((op == OP_DEFINE_EXPANSION) || (op == OP_DEFINE_EXPANSION_STAR)) && - (!is_let(sc->curlet))) + (sc->curlet == sc->rootlet)) set_full_type(mac_name, T_EXPANSION | T_SYMBOL | (full_type(mac_name) & T_UNHEAP)); /* symbol? macro name has already been checked, find name in let, and define it */ @@ -11063,7 +11024,7 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) } else s7_make_slot(sc, sc->curlet, mac_name, mac); /* was current but we've checked immutable already */ if (tree_has_definers(sc, body)) - set_is_definer(mac_name); /* (list-values 'define ...) aux-13 */ + set_is_definer(mac_name); /* (list-values 'define ...) aux-13 */ } if ((!is_either_bacro(mac)) && @@ -11410,8 +11371,7 @@ static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer p, s7_pointer e) {return( void s7_define(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) { s7_pointer x; - if ((let == sc->nil) || (let == sc->rootlet)) - let = sc->shadow_rootlet; + if (let == sc->rootlet) let = sc->shadow_rootlet; x = symbol_to_local_slot(sc, symbol, let); /* x can be #<undefined> */ if (is_slot(x)) slot_set_value_with_hook(x, value); @@ -11430,7 +11390,7 @@ void s7_define(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer valu s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value) { s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, value); + s7_define(sc, sc->rootlet, sym, value); return(sym); } @@ -11600,10 +11560,15 @@ s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr) {return(s7_make_c_pointer s7_pointer s7_make_c_pointer_wrapper_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info) { s7_pointer x = car(sc->c_pointer_wrappers); +#if S7_DEBUGGING + if ((full_type(x) & (~T_GC_MARK)) != (T_C_POINTER | T_IMMUTABLE | T_UNHEAP)) fprintf(stderr, "%s\n", describe_type_bits(sc, x)); +#endif sc->c_pointer_wrappers = cdr(sc->c_pointer_wrappers); c_pointer(x) = ptr; c_pointer_type(x) = type; c_pointer_info(x) = info; + c_pointer_weak1(x) = sc->F; + c_pointer_weak2(x) = sc->F; return(x); } @@ -11920,7 +11885,7 @@ static bool find_baffle(s7_scheme *sc, s7_int key) { /* search backwards through sc->curlet for baffle_let with (continuation_)key as its baffle_key value */ if (sc->baffle_ctr > 0) - for (s7_pointer x = sc->curlet; is_let(x); x = let_outlet(x)) + for (s7_pointer x = sc->curlet; x; x = let_outlet(x)) if ((is_baffle_let(x)) && (let_baffle_key(x) == key)) return(true); @@ -11933,7 +11898,7 @@ static s7_int find_any_baffle(s7_scheme *sc) { /* search backwards through sc->curlet for any sc->baffle_symbol -- called by s7_make_continuation to set continuation_key */ if (sc->baffle_ctr > 0) - for (s7_pointer x = sc->curlet; is_let(x); x = let_outlet(x)) + for (s7_pointer x = sc->curlet; x; x = let_outlet(x)) if (is_baffle_let(x)) return(let_baffle_key(x)); return(NOT_BAFFLED); @@ -12055,7 +12020,7 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c) sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); /* free_cell is unsafe here and below */ }} - else let_temp_done(sc, stack_args(sc->stack, i), T_Lid(stack_let(sc->stack, i))); + else let_temp_done(sc, stack_args(sc->stack, i), T_Let(stack_let(sc->stack, i))); }} break; @@ -12286,7 +12251,7 @@ static void call_with_exit(s7_scheme *sc) case OP_LET_TEMP_DONE: { s7_pointer old_args = sc->args; - let_temp_done(sc, stack_args(sc->stack, i), T_Lid(stack_let(sc->stack, i))); + let_temp_done(sc, stack_args(sc->stack, i), T_Let(stack_let(sc->stack, i))); sc->args = old_args; } break; @@ -12464,13 +12429,13 @@ static inline s7_pointer make_simple_ratio(s7_scheme *sc, s7_int num, s7_int den new_cell(sc, x, T_RATIO); if (den < 0) /* this is noticeably faster in callgrind than using (den < 0) ? ... twice */ { - numerator(x) = -num; - denominator(x) = -den; + set_numerator(x, -num); + set_denominator(x, -den); } else { - numerator(x) = num; - denominator(x) = den; + set_numerator(x, num); + set_denominator(x, den); } return(x); } @@ -13606,7 +13571,7 @@ s7_pointer s7_make_integer(s7_scheme *sc, s7_int n) if (is_small_int(n)) return(small_int(n)); new_cell(sc, x, T_INTEGER); - integer(x) = n; + set_integer(x, n); return(x); } @@ -13614,7 +13579,7 @@ static s7_pointer make_mutable_integer(s7_scheme *sc, s7_int n) { s7_pointer x; new_cell(sc, x, T_INTEGER | T_MUTABLE | T_IMMUTABLE); - integer(x) = n; + set_integer(x, n); return(x); } @@ -13634,6 +13599,8 @@ s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n) return(x); } +#define make_mutable_real(Sc, X) s7_make_mutable_real(Sc, X) + s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b) { s7_pointer x; @@ -13716,8 +13683,8 @@ static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b) return(make_integer(sc, a)); new_cell(sc, x, T_RATIO); - numerator(x) = a; - denominator(x) = b; + set_numerator(x, a); + set_denominator(x, b); return(x); } @@ -13905,7 +13872,7 @@ static inline double dpow(int32_t x, int32_t y) #ifndef WITH_DTOA #define WITH_DTOA 1 #endif -/* there was a time when libc was so slow that this code was all but mandatory, but now (Aug-2023) the difference is much smaller */ +/* there was a time when libc was so slow that this code was all but mandatory, but now (Aug-2023) the difference is smaller (ca. factor of 2) */ #if WITH_DTOA /* fpconv, revised to fit the local coding style @@ -21877,8 +21844,8 @@ static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) { s7_pointer x; new_cell(sc, x, T_RATIO); - numerator(x) = i; - denominator(x) = 2; + set_numerator(x, i); + set_denominator(x, 2); return(x); } return(make_integer(sc, i >> 1)); @@ -22705,7 +22672,8 @@ static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (is_t_integer(x)) return((integer(x) < integer(y)) ? y : x); if (is_t_real(x)) - return(((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y); + /* return(((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y); */ + return(((real(x) >= real(y)) || (is_NaN(real(x)))) ? x : y); if (is_t_ratio(x)) return((fraction(x) < fraction(y)) ? y : x); #if WITH_GMP @@ -22725,8 +22693,7 @@ static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_RATIO: return((integer(x) < fraction(y)) ? y : x); case T_REAL: - if (is_NaN(real(y))) return(y); - return((integer(x) < real(y)) ? y : x); + return(((integer(x) < real(y)) || (is_NaN(real(y)))) ? y : x); #if WITH_GMP case T_BIG_INTEGER: return((mpz_cmp_si(big_integer(y), integer(x)) < 0) ? x : y); @@ -22747,8 +22714,7 @@ static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_INTEGER: return((fraction(x) < integer(y)) ? y : x); case T_REAL: - if (is_NaN(real(y))) return(y); - return((fraction(x) < real(y)) ? y : x); + return(((fraction(x) < real(y)) || (is_NaN(real(y)))) ? y : x); #if WITH_GMP case T_BIG_INTEGER: mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); @@ -22768,8 +22734,7 @@ static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) switch (type(y)) { case T_INTEGER: - if (is_NaN(real(x))) return(x); - return((real(x) < integer(y)) ? y : x); + return(((real(x) >= integer(y)) || (is_NaN(real(x)))) ? x : y); case T_RATIO: return((real(x) < fraction(y)) ? y : x); #if WITH_GMP @@ -22888,7 +22853,7 @@ static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poin static s7_int max_i_ii(s7_int i1, s7_int i2) {return((i1 > i2) ? i1 : i2);} static s7_int max_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 > i2) ? ((i1 > i3) ? i1 : i3) : ((i2 > i3) ? i2 : i3));} -static s7_double max_d_dd(s7_double x1, s7_double x2) {if (is_NaN(x1)) return(x1); return((x1 > x2) ? x1 : x2);} +static s7_double max_d_dd(s7_double x1, s7_double x2) {return(((x1 > x2) || (is_NaN(x1))) ? x1 : x2);} static s7_double max_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(max_d_dd(x1, max_d_dd(x2, x3)));} static s7_double max_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(max_d_dd(x1, max_d_ddd(x2, x3, x4)));} @@ -22904,7 +22869,8 @@ static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (is_t_integer(x)) return((integer(x) > integer(y)) ? y : x); if (is_t_real(x)) - return(((is_NaN(real(x))) || (real(x) <= real(y))) ? x : y); + /* return(((is_NaN(real(x))) || (real(x) <= real(y))) ? x : y); */ + return(((real(x) <= real(y)) || (is_NaN(real(x)))) ? x : y); if (is_t_ratio(x)) return((fraction(x) > fraction(y)) ? y : x); #if WITH_GMP @@ -22923,8 +22889,7 @@ static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_RATIO: return((integer(x) > fraction(y)) ? y : x); case T_REAL: - if (is_NaN(real(y))) return(y); - return((integer(x) > real(y)) ? y : x); + return(((integer(x) > real(y)) || (is_NaN(real(y)))) ? y : x); #if WITH_GMP case T_BIG_INTEGER: return((mpz_cmp_si(big_integer(y), integer(x)) > 0) ? x : y); case T_BIG_RATIO: return((mpq_cmp_si(big_ratio(y), integer(x), 1) > 0) ? x : y); @@ -22943,8 +22908,7 @@ static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_INTEGER: return((fraction(x) > integer(y)) ? y : x); case T_REAL: - if (is_NaN(real(y))) return(y); - return((fraction(x) > real(y)) ? y : x); + return(((fraction(x) > real(y)) || (is_NaN(real(y)))) ? y : x); #if WITH_GMP case T_BIG_INTEGER: mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); @@ -22964,8 +22928,7 @@ static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) switch (type(y)) { case T_INTEGER: - if (is_NaN(real(x))) return(x); - return((real(x) > integer(y)) ? y : x); + return(((real(x) <= integer(y)) || (is_NaN(real(x)))) ? x : y); case T_RATIO: return((real(x) > fraction(y)) ? y : x); #if WITH_GMP @@ -23086,7 +23049,7 @@ static s7_pointer min_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poin static s7_int min_i_ii(s7_int i1, s7_int i2) {return((i1 < i2) ? i1 : i2);} static s7_int min_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 < i2) ? ((i1 < i3) ? i1 : i3) : ((i2 < i3) ? i2 : i3));} -static s7_double min_d_dd(s7_double x1, s7_double x2) {if (is_NaN(x1)) return(x1); return((x1 < x2) ? x1 : x2);} +static s7_double min_d_dd(s7_double x1, s7_double x2) {return(((x1 < x2) || (is_NaN(x1))) ? x1 : x2);} static s7_double min_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(min_d_dd(x1, min_d_dd(x2, x3)));} static s7_double min_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(min_d_dd(x1, min_d_ddd(x2, x3, x4)));} @@ -26805,6 +26768,9 @@ s7_int s7_string_length(s7_pointer str) {return(string_length(str));} static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len) { s7_pointer x = car(sc->string_wrappers); +#if S7_DEBUGGING + if ((full_type(x) & (~T_GC_MARK)) != (T_STRING | T_IMMUTABLE | T_UNHEAP | T_SAFE_PROCEDURE)) fprintf(stderr, "%s\n", describe_type_bits(sc, x)); +#endif sc->string_wrappers = cdr(sc->string_wrappers); string_value(x) = (char *)str; string_length(x) = len; @@ -26863,13 +26829,13 @@ s7_pointer s7_make_semipermanent_string(s7_scheme *sc, const char *str) /* for ( return(x); } -static s7_pointer make_permanent_string(const char *str) /* for (s7) strings outside all s7 GC's */ +static s7_pointer make_permanent_string(const char *str, s7_int len) /* for (s7) strings outside all s7 GC's */ { s7_pointer x = (s7_pointer)Calloc(1, sizeof(s7_cell)); - s7_int len = safe_strlen(str); set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP); set_optimize_op(x, OP_CONSTANT); string_length(x) = len; + if ((S7_DEBUGGING) && (len != safe_strlen(str))) fprintf(stderr, "%s[%d]: strlen(%s) != %" ld64 "\n", __func__, __LINE__, str, safe_strlen(str)); string_block(x) = NULL; string_value(x) = (char *)str; string_hash(x) = 0; @@ -26878,87 +26844,87 @@ static s7_pointer make_permanent_string(const char *str) /* for (s7) s s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str) /* keep s7_scheme* arg for backwards compatibility */ { - return(make_permanent_string(str)); + return(make_permanent_string(str, safe_strlen(str))); } static void init_strings(void) { - nil_string = make_permanent_string(""); + nil_string = make_permanent_string("", 0); nil_string->tf.u64_type = T_STRING | T_UNHEAP; /* turn off T_IMMUTABLE?? */ set_optimize_op(nil_string, OP_CONSTANT); - car_a_list_string = make_permanent_string("a pair whose car is also a pair"); - cdr_a_list_string = make_permanent_string("a pair whose cdr is also a pair"); - - caar_a_list_string = make_permanent_string("a pair whose caar is also a pair"); - cadr_a_list_string = make_permanent_string("a pair whose cadr is also a pair"); - cdar_a_list_string = make_permanent_string("a pair whose cdar is also a pair"); - cddr_a_list_string = make_permanent_string("a pair whose cddr is also a pair"); - - caaar_a_list_string = make_permanent_string("a pair whose caaar is also a pair"); - caadr_a_list_string = make_permanent_string("a pair whose caadr is also a pair"); - cadar_a_list_string = make_permanent_string("a pair whose cadar is also a pair"); - caddr_a_list_string = make_permanent_string("a pair whose caddr is also a pair"); - cdaar_a_list_string = make_permanent_string("a pair whose cdaar is also a pair"); - cdadr_a_list_string = make_permanent_string("a pair whose cdadr is also a pair"); - cddar_a_list_string = make_permanent_string("a pair whose cddar is also a pair"); - cdddr_a_list_string = make_permanent_string("a pair whose cdddr is also a pair"); - - a_list_string = make_permanent_string("a list"); - an_eq_func_string = make_permanent_string("a procedure that can take two arguments"); - an_association_list_string = make_permanent_string("an association list"); - a_normal_real_string = make_permanent_string("a normal real"); - a_rational_string = make_permanent_string("an integer or a ratio"); - a_number_string = make_permanent_string("a number"); - a_procedure_string = make_permanent_string("a procedure"); - a_procedure_or_a_macro_string = make_permanent_string("a procedure or a macro"); - a_normal_procedure_string = make_permanent_string("a normal procedure"); - a_let_string = make_permanent_string("a let (an environment)"); - a_proper_list_string = make_permanent_string("a proper list"); - a_boolean_string = make_permanent_string("a boolean"); - a_byte_vector_string = make_permanent_string("a byte-vector"); - an_input_port_string = make_permanent_string("an input port"); - an_open_input_port_string = make_permanent_string("an open input port"); - an_open_output_port_string = make_permanent_string("an open output port"); - an_output_port_string = make_permanent_string("an output port"); - an_output_port_or_f_string = make_permanent_string("an output port or #f"); - an_input_string_port_string = make_permanent_string("an input string port"); - an_input_file_port_string = make_permanent_string("an input file port"); - an_output_string_port_string = make_permanent_string("an output string port"); - an_output_file_port_string = make_permanent_string("an output file port"); - a_thunk_string = make_permanent_string("a thunk"); - a_symbol_string = make_permanent_string("a symbol"); - a_non_negative_integer_string = make_permanent_string("a non-negative integer"); - an_unsigned_byte_string = make_permanent_string("an unsigned byte"); - something_applicable_string = make_permanent_string("a procedure or something applicable"); - a_random_state_object_string = make_permanent_string("a random-state object"); - a_format_port_string = make_permanent_string("#f, #t, (), or an open output port"); - a_non_constant_symbol_string = make_permanent_string("a non-constant symbol"); - a_sequence_string = make_permanent_string("a sequence"); - a_valid_radix_string = make_permanent_string("it should be between 2 and 16"); - result_is_too_large_string = make_permanent_string("result is too large"); - it_is_too_large_string = make_permanent_string("it is too large"); - it_is_too_small_string = make_permanent_string("it is less than the start position"); - it_is_negative_string = make_permanent_string("it is negative"); - it_is_nan_string = make_permanent_string("NaN usually indicates a numerical error"); - it_is_infinite_string = make_permanent_string("it is infinite"); - too_many_indices_string = make_permanent_string("too many indices"); - parameter_set_twice_string = make_permanent_string("parameter set twice, ~S in ~S"); - immutable_error_string = make_permanent_string("can't ~S ~S (it is immutable)"); - cant_bind_immutable_string = make_permanent_string("~A: can't bind an immutable object: ~S"); - intermediate_too_large_string = make_permanent_string("intermediate result is too large"); + car_a_list_string = make_permanent_string("a pair whose car is also a pair", 31); + cdr_a_list_string = make_permanent_string("a pair whose cdr is also a pair", 31); + + caar_a_list_string = make_permanent_string("a pair whose caar is also a pair", 32); + cadr_a_list_string = make_permanent_string("a pair whose cadr is also a pair", 32); + cdar_a_list_string = make_permanent_string("a pair whose cdar is also a pair", 32); + cddr_a_list_string = make_permanent_string("a pair whose cddr is also a pair", 32); + + caaar_a_list_string = make_permanent_string("a pair whose caaar is also a pair", 33); + caadr_a_list_string = make_permanent_string("a pair whose caadr is also a pair", 33); + cadar_a_list_string = make_permanent_string("a pair whose cadar is also a pair", 33); + caddr_a_list_string = make_permanent_string("a pair whose caddr is also a pair", 33); + cdaar_a_list_string = make_permanent_string("a pair whose cdaar is also a pair", 33); + cdadr_a_list_string = make_permanent_string("a pair whose cdadr is also a pair", 33); + cddar_a_list_string = make_permanent_string("a pair whose cddar is also a pair", 33); + cdddr_a_list_string = make_permanent_string("a pair whose cdddr is also a pair", 33); + + a_list_string = make_permanent_string("a list", 6); + an_eq_func_string = make_permanent_string("a procedure that can take two arguments", 39); + an_association_list_string = make_permanent_string("an association list", 19); + a_normal_real_string = make_permanent_string("a normal real", 13); + a_rational_string = make_permanent_string("an integer or a ratio", 21); + a_number_string = make_permanent_string("a number", 8); + a_procedure_string = make_permanent_string("a procedure", 11); + a_procedure_or_a_macro_string = make_permanent_string("a procedure or a macro", 22); + a_normal_procedure_string = make_permanent_string("a normal procedure", 18); + a_let_string = make_permanent_string("a let (an environment)", 22); + a_proper_list_string = make_permanent_string("a proper list", 13); + a_boolean_string = make_permanent_string("a boolean", 9); + a_byte_vector_string = make_permanent_string("a byte-vector", 13); + an_input_port_string = make_permanent_string("an input port", 13); + an_open_input_port_string = make_permanent_string("an open input port", 18); + an_open_output_port_string = make_permanent_string("an open output port", 19); + an_output_port_string = make_permanent_string("an output port", 14); + an_output_port_or_f_string = make_permanent_string("an output port or #f", 20); + an_input_string_port_string = make_permanent_string("an input string port", 20); + an_input_file_port_string = make_permanent_string("an input file port", 18); + an_output_string_port_string = make_permanent_string("an output string port", 21); + an_output_file_port_string = make_permanent_string("an output file port", 19); + a_thunk_string = make_permanent_string("a thunk", 7); + a_symbol_string = make_permanent_string("a symbol", 8); + a_non_negative_integer_string = make_permanent_string("a non-negative integer", 22); + an_unsigned_byte_string = make_permanent_string("an unsigned byte", 16); + something_applicable_string = make_permanent_string("a procedure or something applicable", 35); + a_random_state_object_string = make_permanent_string("a random-state object", 21); + a_format_port_string = make_permanent_string("#f, #t, (), or an open output port", 34); + a_non_constant_symbol_string = make_permanent_string("a non-constant symbol", 21); + a_sequence_string = make_permanent_string("a sequence", 10); + a_valid_radix_string = make_permanent_string("it should be between 2 and 16", 29); + result_is_too_large_string = make_permanent_string("result is too large", 19); + it_is_too_large_string = make_permanent_string("it is too large", 15); + it_is_too_small_string = make_permanent_string("it is less than the start position", 34); + it_is_negative_string = make_permanent_string("it is negative", 14); + it_is_nan_string = make_permanent_string("NaN usually indicates a numerical error", 39); + it_is_infinite_string = make_permanent_string("it is infinite", 14); + too_many_indices_string = make_permanent_string("too many indices", 16); + parameter_set_twice_string = make_permanent_string("parameter set twice, ~S in ~S", 29); + immutable_error_string = make_permanent_string("can't ~S ~S (it is immutable)", 29); + cant_bind_immutable_string = make_permanent_string("~A: can't bind an immutable object: ~S", 38); + intermediate_too_large_string = make_permanent_string("intermediate result is too large", 32); #if (!HAVE_COMPLEX_NUMBERS) - no_complex_numbers_string = make_permanent_string("this version of s7 does not support complex numbers"); + no_complex_numbers_string = make_permanent_string("this version of s7 does not support complex numbers", 51); #endif - keyword_value_missing_string = make_permanent_string("~A: keyword argument's value is missing: ~S in ~S"); + keyword_value_missing_string = make_permanent_string("~A: keyword argument's value is missing: ~S in ~S", 49); - format_string_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A"); - format_string_2 = make_permanent_string("format: ~S: ~A"); - format_string_3 = make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A"); - format_string_4 = make_permanent_string("format: ~S~&~NT^: ~A"); + format_string_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A", 24); + format_string_2 = make_permanent_string("format: ~S: ~A", 14); + format_string_3 = make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A", 30); + format_string_4 = make_permanent_string("format: ~S~&~NT^: ~A", 20); - too_many_arguments_string = make_permanent_string("~S: too many arguments: ~A"); - not_enough_arguments_string = make_permanent_string("~S: not enough arguments: ~A"); + too_many_arguments_string = make_permanent_string("~S: too many arguments: ~A", 26); + not_enough_arguments_string = make_permanent_string("~S: not enough arguments: ~A", 28); } @@ -29434,7 +29400,6 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int ma s7_int size; #endif block_t *b = mallocate_port(sc); - new_cell(sc, port, T_INPUT_PORT); gc_protect_via_stack(sc, port); port_block(port) = b; @@ -30513,7 +30478,7 @@ s7_pointer s7_read(s7_scheme *sc, s7_pointer port) { s7_pointer old_let = sc->curlet; declare_jump_info(); - set_curlet(sc, sc->nil); + set_curlet(sc, sc->rootlet); push_input_port(sc, port); store_jump_info(sc); set_jump_info(sc, READ_SET_JUMP); @@ -30843,9 +30808,10 @@ s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_poin declare_jump_info(); TRACK(sc); if (e == sc->s7_starlet) return(NULL); + if (e == sc->nil) e = sc->rootlet; #if WITH_C_LOADER - port = load_shared_object(sc, filename, (is_null(e)) ? sc->rootlet : e); + port = load_shared_object(sc, filename, e); if (port) return(port); #endif @@ -30853,7 +30819,7 @@ s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_poin port = load_file_1(sc, filename); if (!port) return(NULL); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + set_curlet(sc, e); push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); store_jump_info(sc); @@ -30873,7 +30839,7 @@ s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_poin return(sc->value); } -s7_pointer s7_load(s7_scheme *sc, const char *filename) {return(s7_load_with_environment(sc, filename, sc->nil));} +s7_pointer s7_load(s7_scheme *sc, const char *filename) {return(s7_load_with_environment(sc, filename, sc->rootlet));} s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e) { @@ -30882,13 +30848,14 @@ s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, declare_jump_info(); TRACK(sc); + if (e == sc->nil) e = sc->rootlet; if (content[bytes] != 0) error_nr(sc, make_symbol(sc, "bad-data", 8), set_elist_1(sc, wrap_string(sc, "s7_load_c_string content is not terminated", 42))); port = open_input_string(sc, content, bytes); port_loc = gc_protect_1(sc, port); set_loader_port(port); push_input_port(sc, port); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + set_curlet(sc, e); push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); s7_gc_unprotect_at(sc, port_loc); @@ -30934,9 +30901,9 @@ defaults to the rootlet. To load into the current environment instead, pass (cu if (e == sc->s7_starlet) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't load ~S into *s7*", 23), name)); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + set_curlet(sc, e); } - else set_curlet(sc, sc->nil); + else set_curlet(sc, sc->rootlet); fname = string_value(name); if ((!fname) || (!(*fname))) /* fopen("", "r") returns a file pointer?? */ @@ -30948,7 +30915,7 @@ defaults to the rootlet. To load into the current environment instead, pass (cu set_elist_2(sc, wrap_string(sc, "load: ~S is a directory", 23), wrap_string(sc, fname, safe_strlen(fname)))); #if WITH_C_LOADER { - s7_pointer p = load_shared_object(sc, fname, (is_null(sc->curlet)) ? sc->rootlet : sc->curlet); + s7_pointer p = load_shared_object(sc, fname, sc->curlet); if (p) return(p); } #endif @@ -30967,8 +30934,9 @@ s7_pointer s7_load_path(s7_scheme *sc) {return(s7_symbol_local_value(sc, sc->loa s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir) { - s7_pointer path = cons(sc, s7_make_string(sc, dir), s7_symbol_value(sc, sc->load_path_symbol)); - s7_symbol_set_value(sc, sc->load_path_symbol, path); + s7_pointer slot = lookup_slot_from(sc->load_path_symbol, sc->curlet); /* rootlet possible here */ + s7_pointer path = cons(sc, s7_make_string(sc, dir), slot_value(slot)); + slot_set_value(slot, path); return(path); } @@ -30981,9 +30949,9 @@ static s7_pointer g_load_path_set(s7_scheme *sc, s7_pointer args) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); for (x = cadr(args); is_pair(x); x = cdr(x)) if (!is_string(car(x))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "can't set *load-path* to ~S, ~S is not a string", 47), cadr(args), car(x))); if (!is_null(x)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S, it is not a proper list", 52), cadr(args))); return(cadr(args)); } @@ -31155,7 +31123,6 @@ static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) /* the *autoload* /* ---------------- require ---------------- */ static bool is_a_feature(const s7_pointer sym, s7_pointer lst) /* used only with *features* which (sigh) can be circular: (set-cdr! *features* *features*) */ { -#if 1 s7_pointer x = lst, slow = lst; while (true) { @@ -31168,11 +31135,6 @@ static bool is_a_feature(const s7_pointer sym, s7_pointer lst) /* used only with slow = cdr(slow); if (x == slow) return(false); } -#else - for (s7_pointer x = lst; is_pair(x); x = cdr(x)) - if (sym == car(x)) - return(true); -#endif return(false); } @@ -31237,13 +31199,13 @@ static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args) * top-level at least. */ topf = global_value(sc->features_symbol); - if (is_a_feature(sym, topf)) /* TODO: somehow *features* can be cyclic?? */ + if (is_a_feature(sym, topf)) return(sc->T); if (is_global(sc->features_symbol)) return(sc->F); - for (x = sc->curlet; symbol_id(sc->features_symbol) < let_id(x); x = let_outlet(x)); - for (; is_let(x); x = let_outlet(x)) + for (x = sc->curlet; let_id(x) > symbol_id(sc->features_symbol); x = let_outlet(x)); + for (; x; x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if ((slot_symbol(y) == sc->features_symbol) && (slot_value(y) != topf) && @@ -31274,7 +31236,7 @@ static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) s7_pointer p; if (!is_symbol(sym)) return(method_or_bust_p(sc, sym, sc->provide_symbol, sc->type_names[T_SYMBOL])); - if ((sc->curlet == sc->nil) || (sc->curlet == sc->shadow_rootlet)) /* sc->curlet can also be (for example) the repl top-level */ + if ((sc->curlet == sc->rootlet) || (sc->curlet == sc->shadow_rootlet)) /* sc->curlet can also be (for example) the repl top-level */ p = global_slot(sc->features_symbol); else p = symbol_to_local_slot(sc, sc->features_symbol, sc->curlet); /* if sc->curlet is nil, this returns the global slot, else local slot */ if ((is_slot(p)) && (is_immutable_slot(p))) @@ -31372,7 +31334,7 @@ static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args) s7_pointer e = cadr(args); if (!is_let(e)) wrong_type_error_nr(sc, sc->eval_string_symbol, 2, e, a_let_string); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + set_curlet(sc, e); } sc->temp3 = sc->args; /* see t101-aux-17.scm */ push_stack(sc, OP_EVAL_STRING, args, sc->code); @@ -31382,12 +31344,6 @@ static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args) return(sc->F); /* I think this means that sc->value defaults to #f in op_eval_string below, so (eval-string "") mimics (eval) -> #f */ } -static s7_pointer eval_string_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return(f); -} - static s7_pointer op_eval_string(s7_scheme *sc) { while (s7_peek_char(sc, current_input_port(sc)) != eof_object) /* (eval-string "(+ 1 2) this is a mistake") */ @@ -31777,20 +31733,6 @@ static s7_pointer let_iterate(s7_scheme *sc, s7_pointer iterator) return(p); } -static s7_pointer rootlet_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer slot = iterator_current(iterator); - if (!is_slot(slot)) - return(iterator_quit(iterator)); - if (iterator_position(iterator) < sc->rootlet_entries) - { - iterator_position(iterator)++; - iterator_current(iterator) = rootlet_element(sc->rootlet, iterator_position(iterator)); - } - else iterator_current(iterator) = sc->nil; - return(cons(sc, slot_symbol(slot), slot_value(slot))); -} - static s7_pointer hash_entry_to_cons(s7_scheme *sc, hash_entry_t *entry, s7_pointer p) { if (!p) @@ -31967,10 +31909,10 @@ static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer e, s7_poin /* -------------------------------- make-iterator -------------------------------- */ static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym) { - if ((has_closure_let(x)) && (is_let(closure_let(x)))) + if ((has_closure_let(x)) && (is_let(closure_let(x))) && (closure_let(x) != sc->rootlet)) { s7_pointer val = symbol_to_local_slot(sc, sym, closure_let(x)); - if ((!is_slot(val)) && (is_let(let_outlet(closure_let(x))))) + if ((!is_slot(val)) && (let_outlet(closure_let(x)) != sc->rootlet)) val = symbol_to_local_slot(sc, sym, let_outlet(closure_let(x))); if (is_slot(val)) return(slot_value(val)); @@ -32011,9 +31953,9 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) case T_LET: if (e == sc->rootlet) { - iterator_current(iter) = rootlet_element(e, 0); /* unfortunately tricky -- let_iterate uses different fields */ - iterator_position(iter) = 0; - iterator_next(iter) = rootlet_iterate; + iterator_set_current_slot(iter, sc->rootlet_slots); + iterator_next(iter) = let_iterate; + iterator_let_cons(iter) = NULL; return(iter); } if (e == sc->s7_starlet) @@ -32431,7 +32373,7 @@ static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top top_cyclic = true; } else - for (s7_pointer q = top; is_let(q) && (q != sc->rootlet); q = let_outlet(q)) + for (s7_pointer q = top; q; q = let_outlet(q)) for (s7_pointer p = let_slots(q); tis_slot(p); p = next_slot(p)) if ((has_structure(slot_value(p))) && (collect_shared_info(sc, ci, slot_value(p), stop_at_print_length))) @@ -32575,11 +32517,11 @@ static shared_info_t *load_shared_info(s7_scheme *sc, s7_pointer top, bool stop_ if (has_structure(vector_element(top, k))) {no_problem = false; break;} if (no_problem) return(NULL); } -#if 1 + else /* added these 19-Oct-22 -- helps in tgc, but not much elsewhere */ if ((is_let(top)) && (top != sc->rootlet)) { - for (s7_pointer lp = top; (no_problem) && (is_let(lp)) && (lp != sc->rootlet); lp = let_outlet(lp)) + for (s7_pointer lp = top; (no_problem) && (lp); lp = let_outlet(lp)) for (s7_pointer p = let_slots(lp); tis_slot(p); p = next_slot(p)) if (has_structure(slot_value(p))) /* slot_symbol need not be checked? */ {no_problem = false; break;} @@ -32594,12 +32536,11 @@ static shared_info_t *load_shared_info(s7_scheme *sc, s7_pointer top, bool stop_ if (hash_table_entries(top) == 0) return(NULL); for (s7_int i = 0; i < len; i++) for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) - if (((!keys_safe) && (has_structure(hash_entry_key(p)))) || - (has_structure(hash_entry_value(p)))) + if (((!keys_safe) && (has_structure(hash_entry_key(p)))) || (has_structure(hash_entry_value(p)))) {no_problem = false; break;} if (no_problem) return(NULL); } -#endif + if ((S7_DEBUGGING) && (is_any_vector(top)) && (!is_t_vector(top))) fprintf(stderr, "%s[%d]: got abnormal vector\n", __func__, __LINE__); clear_shared_info(ci); { @@ -33679,7 +33620,7 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri if (need_new_ci) { new_ci = make_shared_info(sc); - clear_shared_info(new_ci); + /* clear_shared_info(new_ci); */ temp_ci = load_shared_info(sc, cadr(lst), false, new_ci); /* temp_ci can be NULL! */ } else temp_ci = ci; @@ -34011,6 +33952,7 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, bool too_long = false, hash_cyclic = false, copied = false, immut = false, letd = false; s7_pointer iterator, p; int32_t href = -1; + if (len == 0) { if (use_write == P_READABLE) @@ -34356,8 +34298,7 @@ static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); return; } - if ((let_outlet(obj) != sc->nil) && - (let_outlet(obj) != sc->rootlet)) + if (let_outlet(obj) != sc->rootlet) { char buf[128]; int32_t len = (int32_t)catstrs_direct(buf, " (set! (outlet <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); @@ -34405,8 +34346,7 @@ static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ } else { - if ((let_outlet(obj) != sc->nil) && - (let_outlet(obj) != sc->rootlet)) + if (let_outlet(obj) != sc->rootlet) { int32_t ref; port_write_string(port)(sc, "(sublet ", 8, port); @@ -34491,7 +34431,7 @@ static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port) static s7_pointer match_symbol(const s7_pointer symbol, s7_pointer e) { - for (s7_pointer le = e; is_let(le); le = let_outlet(le)) + for (s7_pointer le = e; le; le = let_outlet(le)) for (s7_pointer y = let_slots(le); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) return(y); @@ -34549,7 +34489,7 @@ static void collect_specials(s7_scheme *sc, s7_pointer e, s7_pointer args, s7_in static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let) { - for (s7_pointer e = current_let; is_let(e); e = let_outlet(e)) + for (s7_pointer e = current_let; e; e = let_outlet(e)) { if ((is_funclet(e)) || (is_maclet(e))) { @@ -34714,8 +34654,20 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por { if (tree_is_cyclic(sc, body)) { - port_write_string(port)(sc, "#<write_closure: body is cyclic>", 32, port); /* not s7_error here! */ + port_write_string(port)(sc, "#<write_closure_readably: body is cyclic>", 41, port); /* not s7_error here! */ return; + } + if ((!ci) && (is_pair(arglist))) + { /* (format #f "~W" (make-hook (cons 'ho (list (values (list (let ((<1> (hash-table))) (set! (<1> 'a) <1>) <1>))))))) -- yow! */ + shared_info_t *new_ci = make_shared_info(sc); + clear_shared_info(new_ci); + if (collect_shared_info(sc, new_ci, arglist, false)) + { + free_shared_info(new_ci); + port_write_string(port)(sc, "#<write_closure_readably: arglist is cyclic>", 44, port); /* not s7_error here! */ + return; + } + free_shared_info(new_ci); }} if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); pe = closure_let(obj); @@ -35168,6 +35120,9 @@ static void c_function_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, u (is_slot(initial_slot(sym))) && ((use_write == P_READABLE) || (lookup(sc, sym) != initial_value(sym)))) { + /* this is not ideal, but normally the initial_value == global_value (so we can't set a bit there), and the slot + * is not accessible here, so we can't tell that the #_ value was used (and probably needed) in the original code. + */ port_write_string(port)(sc, "#_", 2, port); port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port); return; @@ -35179,6 +35134,7 @@ static void c_function_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, u static void c_macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) { + /* should this check initial_slot and so on as in c_function_to_port above? */ if (c_macro_name_length(obj) > 0) { port_write_string(port)(sc, "#_", 2, port); @@ -39518,6 +39474,7 @@ static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args) set_list_in_use(sc->safe_lists[num_args]); return(sc->safe_lists[num_args]); }} + /* if ((S7_DEBUGGING) && (num_args >= 16)) fprintf(stderr, "sl: %" ld64 "\n", num_args); */ return(make_big_list(sc, num_args, sc->nil)); } @@ -45596,11 +45553,7 @@ static void s7_function_set_class(s7_scheme *sc, s7_pointer f, s7_pointer base_f static s7_pointer make_function(s7_scheme *sc, const char *name, s7_function f, s7_int req, s7_int opt, bool rst, const char *doc, s7_pointer x, c_proc_t *ptr) { - uint32_t ftype = T_C_FUNCTION; - - if ((req == 0) && (rst)) - ftype = T_C_RST_NO_REQ_FUNCTION; - set_full_type(x, ftype); + set_full_type(x, ((req == 0) && (rst)) ? T_C_RST_NO_REQ_FUNCTION : T_C_FUNCTION); c_function_data(x) = ptr; c_function_call(x) = f; /* f is T_App but needs cast */ @@ -45680,7 +45633,7 @@ static void s7_function_set_setter(s7_scheme *sc, s7_pointer getter, s7_pointer } s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_body(p) : sc->nil);} -s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->nil);} +s7_pointer s7_closure_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);} @@ -45733,7 +45686,7 @@ static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args) /* -------------------------------- *current-function* -------------------------------- */ static s7_pointer let_to_function(s7_scheme *sc, s7_pointer e) { - if ((e == sc->rootlet) || (!is_let(e))) + if ((!e) || (e == sc->rootlet) || (!is_let(e))) return(sc->F); if (!((is_funclet(e)) || (is_maclet(e)))) return(sc->F); @@ -45752,7 +45705,7 @@ static s7_pointer g_function(s7_scheme *sc, s7_pointer args) s7_pointer e, sym = NULL, fname, fval; if (is_null(args)) /* (*function*) is akin to __func__ in C */ { - for (e = sc->curlet; is_let(e); e = let_outlet(e)) + for (e = sc->curlet; e; e = let_outlet(e)) if ((is_funclet(e)) || (is_maclet(e))) break; return(let_to_function(sc, e)); @@ -45804,7 +45757,7 @@ static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args) #define H_funclet "(funclet func) tries to return a function's definition environment" #define Q_funclet s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \ s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_symbol_symbol)) - s7_pointer p = car(args), e; + s7_pointer p = car(args); if (is_symbol(p)) { if ((symbol_ctr(p) == 0) || ((p = s7_symbol_value(sc, p)) == sc->undefined)) @@ -45812,13 +45765,9 @@ static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args) set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args))); /* not p here */ } check_method(sc, p, sc->funclet_symbol, args); - if (!((is_any_procedure(p)) || (is_c_object(p)))) sole_arg_wrong_type_error_nr(sc, sc->funclet_symbol, p, a_procedure_or_a_macro_string); - e = find_let(sc, p); - if ((is_null(e)) && (!is_c_object(p))) - return(sc->rootlet); - return(e); + return(find_let(sc, p)); } @@ -45832,7 +45781,7 @@ s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, { s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); + s7_define(sc, sc->rootlet, sym, func); return(sym); } @@ -45842,7 +45791,7 @@ s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function /* returns (string->symbol name), not the c_proc_t func */ s7_pointer func = s7_make_safe_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); + s7_define(sc, sc->rootlet, sym, func); return(sym); } @@ -45853,7 +45802,7 @@ s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function /* returns (string->symbol name), not the c_proc_t func */ s7_pointer func = s7_make_typed_function(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature); /* includes "safe" bit */ s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); + s7_define(sc, sc->rootlet, sym, func); c_function_set_marker(func, NULL); return(sym); } @@ -45866,7 +45815,7 @@ static s7_pointer define_bool_function(s7_scheme *sc, const char *name, s7_funct s7_pointer bfunc; s7_pointer func = s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, signature); /* includes "safe" bit */ s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); + s7_define(sc, sc->rootlet, sym, func); if (sym_to_type != T_FREE) symbol_set_type(sym, sym_to_type); c_function_symbol(func) = sym; @@ -45887,7 +45836,7 @@ s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_f s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); s7_pointer sym = make_symbol_with_strlen(sc, name); if (signature) c_function_signature(func) = signature; - s7_define(sc, sc->nil, sym, func); + s7_define(sc, sc->rootlet, sym, func); return(sym); } @@ -45899,7 +45848,7 @@ s7_pointer s7_define_semisafe_typed_function(s7_scheme *sc, const char *name, s7 s7_pointer sym = make_symbol_with_strlen(sc, name); if (signature) c_function_signature(func) = signature; set_is_semisafe(func); - s7_define(sc, sc->nil, sym, func); + s7_define(sc, sc->rootlet, sym, func); return(sym); } @@ -45958,7 +45907,7 @@ s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fn else if (is_pair(arg)) /* there is a default */ { - names[i] = symbol_to_keyword(sc, car(arg)); + names[i] = car(arg); /* key can be passed at runtime as :key or key: so we need both or the symbol */ defaults[i] = cadr(arg); remove_from_heap(sc, cadr(arg)); /* ?? */ if ((is_pair(defaults[i])) || @@ -45971,7 +45920,7 @@ s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fn { if (arg == sc->rest_keyword) s7_warn(sc, 256, "%s :rest is not supported in C-side define*: %s\n", name, arglist); - names[i] = symbol_to_keyword(sc, arg); + names[i] = arg; defaults[i] = sc->F; }}} else set_full_type(func, T_C_FUNCTION | T_UNHEAP); @@ -45995,7 +45944,7 @@ static void define_function_star_1(s7_scheme *sc, const char *name, s7_function if (safe) func = s7_make_safe_function_star(sc, name, fnc, arglist, doc); else func = s7_make_function_star(sc, name, fnc, arglist, doc); - s7_define(sc, sc->nil, make_symbol_with_strlen(sc, name), func); + s7_define(sc, sc->rootlet, make_symbol_with_strlen(sc, name), func); if (signature) c_function_signature(func) = signature; } @@ -46021,7 +45970,7 @@ s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc, s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); s7_pointer sym = make_symbol_with_strlen(sc, name); set_full_type(func, T_C_MACRO | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */ - s7_define(sc, sc->nil, sym, func); + s7_define(sc, sc->rootlet, sym, func); return(sym); } @@ -46599,7 +46548,7 @@ s7_int s7_make_c_type(s7_scheme *sc, const char *name) /* shouldn't this be s7_m c_type = (c_object_t *)Calloc(1, sizeof(c_object_t)); /* Malloc+field=NULL is slightly faster here */ sc->c_object_types[tag] = c_type; c_type->type = tag; - c_type->scheme_name = make_permanent_string(name); + c_type->scheme_name = make_permanent_string(name, safe_strlen(name)); c_type->getter = sc->F; c_type->setter = sc->F; c_type->free = fallback_free; @@ -46684,7 +46633,7 @@ static s7_pointer make_c_object_with_let(s7_scheme *sc, s7_int type, void *value */ c_object_type(x) = type; c_object_value(x) = value; - c_object_set_let(x, (let == sc->rootlet) ? sc->nil : let); + c_object_set_let(x, let); c_object_s7(x) = sc; if (with_gc) add_c_object(sc, x); return(x); @@ -46697,12 +46646,12 @@ s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7 s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value) { - return(make_c_object_with_let(sc, type, value, sc->nil, true)); + return(make_c_object_with_let(sc, type, value, sc->rootlet, true)); } s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value) { - return(make_c_object_with_let(sc, type, value, sc->nil, false)); + return(make_c_object_with_let(sc, type, value, sc->rootlet, false)); } s7_pointer s7_c_object_let(s7_pointer obj) {return(c_object_let(obj));} @@ -46711,7 +46660,7 @@ s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e) { if ((!is_immutable(obj)) && (is_let(e))) - c_object_set_let(obj, (e == sc->rootlet) ? sc->nil : e); + c_object_set_let(obj, e); return(e); } @@ -47221,7 +47170,7 @@ static s7_pointer symbol_setter(s7_scheme *sc, s7_pointer sym, s7_pointer e) s7_pointer slot, setter; if (is_keyword(sym)) return(sc->F); - if ((e == sc->rootlet) || (e == sc->nil)) + if (e == sc->rootlet) slot = global_slot(sym); else { @@ -47238,7 +47187,7 @@ static s7_pointer symbol_setter(s7_scheme *sc, s7_pointer sym, s7_pointer e) static s7_pointer setter_p_pp(s7_scheme *sc, s7_pointer p, s7_pointer e) { - if (!((is_let(e)) || (e == sc->rootlet) || (e == sc->nil))) + if (!is_let(e)) wrong_type_error_nr(sc, sc->setter_symbol, 2, e, sc->type_names[T_LET]); /* need to check this in case let arg is bogus */ switch (type(p)) @@ -47294,7 +47243,7 @@ s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj) {return(setter_p_pp(sc, obj, /* -------------------------------- set-setter -------------------------------- */ -static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer acc) +static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer fnc) { s7_int loc; if (sc->protected_setters_size == sc->protected_setters_loc) @@ -47322,7 +47271,7 @@ static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer acc) sc->protected_setters_size = new_size; } loc = sc->protected_setters_loc++; - vector_element(sc->protected_setters, loc) = acc; + vector_element(sc->protected_setters, loc) = fnc; /* has_closure => T_Clo(fnc) checked earlier */ vector_element(sc->protected_setter_symbols, loc) = sym; } @@ -47336,13 +47285,13 @@ static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer ar { s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */ func = caddr(args); - if ((e == sc->rootlet) || (e == sc->nil)) + if (e == sc->rootlet) slot = global_slot(sym); else { if (!is_let(e)) wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, e, sc->type_names[T_LET]); - slot = lookup_slot_with_let(sym, e); + slot = lookup_slot_with_let(sc, sym, e); }} else { @@ -47455,16 +47404,16 @@ s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) if (setter != sc->F) { slot_set_has_setter(global_slot(p)); - protect_setter(sc, p, setter); + if (!is_c_function(setter)) protect_setter(sc, p, T_Clo(setter)); /* these don't need GC protection */ slot_set_setter(global_slot(p), setter); if (s7_is_aritable(sc, setter, 3)) set_has_let_arg(setter); return(setter); } - slot_set_setter(global_slot(p), setter); - return(setter); + slot_set_setter(global_slot(p), sc->F); + return(sc->F); } - return(g_set_setter(sc, set_plist_2(sc, p, setter))); + return(g_set_setter(sc, set_plist_2(sc, p, setter))); /* if T_Clo(setter), doesn't it need GC protection as above? */ } /* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix)) @@ -47586,11 +47535,14 @@ static bool big_floats_are_equivalent(s7_scheme *sc, mpfr_t x, mpfr_t y) static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci) {return(x == y);} -static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) /* symbol equal uses eq -- should it check keywords as below? */ { if (x == y) return(true); - if (!is_normal_symbol(y)) return(false); /* (equivalent? ''(1) '(1)) */ - return((is_slot(global_slot(x))) && /* the optimizer can replace the original symbol with its own */ + if (!is_symbol(y)) return(false); + if (is_keyword(y)) + return((is_keyword(x)) && (keyword_symbol(x) == keyword_symbol(y))); /* (equivalent? key: :key) -> #t */ + if (is_keyword(x)) return(false); + return((is_slot(global_slot(x))) && /* the optimizer can replace the original symbol with its value */ (is_syntax(global_value(x))) && (is_slot(global_slot(y))) && (is_syntax(global_value(y))) && @@ -47872,7 +47824,7 @@ static bool hash_table_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, sha static bool slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci) { - for (s7_pointer ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) + for (s7_pointer ey = y; ey; ey = let_outlet(ey)) for (s7_pointer py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ return(is_equal_1(sc, slot_value(px), slot_value(py), nci)); @@ -47881,7 +47833,7 @@ static bool slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_ static bool slots_equivalent_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci) { - for (s7_pointer ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) + for (s7_pointer ey = y; ey; ey = let_outlet(ey)) for (s7_pointer py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ return(is_equivalent_1(sc, slot_value(px), slot_value(py), nci)); @@ -47900,7 +47852,7 @@ static bool let_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t if ((ci) && (equal_ref(sc, x, y, ci))) return(true); clear_symbol_list(sc); - for (x_len = 0, ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex)) + for (x_len = 0, ex = x; ex; ex = let_outlet(ex)) for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) if (!symbol_is_in_list(sc, slot_symbol(px))) { @@ -47908,12 +47860,12 @@ static bool let_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t x_len++; } - for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) + for (ey = y; ey; ey = let_outlet(ey)) for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (!symbol_is_in_list(sc, slot_symbol(py))) /* symbol in y, not in x */ return(false); - for (y_len = 0, ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) + for (y_len = 0, ey = y; ey; ey = let_outlet(ey)) for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (symbol_tag(slot_symbol(py)) != 0) { @@ -47926,7 +47878,7 @@ static bool let_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t if (!nci) nci = clear_shared_info(sc->circle_info); - for (ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex)) + for (ex = x; ex; ex = let_outlet(ex)) for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) if (symbol_tag(slot_symbol(px)) == 0) /* unshadowed */ { @@ -49088,12 +49040,12 @@ static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer source, s7_point case T_INTEGER: new_cell(sc, dest, T_INTEGER); - integer(dest) = integer(source); + set_integer(dest, integer(source)); return(dest); case T_RATIO: new_cell(sc, dest, T_RATIO); - numerator(dest) = numerator(source); - denominator(dest) = denominator(source); + set_numerator(dest, numerator(source)); + set_denominator(dest, denominator(source)); return(dest); case T_REAL: new_cell(sc, dest, T_REAL); @@ -49135,9 +49087,9 @@ static s7_pointer copy_c_object_to_same_type(s7_scheme *sc, s7_pointer dest, s7_ set_car(sc->t3_2, mj); for (s7_int i = source_start, j = dest_start; i < dest_end; i++, j++) { - integer(mi) = i; + set_integer(mi, i); set_car(sc->t3_3, cref(sc, with_list_t2(source, mi))); - integer(mj) = j; + set_integer(mj, j); cset(sc, sc->t3_1); }} else @@ -49148,11 +49100,11 @@ static s7_pointer copy_c_object_to_same_type(s7_scheme *sc, s7_pointer dest, s7_ s7_int gc_loc2 = gc_protect_1(sc, mj); for (s7_int i = source_start, j = dest_start; i < dest_end; i++, j++) { - integer(mi) = i; + set_integer(mi, i); set_car(sc->t3_3, cref(sc, with_list_t2(source, mi))); set_car(sc->t3_1, dest); set_car(sc->t3_2, mj); - integer(mj) = j; + set_integer(mj, j); cset(sc, sc->t3_1); } s7_gc_unprotect_at(sc, gc_loc1); @@ -50470,7 +50422,7 @@ static s7_pointer let_append(s7_scheme *sc, s7_pointer args) s7_pointer new_let, e = car(args); check_method(sc, e, sc->append_symbol, args); gc_protect_via_stack(sc, args); - new_let = make_let(sc, sc->nil); + new_let = make_let(sc, sc->rootlet); set_stack_protected2(sc, new_let); for (s7_pointer p = args; is_pair(p); p = cdr(p)) if (!sequence_is_empty(sc, car(p))) @@ -50652,7 +50604,7 @@ static s7_pointer c_obj_to_list(s7_scheme *sc, s7_pointer obj) /* "c_object_to_l x = result; for (int64_t i = 0; i < len; i++, x = cdr(x)) /* used to save/restore sc->x|z here */ { - integer(zc) = i; + set_integer(zc, i); set_car(x, (*(c_object_ref(sc, obj)))(sc, z)); } s7_gc_unprotect_at(sc, gc_z); @@ -51950,7 +51902,7 @@ static void op_c_catch_all_a(s7_scheme *sc) static s7_pointer init_owlet(s7_scheme *sc) { s7_pointer p; /* watch out for order below */ - s7_pointer e = make_let(sc, sc->nil); + s7_pointer e = make_let(sc, sc->rootlet); sc->temp3 = e; sc->error_type = add_slot_checked_with_id(sc, e, make_symbol(sc, "error-type", 10), sc->F); /* the error type or tag ('division-by-zero) */ sc->error_data = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-data", 10), sc->F); /* the message or information passed by the error function */ @@ -52342,7 +52294,7 @@ static bool catch_let_temporarily_function(s7_scheme *sc, s7_int catch_loc, s7_p push_stack_direct(sc, OP_EVAL_DONE); eval(sc, OP_SET_UNCHECKED); }} - else let_temp_done(sc, stack_args(sc->stack, catch_loc), T_Lid(stack_let(sc->stack, catch_loc))); + else let_temp_done(sc, stack_args(sc->stack, catch_loc), T_Let(stack_let(sc->stack, catch_loc))); return(false); } @@ -52382,7 +52334,7 @@ static bool catch_dynamic_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_po */ if (sc->debug > 0) { - s7_pointer spaces = lookup_slot_with_let(make_symbol(sc, "*debug-spaces*", 14), T_Lid(stack_let(sc->stack, catch_loc))); + s7_pointer spaces = lookup_slot_with_let(sc, make_symbol(sc, "*debug-spaces*", 14), T_Let(stack_let(sc->stack, catch_loc))); if (is_slot(spaces)) slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */ } @@ -52477,14 +52429,14 @@ static void fill_error_location(s7_scheme *sc) if (((is_input_port(current_input_port(sc))) && (is_loader_port(current_input_port(sc)))) || (((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE)))) { - integer(slot_value(sc->error_line)) = port_line_number(current_input_port(sc)); - integer(slot_value(sc->error_position)) = port_position(current_input_port(sc)); + set_integer(slot_value(sc->error_line), port_line_number(current_input_port(sc))); + set_integer(slot_value(sc->error_position), port_position(current_input_port(sc))); slot_set_value(sc->error_file, wrap_string(sc, port_filename(current_input_port(sc)), port_filename_length(current_input_port(sc)))); } else { - integer(slot_value(sc->error_line)) = 0; - integer(slot_value(sc->error_position)) = 0; + set_integer(slot_value(sc->error_line), 0); + set_integer(slot_value(sc->error_position), 0); slot_set_value(sc->error_file, sc->F); } } @@ -52512,7 +52464,7 @@ static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) slot_set_value(sc->error_data, info); if (unchecked_type(sc->curlet) != T_LET) - set_curlet(sc, sc->nil); /* in the reader, the sc->curlet stack entry is mostly ignored, so it can be (and usually is) garbage */ + set_curlet(sc, sc->rootlet); /* in the reader, the sc->curlet stack entry is mostly ignored, so it can be (and usually is) garbage */ let_set_outlet(sc->owlet, sc->curlet); slot_set_value(sc->error_code, cur_code); /* if mv here, evalable code has the mv bit set, maybe from c-macro that uses s7_values */ @@ -52559,8 +52511,8 @@ static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) fill_error_location(sc); else { - integer(slot_value(sc->error_line)) = line; - integer(slot_value(sc->error_position)) = position; + set_integer(slot_value(sc->error_line), line); + set_integer(slot_value(sc->error_position), position); slot_set_value(sc->error_file, sc->file_names[file]); }} else fill_error_location(sc); @@ -52716,6 +52668,7 @@ static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) /* s7.h backwards compatibility */ { error_nr(sc, type, info); + /* info is a temporary value -- do not expect it to be useful beyond the error handler procedure itself */ return(type); } @@ -52899,8 +52852,8 @@ static noreturn void missing_close_paren_error_nr(s7_scheme *sc) char *syntax_msg = NULL; s7_pointer pt = current_input_port(sc); - if ((unchecked_type(sc->curlet) != T_LET) && (sc->curlet != sc->nil)) - set_curlet(sc, sc->nil); + if (unchecked_type(sc->curlet) != T_LET) + set_curlet(sc, sc->rootlet); /* check *missing-close-paren-hook* */ if (hook_has_functions(sc->missing_close_paren_hook)) @@ -52909,8 +52862,8 @@ static noreturn void missing_close_paren_error_nr(s7_scheme *sc) if ((port_line_number(pt) > 0) && (port_filename(pt))) { - integer(slot_value(sc->error_line)) = port_line_number(pt); - integer(slot_value(sc->error_position)) = port_position(pt); + set_integer(slot_value(sc->error_line), port_line_number(pt)); + set_integer(slot_value(sc->error_position), port_position(pt)); slot_set_value(sc->error_file, wrap_string(sc, port_filename(pt), port_filename_length(pt))); } result = s7_call(sc, sc->missing_close_paren_hook, sc->nil); @@ -53050,14 +53003,14 @@ static bool call_begin_hook(s7_scheme *sc) slot_set_value(sc->error_code, cur_code); if (has_location(cur_code)) { - integer(slot_value(sc->error_line)) = (s7_int)pair_line_number(cur_code); + set_integer(slot_value(sc->error_line), (s7_int)pair_line_number(cur_code)); slot_set_value(sc->error_file, sc->file_names[pair_file_number(cur_code)]); - integer(slot_value(sc->error_position)) = (s7_int)pair_position(cur_code); + set_integer(slot_value(sc->error_position), (s7_int)pair_position(cur_code)); } else { - integer(slot_value(sc->error_line)) = 0; - integer(slot_value(sc->error_position)) = 0; + set_integer(slot_value(sc->error_line), 0); + set_integer(slot_value(sc->error_position), 0); slot_set_value(sc->error_file, sc->F); } #if WITH_HISTORY @@ -53309,7 +53262,7 @@ static inline void fill_star_defaults(s7_scheme *sc, s7_pointer func, int32_t st s7_pointer defval = df[i]; if (is_symbol(defval)) set_car(par, lookup_checked(sc, defval)); - else set_car(par, (is_pair(defval)) ? s7_eval(sc, defval, sc->nil) : defval); + else set_car(par, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval); } } @@ -53343,7 +53296,7 @@ static s7_pointer set_c_function_star_args(s7_scheme *sc) set_checked(kpar); for (; is_pair(kpar); kpar = cdr(kpar)) clear_checked(kpar); - df = c_function_arg_names(func); + df = c_function_arg_names(func); /* changed to use symbols here, not keywords 2-Jan-24 */ for (ki = i, karg = arg, kpar = par; (ki < n_args) && (is_pair(karg)); ki++, karg = cdr(karg)) if (!is_symbol_and_keyword(car(karg))) { @@ -53360,7 +53313,7 @@ static s7_pointer set_c_function_star_args(s7_scheme *sc) { s7_pointer p; for (j = 0, p = call_args; j < n_args; j++, p = cdr(p)) - if (df[j] == car(karg)) + if (df[j] == keyword_symbol(car(karg))) break; if (j == n_args) { @@ -53368,7 +53321,7 @@ static s7_pointer set_c_function_star_args(s7_scheme *sc) { if (!is_safe_procedure(func)) unstack_gc_protect(sc); error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "~A: not a parameter name?", 25), car(karg))); + set_elist_2(sc, wrap_string(sc, "~A is not a parameter name?", 27), car(karg))); } karg = cdr(karg); if (is_null(karg)) /* (f :x) where f arglist includes :allow-other-keys */ @@ -53420,7 +53373,7 @@ static s7_pointer set_c_function_star_args(s7_scheme *sc) s7_pointer defval = df[ki]; if (is_symbol(defval)) set_car(kpar, lookup_checked(sc, defval)); - else set_car(kpar, (is_pair(defval)) ? s7_eval(sc, defval, sc->nil) : defval); + else set_car(kpar, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval); }} if (!is_safe_procedure(func)) unstack_gc_protect(sc); return(call_args); @@ -53507,10 +53460,7 @@ s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e) { push_stack_direct(sc, OP_EVAL_DONE); sc->code = code; - if ((e != sc->rootlet) && - (is_let(e))) - set_curlet(sc, e); - else set_curlet(sc, sc->nil); + set_curlet(sc, (is_let(e)) ? e : sc->rootlet); eval(sc, OP_EVAL); } restore_jump_info(sc); @@ -53529,7 +53479,7 @@ s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer e, c sc->s7_call_file = file; sc->s7_call_line = line; } - result = s7_eval(sc, code, e); + result = s7_eval(sc, code, (e == sc->nil) ? sc->rootlet : e); if (caller) { sc->s7_call_name = NULL; @@ -53557,7 +53507,7 @@ pass (rootlet):\n\ s7_pointer e = cadr(args); if (!is_let(e)) wrong_type_error_nr(sc, sc->eval_symbol, 2, e, a_let_string); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + set_curlet(sc, e); } sc->code = car(args); @@ -53867,7 +53817,7 @@ static s7_pointer V_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, static void check_o_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) { s7_pointer slot = s7_slot(sc, var); - if (lookup_slot_with_let(var, e) != slot) + if (lookup_slot_with_let(sc, var, e) != slot) { fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(e), (tis_slot(slot)) ? display(slot) : "undefined", unbold_text); @@ -56553,7 +56503,7 @@ static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code) new_cell(sc, new_e, T_LET | T_SAFE_PROCEDURE); let_set_slots(new_e, slot_end); /* needed by add_slot_unchecked */ - let_set_outlet(new_e, sc->nil); + let_set_outlet(new_e, sc->rootlet); gc_protect_via_stack(sc, new_e); /* as in let, we need to call the var inits before making the new let, but a simpler equivalent is to make the new let @@ -59879,10 +59829,24 @@ static s7_int opt_set_i_i_f(opt_info *o) return(x); } -static s7_int opt_set_i_i_fm(opt_info *o) /* called in increment: (set! sum (+ sum (...))) where are all ints */ +#if S7_DEBUGGING +static void check_mutability(s7_scheme *sc, opt_info *o, const char *func, int line) +{ + if (!is_mutable_number(slot_value(o->v[1].p))) + { + fprintf(stderr, "%s[%d]: %s value is not mutable", func, line, display(o->v[1].p)); + if (sc->stop_at_error) abort(); + } +} +#else +#define check_mutability(Sc, O, Func, Line) +#endif + +static s7_int opt_set_i_i_fm(opt_info *o) /* called in increment: (set! sum (+ sum (...))) where all are ints */ { s7_int x = o->v[3].fi(o->v[2].o1); - integer(slot_value(o->v[1].p)) = x; + check_mutability(o->sc, o, __func__, __LINE__); + set_integer(slot_value(o->v[1].p), x); return(x); } @@ -59893,6 +59857,14 @@ static s7_int opt_set_i_i_fo(opt_info *o) return(x); } +static s7_int opt_set_i_i_fom(opt_info *o) +{ + s7_int x = integer(slot_value(o->v[3].p)) + o->v[2].i; + check_mutability(o->sc, o, __func__, __LINE__); + set_integer(slot_value(o->v[1].p), x); + return(x); +} + static bool set_i_i_f_combinable(s7_scheme *sc, opt_info *opc) { if ((sc->pc > 1) && @@ -59939,9 +59911,10 @@ static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) if (set_i_i_f_combinable(sc, opc)) return_true(sc, car_x); opc->v[0].fi = (is_mutable_integer(slot_value(opc->v[1].p))) ? opt_set_i_i_fm : opt_set_i_i_f; + /* only a few opt_set_i_i_f|fo's remain in valcall suite */ opc->v[2].o1 = o1; opc->v[3].fi = o1->v[0].fi; - return_true(sc, car_x); /* or OO_I? */ + return_true(sc, car_x); }}} else if ((is_pair(cadr(car_x))) && /* if is_pair(settee) get setter */ @@ -62136,7 +62109,8 @@ static s7_double opt_set_d_d_f(opt_info *o) static s7_double opt_set_d_d_fm(opt_info *o) { s7_double x = o->v[3].fd(o->v[2].o1); - real(slot_value(o->v[1].p)) = x; + check_mutability(o->sc, o, __func__, __LINE__); + set_real(slot_value(o->v[1].p), x); return(x); } @@ -62164,8 +62138,15 @@ static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) opc->v[1].p = settee; if ((!is_t_integer(caddr(car_x))) && (float_optimize(sc, cddr(car_x)))) - { + { /* tari: (set! rlo (min rlo (real-part (v i)))) -- can't tell here that it is used only in this line in the do body */ + /* PERHAPS: if tree_count(body) - tree_count(line) == 0 and no setters within line it's safe as mutable? use the two_sets bit as before? */ + /* but we also need a list of such opt_info ptrs to cancel mutability at the end */ + /* tall: (set! la ca)! (How?) + * (set! temp1 (one-zero dryTap0 (one-pole dryTap1 (piano-noise pnoise amp)))) + * and many more, but none will be self-contained I think + */ opc->v[0].fd = (is_mutable_number(slot_value(opc->v[1].p))) ? opt_set_d_d_fm : opt_set_d_d_f; + /* if (opc->v[0].fd == opt_set_d_d_f) fprintf(stderr, "%d: %s\n", __LINE__, display(car_x)); */ opc->v[2].o1 = o1; opc->v[3].fd = o1->v[0].fd; return_true(sc, car_x); @@ -63526,7 +63507,7 @@ static s7_pointer check_loop_end_ref(s7_pointer p, const char *func, int32_t lin #else #define loop_end(A) denominator(T_Int(slot_value(A))) #endif -#define set_loop_end(A, B) denominator(T_Int(slot_value(A))) = B +#define set_loop_end(A, B) set_denominator(T_Int(slot_value(A)), B) static void check_unchecked(s7_scheme *sc, s7_pointer obj, s7_pointer slot, opt_info *opc, s7_pointer expr) { @@ -64932,6 +64913,23 @@ static s7_pointer opt_set_p_i_f(opt_info *o) slot_set_value(o->v[1].p, x); return(x); } +/* here and below (opt_set_p_d_f), the mutable versions are not safe, and are very tricky to make safe. First if a variable is set twice, + * in the body, as in (do (...) (... (set! buffix (+ 1 buffix)) (if (>= buffix fftsize) (set! buffix 0)))) from pvoc.scm, + * if the first set! is opt_set_p_i_fm (buffix is assumed mutable), the second sets it to built-in immutable zero, so the next time around loop, + * the set_integer is direct so now built-in 0 == 128 (yet still prints itself as "0"). Also if a mutable variable is stored, + * (define (f2) (let ((v (vector 0 0 0)) (y 1.0)) (do ((i 0 (+ i 1))) ((= i 3) v) (set! y (+ y 1.0)) (vector-set! v i y)))) + * (f2) -> #(4.0 4.0 4.0). Maybe safe if body has just one statement? + */ + +#if 0 +static s7_pointer opt_set_p_i_fm(opt_info *o) +{ + s7_int x = o->v[6].fi(o->v[5].o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_integer(slot_value(o->v[1].p), x); + return(slot_value(o->v[1].p)); +} +#endif static s7_pointer opt_set_p_d_s(opt_info *o) { @@ -64949,6 +64947,16 @@ static s7_pointer opt_set_p_d_f(opt_info *o) return(x); } +#if 0 +static s7_pointer opt_set_p_d_fm(opt_info *o) +{ + s7_double x = o->v[5].fd(o->v[4].o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_real(slot_value(o->v[1].p), x); + return(slot_value(o->v[1].p)); +} +#endif + static s7_pointer opt_set_p_d_f_sf_add(opt_info *o) { s7_pointer x = make_real(o->sc, opt_d_dd_sf_add(o->v[4].o1)); @@ -64956,6 +64964,14 @@ static s7_pointer opt_set_p_d_f_sf_add(opt_info *o) return(x); } +static s7_pointer opt_set_p_d_fm_sf_add(opt_info *o) +{ + s7_double x = opt_d_dd_sf_add(o->v[4].o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_real(slot_value(o->v[1].p), x); + return(slot_value(o->v[1].p)); +} + static s7_pointer opt_set_p_d_f_mm_add(opt_info *o) { s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[4].p), integer(slot_value(o->v[5].p))) * real(slot_value(o->v[3].p)); @@ -65032,6 +65048,7 @@ static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc) opc->v[2].p = o1->v[1].p; opc->v[3].i = o1->v[2].i; opc->v[0].fp = (o1->v[0].fi == opt_i_ii_sc_add) ? opt_set_p_i_fo1_add : opt_set_p_i_fo1; + /* opt_if_nbp: opt_set_p_i_fo1_add b/shoot */ backup_pc(sc); return_true(sc, NULL); }} @@ -65173,6 +65190,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy if (!set_p_i_f_combinable(sc, opc)) { opc->v[0].fp = opt_set_p_i_f; + /* fprintf(stderr, "%d: %s\n", __LINE__, display(car_x)); */ opc->v[6].fi = opc->v[5].o1->v[0].fi; } return_true(sc, car_x); @@ -65206,6 +65224,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy opc->v[4].o1 = sc->opts[start_pc]; opc->v[5].fd = sc->opts[start_pc]->v[0].fd; opc->v[0].fp = (opc->v[5].fd == opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add : opt_set_p_d_f; + /* if (opc->v[0].fp == opt_set_p_d_f) fprintf(stderr, "%d: %s\n", __LINE__, display(car_x)); */ } return_true(sc, car_x); } @@ -66236,7 +66255,7 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le /* -------- cell_do -------- */ -#define do_curlet(o) T_Lsd(o->v[2].p) +#define do_curlet(o) T_Let(o->v[2].p) #define do_curlet_unchecked(o) o->v[2].p #define do_body_length(o) o->v[3].i #define do_result_length(o) o->v[4].i @@ -66358,12 +66377,14 @@ static s7_pointer opt_do_step_1(opt_info *o) static s7_pointer opt_do_step_i(opt_info *o) { - /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */ + /* 1 stepper (multi inits perhaps), 1 body expr, 1 rtn expr */ + /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) */ opt_info *o1; opt_info *ostart = do_any_test(o); opt_info *ostep = o->v[9].o1; opt_info *inits = do_any_inits(o); opt_info *body = do_any_body(o); + s7_pointer (*fp)(opt_info *o) = body->v[0].fp; int32_t k; s7_pointer vp, result, stepper = NULL, si; s7_scheme *sc = o->sc; @@ -66381,12 +66402,19 @@ static s7_pointer opt_do_step_i(opt_info *o) incr = ostep->v[2].i; si = make_mutable_integer(sc, integer(slot_value(ostart->v[1].p))); if (stepper) slot_set_value(stepper, si); + if (fp == opt_set_p_d_f_sf_add) /* ok since used only if body has one expr */ + { + fp = opt_set_p_d_fm_sf_add; + slot_set_value(body->v[1].p, make_mutable_real(sc, real(slot_value(body->v[1].p)))); + } while (integer(si) != end) { - body->v[0].fp(body); + fp(body); integer(si) += incr; } clear_mutable_integer(si); + if (fp == opt_set_p_d_fm_sf_add) + clear_mutable_number(slot_value(body->v[1].p)); o1 = do_any_results(o); result = o1->v[0].fp(o1); unstack_gc_protect(sc); @@ -66450,13 +66478,13 @@ static s7_pointer opt_do_1(opt_info *o) while (!ostart->v[0].fb(ostart)) { body->v[0].fp(body); - integer(step_val) = opt_i_ii_ss_add(ostep); + set_integer(step_val, opt_i_ii_ss_add(ostep)); } else while (!ostart->v[0].fb(ostart)) { body->v[0].fp(body); - integer(step_val) = ostep->v[O_WRAP].fi(ostep); + set_integer(step_val, ostep->v[O_WRAP].fi(ostep)); } unstack_gc_protect(sc); set_curlet(sc, old_e); @@ -66537,7 +66565,7 @@ static s7_pointer opt_do_times(opt_info *o) s7_pointer old_e = sc->curlet; gc_protect_via_stack(sc, old_e); set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); + set_integer(vp, integer(o1->v[0].fp(o1))); if (len == 2) /* tmac tmisc */ { opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1; @@ -66603,7 +66631,7 @@ static s7_pointer opt_do_very_simple(opt_info *o) s7_pointer old_e = sc->curlet; gc_protect_via_stack(sc, old_e); set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); + set_integer(vp, integer(o1->v[0].fp(o1))); o1 = do_any_body(o); f = o1->v[0].fp; if (f == opt_p_pip_ssf) /* tref.scm */ @@ -66656,7 +66684,7 @@ static s7_pointer opt_do_very_simple(opt_info *o) slot_set_value(o1->v[1].p, ival); while (integer(vp) < end) { - integer(ival) = fi(o2); + set_integer(ival, fi(o2)); integer(vp)++; } slot_set_value(o1->v[1].p, make_integer(sc, integer(slot_value(o1->v[1].p)))); @@ -66695,7 +66723,7 @@ static s7_pointer opt_do_prepackaged(opt_info *o) s7_pointer old_e = sc->curlet; gc_protect_via_stack(sc, old_e); set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); + set_integer(vp, integer(o1->v[0].fp(o1))); do_prepack_stepper(o) = vp; do_prepack_end(o) = end; @@ -66752,15 +66780,15 @@ static bool tree_has_setters(s7_scheme *sc, s7_pointer tree) return(pair_set_memq(sc, tree)); } -static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, bool *has_set); +static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set); -static bool do_passes_safety_check(s7_scheme *sc, s7_pointer body, s7_pointer stepper, bool *has_set) +static bool do_passes_safety_check(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer step_vars, bool *has_set) { if (!is_pair(body)) return(true); if (!is_safety_checked(body)) { set_safety_checked(body); - if (!(do_is_safe(sc, body, stepper, sc->nil, has_set))) + if (!(do_is_safe(sc, body, stepper, sc->nil, step_vars, has_set))) set_unsafe_do(body); } return(!is_unsafe_do(body)); @@ -67031,7 +67059,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) return_false(sc, car_x); } - do_curlet_unchecked(opc) = T_Lsd(let); + do_curlet_unchecked(opc) = T_Let(let); do_body_length(opc) = len - 3; do_result_length(opc) = rtn_len; opc->v[9].o1 = sc->opts[step_pc]; @@ -67144,7 +67172,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) (cadr(ind_step) == ind) && (caddr(ind_step) == int_one) && (is_null(cdddr(ind_step))) && - (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) + (do_passes_safety_check(sc, cdddr(car_x), ind, cadr(car_x), &has_set))) { s7_pointer slot = let_slots(let); let_set_dox_slot1(let, slot); @@ -67181,7 +67209,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) (cadr(ind_step) == ind) && (is_null(cddr(ind_step))) && (body_len == 1) && - (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) + (do_passes_safety_check(sc, cdddr(car_x), ind, cadr(car_x), &has_set))) opc->v[0].fp = opt_do_list_simple; } return_true(sc, car_x); @@ -67946,10 +67974,10 @@ static Inline s7_pointer inline_make_counter(s7_scheme *sc, s7_pointer iter) /* new_cell(sc, x, T_COUNTER); counter_set_result(x, sc->nil); if ((S7_DEBUGGING) && (!is_iterator(iter)) && (!is_pair(iter))) fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, display(iter)); - counter_set_list(x, iter); /* iterator -- here it's always either an iterator or a pair */ - counter_set_capture(x, 0); /* will be capture_let_counter */ - counter_set_let(x, sc->nil); /* will be the saved let */ - counter_set_slots(x, sc->nil); /* local let slots before body is evalled */ + counter_set_list(x, iter); /* iterator -- here it's always either an iterator or a pair */ + counter_set_capture(x, 0); /* will be capture_let_counter */ + counter_set_let(x, sc->rootlet); /* will be the saved let */ + counter_set_slots(x, sc->nil); /* local let slots before body is evalled */ stack_set_has_counters(sc->stack); return(x); } @@ -68043,23 +68071,23 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq if ((len > MUTLIM) && (!tree_has_setters(sc, body))) { - s7_pointer sv = wrapped_real(sc); /* s7_make_mutable_real(sc, 0.0) 16-Nov-23 */ + s7_pointer sv = wrapped_real(sc); /* make_mutable_real(sc, 0.0) 16-Nov-23 */ slot_set_value(slot, sv); if (func == opt_float_any_nv) { opt_info *o = sc->opts[0]; s7_double (*fd)(opt_info *o) = o->v[0].fd; - for (i = 0; i < len; i++) {real(sv) = vals[i]; fd(o);}} + for (i = 0; i < len; i++) {set_real(sv, vals[i]); fd(o);}} else if (func == opt_cell_any_nv) { opt_info *o = sc->opts[0]; s7_pointer (*fp)(opt_info *o) = o->v[0].fp; if (fp == opt_unless_p_1) - for (i = 0; i < len; i++) {real(sv) = vals[i]; if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1);} - else for (i = 0; i < len; i++) {real(sv) = vals[i]; fp(o);} + for (i = 0; i < len; i++) {set_real(sv, vals[i]); if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1);} + else for (i = 0; i < len; i++) {set_real(sv, vals[i]); fp(o);} } - else for (i = 0; i < len; i++) {real(sv) = vals[i]; func(sc);} + else for (i = 0; i < len; i++) {set_real(sv, vals[i]); func(sc);} } else for (i = 0; i < len; i++) {slot_set_value(slot, make_real(sc, vals[i])); func(sc);} res = sc->unspecified; @@ -68081,9 +68109,9 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq { opt_info *o = sc->opts[0]; s7_int (*fi)(opt_info *o) = o->v[0].fi; - for (i = 0; i < len; i++) {integer(sv) = vals[i]; fi(o);} + for (i = 0; i < len; i++) {set_integer(sv, vals[i]); fi(o);} } - else for (i = 0; i < len; i++) {integer(sv) = vals[i]; func(sc);} + else for (i = 0; i < len; i++) {set_integer(sv, vals[i]); func(sc);} } else for (i = 0; i < len; i++) {slot_set_value(slot, make_integer(sc, vals[i])); func(sc);} res = sc->unspecified; @@ -68411,11 +68439,11 @@ Each object can be a list, string, vector, hash-table, or any other sequence." s7_int vlen = vector_length(v); if (is_float_vector(v)) { - s7_pointer rl = wrapped_real(sc); /* s7_make_mutable_real(sc, 0.0) */ + s7_pointer rl = wrapped_real(sc); /* make_mutable_real(sc, 0.0) */ sc->temp7 = rl; for (s7_int i = 0; i < vlen; i++) { - real(rl) = float_vector(v, i); + set_real(rl, float_vector(v, i)); fp(sc, rl); }} else @@ -68425,7 +68453,7 @@ Each object can be a list, string, vector, hash-table, or any other sequence." sc->temp7 = iv; for (s7_int i = 0; i < vlen; i++) { - integer(iv) = int_vector(v, i); + set_integer(iv, int_vector(v, i)); fp(sc, iv); }} else @@ -69943,16 +69971,34 @@ static void init_choosers(s7_scheme *sc) /* string-ref et al */ set_function_chooser(sc->string_ref_symbol, string_substring_chooser); - set_function_chooser(sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here */ + set_function_chooser(sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here (not const char*??) */ set_function_chooser(sc->string_to_keyword_symbol, string_substring_chooser); set_function_chooser(sc->string_downcase_symbol, string_substring_chooser); set_function_chooser(sc->string_upcase_symbol, string_substring_chooser); - /* if the function assumes a null-terminated string, substring needs to return a copy */ + set_function_chooser(sc->string_position_symbol, string_substring_chooser); + set_function_chooser(sc->string_geq_symbol, string_substring_chooser); + set_function_chooser(sc->string_leq_symbol, string_substring_chooser); + set_function_chooser(sc->string_copy_symbol, string_copy_chooser); + set_function_chooser(sc->eval_string_symbol, string_substring_chooser); + set_function_chooser(sc->symbol_symbol, string_substring_chooser); + /* if the function assumes a null-terminated string, substring needs to return a copy (which assume this?) */ #if (!WITH_PURE_S7) set_function_chooser(sc->string_length_symbol, string_substring_chooser); set_function_chooser(sc->string_to_list_symbol, string_substring_chooser); + set_function_chooser(sc->string_ci_eq_symbol, string_substring_chooser); + set_function_chooser(sc->string_ci_geq_symbol, string_substring_chooser); + set_function_chooser(sc->string_ci_leq_symbol, string_substring_chooser); + set_function_chooser(sc->string_ci_gt_symbol, string_substring_chooser); + set_function_chooser(sc->string_ci_lt_symbol, string_substring_chooser); #endif - set_function_chooser(sc->string_copy_symbol, string_copy_chooser); +#if WITH_SYSTEM_EXTRAS + set_function_chooser(sc->file_exists_symbol, string_substring_chooser); +#endif + + /* also: directory->list substring string->byte-vector with-input-from-file with-input-from-string + * system load getenv file-mtime gensym with-output-to-file open-output-file directory? open-input-file + * call-with-output-file delete-file call-with-input-file call-with-input-string open-input-string + */ /* symbol->string */ f = global_value(sc->symbol_to_string_symbol); @@ -70064,9 +70110,6 @@ static void init_choosers(s7_scheme *sc) f = set_function_chooser(sc->tree_set_memq_symbol, tree_set_memq_chooser); sc->tree_set_memq_syms = make_function_with_class(sc, f, "tree-set-memq", g_tree_set_memq_syms, 2, 0, false); - /* eval-string */ - set_function_chooser(sc->eval_string_symbol, eval_string_chooser); - /* dynamic-wind */ f = set_function_chooser(sc->dynamic_wind_symbol, dynamic_wind_chooser); sc->dynamic_wind_unchecked = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_unchecked, 3, 0, false); @@ -70644,8 +70687,8 @@ static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer sym (symbol_is_in_list(sc, symbol_to_keyword(sc, symbol)))) return(sc->nil); - for (x = sc->curlet, id = symbol_id(symbol); id < let_id(x); x = let_outlet(x)); - for (; is_let(x); x = let_outlet(x)) + for (x = sc->curlet, id = symbol_id(symbol); let_id(x) > id; x = let_outlet(x)); + for (; x; x = let_outlet(x)) { if (let_id(x) == id) return(local_slot(symbol)); @@ -71911,6 +71954,7 @@ static opt_t optimize_safe_c_func_three_args(s7_scheme *sc, s7_pointer expr, s7_ (is_normal_symbol(arg3))) { set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */ + clear_has_fx(cdr(expr)); /* (s7test safe_c_func_three_args) this is used above -- maybe just clear it at the top? */ set_opt2_sym(cdr(expr), arg3); set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ choose_c_function(sc, expr, func, 3); @@ -75908,7 +75952,7 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ else { set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ - set_opt3_let(code, sc->nil); + set_opt3_let(code, sc->rootlet); }} /* fx_tree inits */ @@ -76018,7 +76062,7 @@ static bool op_let1(s7_scheme *sc) sc->code = car(x); /* restore the original form */ y = cdr(x); /* use sc->args as the new let */ sc->temp8 = y; - set_curlet(sc, reuse_as_let(sc, x, sc->curlet)); + set_curlet(sc, reuse_as_let(sc, x, T_Let(sc->curlet))); if (is_symbol(car(sc->code))) return(op_named_let_1(sc, y)); /* inner let here */ @@ -76246,7 +76290,7 @@ static void op_let_a_a_new(s7_scheme *sc) binding = opt2_pair(sc->code); set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding)))); sc->value = fx_call(sc, cdr(sc->code)); - free_cell(sc, sc->curlet); /* t101-aux-3 */ /* don't free let_slots here unless checked first (can be null after fx_call above?) */ + /* free_cell(sc, sc->curlet); *//* t101-aux-3 and t725+unlet */ /* don't free let_slots here unless checked first (can be null after fx_call above?) */ /* upon return, we continue, so sc->curlet should be ok */ } @@ -76317,7 +76361,7 @@ static Inline void inline_op_let_na_new(s7_scheme *sc) /* called once in eval, c new_cell(sc, let, T_LET | T_SAFE_PROCEDURE); let_set_id(let, sc->let_number + 1); let_set_slots(let, slot_end); - let_set_outlet(let, sc->curlet); + let_set_outlet(let, T_Let(sc->curlet)); sc->args = let; for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p)) { @@ -76532,7 +76576,7 @@ static bool check_let_star(s7_scheme *sc) else { set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ - set_opt3_let(code, sc->nil); + set_opt3_let(code, sc->rootlet); }}} else /* multiple variables */ { @@ -77738,7 +77782,7 @@ static void op_if_unchecked(s7_scheme *sc) static bool op_if1(s7_scheme *sc) { - sc->code = (is_true(sc, sc->value)) ? car(sc->code) : unchecked_car(cdr(sc->code)); + sc->code = (is_true(sc, sc->value)) ? T_Pos(car(sc->code)) : T_Pos(unchecked_car(cdr(sc->code))); /* even pre-optimization, (if #f #f) ==> #<unspecified> because unique_car(sc->nil) = sc->unspecified */ if (is_pair(sc->code)) return(true); @@ -78387,7 +78431,7 @@ static void op_define_macro(s7_scheme *sc) sc->code = cdr(sc->code); check_define_macro(sc, sc->cur_op, form); if ((is_immutable(sc->curlet)) && - (is_let(sc->curlet))) /* not () */ + (is_let(sc->curlet))) syntax_error_nr(sc, "define-macro ~S: let is immutable", 33, caar(sc->code)); /* need syntax_error_any_with_caller? */ sc->value = make_macro(sc, sc->cur_op, true); } @@ -78457,7 +78501,7 @@ static goto_t op_expansion(s7_scheme *sc) { s7_pointer symbol = car(sc->value), slot; /* we're playing fast and loose with sc->curlet in the reader, so here we need a disaster check */ - if (!is_let(sc->curlet)) set_curlet(sc, sc->nil); + if (!is_let(sc->curlet)) set_curlet(sc, sc->rootlet); if ((symbol_id(symbol) == 0) || (sc->curlet == sc->nil)) @@ -78660,7 +78704,7 @@ static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) s7_pointer e = lookup_checked(sc, car(code)); s7_pointer sym = cadr(code); s7_pointer val; - if ((!is_let(e)) && (e != sc->rootlet)) + if (!is_let(e)) { e = find_let(sc, e); if (!is_let(e)) @@ -78671,7 +78715,7 @@ static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) { if ((e == sc->s7_starlet) && (is_slot(global_slot(sym)))) /* (let () (define (func) (with-let *s7* letrec*)) (func) (func)), .5 tlet */ return(global_value(sym)); /* perhaps the e=*s7* check is not needed */ - if (is_slot(lookup_slot_with_let(sym, e))) + if (is_slot(lookup_slot_with_let(sc, sym, e))) return(sc->undefined); unbound_variable_error_nr(sc, sym); } @@ -78680,15 +78724,15 @@ static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) static void activate_with_let(s7_scheme *sc, s7_pointer e) { - if (!is_let(e)) /* (with-let . "hi") */ + if (!is_let(e)) /* (with-let . "hi") */ { - s7_pointer new_e = find_let(sc, e); - if (!is_let(new_e)) + s7_pointer new_e = find_let(sc, e); /* sc->nil here means no let found */ + if ((!is_let(new_e)) && (!has_closure_let(e))) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), e)); e = new_e; } if (e == sc->rootlet) - set_curlet(sc, sc->nil); /* (with-let (rootlet) ...) */ + set_curlet(sc, e); /* (with-let (rootlet) ...) */ else { set_with_let_let(e); @@ -79819,7 +79863,7 @@ static bool op_set1(s7_scheme *sc) symbol_increment_ctr(sym); /* see define setfib example in s7test.scm -- I'm having second thoughts about this... */ return(true); /* continue */ } - if ((!is_let(sc->curlet)) || /* (with-let (rootlet) (set! undef 3)) */ /* TODO: not right -- let () through */ + if ((!is_let(sc->curlet)) || /* (with-let (rootlet) (set! undef 3)) */ (!has_let_set_fallback(sc->curlet))) /* (with-let (mock-hash-table 'b 2) (set! b 3)) */ error_nr(sc, sc->unbound_variable_symbol, set_elist_4(sc, wrap_string(sc, "~S is unbound in (set! ~S ~S)", 29), sym, sym, sc->value)); sc->value = call_let_set_fallback(sc, sc->curlet, sym, sc->value); @@ -79918,8 +79962,8 @@ static Inline void inline_op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ct { case T_RATIO: new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) + denominator(val); - denominator(sc->value) = denominator(val); + set_numerator(sc->value, numerator(val) + denominator(val)); + set_denominator(sc->value, denominator(val)); break; case T_REAL: sc->value = make_real(sc, real(val) + 1.0); @@ -79947,8 +79991,8 @@ static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ { case T_RATIO: new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) - denominator(val); - denominator(sc->value) = denominator(val); + set_numerator(sc->value, numerator(val) - denominator(val)); + set_denominator(sc->value, denominator(val)); break; case T_REAL: sc->value = make_real(sc, real(val) - 1.0); @@ -80753,7 +80797,53 @@ static bool tree_match(s7_pointer tree) ((tree_match(car(tree))) || (tree_match(cdr(tree))))); } -static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, bool *has_set) +static bool all_ints_here(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_pointer step_vars) /* see also all_integers above */ +{ + /* since any type change causes false return, we can accept inits across step-vars */ + s7_pointer func, sig; + if (is_number(expr)) + return(is_t_integer(expr)); + if (is_symbol(expr)) + { + s7_pointer val; + if (expr == settee) return(true); + for (s7_pointer step = step_vars; is_pair(step); step = cdr(step)) + if (caar(step) == expr) + { + if (!all_ints_here(sc, caar(step), cadar(step), step_vars)) /* TODO: can we lookup step_vars here? or only in do_is_safe? */ + return(false); + if (is_pair(cddar(step))) + return(all_ints_here(sc, caar(step), caddar(step), step_vars)); + return(true); + } + val = lookup_unexamined(sc, expr); + return((val) && (is_t_integer(val))); + } + if (!is_pair(expr)) return(false); + if (!is_symbol(car(expr))) return(false); + func = lookup_unexamined(sc, car(expr)); + if (!func) return(false); + if ((is_int_vector(func)) || (is_byte_vector(func))) return(true); + if (!is_any_c_function(func)) return(false); + if ((car(expr) == sc->vector_ref_symbol) && (is_pair(cdr(expr))) && (is_symbol(cadr(expr)))) + { + s7_pointer v = lookup_unexamined(sc, cadr(expr)); + if ((v) && ((is_int_vector(v)) || (is_byte_vector(v)))) return(true); + } + sig = c_function_signature(func); + if ((is_pair(sig)) && + ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol) || + ((is_pair(car(sig))) && + ((direct_memq(sc->is_integer_symbol, car(sig))) || (direct_memq(sc->is_byte_symbol, car(sig))))))) + return(true); /* like int-vector or length */ + if (!is_all_integer(car(expr))) return(false); + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + if (!all_ints_here(sc, settee, car(p), step_vars)) + return(false); + return(true); +} + +static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set) { /* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble * we can free var_list if return(false) not after (!do_is_safe...), but it seems to make no difference, or be slightly slower @@ -80805,38 +80895,43 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po sc->x = cp; } sc->x = sc->unused; - if (!do_is_safe(sc, cddr(expr), stepper, cp, has_set)) return(false); + if (!do_is_safe(sc, cddr(expr), stepper, cp, step_vars, has_set)) return(false); break; case OP_DO: - if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ - return(false); - cp = var_list; - for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var; - if (!is_pair(car(vars))) return(false); - var = caar(vars); - if ((direct_memq(var, cp)) || (var == stepper)) return(false); - cp = cons(sc, var, cp); - sc->x = cp; - if ((is_pair(cdar(vars))) && - (!do_is_safe(sc, cdar(vars), stepper, cp, has_set))) - { - sc->x = sc->unused; - return(false); - }} - sc->x = sc->unused; - if (!do_is_safe(sc, caddr(expr), stepper, cp, has_set)) return(false); - if ((is_pair(cdddr(expr))) && - (!do_is_safe(sc, cdddr(expr), stepper, cp, has_set))) - return(false); + { + s7_pointer combined_vars; + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ + return(false); + cp = var_list; + sc->w = (is_pair(cadr(expr))) ? pair_append(sc, cadr(expr), step_vars) : step_vars; + combined_vars = sc->w; + for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + if (!is_pair(car(vars))) return(false); + var = caar(vars); + if ((direct_memq(var, cp)) || (var == stepper)) return(false); + cp = cons(sc, var, cp); + sc->x = cp; + if ((is_pair(cdar(vars))) && + (!do_is_safe(sc, cdar(vars), stepper, cp, combined_vars, has_set))) + { + sc->x = sc->unused; + return(false); + }} + sc->x = sc->unused; + if (!do_is_safe(sc, caddr(expr), stepper, cp, combined_vars, has_set)) return(false); + if ((is_pair(cdddr(expr))) && + (!do_is_safe(sc, cadddr(expr), stepper, cp, combined_vars, has_set))) + return(false); + } break; case OP_SET: { s7_pointer settee; - if (!is_pair(cdr(expr))) /* (set!) */ + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (set!) or (set! x) */ return(false); settee = cadr(expr); if (!is_symbol(settee)) /* (set! (...) ...) which is tricky due to setter functions/macros */ @@ -80854,19 +80949,26 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po } else { - if ((is_pair(caddr(sc->code))) && /* sc->code = do-form (formerly (cdr(do-form)) causing a bug here) */ - (is_pair(caaddr(sc->code)))) + s7_pointer end_and_result = caddr(sc->code); + if ((is_pair(end_and_result)) && /* sc->code = do-form (formerly (cdr(do-form)) causing a bug here) */ + (is_pair(car(end_and_result))) && + (!is_syntax(caar(end_and_result)))) /* 10-Jan-24 */ { bool res; set_match_symbol(settee); - res = tree_match(caaddr(sc->code)); /* (set! end ...) in some fashion */ + res = tree_match(car(end_and_result)); /* (set! end ...) in some fashion */ clear_match_symbol(settee); if (res) return(false); } - if ((has_set) && (!direct_memq(cadr(expr), var_list))) /* is some non-local variable being set? */ - (*has_set) = true; - } - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) return(false); + if (!direct_memq(settee, var_list)) /* is some local variable being set? */ + { + s7_pointer val = lookup_unexamined(sc, settee); + if (has_set) (*has_set) = true; + if ((val) && (is_t_integer(val)) && (!all_ints_here(sc, settee, caddr(expr), step_vars))) + return(false); + }} + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + return(false); if (!safe_stepper_expr(expr, stepper)) /* is step var's value used as the stored value by set!? */ return(false); } @@ -80880,36 +80982,36 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po for (cp = cadr(expr); is_pair(cp); cp = cdr(cp)) if ((!is_pair(car(cp))) || (!is_pair(cdar(cp))) || - (!do_is_safe(sc, cdar(cp), stepper, var_list, has_set))) + (!do_is_safe(sc, cdar(cp), stepper, var_list, step_vars, has_set))) return(false); - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) return(false); + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) return(false); break; case OP_COND: for (cp = cdr(expr); is_pair(cp); cp = cdr(cp)) - if (!do_is_safe(sc, car(cp), stepper, var_list, has_set)) + if (!do_is_safe(sc, car(cp), stepper, var_list, step_vars, has_set)) return(false); break; case OP_CASE: if ((!is_pair(cdr(expr))) || - (!do_is_safe(sc, cadr(expr), stepper, var_list, has_set))) + (!do_is_safe(sc, cadr(expr), stepper, var_list, step_vars, has_set))) return(false); for (cp = cddr(expr); is_pair(cp); cp = cdr(cp)) if ((!is_pair(car(cp))) || /* (case x #(123)...) */ - (!do_is_safe(sc, cdar(cp), stepper, var_list, has_set))) + (!do_is_safe(sc, cdar(cp), stepper, var_list, step_vars, has_set))) return(false); break; case OP_IF: case OP_WHEN: case OP_UNLESS: case OP_AND: case OP_OR: case OP_BEGIN: case OP_WITH_BAFFLE: - if (!do_is_safe(sc, cdr(expr), stepper, var_list, has_set)) + if (!do_is_safe(sc, cdr(expr), stepper, var_list, step_vars, has_set)) return(false); break; case OP_WITH_LET: - return(true); /* ?? did I mean false here?? */ + return(false); /* 11-Jan-24, this was true!? */ default: return(false); @@ -80925,7 +81027,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po /* if a macro, we'll eventually expand it (if *_optimize), but that requires a symbol lookup here and macroexpand */ if ((!is_optimized(expr)) || (optimize_op(expr) == OP_UNKNOWN_NP) || - (!do_is_safe(sc, cdr(expr), stepper, var_list, has_set))) + (!do_is_safe(sc, cdr(expr), stepper, var_list, step_vars, has_set))) return(false); /* is this still needed? fx_c_optcq bug -- tests seem ok without it -- 3.5 in tmat */ @@ -80955,7 +81057,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po ((is_pair(cadddr(expr))) && (s7_tree_memq(sc, stepper, cadddr(expr)))))) (*has_set) = true; - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) return(false); if (!safe_stepper_expr(expr, stepper)) return(false); @@ -81310,7 +81412,7 @@ static s7_pointer check_do(s7_scheme *sc) } if (((caddr(step_expr) == int_one) || (cadr(step_expr) == int_one)) && - (do_is_safe(sc, body, car(v), sc->nil, &has_set))) + (do_is_safe(sc, body, car(v), sc->nil, vars, &has_set))) { pair_set_syntax_op(form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */ /* no semipermanent let here because apparently do_is_safe accepts recursive calls? */ @@ -81457,7 +81559,7 @@ static s7_pointer check_do(s7_scheme *sc) else set_opt2_con(code, int_zero); } - if (do_passes_safety_check(sc, body, sc->nil, NULL)) + if (do_passes_safety_check(sc, body, sc->nil, vars, NULL)) { s7_pointer var1 = NULL, var2 = NULL, var3 = NULL; bool more_vars = false; @@ -81573,7 +81675,7 @@ static bool has_safe_steppers(s7_scheme *sc, s7_pointer let) else { if (is_t_real(val)) - slot_set_value(slot, s7_make_mutable_real(sc, real(val))); + slot_set_value(slot, make_mutable_real(sc, real(val))); else if (is_t_integer(val)) slot_set_value(slot, make_mutable_integer(sc, integer(val))); @@ -81827,7 +81929,7 @@ static goto_t op_dox(s7_scheme *sc) (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[3].p), i, endp, stepper)))) { if (has_loop_end(stepper)) - { + { /* (do ((val 0) (i 0 (+ i 1))) ((= i 1) val) (set! val (real-part (v b1 b2)))) */ s7_int lim = loop_end(stepper); if ((i >= 0) && (lim < NUM_SMALL_INTS)) do {fp(o); slot_set_value(stepper, small_int(++i));} while (i < lim); @@ -81835,7 +81937,7 @@ static goto_t op_dox(s7_scheme *sc) sc->value = sc->T; } else - do { + do { /* (do ((i start (+ i 1))) ((= end i)) (display i)) */ fp(o); slot_set_value(stepper, make_integer(sc, ++i)); } while ((sc->value = endf(sc, endp)) == sc->F); @@ -81853,14 +81955,14 @@ static goto_t op_dox(s7_scheme *sc) ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_pi_direct))) && (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), i, endp, stepper))))) /* here the has_loop_end business doesn't happen much */ - do { + do { /* (do ((count 0) (i 7 (+ i 1))) ((= i 10) count) (set! count (quotient i 3))) */ bodyf(sc); slot_set_value(stepper, make_integer(sc, ++i)); } while ((sc->value = endf(sc, endp)) == sc->F); sc->code = cdr(end); return(goto_do_end_clauses); } - do { + do { /* (do ((count 0.0) (i 7.0 (+ i 1.0))) ((>= i 10.0) count) (set! count (modulo i 3.0))) */ bodyf(sc); slot_set_value(stepper, stepf(sc, stepa)); } while ((sc->value = endf(sc, endp)) == sc->F); @@ -81876,32 +81978,35 @@ static goto_t op_dox(s7_scheme *sc) s7_function f2 = fx_proc(slot_expression(s2)); s7_pointer p1 = car(slot_expression(s1)); s7_pointer p2 = car(slot_expression(s2)); - /* split out opt_float_any_nv gained nothing (see tmp), same for opt_cell_any_nv */ + /* split out opt_float_any_nv gained nothing (see tmp), same for opt_cell_any_nv, constant end value was never hit */ if (bodyf == opt_cell_any_nv) { opt_info *o = sc->opts[0]; s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - /* maybe this can be generalized (thash:79) -- explicit integer stepper, but there must be a simpler way */ - if ((f2 == fx_add_u1) && (is_t_integer(slot_value(s2))) && (endf == fx_num_eq_ui) && - (is_symbol(cadr(endp))) && (cadr(endp) == slot_symbol(s2)) && - (is_t_integer(caddr(endp))) && (!s7_tree_memq(sc, cadr(endp), body))) - { - s7_int i = integer(slot_value(s2)), endi = integer(caddr(endp)); + s7_pointer s3 = NULL; + /* thash case -- this is dumb */ + if ((f2 == fx_add_u1) && (is_t_integer(slot_value(s2))) && (cadr(endp) == slot_symbol(s2)) && (!s7_tree_memq(sc, cadr(endp), body)) && + (((endf == fx_num_eq_ui) && (is_t_integer(caddr(endp)))) || + ((endf == fx_num_eq_us) && (s3 = opt_integer_symbol(sc, caddr(endp))) && (!s7_tree_memq(sc, caddr(endp), body))))) + { /* (do ((i 0 (+ i 1)) (z (random 100) (random 100))) ((= i 5000000) counts) (hash-table-set! counts z (+ (or (hash-table-ref counts z) 0) 1))) */ + s7_int i = integer(slot_value(s2)); + s7_int endi = (is_t_integer(caddr(endp))) ? integer(caddr(endp)) : integer(slot_value(s3)); do { fp(o); slot_set_value(s1, f1(sc, p1)); i++; } while (i < endi); + slot_set_value(s2, make_integer(sc, endi)); } else - do { + do { /* (do ((i 0 (+ i 1)) (lst lis (cdr lst))) ((= i (- len 1)) (reverse result)) (set! result (cons (car lst) result))) */ fp(o); slot_set_value(s1, f1(sc, p1)); slot_set_value(s2, f2(sc, p2)); } while ((sc->value = endf(sc, endp)) == sc->F); } else - do { + do { /* (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3) x) (set! x (max x (* i j)))) */ bodyf(sc); slot_set_value(s1, f1(sc, p1)); slot_set_value(s2, f2(sc, p2)); @@ -81910,7 +82015,7 @@ static goto_t op_dox(s7_scheme *sc) return(goto_do_end_clauses); } if (bodyf == opt_cell_any_nv) - { + { /* (do ((i npats (- i 1)) (ipats ipats (cdr ipats)) (a '())) ((zero? i) a) (set! a (cons (car ipats) a))) */ opt_info *o = sc->opts[0]; s7_pointer (*fp)(opt_info *o) = o->v[0].fp; do { @@ -81924,7 +82029,7 @@ static goto_t op_dox(s7_scheme *sc) } while ((sc->value = endf(sc, endp)) == sc->F); } else - do { + do { /* (do ((i 0 (+ i 1)) (ph 0.0 (+ ph incr)) (kph 0.0 (+ kph kincr))) ((= i 4410)) (float-vector-set! v1 i (+ (cos ph) (cos kph)))) */ s7_pointer slot1 = slots; bodyf(sc); do { @@ -81960,7 +82065,7 @@ static goto_t op_dox(s7_scheme *sc) val = car(val); stepf = fx_proc(slot_expression(stepper)); stepa = car(slot_expression(stepper)); - do { + do { /* (do ((i 1 4)) ((> i 3)) (set! x (+ x i))) */ slot_set_value(slot, valf(sc, val)); slot_set_value(stepper, stepf(sc, stepa)); } while ((sc->value = endf(sc, endp)) == sc->F); @@ -81972,6 +82077,7 @@ static goto_t op_dox(s7_scheme *sc) if ((has_gx(body)) || (gx_annotate_arg(sc, code, sc->curlet))) { s7_function f = fx_proc_unchecked(code); + if (S7_DEBUGGING) fprintf(stderr, "%d: %s\n", __LINE__, display(form)); do { s7_pointer slot1 = slots; f(sc, body); @@ -82025,17 +82131,17 @@ static goto_t op_dox(s7_scheme *sc) s7_function stepf = NULL; if (!use_opts) fx_annotate_args(sc, code, sc->curlet); - if (stepper) { stepf = fx_proc(slot_expression(stepper)); stepa = car(slot_expression(stepper)); } - while (true) + while (true) /* (do ((i 0 (+ 1 i))) ((= end i)) (set! end 8) (display i)) */ { if (use_opts) for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); + /* opt_set_p_d_f shoot: 144,186,857 => s7.c:opt_set_p_d_f (2,093,278x) (b also, big/fft as part of fft code 7M) */ else for (p = code; is_pair(p); p = cdr(p)) fx_call(sc, p); @@ -82383,10 +82489,8 @@ static bool do_step1(s7_scheme *sc) for (s7_pointer x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ { s7_pointer slot = car(x); -#if 0 if (is_immutable_slot(slot)) /* (let () (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (immutable! 'i)))) (func)) */ immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S is immutable in ~S", 21), slot_symbol(slot), car(slot_expression(slot)))); -#endif slot_set_value(slot, slot_pending_value(slot)); slot_clear_has_pending_value(slot); } @@ -83013,23 +83117,39 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool one { /* (do ((i 0 (+ i 1))) ((= i size) sum) (set! sum (+ sum (floor (vector-ref v i))))) */ opt_info *o = sc->opts[0]; s7_int (*fi)(opt_info *o) = o->v[0].fi; + if ((fi == opt_set_i_i_f) || (fi == opt_set_i_i_fo)) + { + slot_set_value(o->v[1].p, make_mutable_integer(sc, integer(slot_value(o->v[1].p)))); + fi = (fi == opt_set_i_i_f) ? opt_set_i_i_fm : opt_set_i_i_fom; + } while (step < stop) { fi(o); step = ++integer(step_val); - }} + } + if ((fi == opt_set_i_i_fm) || (fi == opt_set_i_i_fom)) + clear_mutable_integer(slot_value(o->v[1].p)); + } else if (func == opt_float_any_nv) { /* (do ((i 1 (+ i 1))) ((= i 1000)) (set! (v i) (filter f1 0.0))) */ opt_info *o = sc->opts[0]; s7_double (*fd)(opt_info *o) = o->v[0].fd; + if (fd == opt_set_d_d_f) + { /* (do ((i 0 (+ i 1))) ((= i 32768)) (set! sum (+ sum (float-vector-ref ndat i)))) */ + slot_set_value(o->v[1].p, make_mutable_real(sc, real(slot_value(o->v[1].p)))); + fd = opt_set_d_d_fm; + } while (step < stop) { fd(o); step = ++integer(step_val); - }} + } + 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) */ + { /* 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);} }} @@ -83054,6 +83174,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool one body[k] = sc->opts[sc->pc]; if (!float_optimize(sc, p)) break; + /* if opt_set_d_d_f -> fm mutablizing body[k]->v[1].p? see 83033 but protect against (data i) as below */ } if (is_pair(p)) { @@ -83079,6 +83200,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool one step_val = slot_value(step_slot); for (s7_int step = integer(step_val); step < stop; step = ++integer(step_val)) for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); + /* tari[99 ff]: 4 calls here all safe (see d_syntax_ok, need to make the change and the list here dependent on two-sets bit(?) (3.3M calls) */ + /* tall: (3.3M calls) */ } sc->value = sc->T; sc->code = cdadr(scc); @@ -83168,12 +83291,12 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) return(false); } if (let_star) - add_slot_checked(sc, sc->curlet, caar(p), s7_make_mutable_real(sc, 1.5)); + add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5)); } if (!let_star) for (p = let_vars; is_pair(p); p = cdr(p)) - add_slot_checked(sc, sc->curlet, caar(p), s7_make_mutable_real(sc, 1.5)); + add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5)); for (k = 0, p = let_body; is_pair(p); k++, p = cdr(p)) { @@ -83201,7 +83324,7 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) s7_pointer xp = t_lookup(sc, caar(let_vars), let_vars); s7_double (*f1)(opt_info *o) = first->v[0].fd; s7_double (*f2)(opt_info *o) = o->v[0].fd; - integer(ip) = numerator(stepper); + set_integer(ip, numerator(stepper)); set_real(xp, f1(first)); f2(o); if ((f2 == opt_fmv) && @@ -83235,7 +83358,7 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) else for (k = numerator(stepper) + 1; k < end; k++) { - integer(ip) = k; + set_integer(ip, k); set_real(xp, f1(first)); f2(o); }} /* body_len == 1 and var_len == 1 */ @@ -83247,7 +83370,7 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) s7_pointer s2 = next_slot(s1); for (k = numerator(stepper); k < end; k++) { - integer(ip) = k; + set_integer(ip, k); set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); set_real(slot_value(s2), vars[1]->v[0].fd(vars[1])); body[0]->v[0].fd(body[0]); @@ -83255,7 +83378,7 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) else for (k = numerator(stepper); k < end; k++) { - integer(ip) = k; + set_integer(ip, k); p = let_slots(sc->curlet); for (int32_t n = 0; tis_slot(p); n++, p = next_slot(p)) set_real(slot_value(p), vars[n]->v[0].fd(vars[n])); @@ -83267,7 +83390,7 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) s7_pointer s1 = let_slots(sc->curlet); for (k = numerator(stepper); k < end; k++) { - integer(ip) = k; + set_integer(ip, k); set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); body[0]->v[0].fd(body[0]); body[1]->v[0].fd(body[1]); @@ -83276,7 +83399,7 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) for (k = numerator(stepper); k < end; k++) { int32_t i; - integer(ip) = k; + set_integer(ip, k); for (i = 0, p = let_slots(sc->curlet); tis_slot(p); i++, p = next_slot(p)) set_real(slot_value(p), vars[i]->v[0].fd(vars[i])); for (i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); @@ -83468,7 +83591,7 @@ static goto_t op_safe_do(s7_scheme *sc) s7_pointer step_val = slot_value(step_slot); do { slot_set_value(val_slot, fx_call(sc, fx_p)); - integer(step_val) = ++step; + set_integer(step_val, ++step); } while (step != endi); /* geq not needed here -- we're leq endi and stepping by +1 all ints */ clear_mutable_integer(step_val); sc->value = sc->T; @@ -83575,7 +83698,7 @@ static bool op_do_init_1(s7_scheme *sc) sc->args = cdr(sc->args); /* init values */ /* sc->args was cons'd above, so it should be safe to reuse it as the new let */ - set_curlet(sc, reuse_as_let(sc, z, sc->curlet)); /* set_curlet(sc, make_let(sc, sc->curlet)); */ + 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; @@ -84707,7 +84830,7 @@ static void op_define_with_setter(s7_scheme *sc) */ set_let_file_and_line(sc, new_let, new_func); /* add the newly defined thing to the current environment */ - if (is_let(sc->curlet)) + if ((is_let(sc->curlet)) && (sc->curlet != sc->rootlet)) { if (let_id(sc->curlet) <= symbol_id(code)) /* we're adding a later-bound symbol to an old let (?) */ { /* was < 16-Aug-22: (let ((a 3)) (define (a) 4) (curlet)) */ @@ -86076,7 +86199,7 @@ static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code, bool cond) { s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); slot_set_value(la_slot, val); - while (!(o->v[0].fb(o))){integer(val) = o1->v[0].fi(o1);} + while (!(o->v[0].fb(o))){set_integer(val, o1->v[0].fi(o1));} return(op_tc_z(sc, if_true)); }}} while (fx_call(sc, if_test) == sc->F) {slot_set_value(la_slot, fx_call(sc, la));} @@ -86113,7 +86236,7 @@ static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code, bool cond) { s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); slot_set_value(la_slot, val); - while (o->v[0].fb(o)) {integer(val) = o1->v[0].fi(o1);} + while (o->v[0].fb(o)) {set_integer(val, o1->v[0].fi(o1));} return(op_tc_z(sc, if_false)); }}} while (fx_call(sc, if_test) != sc->F) {slot_set_value(la_slot, fx_call(sc, la));} @@ -86186,15 +86309,15 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_ch while (integer(slot_value(slot1)) >= lim) { s7_int i1 = integer(slot_value(slot2)) - m; - integer(val2) = fi2(o2); - integer(val1) = i1; + set_integer(val2, fi2(o2)); + set_integer(val1, i1); }} else while (fb(o) != z_first) { s7_int i1 = fi1(o1); - integer(val2) = fi2(o2); - integer(val1) = i1; + set_integer(val2, fi2(o2)); + set_integer(val1, i1); } return(op_tc_z(sc, if_z)); }}} @@ -86211,8 +86334,8 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_ch s7_double (*fd1)(opt_info *o) = o1->v[0].fd; s7_double (*fd2)(opt_info *o) = o2->v[0].fd; bool (*fb)(opt_info *o) = o->v[0].fb; - s7_pointer val1 = s7_make_mutable_real(sc, real(slot_value(la_slot))); - s7_pointer val2 = s7_make_mutable_real(sc, real(slot_value(laa_slot))); + s7_pointer val1 = make_mutable_real(sc, real(slot_value(la_slot))); + s7_pointer val2 = make_mutable_real(sc, real(slot_value(laa_slot))); slot_set_value(la_slot, val1); slot_set_value(laa_slot, val2); if ((z_first) && @@ -86226,15 +86349,15 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_ch while (real(slot_value(slot1)) >= lim) { s7_double x1 = real(slot_value(slot2)) - m; - real(val2) = fd2(o2); - real(val1) = x1; + set_real(val2, fd2(o2)); + set_real(val1, x1); }} else while (fb(o) != z_first) { s7_double x1 = fd1(o1); - real(val2) = fd2(o2); - real(val1) = x1; + set_real(val2, fd2(o2)); + set_real(val1, x1); } return(op_tc_z(sc, if_z)); }}}} @@ -86442,14 +86565,14 @@ static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, { if (!o->v[0].fb(o)) {sc->value = sc->F; return(true);} if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} - integer(val) = o2->v[0].fi(o2); + set_integer(val, o2->v[0].fi(o2)); } else while (true) { if (o->v[0].fb(o)) {endp = if_true; break;} if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} - integer(val) = o2->v[0].fi(o2); + set_integer(val, o2->v[0].fi(o2)); } return(op_tc_z(sc, endp)); }}}} @@ -86737,9 +86860,9 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) while (!(o->v[0].fb(o))) { s7_int i1 = o1->v[0].fi(o1); - integer(val2) = o2->v[0].fi(o2); - integer(val1) = i1; - integer(val3) = o3->v[0].fi(o3); + set_integer(val2, o2->v[0].fi(o2)); + set_integer(val1, i1); + set_integer(val3, o3->v[0].fi(o3)); } unstack_gc_protect(sc); if (!op_tc_z(sc, if_true)) /* sc->inner_let in effect here since it was the last set above */ @@ -87210,7 +87333,7 @@ static s7_int oprec_i_if_a_a_opa_laq(s7_scheme *sc) s7_int i1; if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); + set_integer(sc->rec_val1, sc->rec_a2_o->v[0].fi(sc->rec_a2_o)); return(sc->rec_i_ii_f(i1, oprec_i_if_a_a_opa_laq(sc))); } @@ -87219,7 +87342,7 @@ static s7_int oprec_i_if_a_opa_laq_a(s7_scheme *sc) s7_int i1; if (!sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); + set_integer(sc->rec_val1, sc->rec_a2_o->v[0].fi(sc->rec_a2_o)); return(sc->rec_i_ii_f(i1, oprec_i_if_a_opa_laq_a(sc))); } @@ -87522,7 +87645,7 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) sc->rec_a2_o = sc->opts[sc->pc]; if (float_optimize(sc, cdr(opt3_pair(caller)))) { - sc->rec_val1 = s7_make_mutable_real(sc, real(slot_value(slot))); + sc->rec_val1 = make_mutable_real(sc, real(slot_value(slot))); slot_set_value(slot, sc->rec_val1); return(OPT_DBL); }}}}}}}} @@ -87542,9 +87665,9 @@ static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc) if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) /* if_(A) */ return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */ i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */ - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); /* slot1 = a2 */ + set_integer(sc->rec_val1, sc->rec_a2_o->v[0].fi(sc->rec_a2_o));/* slot1 = a2 */ i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */ - integer(sc->rec_val1) = i1; /* slot1 = a1 */ + set_integer(sc->rec_val1, i1); /* slot1 = a1 */ return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq(sc), i2)); /* call op(la1, la2) */ } @@ -87553,19 +87676,19 @@ static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme *sc) s7_int i1, i2; if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); i1 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o)); if (sc->rec_fb1(sc->rec_test_o)) i2 = sc->rec_fi1(sc->rec_result_o); else { s7_int i3; i2 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o)); i3 = oprec_i_if_a_a_opla_laq_0(sc); - integer(sc->rec_val1) = i2; + set_integer(sc->rec_val1, i2); i2 = sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i3); } - integer(sc->rec_val1) = i1; + set_integer(sc->rec_val1, i1); return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i2)); } @@ -87574,19 +87697,19 @@ static s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc) s7_double x1, x2; if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); + set_real(sc->rec_val1, sc->rec_a2_o->v[0].fd(sc->rec_a2_o)); if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) x2 = sc->rec_result_o->v[0].fd(sc->rec_result_o); else { s7_double x3; x2 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); + set_real(sc->rec_val1, sc->rec_a2_o->v[0].fd(sc->rec_a2_o)); x3 = oprec_d_if_a_a_opla_laq(sc); - real(sc->rec_val1) = x2; + set_real(sc->rec_val1, x2); x2 = sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x3); } - real(sc->rec_val1) = x1; + set_real(sc->rec_val1, x1); return(sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x2)); } @@ -87606,9 +87729,9 @@ static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc) s7_int i1, i2; if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); + set_integer(sc->rec_val1, sc->rec_a2_o->v[0].fi(sc->rec_a2_o)); i2 = oprec_i_if_a_opla_laq_a(sc); - integer(sc->rec_val1) = i1; + set_integer(sc->rec_val1, i1); return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a(sc), i2)); } @@ -87617,19 +87740,19 @@ static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme *sc) s7_int i1, i2; if (!sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); i1 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o)); if (!sc->rec_fb1(sc->rec_test_o)) i2 = sc->rec_fi1(sc->rec_result_o); else { s7_int i3; i2 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o)); i3 = oprec_i_if_a_opla_laq_a_0(sc); - integer(sc->rec_val1) = i2; + set_integer(sc->rec_val1, i2); i2 = sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i3); } - integer(sc->rec_val1) = i1; + set_integer(sc->rec_val1, i1); return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i2)); } @@ -87638,9 +87761,9 @@ static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc) s7_double x1, x2; if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); + set_real(sc->rec_val1, sc->rec_a2_o->v[0].fd(sc->rec_a2_o)); x2 = oprec_d_if_a_opla_laq_a(sc); - real(sc->rec_val1) = x1; + set_real(sc->rec_val1, x1); return(sc->rec_d_dd_f(oprec_d_if_a_opla_laq_a(sc), x2)); } @@ -88218,16 +88341,16 @@ static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) if (sc->rec_a1_o->v[0].fb(sc->rec_a1_o)) { i1 = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - integer(sc->rec_val2) = sc->rec_a3_o->v[0].fi(sc->rec_a3_o); - integer(sc->rec_val1) = i1; + set_integer(sc->rec_val2, sc->rec_a3_o->v[0].fi(sc->rec_a3_o)); + set_integer(sc->rec_val1, i1); return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); } i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o); i2 = sc->rec_a5_o->v[0].fi(sc->rec_a5_o); - integer(sc->rec_val2) = sc->rec_a6_o->v[0].fi(sc->rec_a6_o); - integer(sc->rec_val1) = i2; - integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq(sc); - integer(sc->rec_val1) = i1; + set_integer(sc->rec_val2, sc->rec_a6_o->v[0].fi(sc->rec_a6_o)); + set_integer(sc->rec_val1, i2); + set_integer(sc->rec_val2, oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); + set_integer(sc->rec_val1, i1); return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); } @@ -88238,16 +88361,16 @@ static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq_0(s7_scheme *sc) if (sc->rec_fb2(sc->rec_a1_o)) { i1 = sc->rec_fi2(sc->rec_a2_o); - integer(sc->rec_val2) = sc->rec_fi3(sc->rec_a3_o); - integer(sc->rec_val1) = i1; + set_integer(sc->rec_val2, sc->rec_fi3(sc->rec_a3_o)); + set_integer(sc->rec_val1, i1); return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); } i1 = sc->rec_fi4(sc->rec_a4_o); i2 = sc->rec_fi5(sc->rec_a5_o); - integer(sc->rec_val2) = sc->rec_fi6(sc->rec_a6_o); - integer(sc->rec_val1) = i2; - integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc); - integer(sc->rec_val1) = i1; + set_integer(sc->rec_val2, sc->rec_fi6(sc->rec_a6_o)); + set_integer(sc->rec_val1, i2); + set_integer(sc->rec_val2, oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); + set_integer(sc->rec_val1, i1); return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); } @@ -90362,7 +90485,7 @@ static bool is_immutable_and_stable(s7_scheme *sc, s7_pointer func) return(false); if ((is_global(func)) && (is_immutable_slot(global_slot(func)))) return(true); - for (s7_pointer p = sc->curlet; is_let(p); p = let_outlet(p)) + for (s7_pointer p = sc->curlet; p; p = let_outlet(p)) if ((is_funclet(p)) && (funclet_function(p) != func)) return(false); return(is_immutable_slot(s7_slot(sc, func))); @@ -93393,22 +93516,24 @@ 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"); for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "out-of-range"); for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple out-of-range"); - - { - s7_pointer *tmp = rootlet_elements(sc->rootlet); - s7_pointer *top = (s7_pointer *)(tmp + sc->rootlet_entries); - while (tmp < top) {s7_pointer slot = *tmp++; mark_holdee(NULL, slot_value(slot), "rootlet");} - } + for (s7_pointer y = sc->rootlet_slots; tis_slot(y); y = next_slot(y)) + mark_holdee(NULL, slot_value(y), "rootlet"); #if WITH_HISTORY for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3)) { @@ -93530,7 +93655,6 @@ static s7_pointer g_is_op_stack(s7_scheme *sc, s7_pointer args) /* -------------------------------- *s7* let -------------------------------- */ -/* maybe *features* field in *s7*, others are *libraries*, *load-path*, *cload-directory*, *autoload*, *#readers* */ static noreturn void s7_starlet_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ) { @@ -93571,7 +93695,7 @@ static s7_pointer make_s7_starlet(s7_scheme *sc) /* *s7* is semipermanent -- 20 s7_pointer x = alloc_pointer(sc); set_full_type(x, T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK); let_set_id(x, ++sc->let_number); - let_set_outlet(x, sc->nil); + let_set_outlet(x, sc->rootlet); symbol_set_local_slot(sc->let_set_fallback_symbol, sc->let_number, slot1); slot_set_next(slot1, slot_end); symbol_set_local_slot(sc->let_ref_fallback_symbol, sc->let_number, slot2); @@ -93704,7 +93828,7 @@ static s7_pointer memory_usage(s7_scheme *sc) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "IO", 2), cons(sc, make_integer(sc, info.ru_inblock), make_integer(sc, info.ru_oublock))); #endif - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size", 12), make_integer(sc, sc->rootlet_entries)); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size", 12), make_integer(sc, let_length(sc, sc->rootlet))); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-size", 9), cons(sc, make_integer(sc, sc->heap_size), kmg(sc, sc->heap_size * (sizeof(s7_cell) + 2 * sizeof(s7_pointer))))); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cell-size", 9), make_integer(sc, sizeof(s7_cell))); @@ -94047,7 +94171,7 @@ static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice) case SL_PROFILE: return(make_integer(sc, sc->profile)); case SL_PROFILE_INFO: return(profile_info_out(sc)); case SL_PROFILE_PREFIX: return(sc->profile_prefix); - case SL_ROOTLET_SIZE: return(make_integer(sc, sc->rootlet_entries)); + case SL_ROOTLET_SIZE: return(make_integer(sc, let_length(sc, sc->rootlet))); case SL_SAFETY: return(make_integer(sc, sc->safety)); case SL_STACK: return(sl_stack_entries(sc, sc->stack, stack_top(sc))); case SL_STACKTRACE_DEFAULTS: return(copy_proper_list(sc, sc->stacktrace_defaults)); /* if not copied, we can set! entries directly to garbage */ @@ -94560,6 +94684,8 @@ static void init_s7_starlet_immutable_field(void) s7_starlet_immutable_field[SL_MINOR_VERSION] = true; } +#define NUM_INTEGER_WRAPPERS 4 +#define NUM_REAL_WRAPPERS 4 /* ---------------- gdbinit annotated stacktrace ---------------- */ #if (!MS_WINDOWS) @@ -94583,7 +94709,6 @@ static const char *decoded_name(s7_scheme *sc, const s7_pointer p) if (p == sc->symbol_table) return("symbol_table"); if (p == sc->rootlet) return("rootlet"); if (p == sc->s7_starlet) return("*s7*"); /* this is the function */ - if (p == sc->unlet) return("unlet"); if (p == sc->owlet) return("owlet"); if (p == sc->standard_input) return("*stdin*"); if (p == sc->standard_output) return("*stdout*"); @@ -94593,6 +94718,14 @@ static const char *decoded_name(s7_scheme *sc, const s7_pointer p) if (p == current_output_port(sc)) return("current-output-port"); if (p == current_error_port(sc)) return("current-error_port"); if ((is_let(p)) && (is_unlet(p))) return("unlet"); + { + s7_pointer wrapper; + int32_t i; + for (i = 0, wrapper = sc->string_wrappers; i < NUM_STRING_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("string-wrapper"); + for (i = 0, wrapper = sc->integer_wrappers; i < NUM_INTEGER_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("integer-wrapper"); + for (i = 0, wrapper = sc->real_wrappers; i < NUM_REAL_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("real-wrapper"); + for (i = 0, wrapper = sc->c_pointer_wrappers; i < NUM_C_POINTER_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("c-pointer-wrapper"); + } return((p == sc->stack) ? "stack" : NULL); } @@ -95506,15 +95639,13 @@ static void init_features(s7_scheme *sc) static void init_wrappers(s7_scheme *sc) { s7_pointer cp, qp; - #define NUM_INTEGER_WRAPPERS 4 - #define NUM_REAL_WRAPPERS 4 sc->integer_wrappers = semipermanent_list(sc, NUM_INTEGER_WRAPPERS); for (cp = sc->integer_wrappers, qp = sc->integer_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) { s7_pointer p = alloc_pointer(sc); - full_type(p) = T_INTEGER | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; /* mutable to turn off set_has_number_name */ - integer(p) = 0; + full_type(p) = T_INTEGER | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; /* mutable to turn off set_has_number_name (see set_number_name) */ + set_integer(p, 0); set_car(cp, p); } unchecked_set_cdr(qp, sc->integer_wrappers); @@ -95524,7 +95655,7 @@ static void init_wrappers(s7_scheme *sc) { s7_pointer p = alloc_pointer(sc); full_type(p) = T_REAL | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; - real(p) = 0.0; + set_real(p, 0.0); set_car(cp, p); } unchecked_set_cdr(qp, sc->real_wrappers); @@ -95559,9 +95690,10 @@ static void init_wrappers(s7_scheme *sc) static s7_pointer syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) { - uint64_t hash = raw_string_hash((const uint8_t *)name, safe_strlen(name)); + s7_int len = safe_strlen(name); + uint64_t hash = raw_string_hash((const uint8_t *)name, len); uint32_t loc = hash % SYMBOL_TABLE_SIZE; - s7_pointer x = new_symbol(sc, name, safe_strlen(name), hash, loc); + s7_pointer x = new_symbol(sc, name, len, hash, loc); s7_pointer syn = alloc_pointer(sc); set_full_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_GLOBAL | T_UNHEAP); @@ -95572,6 +95704,8 @@ static s7_pointer syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointe syntax_documentation(syn) = doc; set_global_slot(x, make_semipermanent_slot(sc, x, syn)); set_initial_slot(x, make_semipermanent_slot(sc, x, syn)); /* set_local_slot(x, global_slot(x)); */ + slot_set_next(initial_slot(x), sc->unlet_slots); + sc->unlet_slots = initial_slot(x); set_type_bit(x, T_SYMBOL | T_SYNTACTIC | T_GLOBAL | T_UNHEAP); symbol_set_local_slot_unchecked(x, 0LL, sc->nil); symbol_clear_ctr(x); @@ -95771,6 +95905,7 @@ then returns each var to its original value." sc->unless_symbol = syntax(sc, "unless", OP_UNLESS, int_two, max_arity, H_unless); sc->begin_symbol = syntax(sc, "begin", OP_BEGIN, int_zero, max_arity, H_begin); /* (begin) is () */ sc->set_symbol = syntax(sc, "set!", OP_SET, int_two, int_two, H_set); + set_is_setter(sc->set_symbol); /* ? 26-Jan-24 */ sc->cond_symbol = copy_args_syntax(sc, "cond", OP_COND, int_one, max_arity, H_cond); sc->and_symbol = copy_args_syntax(sc, "and", OP_AND, int_zero, max_arity, H_and); sc->or_symbol = copy_args_syntax(sc, "or", OP_OR, int_zero, max_arity, H_or); @@ -95833,7 +95968,7 @@ then returns each var to its original value." sc->function_symbol = make_symbol(sc, "function", 8); sc->else_symbol = make_symbol(sc, "else", 4); - s7_make_slot(sc, sc->nil, sc->else_symbol, sc->else_symbol); + s7_make_slot(sc, sc->rootlet, sc->else_symbol, sc->else_symbol); slot_set_value(initial_slot(sc->else_symbol), s7_make_keyword(sc, "else")); /* 3-Oct-23 was #t */ /* if we set #_else to 'else, it can pick up a local else value: (let ((else #f)) (cond (#_else 2)...)) -- #_* is read-time */ @@ -95849,11 +95984,6 @@ static void init_rootlet(s7_scheme *sc) { /* most of init_rootlet (the built-in functions for example), could be shared by all s7 instances. * currently, each s7_init call allocates room for them, then s7_free frees it -- kinda wasteful. - * allocate separately filling unlet then set symbols in init_rootlet by running through unlet and calling s7_define for each? - * need pre-unlet separate from thread-local unlet (dynamic loads). - * but currently the init_unlet run through the symbol table is wasting lots of time. - * unlet has only c_functions/syntax but should we support #_gsl* etc? - * split init_unlet, add load to defun macros */ s7_pointer sym; init_syntax(sc); @@ -96471,7 +96601,7 @@ static void init_rootlet(s7_scheme *sc) s7_set_setter(sc, sc->features_symbol, sc->features_setter = s7_make_safe_function(sc, "#<set-*features*>", g_features_set, 2, 0, false, "*features* setter")); /* -------- *load-path* -------- */ - sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", list_1(sc, make_string_with_length(sc, ".", 1)), /* not plist! */ + sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", sc->nil, /* list_1(sc, make_string_with_length(sc, ".", 1)), */ /* not plist! */ "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name"); s7_set_setter(sc, sc->load_path_symbol, s7_make_safe_function(sc, "#<set-*load-path*>", g_load_path_set, 2, 0, false, "*load-path* setter")); @@ -96631,12 +96761,8 @@ s7_scheme *s7_init(void) sc->unspecified = make_unique(sc, "#<unspecified>", T_UNSPECIFIED); sc->no_value = make_unique(sc, (SHOW_EVAL_OPS) ? "#<no-value>" : "#<unspecified>", T_UNSPECIFIED); - unique_car(sc->nil) = sc->unspecified; + unique_car(sc->nil) = sc->unspecified; /* see op_if1 */ unique_cdr(sc->nil) = sc->unspecified; - /* this is mixing two different s7_cell structs, cons and envr, but luckily envr has two initial s7_pointer fields, equivalent to car and cdr, so - * let_id which is the same as opt1 is unaffected. To get the names built-in, I'll append unique_name and unique_name_length fields to the envr struct. - */ - let_set_id(sc->nil, -1); unique_cdr(sc->unspecified) = sc->unspecified; sc->t1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); @@ -96731,7 +96857,7 @@ s7_scheme *s7_init(void) #if S7_DEBUGGING sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; #endif - clear_type(sc->heap[i]); + clear_type(sc->heap[i]); /* type(sc->heap[i]) = T_FREE */ i++; sc->heap[i] = &cells[i]; sc->free_heap[i] = sc->heap[i]; @@ -96740,6 +96866,8 @@ s7_scheme *s7_init(void) #endif clear_type(sc->heap[i]); } + /* memcpy((void *)(sc->free_heap), (const void *)(sc->heap), sizeof(s7_pointer) * INITIAL_HEAP_SIZE); */ + /* weird that this memcpy (without the equivalent sets above) is much slower */ sc->heap_blocks = (heap_block_t *)Malloc(sizeof(heap_block_t)); sc->heap_blocks->start = (intptr_t)cells; sc->heap_blocks->end = (intptr_t)cells + (sc->heap_size * sizeof(s7_cell)); @@ -96752,6 +96880,12 @@ s7_scheme *s7_init(void) sc->max_heap_size = (1LL << 45); sc->gc_calls = 0; sc->gc_total_time = 0; + /* unvectorize free-heap? t_free obj nxt -> next in list, free_heap_top|length; get free: obj=free_heap_top; top=nxt; len-- + * push: cur->nxt=top, top=cur len++; trigger when len<trigger; can still do batch alloc/free setting len at end; + * how to gc sweep tmps -- seems to require a back pointer (2-way list) but there's no room; no need to realloc when heap grows, but do + * need to place new cells on the free list; no malloc needed, but we need to make the initial list; saves 1/8 of heap-related space. + * maybe a circular list (vector?) for tmps + */ sc->max_port_data_size = (1LL << 45); #ifndef OUTPUT_FILE_PORT_DATA_SIZE @@ -96900,12 +97034,16 @@ s7_scheme *s7_init(void) sc->tree_pointers_size = 0; sc->tree_pointers_top = 0; - sc->rootlet = make_vector_1(sc, INITIAL_ROOTLET_SIZE, FILLED, T_VECTOR); - set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE); - sc->rootlet_entries = 0; - for (i = 0; i < INITIAL_ROOTLET_SIZE; i++) rootlet_element(sc->rootlet, i) = sc->nil; - set_curlet(sc, sc->nil); - sc->shadow_rootlet = sc->nil; + sc->rootlet = alloc_pointer(sc); + set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE | T_UNHEAP); + let_set_id(sc->rootlet, -1); + let_set_outlet(sc->rootlet, NULL); + let_set_slots(sc->rootlet, slot_end); + add_semipermanent_let_or_slot(sc, sc->rootlet); /* need to mark outlet and maybe slot values */ + sc->rootlet_slots = slot_end; + set_curlet(sc, sc->rootlet); + sc->shadow_rootlet = sc->rootlet; + sc->unlet_slots = slot_end; sc->objstr_max_len = S7_INT64_MAX; init_wrappers(sc); @@ -96940,6 +97078,8 @@ s7_scheme *s7_init(void) sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc)); /* not actually a constant because it changes with bignum-precision */ set_initial_slot(sc->pi_symbol, make_semipermanent_slot(sc, sc->pi_symbol, big_pi(sc))); /* s7_make_slot does not handle this */ + slot_set_next(initial_slot(sc->pi_symbol), sc->unlet_slots); + sc->unlet_slots = initial_slot(sc->pi_symbol); s7_provide(sc, "gmp"); #else random_seed(p) = (uint64_t)my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */ @@ -96964,7 +97104,6 @@ s7_scheme *s7_init(void) init_tc_rec(sc); #endif - init_unlet(sc); init_signatures(sc); /* depends on procedure symbols */ sc->s7_starlet = make_s7_starlet(sc); s7_set_history_enabled(sc, true); @@ -97254,8 +97393,6 @@ void s7_free(s7_scheme *sc) big_block_free(sc, stack_block(sc->stack)); big_block_free(sc, vector_block(sc->protected_objects)); - big_block_free(sc, rootlet_block(sc->rootlet)); - for (i = 0; i < sc->saved_pointers_loc; i++) free(sc->saved_pointers[i]); free(sc->saved_pointers); @@ -97272,7 +97409,6 @@ void s7_free(s7_scheme *sc) free(sc->free_heap); free(vector_elements(sc->symbol_table)); /* alloc'd directly, not via block */ free(sc->symbol_table); - free(sc->unlet); free(sc->setters); free(sc->op_stack); if (sc->tree_pointers) free(sc->tree_pointers); @@ -97370,7 +97506,7 @@ void s7_repl(s7_scheme *sc) { s7_pointer libs = global_slot(sc->libraries_symbol); uint64_t hash = raw_string_hash((const uint8_t *)"*libc*", 6); /* hack around an idiotic gcc 10.2.1 warning */ - s7_define(sc, sc->nil, new_symbol(sc, "*libc*", 6, hash, hash % SYMBOL_TABLE_SIZE), e); + s7_define(sc, sc->rootlet, new_symbol(sc, "*libc*", 6, hash, hash % SYMBOL_TABLE_SIZE), e); slot_set_value(libs, cons(sc, cons(sc, s7_make_semipermanent_string(sc, "libc.scm"), e), slot_value(libs))); } @@ -97475,69 +97611,70 @@ int main(int argc, char **argv) #endif #endif -/* --------------------------------------------- - * 20.9 21.0 22.0 23.0 24.0 - * --------------------------------------------- - * tpeak 115 114 108 105 102 148 - * tref 691 687 463 459 464 1081 - * index 1026 1016 973 967 972 - * tmock 1177 1165 1057 1019 1032 - * tvect 2519 2464 1772 1669 1497 3408 - * tauto ---- ---- 2562 2048 1729 - * timp 2637 2575 1930 1694 1740 - * texit ---- ---- 1778 1741 1770 1884 - * s7test 1873 1831 1818 1829 1830 - * lt 2187 2172 2150 2185 1950 2222 - * thook ---- ---- 2590 2030 2046 7651 - * dup 3805 3788 2492 2239 2097 - * tcopy 8035 5546 2539 2375 2386 - * tread 2440 2421 2419 2408 2405 - * trclo 2735 2574 2454 2445 2449 8031 - * titer 2865 2842 2641 2509 2449 3657 - * fbench 2688 2583 2460 2430 2478 2933 - * tload ---- ---- 3046 2404 2566 - * tmat 3065 3042 2524 2578 2590 - * tsort 3105 3104 2856 2804 2858 3683 - * tobj 4016 3970 3828 3577 3508 - * teq 4068 4045 3536 3486 3544 - * tio 3816 3752 3683 3620 3583 - * tmac 3950 3873 3033 3677 3677 - * tcase 4960 4793 4439 4430 4439 - * tlet 7775 5640 4450 4427 4457 9166 - * tclo 4787 4735 4390 4384 4474 6362 - * tfft 7820 7729 4755 4476 4536 - * tstar 6139 5923 5519 4449 4550 - * tmap 8869 8774 4489 4541 4586 - * tshoot 5525 5447 5183 5055 5034 - * tform 5357 5348 5307 5316 5084 - * tstr 6880 6342 5488 5162 5180 10.0 - * tnum 6348 6013 5433 5396 5409 - * tgsl 8485 7802 6373 6282 6208 - * tari 13.0 12.7 6827 6543 6278 15.0 - * tlist 7896 7546 6558 6240 6300 9219 - * tset ---- ---- ---- 6260 6364 - * trec 6936 6922 6521 6588 6583 19.5 - * tleft 10.4 10.2 7657 7479 7627 11.1 - * tmisc ---- ---- ---- 8488 7862 6386 - * tlamb ---- ---- ---- ---- 7941 9894 - * tgc 11.9 11.1 8177 7857 7986 - * thash 11.8 11.7 9734 9479 9526 - * cb 11.2 11.0 9658 9564 9609 12.9 - * tgen 11.2 11.4 12.0 12.1 12.2 - * tall 15.6 15.6 15.6 15.6 15.1 15.9 - * calls 36.7 37.5 37.0 37.5 37.1 - * sg ---- ---- 55.9 55.8 55.4 - * tbig 177.4 175.8 156.5 148.1 146.2 - * --------------------------------------------- +/* ------------------------------------------------------------- + * 19.9 20.9 21.0 22.0 23.0 24.0 24.1 + * ------------------------------------------------------------- + * tpeak 148 115 114 108 105 102 102 + * tref 1081 691 687 463 459 464 466 + * index 1026 1016 973 967 972 974 + * tmock 1177 1165 1057 1019 1032 1037 + * tvect 3408 2519 2464 1772 1669 1497 1452 + * tauto 2562 2048 1729 1704 + * timp 2637 2575 1930 1694 1740 1738 + * texit 1884 1778 1741 1770 1771 + * s7test 1873 1831 1818 1829 1830 1855 + * lt 2222 2187 2172 2150 2185 1950 1950 + * thook 7651 2590 2030 2046 2046 + * dup 3805 3788 2492 2239 2097 2042 + * tcopy 8035 5546 2539 2375 2386 2386 + * tread 2440 2421 2419 2408 2405 2402 + * trclo 8031 2735 2574 2454 2445 2449 2470 + * titer 3657 2865 2842 2641 2509 2449 2446 + * tload 3046 2404 2566 2444 + * fbench 2933 2688 2583 2460 2430 2478 2559 + * tmat 3065 3042 2524 2578 2590 2576 + * tsort 3683 3105 3104 2856 2804 2858 2858 + * tobj 4016 3970 3828 3577 3508 3502 + * teq 4068 4045 3536 3486 3544 3537 + * tio 3816 3752 3683 3620 3583 3601 + * tmac 3950 3873 3033 3677 3677 3680 + * tcase 4960 4793 4439 4430 4439 4467 + * tlet 9166 7775 5640 4450 4427 4457 4466 + * tclo 6362 4787 4735 4390 4384 4474 4447 + * tfft 7820 7729 4755 4476 4536 4543 + * tstar 6139 5923 5519 4449 4550 4604 + * tmap 8869 8774 4489 4541 4586 4592 + * tshoot 5525 5447 5183 5055 5034 5034 + * tform 5357 5348 5307 5316 5084 5095 + * tstr 10.0 6880 6342 5488 5162 5180 5180 + * tnum 6348 6013 5433 5396 5409 5423 + * tgsl 8485 7802 6373 6282 6208 6193 + * tari 15.0 13.0 12.7 6827 6543 6278 6278 + * tlist 9219 7896 7546 6558 6240 6300 6300 + * tset 6260 6364 6402 + * trec 19.5 6936 6922 6521 6588 6583 6583 + * tleft 11.1 10.4 10.2 7657 7479 7627 7622 + * tlamb 7941 7941 + * tgc 11.9 11.1 8177 7857 7986 8005 + * tmisc 8488 7862 8041 + * thash 11.8 11.7 9734 9479 9526 9542 + * cb 12.9 11.2 11.0 9658 9564 9609 9635 + * tgen 11.2 11.4 12.0 12.1 12.2 12.3 + * tall 15.9 15.6 15.6 15.6 15.6 15.1 15.1 + * calls 36.7 37.5 37.0 37.5 37.1 37.0 + * sg 55.9 55.8 55.4 55.2 + * tbig 177.4 175.8 156.5 148.1 146.2 146.3 + * ------------------------------------------------------------- * * 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? * fx_chooser can't depend on the is_global bit because it sees args before local bindings reset that bit, get rid of these if possible * lots of is_global(sc->quote_symbol) - * add wasm test to test suite somehow (at least emscripten) - * combine lets? - * widget-size (pane equal) - * copy/fill!/reverse! + setter/features/let is a mess - * either in t725 or safety>0? check func sig against actual call/returned value, same for typers/actual values - * missing cr's?, limit printout - * add rootlet special let, so sc->nil isn't used as a let + * do bodies use cell_optimize which is not optimal + * set_pending_value wrapped (big, rclo) + * wrapped form of FFI funcs? reals/ints? let wrappers seem doable [in safe-do etc] + * more string_uncopied, read-line-uncopied (etc), generics uncopied? + * op-*-vector etc + * hash_string is very slow? thash add 1M strs/syms and check -- for normal strings/hash-tables, it's hashing on the last 1..2 chars! + * gmp+debugging snd (snd-test): g_vector_set[41123]: not a number, but a big real (type: 17): Abort (core dumped) + * T_Num does not include bignums?! tests7 tries this? */ @@ -1,10 +1,10 @@ #ifndef S7_H #define S7_H -#define S7_VERSION "10.7" -#define S7_DATE "1-Jan-2024" +#define S7_VERSION "10.8" +#define S7_DATE "2-Feb-2024" #define S7_MAJOR_VERSION 10 -#define S7_MINOR_VERSION 7 +#define S7_MINOR_VERSION 8 #include <stdint.h> /* for int64_t */ @@ -148,6 +148,7 @@ s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x); void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc); s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc); s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x); +s7_pointer s7_gc_protect_2_via_stack(s7_scheme *sc, s7_pointer x, s7_pointer y); s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x); s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc); s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc); @@ -903,7 +904,9 @@ bool s7_is_bignum(s7_pointer obj); /* -------------------------------------------------------------------------------- * * s7 changes - * + + * 8-Jan-23: s7_gc_protect_2_via_stack. + * -------- * 15-Nov: s7_make_c_pointer_wrapper_with_type. * 17-Mar-23: moved s7_is_bignum declaration outside WITH_GMP. * -------- @@ -3029,9 +3029,8 @@ This is similar to a let form inside another let. </pre> <p> To add the bindings directly to the environment, -use <b>varlet</b>. Both of these functions accept () as the -'env' argument as shorthand for <code>(rootlet)</code>. -Both also accept other environments as well as individual bindings, +use <b>varlet</b>. +Both accept environment other than the first as well as individual bindings, adding all the argument's bindings to the new environment. <b>inlet</b> is very similar, but normally omits the environment argument. The arguments to sublet and inlet can be passed as @@ -6118,7 +6117,7 @@ get-output-string should be current-output-string. write-char behaves like displ provided? should be feature? or *features* should be *provisions*. list-ref, list-set!, and list-tail actually only apply to pairs. let-temporarily should be templet, or maybe set-temporarily. define-expansion should be define-reader-macro, but -that name collides with reader macros in Common Lisp. +that name collides with reader macros in Common Lisp. *cload-directory* should be *cload-path*. There should not be two names for the same thing: call/cc and call-with-current-continuation: flush the latter! The CL-inspired "log*" names such as logand look very old-fashioned. Standard scheme opts for the name "bitwise*"; why not "integerwise" or "bytevectorwise"? The "wise" business is just noise; are they thinking of The Hobbit? @@ -6862,7 +6861,7 @@ mbrot: 12.6, mbrotZ: 8.0, mperm: 18.9, nboyer: 20.1, nqueens: 27.0, ntakl: 8.0, nucleic: 8.3, paraffins: 4.4, parsing: 20.7, peval: 15.2, pnpoly: 9.8, primes: 10.2, puzzle: 10.2, quicksort: 40.0, ray: 8.3, read1: 0.2, sboyer: 19.1, scheme: 29.5, simplex: 26.9, slatex: 4.2, -string: 0.8, sum1: 0.2, sum: 4.1, sumfp: 2.2, tail: 0.1, tak: 7.1, +string: 0.3, sum1: 0.2, sum: 4.1, sumfp: 2.2, tail: 0.1, tak: 7.1, takl: 8.1, triangl: 16.4, wc: 4.9. In the gmp case, chudnovsky: 0.017, pi: .01. </p> </div> @@ -8867,14 +8866,15 @@ the Flint and Arb libraries, flintlib.org and arblib.org. In Linux: <pre class="indented"> gcc -fPIC -c libarb_s7.c -gcc libarb_s7.o -shared -o libarb_s7.so -lflint -larb +gcc libarb_s7.o -shared -o libarb_s7.so -lflint repl > (load "libarb_s7.so" (inlet 'init_func 'libarb_s7_init)) <em class="gray">#f</em> > (acb_bessel_j 0 1.0) <em class="gray">7.651976865579665514497175261026632209096E-1</em> </pre> - +<p>As of January 2024, libarb has been absorbed into libflint 3.0. +</p> <div class="header" id="gdb"><h4>gdb</h4></div> @@ -9074,6 +9074,7 @@ void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc); s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc); s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x); +s7_pointer s7_gc_protect_2_via_stack(s7_scheme *sc, s7_pointer x, s7_pointer y); s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x); s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc); @@ -9101,7 +9102,8 @@ s7_cons(s7, s7_make_real(s7, 3.14), <p>The protect_via_stack functions place the object on the s7 stack where it is protected until the stack unwinds past that point. Besides speed, this provides a way to be sure an object is unprotected even in some complicated situation where -error handling may bypass an explicit s7_gc_unprotect_at call. +error handling may bypass an explicit s7_gc_unprotect_at call. s7_gc_protect_2_via_stack +protects two objects in one stack location, saving stack space. The protect_via_location are intended for cases where you have a location already (from s7_gc_protect), and want to reuse it for a different object. s7_gc_on turns the GC on or off. Objects can be created at a blistering pace, @@ -9269,7 +9271,7 @@ s7_eval evaluates a list that represents Scheme code. That is, s7_eval(sc, s7_cons(sc, s7_make_symbol(sc, "+"), s7_cons(sc, s7_make_integer(sc, 1), s7_cons(sc, s7_make_integer(sc, 2), s7_nil(sc)))), - s7_rootlet(sc)); /* s7_nil here is the same as s7_rootlet */ + s7_rootlet(sc)); </pre> <p>returns 3 (as a Scheme integer). This may look ridiculous, but see snd-sig.c for an actual use. s7_eval_c_string evaluates a Scheme expression presented to it as a C string; it combines read and @@ -2122,6 +2122,10 @@ void block_init(s7_scheme *sc) (test (let () (define (f) (blocks5 :ho)) (f)) 'error) (test (let () (define (f) (blocks5 (symbol->keyword 'oops))) (f)) 'error) (test (let () (define (f) (blocks5 (string->keyword 'oops))) (f)) 'error) + (test (blocks5 frequency: 440) '(440)) + (test (blocks5 frequency: 440 amplitude: 1.0) '(440)) + (test (blocks5 a: 1 :b 2) '(4)) + (test (blocks5 :a 1 b: 2 frequency: 440 :c 3) '(440)) (test (call/cc (setter (block))) 'error) (test (call-with-exit (setter (block))) 'error) @@ -2960,6 +2964,10 @@ void block_init(s7_scheme *sc) (test (equivalent? (cdr '(a)) '()) #t) (test (equivalent? 'a 'a) #t) (test (equivalent? 'a 'b) #f) +(test (equivalent? :a a:) #t) +(test (equivalent? :a 123) #f) +(test (equivalent? :a 'a) #f) +(test (equivalent? 'a :a) #f) (test (equivalent? 'a (string->symbol "a")) #t) (test (equivalent? '(a) '(b)) #f) (test (equivalent? '(a) '(a)) #t) @@ -7942,8 +7950,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (symbol->value 'abs arg) 'error) (test (symbol->dynamic-value arg) 'error) (test (symbol->dynamic-value 'abs arg) 'error)) - (list #\a 1 () (list 1) "hi" '(1 . 2) #f (make-vector 3) abs _ht_ _undef_ _null_ quasiquote macroexpand 1/0 (log 0) - 3.14 3/4 1.0+1.0i #t (if #f #f) #<eof>)) + (list #\a 1 () (list 1) "hi" '(1 . 2) #f (make-vector 3) _ht_ _undef_ 1/0 (log 0) 3.14 3/4 1.0+1.0i #t (if #f #f) #<eof>)) (test (symbol->value) 'error) (test (symbol->value 'hi 'ho) 'error) @@ -7960,6 +7967,8 @@ i" (lambda (p) (eval (read p)))) pi) (test (symbol->value 'else) else) (test (symbol->value :hi) :hi) (test (symbol->value hi:) hi:) +(test (symbol->value :hi 123) 'error) +(test (symbol->value :hi abs) :hi) (test (symbol->value :readable (lambda a (copy a))) :readable) (test (symbol->dynamic-value 'lambda) lambda) @@ -7987,6 +7996,8 @@ i" (lambda (p) (eval (read p)))) pi) (test (eq? #_abs (symbol->value 'abs 'unlet)) #t) (test (eq? #_lambda (symbol->value 'lambda 'unlet)) #t) +(test (eq? #_case case) #t) +(test (eq? #_cond #_if) #f) (test (let ((b 2)) (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e)))) #<undefined>) (test (let ((a 2)) (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e)))) 2) (test (let ((a 2)) (let ((e (curlet))) (let ((a 1)) (symbol->value 'a)))) 1) @@ -11882,8 +11893,15 @@ i" (lambda (p) (eval (read p)))) pi) (test (eval-string "#(1 2 . 3)") 'error) (test (eval-string "#(1 2 . ())") #(1 2)) (test (eval-string "#i(1 2 . 3)") 'error) +(test (eval-string "#i(1 2 3+i)") 'error) +(test (eval-string "#i(1 2 ())") 'error) +(test (eval-string "#i(1 2 1.5)") 'error) +(test (eval-string "#i(1 2 1.0)") 'error) (test (eval-string "#u(1 2 . 3)") 'error) (test (eval-string "#r(1.0 2.0 . 3.0)") 'error) +(test (eval-string "#r(1.0 2.0 3.0+i)") 'error) +(test (eval-string "#r(1.0 2.0 ())") 'error) +(test (eval-string "#r(1 2)") (float-vector 1.0 2.0)) (test (eval-string "#2d((1 2) (3 4) . 5)") 'error) (test (eval-string "#2d((1 2) (3 . 4))") 'error) (test (eval-string "#2d((1 2) (3 4 . ()))") #2d((1 2) (3 4))) @@ -16250,6 +16268,10 @@ i" (lambda (p) (eval (read p)))) pi) (test (let () (define h (make-hook 'x)) (set! (hook-functions h) (list (lambda (hk) (set! (hk 'result) (hk 'abs))))) (h 123)) #<undefined>) ; new version of make-hook +(let-temporarily (((*s7* 'safety) 1)) + (test (format #f "~W" (make-hook (cons 'ho (list (values (list (let ((<1> (hash-table))) (set! (<1> 'a) <1>) <1>))))))) ; segfault if not checked + "#<write_closure_readably: arglist is cyclic>")) + (let () (for-each (lambda (arg) @@ -24537,6 +24559,8 @@ so anything that quotes ` is not going to equal quote quasiquote (test (object->string #()) "#()") (test (object->string "") "\"\"") (test (object->string abs) "abs") +(test (object->string :asdf) ":asdf") +(test (object->string asdf:) "asdf:") (test (object->string lambda) "#_lambda") (test (object->string (lambda () a)) "#<lambda ()>") (test (object->string (lambda a a)) "#<lambda a>") @@ -25293,7 +25317,8 @@ c" (system "gcc -fPIC -c libarb_s7.c") (system "gcc libarb_s7.o -shared -o libarb_s7.so -lflint -larb") (load "libarb_s7.so" (inlet 'init_func 'libarb_s7_init)) - (test (= (acb_bessel_j 0 1.0) 7.651976865579665514497175261026632209096E-1) #t)) + (test (= (acb_bessel_j 0 1.0) 7.651976865579665514497175261026632209096E-1) #t) + (test (length *arb*) 86)) |# (when full-s7test @@ -29502,6 +29527,73 @@ in s7: (define (g) (catch #t f1 (lambda args #f))) (test (g) 2)) +(let () ; int->real via set! after use as int in body: d_id_ok -> opt_d_id_sf bug + (define (f1) + (let ((x 0) + (y 2.0)) + (do ((i 0 (+ i 1))) + ((= i 2)) + (set! x (* i y)) + (cos (+ x (* y 2.0)))))) + (test (f1) #t) + + (define (f2) + (let ((x 0) + (y 2.1)) + (do ((i 0 (+ i 1)) + (j 0 (+ j 1))) + ((= i 2) x) + (set! x (* i j)) + (cos (+ x (* y 2.3)))))) + (test (f2) 1) + + (define (f3) + (let ((x 0) + (y 2)) + (do ((i 0 (+ i 1))) + ((= i 3) x) + (set! x (* i y)) + (set! y (* i 2.1)) + (cos (+ x (* y 2.1)))))) + (test (f3) 4.2) + + (define (f4) + (let ((x 0) + (y 2)) + (do ((i 0 (+ i 1)) + (j 0 (+ j 1.1))) + ((= i 3) x) + (set! x (* i j)) + (cos (+ x (* y 2.1)))))) + (test (f4) 4.4) + + (define (f5) + (let ((x 0)) + (do ((i 0 (+ i 1)) + (j 0 (+ j 1))) + ((= i 3) x) + (set! x (max x (* i j)))))) + (test (f5) 4) + + (define (f5a) + (let ((x 0) + (i 2.2) + (j 2.1)) + (do ((i 0 (+ i 1)) + (j 0 (+ j 1))) + ((= i 3) x) + (set! x (max x (* i j)))))) + (test (f5a) 4) + + (define (f6) + (let ((sum 0)) + (do ((i 0 (+ i 1))) + ((= i 10) sum) + (do ((j 0 (+ j 1))) + ((= j 3)) + (set! sum (+ sum i j)))))) + (test (f6) 165)) + (test (let ((lst '(1 2 3)) (v (vector 0 0 0))) (do ((l lst (map (lambda (a) (+ a 1)) (cdr l)))) @@ -29528,6 +29620,14 @@ in s7: lst)) '(1 4 9)) +(let () ;; test that set! of stepper is ignored in step vals etc, Guile agrees except it says z is #<unspecified>, do is weird + (define (hash-ints1 calls) + (do ((i 0 (+ i 1)) + (z 0 (set! i (- calls 1))) + (steps 0 (+ steps i))) + ((= i calls) (list i z steps)))) + (test (hash-ints1 10) '(10 9 90))) + (test (let ((sum 0)) (do ((i_0 0 (+ i_0 0))(i_1 1 (+ i_1 1))(i_2 2 (+ i_2 2))(i_3 3 (+ i_3 3))(i_4 4 (+ i_4 4))(i_5 5 (+ i_5 5))(i_6 6 (+ i_6 6))(i_7 7 (+ i_7 7))(i_8 8 (+ i_8 8))(i_9 9 (+ i_9 9))(i_10 10 (+ i_10 10))(i_11 11 (+ i_11 11))(i_12 12 (+ i_12 12))(i_13 13 (+ i_13 13))(i_14 14 (+ i_14 14))(i_15 15 (+ i_15 15))(i_16 16 (+ i_16 16))(i_17 17 (+ i_17 17))(i_18 18 (+ i_18 18))(i_19 19 (+ i_19 19))(i_20 20 (+ i_20 20))(i_21 21 (+ i_21 21))(i_22 22 (+ i_22 22))(i_23 23 (+ i_23 23))(i_24 24 (+ i_24 24))(i_25 25 (+ i_25 25))(i_26 26 (+ i_26 26))(i_27 27 (+ i_27 27))(i_28 28 (+ i_28 28))(i_29 29 (+ i_29 29))(i_30 30 (+ i_30 30))(i_31 31 (+ i_31 31))(i_32 32 (+ i_32 32))(i_33 33 (+ i_33 33))(i_34 34 (+ i_34 34))(i_35 35 (+ i_35 35))(i_36 36 (+ i_36 36))(i_37 37 (+ i_37 37))(i_38 38 (+ i_38 38))(i_39 39 (+ i_39 39))) ((= i_1 10) sum) (set! sum (+ sum i_0 i_1 i_2 i_3 i_4 i_5 i_6 i_7 i_8 i_9 i_10 i_11 i_12 i_13 i_14 i_15 i_16 i_17 i_18 i_19 i_20 i_21 i_22 i_23 i_24 i_25 i_26 i_27 i_28 i_29 i_30 i_31 i_32 i_33 i_34 i_35 i_36 i_37 i_38 i_39)))) @@ -29583,6 +29683,25 @@ in s7: (test (let ((v 2+i)) (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((> j 0)) (set! j v)))) (func)) 'error) (test (let ((v #(2))) (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((> j 0)) (set! j v)))) (func)) 'error) +(let () ; opt_set_p_i|d_fm bug + (define (f1) + (let ((v (vector 0 0 0)) + (y 1)) + (do ((i 0 (+ i 1))) + ((= i 3) v) + (set! y (round (+ y 1))) + (vector-set! v i y)))) + (test (f1) #(2 3 4)) + + (define (f2) + (let ((v (vector 0 0 0)) + (y 1.0)) + (do ((i 0 (+ i 1))) + ((= i 3) v) + (set! y (+ y 1.0)) + (vector-set! v i y)))) + (test (f2) #(2.0 3.0 4.0))) + (test (let () (define-constant _bg_ 0) (define (f) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (set! _bg_ x)))) (f)) 0) ; op_set1 s7_is_eqv (let () ; opt_dotimes coverage tests (some miss their target...) @@ -30707,8 +30826,8 @@ in s7: (test (let () (define (f) (set! _not_a_var2_ 1)) (f)) 'error) (test (let () (define (f) (set! _not_a_var3_ 1)) (define (g) (f)) (g)) 'error) (test (set! (_not_a_var6_ 1) 2) 'error) -(test (let ((_not_a_var7_ 1)) (with-let () (set! _not_a_var7_ 2))) 'error) -(test (let ((_not_a_var7_ 1)) (with-let () (do ((i 0 (+ i 1))) ((= i 1)) (set! _not_a_var7_ 2)))) 'error) +(test (let ((_not_a_var7_ 1)) (with-let (rootlet) (set! _not_a_var7_ 2))) 'error) +(test (let ((_not_a_var7_ 1)) (with-let (rootlet) (do ((i 0 (+ i 1))) ((= i 1)) (set! _not_a_var7_ 2)))) 'error) (test (let () (define (f x) (do ((i 0 (+ i 1))) ((= i 1)) (set! (x 0) 1))) (f _not_a_var8_)) 'error) (test (set! (_not_a_pws_) 1) 'error) (test (let ((x 1)) (set! ((lambda () 'x)) 3) x) 'error) @@ -37482,11 +37601,9 @@ yow... (test (let* func ((a 1) (b 2)) (+ a b (if (> a 0) (func :b (- b 1) :a (- a 1)) 0))) 4) (test (let* func ((a 1) (b 2)) (+ a b (if (> a 0) (func :a (- a 1)) 0))) 5) -;;; these ought to work, but see s7.c under EVAL: (it's a speed issue) -;(test (let let ((i 0)) (if (< i 3) (let (+ i 1)) i)) 3) -;(test (let () (define (if a) a) (if 1)) 1) -;(test (let begin ((i 0)) (if (< i 3) (begin (+ i 1)) i)) 3) - +(test (let* loop ((i 10) (j 1) (k 0)) (if (<= i 0) k (loop (- i j) :k (+ k 1)))) 10) +(test (let* loop ((i 10) (j 1) (k 0)) (if (<= i 0) k (loop (- i j) :j 2 :k (+ k 1)))) 6) +(test (let* loop ((i 10) (j 1) (k 0)) (if (<= i 0) k (loop (- i j)))) 0) ;;; from the scheme wiki ;;; http://community.schemewiki.org/?sieve-of-eratosthenes @@ -41385,6 +41502,47 @@ who says the continuation has to restart the map from the top? (set! (*s7* 'safety) old-safety) +;;; local *load-path* +(when (and (defined? 'file-exists?) + (file-exists? "/home/bil/test")) + (define old-load-path *load-path*) + (call-with-output-file "test-load-1.scm" + (lambda (port) + (format port "(define (lt1) 111)\n(lt1)\n"))) + (call-with-output-file "/home/bil/test/test-load-2.scm" + (lambda (port) + (format port "(define (lt2) 222)\n(lt2)\n"))) + (call-with-output-file "/home/bil/test/test-load-1.scm" + (lambda (port) + (format port "(define (lt3) 333)\n(lt3)\n"))) + + (test (load "test-load-1.scm") 111) + (test (load "test-load-2.scm") 'error) + + (set! *load-path* (cons "/home/bil/test/" *load-path*)) + (test (load "test-load-1.scm") 111) ; local dir is always searched first + (test (load "test-load-2.scm") 222) + + (set! *load-path* (list "/home/bil/test/")) + (test (load "test-load-1.scm") 111) + (test (load "test-load-2.scm") 222) + + (set! *load-path* (list ".")) + (let ((*load-path* (list "/home/bil/test/" "."))) + (test (load "test-load-1.scm" (curlet)) 111) ; if no env, curlet set to rootlet during load, so the *load-path* used is the rootlet version + (test (load "test-load-2.scm" (curlet)) 222)) + + (test (delete-file "test-load-1.scm") 0) + (test (load "test-load-1.scm") 'error) + (test (load "test-load-2.scm") 'error) + + (let ((*load-path* (list "/home/bil/test/"))) + (test (load "test-load-1.scm" (curlet)) 333) + (test (load "test-load-2.scm" (curlet)) 222)) + + (set! *load-path* old-load-path)) +;;; -------- + ;;; (*s7* 'print-length) (test (integer? (*s7* 'print-length)) #t) @@ -47132,7 +47290,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (signature symbol->dynamic-value) '(#t symbol?)) (test (signature symbol->keyword) '(keyword? symbol?)) (test (signature symbol->string) '(string? symbol?)) -(test (signature symbol->value) '(#t symbol? let?)) +(test (signature symbol->value) '(#t symbol? (let? procedure? c-pointer? continuation? goto? macro?))) ;(test (signature setter) '((boolean? procedure?) symbol? let?)) (test (signature symbol-table) '(vector?)) (test (signature symbol?) '(boolean? #t)) @@ -49247,7 +49405,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (label 'the-end) 0) (let-temporarily (((*s7* 'safety) 1)) - (test (object->string ho :readable) "#<write_closure: body is cyclic>") ; changed 12-Mar-19 + (test (object->string ho :readable) "#<write_closure_readably: body is cyclic>") ; changed 12-Mar-19 (test (equivalent? ho hi) #f)) (test (ho 2) 0)) @@ -49826,6 +49984,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (fill! (immutable! (inlet :a 1 :b 2)) #f) #f) ; was 'error 8-Jun-20 (test (fill! (immutable! (list 1 2 3)) 0) 'error) (test (let () (define (func) (immutable? (string-append (get-output-string (open-output-string))))) (func)) #f) +(test (let () (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (immutable! 'i)))) (func)) 'error) (test (reverse! (copy (immutable! (string #\a #\b #\c)))) "cba") (test (immutable? (copy (immutable! (list 1 2)))) #f) @@ -50506,11 +50665,11 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (lambda (arg) (test (defined? arg) 'error) (test (defined? 'abs arg) 'error)) - (list -1 #\a 1 _ht_ _undef_ _null_ #(1 2 3) 3.14 3/4 1.0+1.0i () #f #(()) (list 1 2 3) '(1 . 2) "hi")) -(test (defined? 'lambda car) 'error) ; gad, trying to be consistent, but maybe chose the wrong path here, 10-May-22 + (list -1 #\a 1 _ht_ _undef_ #(1 2 3) 3.14 3/4 1.0+1.0i () #f #(()) (list 1 2 3) '(1 . 2) "hi")) +(test (defined? 'lambda car) #t) (test (defined? lambda gensym) 'error) -(test (defined? 'lambda defined?) 'error) -(test (defined? 'define car) 'error) +(test (defined? 'lambda defined?) #t) +(test (defined? 'define car) #t) (test (defined? 'abs (sublet ())) #t) ; nil = global now (test (defined? lambda) 'error) (test (defined? 'lambda) #t) @@ -50758,13 +50917,9 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (equal? (inlet (cons :a 1)) (inlet 'a 1)) #t) (test (equal? (inlet :a 1) (inlet 'a 1)) #t) (test (equal? (inlet a: 1) (inlet :a 1)) #t) -(test (inlet 'if 3) 'error) (test (inlet 'pi 3) 'error) (test (inlet 'let-ref (lambda (obj val) val)) 'error) (test (inlet 'let-set! (lambda (obj arg val) val)) 'error) -(test (apply (lambda (g) (inlet :if 32)) (list 2)) 'error) ; g_simple_inlet bug -(test (apply (lambda (g) (inlet ':if 32)) (list 2)) 'error) -(test (inlet :if `((x))) 'error) (test (let ((incr (lambda (val) (+ val 1)))) (let ((e1 (curlet)) (incr (lambda (val) (+ val 2)))) @@ -50899,11 +51054,13 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (set! #_+ 3) 'error) (test (with-let (inlet :rest 3) rest) 3) (test (with-let (inlet :allow-other-keys 32) allow-other-keys) 32) +(test (with-let (sublet (rootlet)) (with-let (rootlet) :display)) :display) +(test (with-let (lambda (x) (fill! (copy x) 0)) :if) :if) (test (let ((a 21)) (let ((e (inlet (curlet)))) (set! a 32) (with-let e a))) 21) (test (let ((a 21)) (let ((e (sublet (curlet)))) (set! a 32) (with-let e a))) 32) (test (with-let (block 1 2 3) ((curlet) 0)) 'error) -(test (with-let (c-pointer 0) (curlet)) 'error) +(test (with-let (c-pointer 0) (curlet)) (rootlet)) (test (let () (define (f sym ?x) (with-let (inlet sym ?x) a)) (f 'a 123)) 123) (test (integer? (let () ((sublet (curlet) *s7*) 'gc-freed))) #t) ; append_let coverage ;(test (let () (sublet (curlet) (rootlet))) (inlet)) @@ -51207,7 +51364,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (set! (e arg) #f) 'error) (test (eref arg) 'error) (test (eset (e arg) #f) 'error)) - (list -1 #\a 1 #(1 2 3) 3.14 3/4 1.0+1.0i pi abs macroexpand () #<eof> #<unspecified> #f #(()) (list 1 2 3) '(1 . 2) "hi" '((a . 1))))) + (list -1 #\a 1 #(1 2 3) 3.14 3/4 1.0+1.0i pi () #<eof> #<unspecified> #f #(()) (list 1 2 3) '(1 . 2) "hi" '((a . 1))))) (test (let () (define (func) (set! (let-ref) (vector))) (func))'error) (test (let ((L (inlet 'a 1))) (define (func) (set! (let-ref) L :a (vector))) (func)) 'error) @@ -51423,6 +51580,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (string=? str "(inlet 'b 4 'a 3)")))) (test (let () (varlet (unlet) (cons 'a 32)) (symbol->value 'a (unlet))) #<undefined>) +(test (let ((abs 32)) (with-let (unlet) (abs -1))) 1) (test (let ((caar 123)) (+ caar (with-let (unlet) (caar '((2) 3))))) 125) (test (let () (+ (let ((caar 123)) @@ -51447,6 +51605,65 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (sublet (unlet) (cons 'a 2))) 1) +#| +;;; this checks each procedure call against its signature -- it could be simplified to check just one procedure +(define (setup-check-sig) + + (define (check-sig sym sig arg args) + ;; signature can be #t, values, a symbol=type desired, or a list of these. We ignore #t and values before calling check-sig. + (if (#_symbol? sig) + ((#_with-let (#_unlet) (symbol->value sig)) arg) ; "unlet" in pretty-print? + (if (#_pair? sig) + (#_call-with-exit + (lambda (return) + (#_for-each + (lambda (checker) + (if ((#_with-let (#_unlet) (symbol->value checker)) arg) + (return #t))) + sig) + #f)) + (#_format *stderr* "~S for ~S if (~S ~{~^ S~}~%" arg sig sym args)))) + + ;; redefine all the built-in procedures (so this code gradually clobbers rootlet as it runs) + (#_for-each + (lambda (sym) + (let ((x (#_symbol->value sym))) + (when (and (#_procedure? x) + (#_signature x) + (#_not (#_immutable? sym)) ; unlet etc + (#_not (#_memq sym '(values setup-check-sig check-sig)))) + (apply set! sym + (#_list (let ((old-x x)) + (lambda args + (#_catch #t ; this messes with outside error handling -- it's probably also unnecessary + (lambda () + (let ((result (#_apply old-x args)) + (sig (#_signature old-x))) + + ;; check result against (car signature) + (unless (#_memq (#_car sig) '(#t values)) + (let ((sig-result (check-sig sym (#_car sig) result args))) + (if (#_not sig-result) + (#_format *stderr* "(~S~{~^ ~$~}) -> ~$ (~S) but sig: ~S~%" sym args result (#_type-of result) (#_car sig))))) + + ;; check args against (cdr signature) + (#_for-each + (lambda (arg-sig arg) + (unless (#_memq arg-sig '(#t values)) + (let ((sig-result (check-sig sym arg-sig arg args))) + (if (#_not sig-result) + (#_format *stderr* "(~S~{~^ ~$~}) arg ~$ (~S) -> ~$ but sig: ~S~%" sym args arg (#_type-of arg) result arg-sig))))) + (#_cdr sig) + args) + + ;; return function result + result)) + (lambda (type info) + #f))))))))) + ;; this does not fixup any preset setter (current-output-port for example) + (symbol-table))) +|# + (let ((e (openlet ; make it appear to be empty to the rest of s7 (inlet 'object->string (lambda args "(inlet)") 'map (lambda args ()) @@ -51671,10 +51888,10 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (with-let arg #f) 'error) (test (outlet arg) 'error) (test (set! (outlet (curlet)) arg) 'error)) - (list -1 #\a #(1 2 3) 3.14 3/4 1.0+1.0i () 'hi "hi" abs #(()) (list 1 2 3) '(1 . 2))) + (list -1 () #\a #(1 2 3) 3.14 3/4 1.0+1.0i 'hi "hi" #(()) (list 1 2 3) '(1 . 2))) -(test (with-let (sublet (sublet ()) '(a . 1)) 1) 1) -(test (with-let (sublet (sublet ()) '(a . 1)) a) 1) +(test (with-let (sublet (sublet (rootlet)) '(a . 1)) 1) 1) +(test (with-let (sublet (sublet (rootlet)) '(a . 1)) a) 1) (test (with-let (curlet) 1) 1) (test (let ((a 1)) (+ (with-let @@ -52769,12 +52986,12 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (let ((h (make-hash-table 8 string=?))) (test (object->let h) (inlet :value h :type 'hash-table? :size 8 :entries 0 :mutable? #t :function 'string=?))) (test ((object->let (make-weak-hash-table)) 'weak) #t) -(let ((e (inlet 'a 1 'b 2))) (test (object->let e) (inlet :value e :type 'let? :size 2 :open #f :outlet () :mutable? #t))) +(let ((e (inlet 'a 1 'b 2))) (test (object->let e) (inlet :value e :type 'let? :size 2 :open #f :outlet (rootlet) :mutable? #t))) (test (object->let (rootlet)) (inlet :value (rootlet) :type 'let? :size (length (rootlet)) :open #f :outlet () :mutable? #t :alias 'rootlet)) -;(test (object->let (owlet)) (inlet :value (owlet) :type 'let? :size (length (owlet)) :open #f :outlet () :alias 'owlet)) +;(test (object->let (owlet)) (inlet :value (owlet) :type 'let? :size (length (owlet)) :open #f :outlet (rootlet) :alias 'owlet)) (let ((e (openlet (inlet 'a 1 'b 2 'object->let (lambda (p lt) (varlet lt 'a+b (+ (p 'a) (p 'b)))))))) - (test (object->let e) (inlet :value e :type 'let? :size 3 :open #t :outlet () :mutable? #t 'a+b 3))) + (test (object->let e) (inlet :value e :type 'let? :size 3 :open #t :outlet (rootlet) :mutable? #t 'a+b 3))) (test (equal? (object->let (byte-vector-ref (make-byte-vector '(2 3) 1) 1)) (inlet 'value #u(1 1 1) 'type '(subvector? . byte-vector?) 'size 3 'dimensions '(3) 'mutable? #t 'position 3 'original-vector #u2d((1 1 1) (1 1 1)))) @@ -52795,7 +53012,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test ((object->let e) :type) 'let?))) ; (inlet 'value e :type 'let? :size 1 :open #f :outlet (inlet 'fff fff) :function 'fff :file "s7test.scm" :line (port-line-number))))) (let ((e (openlet (inlet :abs (lambda (x) (- x 1)))))) - (test (object->let e) (inlet :value e :type 'let? :size 1 :open #t :outlet () :mutable? #t))) + (test (object->let e) (inlet :value e :type 'let? :size 1 :open #t :outlet (rootlet) :mutable? #t))) (when with-block (let* ((b (make-block 8)) @@ -53029,6 +53246,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test a 1) (test (let-temporarily ((a (let-temporarily ((a 3))))) a) ()) (test a 1)) +(test (let ((x 31)) (set! (setter 'x) (lambda (a b) 16)) (let-temporarily ((x 1)) x)) 16) (let () (define ourlet @@ -54884,7 +55102,24 @@ hi6: (string-app... ;;; -------------------------------------------------------------------------------- ;;; tail recursion tests -(define _max_stack_tc_ 13) +(define (command-line) + (let ((lst ())) + (with-input-from-file "/proc/self/cmdline" + (lambda () + (do ((c (read-char) (read-char)) + (s "")) + ((eof-object? c) + (reverse lst)) + (if (char=? c #\null) + (begin + (set! lst (cons s lst)) + (set! s "")) + (set! s (string-append s (string c))))))))) + +(if (provided? 'linux) + (define _max_stack_tc_ (if (member "s7test.scm" (command-line)) 13 20)) + (define _max_stack_tc_ 20)) + (let ((max-stack 0)) (define (tc-1 a c) (let ((b (+ a 1))) @@ -55131,7 +55366,7 @@ hi6: (string-app... (if (not (= a 1)) (error 'wrong-type-arg ";for-each arg is ~A" a))) (make-list 100 1)) - (test (< max-stack 20) #t)) ; 10 is not snd-test (and below) + (test (<= max-stack 21) #t)) ; 10 is not snd-test (and below) (let ((max-stack 0)) (map @@ -55141,7 +55376,7 @@ hi6: (string-app... (if (not (= a 1)) (error 'wrong-type-arg ";map arg is ~A" a))) (make-list 100 1)) - (test (< max-stack 20) #t)) + (test (<= max-stack 21) #t)) (let ((max-stack 0) @@ -72208,6 +72443,12 @@ hi6: (string-app... (test (nan? (min 3/4 1/0)) #t) (test (nan? (min 3/4 +nan.0)) #t) (test (min 3/4 +nan.0 #\a) 'error) +(num-test (min 1 +nan.0) +nan.0) +(num-test (min +nan.0 1) +nan.0) +(num-test (min 1.0 +nan.0) +nan.0) +(num-test (min +nan.0 1.0) +nan.0) +(num-test (min 1 1.0) 1) ; (eqv? (min 1 1.0) 1): #t etc +(num-test (min 1.0 1) 1.0) (for-each (lambda (arg) @@ -72585,6 +72826,13 @@ hi6: (string-app... (test (max 3/4 +nan.0 #\a) 'error) ;; s7 and Guile say (max -nan.0 -nan.0) -> +nan.0 +(num-test (max 1 +nan.0) +nan.0) +(num-test (max +nan.0 1) +nan.0) +(num-test (max 1.0 +nan.0) +nan.0) +(num-test (max +nan.0 1.0) +nan.0) +(num-test (max 1 1.0) 1) +(num-test (max 1.0 1) 1.0) + (for-each (lambda (arg) (test (max arg +nan.0) 'error) @@ -95961,6 +96209,19 @@ etc (define (_f8_ x) (let-temporarily ((x (+ x 1))) (values x x))) (define (func) (let ((x #f)) (do ((i 0 (+ i 1))) ((= i 1)) (pretty-print (list-values #t (_f8_ 1)) #f)))) (test (func) #t)) ; #t = do loop value + + (test (pp (list #_if (list '> 3 2) #_case abs)) "(#_if (> 3 2) #_case abs)") + (test (pp (list #_set! 'sym 32)) "(#_set! sym 32)") + (test (pp (list 'set! 'sym 32)) "(set! sym 32)") + (test (string-wi=? (pp (list #_catch #t (list #_lambda () (list 'abs 'x)) (list #_lambda (list 'type 'info) #f))) + "(#_catch #t (#_lambda () (abs x)) (#_lambda (type info) #f))") #t) + (test (string-wi=? (pp (list '#_define 'x 32)) "(#_define x 32)") #t) + (test (string-wi=? (pp (list 'define 'x 32)) "(define x 32)") #t) + (test (string-wi=? (pp (list #_unless (list '< 2 1) (list 'display 'ok) #f)) "(#_unless (< 2 1) (display ok) #f)") #t) + (test (string-wi=? (pp (list 'when (list '< 2 1) (list 'display 'ok))) "(when (< 2 1) (display ok))") #t) + (test (string-wi=? (pp (list #_letrec (list (list 'i 32) (list 'j 12)) (list '+ 'i 'j))) "(#_letrec ((i 32) (j 12)) (+ i j))") #t) + (test (string-wi=? (pp (list #_let* 'loop (list (list 'i 10) (list 'j 12)) (list '+ 'i 'j))) "(#_let* loop ((i 10) (j 12)) (+ i j))") #t) + (test (string-wi=? (pp (list #_and (list 'or #t) #f)) "(#_and (or #t) #f)") #t) ) (let () @@ -99604,7 +99865,8 @@ etc (lambda () (catch 'three (lambda () - (test (*s7* 'catches) '(#t three two one))) + (let ((cs (*s7* 'catches))) + (test (or (equal? cs '(three two one)) (equal? cs '(three two one string-read-error #t #t))) #t))) (lambda a a))) (lambda a a))) (lambda a a))) (test (vector? (*s7* 'gc-protected-objects)) #t) @@ -100287,7 +100549,7 @@ etc (test (let () (define (func x) (fill! (values 1 2) `(+ x 1))) (define (hi) (func #f)) (hi)) 'error) (test (let () (define (func x) (not (zero? :readable))) (define (hi) (func #f)) (hi)) 'error) (test (let () (define (func x) (do ((i 0 (+ i 1))) ((= i 1) i) (exact->inexact 1.0+123.0i))) (define (hi) (func #f)) (hi)) 1) -(test (let () (define (func x) (inlet 'if 3)) (define (hi) (func #f)) (hi)) 'error) +(test (let () (define (func x) (inlet 'if 3)) (define (hi) (func #f)) (hi)) (inlet 'if 3)) (test ((let () (define (func x) (inlet ':allow-other-keys 3)) (define (hi) (func #f)) (hi)) 'allow-other-keys) 3) (test (let () (define (func x) (vector (setter car) (quote (null? i) #r2d((.1 .2) (.3 .4))))) (define (hi) (func #f)) (hi)) 'error) (test (let () (define (func x) (c-pointer? begin (member let-temporarily (values 1 2)))) (define (hi) (func #f)) (hi)) 'error) @@ -100549,7 +100811,11 @@ etc (let () (define (func x) (fill! (values 1 2) `(+ x 1))) (define (hi) (func #f)) (test (hi) 'error)) (let () (define (func x) (not (zero? :readable))) (define (hi) (func #f)) (test (hi) 'error)) (let () (define (func x) (do ((i 0 (+ i 1))) ((= i 1) i) (exact->inexact 1.0+123.0i))) (define (hi) (func #f)) (test (hi) 1)) -(let () (define (func x) (inlet 'if 3)) (define (hi) (func #f)) (test (hi) 'error)) +(let () (define (func x) (inlet 'if 3)) (define (hi) (func #f)) (test (hi) (inlet 'if 3))) +(test (inlet 'if 3) (inlet 'if 3)) +(test (apply (lambda (g) (inlet :if 32)) (list 2)) (inlet 'if 32)) +(test (apply (lambda (g) (inlet ':if 32)) (list 2)) (inlet 'if 32)) +(test (inlet :if `((x))) (inlet 'if '((x)))) (let () (define (func x) (vector (setter car) (quote (null? i) #r2d((.1 .2) (.3 .4))))) (define (hi) (func #f)) (test (hi) 'error)) (let () (define (func x) (c-pointer? begin (member let-temporarily (values 1 2)))) (define (hi) (func #f)) (test (hi) 'error)) (let () (define (func x) (integer? (assoc (values) '((x 1) (y) . 2) cons))) (define (hi) (func #f)) (test (hi) #f)) @@ -101645,20 +101911,6 @@ etc (reader-cond ((and (not (provided? 'openbsd)) (not (provided? 'solaris))) (define (little-endian?) (= __BYTE_ORDER __LITTLE_ENDIAN)))) - (define (command-line) - (let ((lst ())) - (with-input-from-file "/proc/self/cmdline" - (lambda () - (do ((c (read-char) (read-char)) - (s "")) - ((eof-object? c) - (reverse lst)) - (if (char=? c #\null) - (begin - (set! lst (cons s lst)) - (set! s "")) - (set! s (string-append s (string c))))))))) - (define (daytime) (let ((timestr (make-string 64)) (p #f)) @@ -101806,7 +102058,7 @@ etc (test (integer? (getpid)) #t) (test (integer? _POSIX_VERSION) #t) (if (provided? 'linux) (test (>= __GLIBC__ 2) #t)) - (test (c-null? (c-pointer 0)) #t) + ;(test (c-null? (c-pointer 0)) #t) (test (fnmatch "*.c" "s7.c" FNM_PATHNAME) 0) (test (string? (realpath "s7.c" (string))) #t) ; second arg is simply ignored (test (string? (realpath "s7.c" #f)) #t) @@ -102604,7 +102856,12 @@ etc (error 'regex-error "~S~%" (regerror res rg))) (regfree rg) res)) - #i(0 8 0 8 4 6)))) + #i(0 8 0 8 4 6))) + + (test (procedure? (*libc* 'memcpy)) #t) + (test ((rootlet) 'memcpy) #<undefined>) + (test (with-let (rootlet) memcpy) 'error) + (test (procedure? (with-let *libc* memcpy)) #t)) ;;; -------------------------------- case.scm -------------------------------- @@ -107159,7 +107416,7 @@ etc (lint-test "(and (or A B) (or C B))" " and: perhaps (and (or A B) (or C B)) -> (or (and A C) B)") (lint-test "(or (not A) (and A B))" " or: perhaps (or (not A) (and A B)) -> (or (not A) B)") (lint-test "(or A (and (not A) B))" " or: perhaps (or A (and (not A) B)) -> (or A B)") - + (lint-test "(and A (not A))" " and: perhaps (and A (not A)) -> #f") (lint-test "(or (and x y) (and x z) (and x w))" " or: perhaps (or (and x y) (and x z) (and x w)) -> (and x (or y z w))") (lint-test "(or (and x y) (and z y) (and w y))" " or: perhaps (or (and x y) (and z y) (and w y)) -> (and (or x z w) y)") (lint-test "(or (and x y w) (and x z) (and x a b))" " or: perhaps (or (and x y w) (and x z) (and x a b)) -> (and x (or (and y w) z (and a b)))") @@ -110559,6 +110816,18 @@ etc (test val 3) (test (ho) #<unspecified>)) +(when with-block ; optimize_safe_c_func_three_args[71842]: overwrite has_fx: opt2_sym (fvset1 '((x 1)) imh111) + (let () + (define (func) + (do () + ((not #f) + (make-string 3 #\space) + (with-let (block) + (let ((fvset1 float-vector-set!)) + (define-constant imh111 (hash-table)) + (subsequence fvset1 `((x 1)) imh111)))))) + (test (func) 'error))) + (let () (define mac (let ((var (gensym))) (define-macro (mac-inner b) @@ -110981,6 +111250,7 @@ etc (test (with-let-(rootlet) (apply define (list 'abs 1))) 'error) (test (cutlet (rootlet) 'abs) 'error) (test (set! ((unlet) 'abs) 2) 'error) +(test (let () (define + -) (with-let (unlet) (+ (openlet (unlet)) 2))) 'error) (test (varlet (rootlet) 'abs 1) 'error) (test (let-set! (rootlet) 'abs 3) 'error) (test (set! (with-let (rootlet) abs) 3) 'error) @@ -8864,11 +8864,19 @@ to the info dialog if filename is omitted" } if (!fd) - Xen_error(Xen_make_error_type("cant-open-file"), - Xen_list_3(C_string_to_Xen_string(S_peaks ": ~S ~A"), - C_string_to_Xen_string(name), - C_string_to_Xen_string(snd_io_strerror()))); - + { + XEN res = C_string_to_Xen_string(name); + if (name) free(name); /* 18-Jan-24 */ + Xen_error(Xen_make_error_type("cant-open-file"), + Xen_list_3(C_string_to_Xen_string(S_peaks ": ~S ~A"), + res, + C_string_to_Xen_string(snd_io_strerror()))); +#if HAVE_SCHEME + return(NULL); /* idiotic compiler... Xen_error does not return so this is actually pointless */ +#else + return(0); +#endif + } write_transform_peaks(fd, cp); snd_fclose(fd, name); @@ -1156,6 +1156,7 @@ static dac_info *add_channel_to_play_list(chan_info *cp, snd_info *sp, mus_long_ si = snd_sync(sp->sync); for (i = 0; i < si->chans; i++) si->cps[i]->original_cursor = cursor_sample(cp); + free_sync_info(si); /* 18-Jan-24 */ } } diff --git a/snd-edits.c b/snd-edits.c index 05f8b8c..c791cf4 100644 --- a/snd-edits.c +++ b/snd-edits.c @@ -7093,13 +7093,18 @@ snd can be a filename, a mix, a region, or a sound index number." if (Xen_is_string(snd)) { - const char *filename; + char *filename; int chan = 0; Xen_check_type(Xen_is_integer_boolean_or_unbound(chn), chn, 3, S_make_sampler, "an integer or boolean"); filename = mus_expand_filename(Xen_string_to_C_string(snd)); if (mus_file_probe(filename)) loc_sp = make_sound_readable(filename, false); - else return(snd_no_such_file_error(S_make_sampler, snd)); + else + { + if (filename) free(filename); + return(snd_no_such_file_error(S_make_sampler, snd)); + } + if (filename) free(filename); if (Xen_is_integer(chn)) chan = Xen_integer_to_C_int(chn); if ((chan < 0) || (chan >= (int)loc_sp->nchans)) @@ -8428,7 +8433,7 @@ history position to read (defaults to current position). snd can be a filename, { snd_info *loc_sp = NULL; int chan = 0, chans; - const char *filename; + char *filename; mus_float_t *fvals; vct *v; @@ -8438,17 +8443,24 @@ history position to read (defaults to current position). snd can be a filename, filename = mus_expand_filename(Xen_string_to_C_string(snd)); if (!mus_file_probe(filename)) - return(snd_no_such_file_error(S_make_sampler, snd)); - + { + if (filename) free(filename); + return(snd_no_such_file_error(S_make_sampler, snd)); + } if (Xen_is_integer(samps)) len = Xen_integer_to_C_int(samps); else len = mus_sound_framples(filename); - if (len <= 0) return(Xen_false); - + if (len <= 0) + { + if (filename) free(filename); + return(Xen_false); + } chans = mus_sound_chans(filename); if (chan >= chans) - return(snd_no_such_channel_error(S_samples, snd, chn_n)); - + { + if (filename) free(filename); + return(snd_no_such_channel_error(S_samples, snd, chn_n)); + } loc_sp = make_sound_readable(filename, false); /* cp = loc_sp->chans[chan]; */ v = mus_vct_make(len); @@ -8456,6 +8468,7 @@ history position to read (defaults to current position). snd can be a filename, mus_file_to_array(filename, chan, beg, len, fvals); completely_free_snd_info(loc_sp); + if (filename) free(filename); return(vct_to_xen(v)); } @@ -3478,6 +3478,7 @@ If " S_help_hook " is not empty, it is invoked with the subject and the snd-help and its value is returned." char *str = NULL, *subject = NULL; + bool need_str_free = false; if (Xen_is_keyword(text)) return(C_string_to_Xen_string("keyword")); @@ -3555,7 +3556,7 @@ and its value is returned." s7_pointer e; e = s7_funclet(s7, sym); str = (char *)calloc(256, sizeof(char)); - /* unavoidable memleak I guess -- we could use a backup statically allocated buffer here */ + need_str_free = true; if (s7_is_null(s7, e)) snprintf(str, 256, "this function appears to come from eval or eval-string?"); else @@ -3605,6 +3606,7 @@ and its value is returned." { if ((!subject) || (mus_strlen(subject) == 0)) return(Xen_false); + need_str_free = false; str = snd_finder(subject, false); need_free = true; } @@ -3662,7 +3664,11 @@ and its value is returned." } if (str) - return(C_string_to_Xen_string(str)); + { + XEN res = C_string_to_Xen_string(str); + if (need_str_free) free(str); + return(res); + } return(Xen_false); } diff --git a/snd-select.c b/snd-select.c index 974453f..e19fd92 100644 --- a/snd-select.c +++ b/snd-select.c @@ -1038,6 +1038,7 @@ static Xen s7_xen_selection_fill(s7_scheme *sc, Xen args) update_graph(si->cps[i]); free(data); } + free_sync_info(si); } return(Xen_false); } @@ -4459,7 +4459,10 @@ static s7_pointer g_new_sound(s7_scheme *sc, s7_pointer args) return(s7_wrong_type_arg_error(sc, S_new_sound, 2, fp, "an integer (channels)")); ch = s7_integer(fp); if (ch <= 0) - Xen_out_of_range_error(S_new_sound, 2, fp, "channels <= 0?"); + { + if (str) free(str); + Xen_out_of_range_error(S_new_sound, 2, fp, "channels <= 0?"); + } } else ch = default_output_chans(ss); @@ -4468,10 +4471,16 @@ static s7_pointer g_new_sound(s7_scheme *sc, s7_pointer args) if (fp != Xen_false) { if (!s7_is_integer(fp)) - return(s7_wrong_type_arg_error(sc, S_new_sound, 3, fp, "an integer (srate)")); + { + if (str) free(str); + return(s7_wrong_type_arg_error(sc, S_new_sound, 3, fp, "an integer (srate)")); + } sr = s7_integer(fp); if (sr <= 0) - Xen_out_of_range_error(S_new_sound, 3, fp, "srate <= 0?"); + { + if (str) free(str); + Xen_out_of_range_error(S_new_sound, 3, fp, "srate <= 0?"); + } } else sr = default_output_srate(ss); @@ -4479,10 +4488,16 @@ static s7_pointer g_new_sound(s7_scheme *sc, s7_pointer args) if (fp != Xen_false) { if (!s7_is_integer(fp)) - return(s7_wrong_type_arg_error(sc, S_new_sound, 4, fp, "an integer (sample type)")); + { + if (str) free(str); + return(s7_wrong_type_arg_error(sc, S_new_sound, 4, fp, "an integer (sample type)")); + } df = (mus_sample_t)s7_integer(fp); if (!(mus_is_sample_type(df))) - Xen_out_of_range_error(S_new_sound, 4, fp, "invalid sample type"); + { + if (str) free(str); + Xen_out_of_range_error(S_new_sound, 4, fp, "invalid sample type"); + } } else df = default_output_sample_type(ss); @@ -4491,15 +4506,24 @@ static s7_pointer g_new_sound(s7_scheme *sc, s7_pointer args) if (fp != Xen_false) { if (!s7_is_integer(fp)) - return(s7_wrong_type_arg_error(sc, S_new_sound, 5, fp, "an integer (header type)")); + { + if (str) free(str); + return(s7_wrong_type_arg_error(sc, S_new_sound, 5, fp, "an integer (header type)")); + } ht = (mus_header_t)s7_integer(fp); if (!(mus_is_header_type(ht))) - Xen_out_of_range_error(S_new_sound, 5, fp, "invalid header type"); + { + if (str) free(str); + Xen_out_of_range_error(S_new_sound, 5, fp, "invalid header type"); + } if (!(mus_header_writable(ht, df))) - Xen_error(BAD_HEADER, - Xen_list_3(C_string_to_Xen_string(S_new_sound ": can't write ~A data to a ~A header"), - C_string_to_Xen_string(mus_sample_type_short_name(df)), - C_string_to_Xen_string(mus_header_type_name(ht)))); + { + if (str) free(str); + Xen_error(BAD_HEADER, + Xen_list_3(C_string_to_Xen_string(S_new_sound ": can't write ~A data to a ~A header"), + C_string_to_Xen_string(mus_sample_type_short_name(df)), + C_string_to_Xen_string(mus_header_type_name(ht)))); + } } else ht = default_output_header_type(ss); @@ -4507,7 +4531,10 @@ static s7_pointer g_new_sound(s7_scheme *sc, s7_pointer args) if (fp != Xen_false) { if (!s7_is_string(fp)) - return(s7_wrong_type_arg_error(sc, S_new_sound, 6, fp, "a string")); + { + if (str) free(str); + return(s7_wrong_type_arg_error(sc, S_new_sound, 6, fp, "a string")); + } com = s7_string(fp); } else com = NULL; @@ -4516,10 +4543,16 @@ static s7_pointer g_new_sound(s7_scheme *sc, s7_pointer args) if (fp != Xen_false) { if (!s7_is_integer(fp)) - return(s7_wrong_type_arg_error(sc, S_new_sound, 7, fp, "an integer (initial file size)")); + { + if (str) free(str); + return(s7_wrong_type_arg_error(sc, S_new_sound, 7, fp, "an integer (initial file size)")); + } len = s7_integer(fp); if (len < 0) - Xen_out_of_range_error(S_new_sound, 7, fp, "size < 0?"); + { + if (str) free(str); + Xen_out_of_range_error(S_new_sound, 7, fp, "size < 0?"); + } } else len = 1; @@ -4528,7 +4561,7 @@ static s7_pointer g_new_sound(s7_scheme *sc, s7_pointer args) { s7_pointer filep; filep = s7_make_string(sc, str); - if (str) {free(str); str = NULL;} + if (str) free(str); Xen_error(Xen_make_error_type("IO-error"), Xen_list_3(C_string_to_Xen_string(S_new_sound ": ~S, ~A"), filep, @@ -4638,7 +4671,7 @@ static Xen g_new_sound(Xen arglist) io_err = snd_write_header(str, ht, sr, ch, len * ch, df, com, NULL); /* last arg is loop info */ if (io_err != IO_NO_ERROR) { - if (str) {free(str); str = NULL;} + if (str) free(str); Xen_error(Xen_make_error_type("IO-error"), Xen_list_3(C_string_to_Xen_string(S_new_sound ": ~S, ~A"), keys[0], diff --git a/snd-test.scm b/snd-test.scm index 5990765..6eadbf2 100644 --- a/snd-test.scm +++ b/snd-test.scm @@ -17128,7 +17128,7 @@ EDITS: 2 (if (not (>= 1.0 val2 -1.0)) (snd-display "rand-interp: ~A ~A" val2 gen1)))) - (let ((gen (make-rand 10000.0 :distribution (inverse-integrate '(0 0 1 1)))) + (let ((gen (make-rand 10000.0 :distribution (inverse-integrate '(0.0 0.0 1 1)))) (v0 (make-float-vector 10))) (print-and-check gen "rand" @@ -17144,8 +17144,8 @@ EDITS: 2 (= (mus-length gen) 512))) (snd-display "(dist 2) rand data: ~A ~A" (mus-length gen) (mus-data gen)))) - (let ((gen1 (make-rand 10000.0 :distribution (inverse-integrate '(0 0 1 1)))) - (gen2 (make-rand 10000.0 :distribution (inverse-integrate '(0 1 1 0)))) + (let ((gen1 (make-rand 10000.0 :distribution (inverse-integrate '(0.0 0.0 1 1)))) + (gen2 (make-rand 10000.0 :distribution (inverse-integrate '(0.0 1.0 1 0)))) (up1 0) (down1 0) (bad1 0) @@ -17187,16 +17187,16 @@ EDITS: 2 (map-channel (lambda (y) (any-random 1.0 g)))) (clean-up-sound ind)) - (let ((v1 (inverse-integrate '(-1 1 1 1)))) + (let ((v1 (inverse-integrate '(-1.0 1.0 1 1)))) (if (fneq (v1 4) -0.984) (snd-display "inverse-integrate -1 to 1 uniform: ~A" v1))) - (let ((v1 (inverse-integrate '(0 1 1 1)))) + (let ((v1 (inverse-integrate '(0.0 1.0 1 1)))) (if (fneq (v1 4) .008) (snd-display "inverse-integrate 0 to 1 uniform: ~A" v1))) - (let ((v1 (inverse-integrate '(0 1 1 0)))) + (let ((v1 (inverse-integrate '(0.0 1.0 1 0)))) (if (fneq (v1 4) .004) (snd-display "inverse-integrate 0 to 1 1 to 0: ~A" v1))) - (let ((v1 (inverse-integrate '(0 0 .5 1 1 0)))) + (let ((v1 (inverse-integrate '(0.0 0.0 .5 1 1 0)))) (if (fneq (v1 4) .073) (snd-display "inverse-integrate triangle: ~A" v1))) (let ((v1 (inverse-integrate (gaussian-envelope 1.0)))) @@ -47,11 +47,11 @@ #include "snd-strings.h" -#define SND_DATE "1-Jan-24" +#define SND_DATE "2-Feb-24" #ifndef SND_VERSION -#define SND_VERSION "24.0" +#define SND_VERSION "24.1" #endif #define SND_MAJOR_VERSION "24" -#define SND_MINOR_VERSION "0" +#define SND_MINOR_VERSION "1" #endif diff --git a/sndlib2xen.c b/sndlib2xen.c index c7b8eb2..e02579a 100644 --- a/sndlib2xen.c +++ b/sndlib2xen.c @@ -427,7 +427,8 @@ static Xen g_mus_sound_duration(Xen gfilename) char *str = NULL; Xen_check_type(Xen_is_string(gfilename), gfilename, 1, S_mus_sound_duration, "a string"); - res = mus_sound_duration(str = mus_expand_filename(Xen_string_to_C_string(gfilename))); + str = mus_expand_filename(Xen_string_to_C_string(gfilename)); + res = mus_sound_duration(str); if (str) free(str); return(C_double_to_Xen_real(res)); @@ -1471,7 +1471,7 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.") (if (not (string? name)) (error 'wrong-type-arg "directory name should be a string: ~S" name) (make-iterator - (with-let (sublet *libc* :name name :recursive recursive) + (with-let (sublet *libc* :name name :recursive recursive :NULL (c-pointer 0 'void*)) (let ((dir (opendir name))) (if (equal? dir NULL) (error 'io-error "can't open ~S: ~S" name (strerror (errno))) diff --git a/tools/auto-tester.scm b/tools/auto-tester.scm index 8b94e33..8456a3d 100644 --- a/tools/auto-tester.scm +++ b/tools/auto-tester.scm @@ -1096,7 +1096,7 @@ 'weak-hash-table 'byte? 'the 'lognand 'logeqv 'local-random 'local-read-string 'local-varlet 'local-let-set! - 'pp-checked + ;'pp-checked 'kar '_dilambda_ '_vals_ '_vals1_ '_vals2_ '_vals3_ '_vals4_ '_vals5_ '_vals6_ '_vals3s_ '_vals4s_ '_vals5s_ '_vals6s_ '_svals3_ '_svals4_ '_svals5_ '_svals6_ '_svals3s_ '_svals4s_ '_svals5s_ '_svals6s_ @@ -1117,7 +1117,8 @@ 'gb1 'gb2 'gb3 'cf00 'c-function-with-values 'c-macro-with-values 'safe-c-function-with-2-values - 'bignum 'symbol 'count-if 'pretty-print 'tree-member 'funclet? 'bignum? 'copy-tree + 'bignum 'symbol 'count-if ;'pretty-print + 'tree-member 'funclet? 'bignum? 'copy-tree ;'dynamic-unwind ; many swaps that are probably confused ;'function-open-output 'function-open-input 'function-get-output 'function-close-output ;see s7test, not set up for t725 @@ -1129,9 +1130,9 @@ "(bignum +inf.0)" "(bignum +nan.0)" "(bignum -inf.0)" "(bignum 0+i)" "(bignum 0.0)" "(bignum 0-i)" "(expt 2 -32)" "1/2+1/3i" "=>" - "\"ho\"" ":ho" "'ho" "(list 1)" "(list 1 2)" "(cons 1 2)" "()" "(list (list 1 2))" "(list (list 1))" "(list ())" + "\"ho\"" ":ho" "ho:" "'ho" "(list 1)" "(list 1 2)" "(cons 1 2)" "()" "(list (list 1 2))" "(list (list 1))" "(list ())" "#f" "#t" "()" "#()" "\"\"" ; ":write" -- not this because sr2 calls write and this can be an arg to sublet redefining write - ":readable" ":rest" ":allow-other-keys" ":display" ":write" ":if" "':abs" ":a" ":frequency" ":scaler" ; for blocks5 s7test.scm + ":readable" ":rest" ":allow-other-keys" ":display" ":write" ":if" "':abs" ":a" "a:" ":frequency" ":scaler" ; for blocks5 s7test.scm "1/0+i" "0+0/0i" "0+1/0i" "1+0/0i" "0/0+0/0i" "0/0+i" "+nan.0-3i" "+inf.0-nan.0i" "cons" "\"ra\"" "''2" "'a" "_!asdf!_" "let-ref-fallback" @@ -1304,7 +1305,7 @@ "begin" "cond" "case" "when" "unless" "letrec" "letrec*" "or" "and" "let-temporarily" "catch" "call-with-exit" "map" "for-each" ;"lambda*" "lambda" ;-- cyclic body etc - "let" "let*" ;"do" + ;"let" "let*" ;"do" ; infinite loops "set!" "with-let" "values" "let-set!" ;"define" "define*" "define-macro" "define-macro*" "define-bacro" "define-bacro*" "(let ((L (list 1))) (set-cdr! L L) L)" @@ -1380,8 +1381,8 @@ "(let loop ((i 2)) (if (> i 0) (loop (- i 1)) i))" - "(rootlet)" ; why was this commented out? - ;"(unlet)" ; variable + ;"(rootlet)" ; why was this commented out? -- very verbose useless diffs + "(unlet)" "(let? (curlet))" ;"*s7*" ;variable @@ -1410,8 +1411,8 @@ (lambda (s) (string-append "(case x (else " s "))"))) (list (lambda (s) (string-append "(case false ((#f) " s "))")) (lambda (s) (string-append "(case false ((1) #t) (else " s "))"))) - (list (lambda (s) (string-append "(with-let (rootlet) " s ")")) - (lambda (s) (string-append "(with-let (sublet (rootlet)) " s ")"))) +; (list (lambda (s) (string-append "(with-let (rootlet) " s ")")) +; (lambda (s) (string-append "(with-let (sublet (rootlet)) " s ")"))) (reader-cond (with-continuations (list (lambda (s) (string-append "(call-with-exit (lambda (_x_) " s "))")) @@ -1549,9 +1550,6 @@ (list (lambda (s) (string-append "(_stable1_ " s ")")) (lambda (s) (string-append "(_stable2_ " s ")"))) -;;; (+ (dynamic-wind (lambda () #f) (lambda () (values 1 2 3)) (lambda () #f))): 6 - - ;; perhaps function port (see _rd3_ for open-input-string), gmp? )) @@ -1957,12 +1955,14 @@ (set! last-func outer-funcs)) ;(unless (output-port? imfo) (format *stderr* "(new) imfo ~S -> ~S~%" estr imfo) (abort)) ; with-mock-data - (when (infinite? (length *features*)) - (format *stderr* "*features*: ~S, estr: ~A~%" *features* estr) - (abort)) +; (when (infinite? (length *features*)) +; (format *stderr* "*features*: ~S, estr: ~A~%" *features* estr) +; (abort)) (set! error-info #f) (set! error-type 'no-error) (set! error-code "") +; (when (pair? x) (format *stderr* "x is pair, estr: ~S~%" estr)) + (set! x 0) (when (string-position "H_" str) (if (string-position "H_1" str) (fill! H_1 #f)) (if (string-position "H_2" str) (fill! H_2 #f)) diff --git a/tools/dup.scm b/tools/dup.scm index eaf51d8..78ce5cc 100644 --- a/tools/dup.scm +++ b/tools/dup.scm @@ -1,5 +1,5 @@ ;;; dup.scm -;;; (dups size file alloc-lines): +;;; (dup size file alloc-lines): ;;; find all matches of "size" successive lines in "file" ignoring empty lines and leading/trailing whitespace ;;; "alloc-lines" is any number bigger than the number of lines in "file" ;;; (dups 16 "s7.c" 91000) finds all 16-line matches in s7.c which (we wish) has less than 91000 lines in all @@ -57,7 +57,7 @@ (set! size (min size total-lines)) (set! size-1 (- size 1)) - ;; (format *stderr* "lines: ~S~%" total-lines) ; 84201 2-jul-19, 89690 29-Aug-20, 85715 28-May-22 + ;; (format *stderr* "lines: ~S~%" total-lines) ; 84201 2-jul-19, 89690 29-Aug-20, 85715 28-May-22, 88607 17-Jan-24 ;; mark unmatchable strings (let ((sortv (make-vector total-lines))) @@ -127,6 +127,7 @@ ) (dup 16 "s7.c" 110000) +;(dup 12 "s7.c" 110000) ;(dup 8 "s7.c" 110000) ;(dup 12 "ffitest.c" 10000) ;(dup 8 "ffitest.c" 10000) diff --git a/tools/ffitest.c b/tools/ffitest.c index b6cb1ae..66f5704 100644 --- a/tools/ffitest.c +++ b/tools/ffitest.c @@ -1607,6 +1607,25 @@ int main(int argc, char **argv) {fprintf(stderr, "%d: %s is not an integer?\n", __LINE__, s1 = TO_STR(p)); free(s1);} if (s7_integer(p) != 4) {fprintf(stderr, "%d: %s is not 4?\n", __LINE__, s1 = TO_STR(p)); free(s1);} + { + s7_int val; + val = s7_integer(s7_apply_function_star(sc, s7_name_to_value(sc, "plus"), + s7_list(sc, 2, s7_make_integer(sc, 1), s7_make_integer(sc, 2)))); + if (val != 4) + fprintf(stderr, "%d: plus: %" ld64 "\n", __LINE__, val); + val = s7_integer(s7_apply_function_star(sc, s7_name_to_value(sc, "plus"), + s7_list(sc, 2, s7_make_keyword(sc, "blue"), s7_make_integer(sc, 2)))); + if (val != 66) + fprintf(stderr, "%d: plus: %" ld64 "\n", __LINE__, val); + val = s7_integer(s7_apply_function_star(sc, s7_name_to_value(sc, "plus"), + s7_list(sc, 2, s7_make_symbol(sc, ":blue"), s7_make_integer(sc, 2)))); + if (val != 66) + fprintf(stderr, "%d: plus: %" ld64 "\n", __LINE__, val); + val = s7_integer(s7_apply_function_star(sc, s7_name_to_value(sc, "plus"), + s7_list(sc, 2, s7_make_symbol(sc, "blue:"), s7_make_integer(sc, 2)))); + if (val != 66) + fprintf(stderr, "%d: plus: %" ld64 "\n", __LINE__, val); + } s7_define_function_star(sc, "plus1", plus1, "a b c", "an example of define* from C"); { @@ -1748,7 +1767,7 @@ int main(int argc, char **argv) {fprintf(stderr, "%d: %s is a multiple-values object?\n", __LINE__, s1 = TO_STR(p)); free(s1);} s7_define_semisafe_typed_function(sc, "open-plus", open_plus, 1, 0, true, plus_help, s7_make_circular_signature(sc, 1, 2, s7_make_symbol(sc, "number?"), s7_t(sc))); - p = s7_sublet(sc, s7_nil(sc), s7_cons(sc, s7_cons(sc, s7_make_symbol(sc, "plus"), s7_name_to_value(sc, "plus")), s7_nil(sc))); + p = s7_sublet(sc, s7_rootlet(sc), s7_cons(sc, s7_cons(sc, s7_make_symbol(sc, "plus"), s7_name_to_value(sc, "plus")), s7_nil(sc))); s7_openlet(sc, p); p1 = s7_apply_function(sc, s7_name_to_value(sc, "open-plus"), s7_list(sc, 3, p, s7_make_integer(sc, 2), s7_make_integer(sc, 3))); if ((!s7_is_integer(p1)) || @@ -1889,6 +1908,7 @@ int main(int argc, char **argv) old_e = s7_set_curlet(sc, e); arg = s7_make_symbol(sc, "arg"); yp = s7_make_slot(sc, e, arg, s7_make_mutable_real(sc, 1.0)); + s7_gc_protect_2_via_stack(sc, yp, old_e); if (s7_real(s7_slot_value(yp)) != 1.0) {fprintf(stderr, "%d: mutable real slot-value %s is not 1.0?\n", __LINE__, s1 = TO_STR(s7_slot_value(yp))); free(s1);} s7_slot_set_real_value(sc, yp, 2.0); @@ -2264,7 +2284,7 @@ int main(int argc, char **argv) free(s1); s1 = TO_STR(s7_closure_let(sc, p)); - if (strcmp(s1, "()") != 0) + if (strcmp(s1, "(rootlet)") != 0) {fprintf(stderr, "%d: s7_closure_let is %s?\n", __LINE__, s1);} free(s1); @@ -2272,8 +2292,8 @@ int main(int argc, char **argv) fprintf(stderr, "closure_body(abs) is not nil?\n"); if (s7_closure_args(sc, s7_name_to_value(sc, "abs")) != s7_nil(sc)) fprintf(stderr, "closure_args(abs) is not nil?\n"); - if (s7_closure_let(sc, s7_name_to_value(sc, "abs")) != s7_nil(sc)) - fprintf(stderr, "closure_let(abs) is not nil?\n"); + if (s7_closure_let(sc, s7_name_to_value(sc, "abs")) != s7_rootlet(sc)) + fprintf(stderr, "closure_let(abs) is not rootlet?\n"); if (!s7_is_aritable(sc, p, 2)) {fprintf(stderr, "%d: aritable? lambda 2 = #f?\n", __LINE__);} diff --git a/tools/tclo.scm b/tools/tclo.scm index 5d91ddd..469dca8 100644 --- a/tools/tclo.scm +++ b/tools/tclo.scm @@ -176,19 +176,19 @@ (+ a0 a1)) (define (g100) + (let ((args (list :a0 1 :a1 1 :a2 1 :a3 1 :a4 1 :a5 1 :a6 1 :a7 1 :a8 1 :a9 1 + :a10 1 :a11 1 :a12 1 :a13 1 :a14 1 :a15 1 :a16 1 :a17 1 :a18 1 :a19 1 + :a20 1 :a21 1 :a22 1 :a23 1 :a24 1 :a25 1 :a26 1 :a27 1 :a28 1 :a29 1 + :a30 1 :a31 1 :a32 1 :a33 1 :a34 1 :a35 1 :a36 1 :a37 1 :a38 1 :a39 1 + :a40 1 :a41 1 :a42 1 :a43 1 :a44 1 :a45 1 :a46 1 :a47 1 :a48 1 :a49 1 + :a50 1 :a51 1 :a52 1 :a53 1 :a54 1 :a55 1 :a56 1 :a57 1 :a58 1 :a59 1 + :a60 1 :a61 1 :a62 1 :a63 1 :a64 1 :a65 1 :a66 1 :a67 1 :a68 1 :a69 1 + :a70 1 :a71 1 :a72 1 :a73 1 :a74 1 :a75 1 :a76 1 :a77 1 :a78 1 :a79 1 + :a80 1 :a81 1 :a82 1 :a83 1 :a84 1 :a85 1 :a86 1 :a87 1 :a88 1 :a89 1 + :a90 1 :a91 1 :a92 1 :a93 1 :a94 1 :a95 1 :a96 1 :a97 1 :a98 1 :a99 1))) (do ((i 0 (+ i 1))) ((= i k100-size)) - (k100 :a0 1 :a1 1 :a2 1 :a3 1 :a4 1 :a5 1 :a6 1 :a7 1 :a8 1 :a9 1 - :a10 1 :a11 1 :a12 1 :a13 1 :a14 1 :a15 1 :a16 1 :a17 1 :a18 1 :a19 1 - :a20 1 :a21 1 :a22 1 :a23 1 :a24 1 :a25 1 :a26 1 :a27 1 :a28 1 :a29 1 - :a30 1 :a31 1 :a32 1 :a33 1 :a34 1 :a35 1 :a36 1 :a37 1 :a38 1 :a39 1 - :a40 1 :a41 1 :a42 1 :a43 1 :a44 1 :a45 1 :a46 1 :a47 1 :a48 1 :a49 1 - :a50 1 :a51 1 :a52 1 :a53 1 :a54 1 :a55 1 :a56 1 :a57 1 :a58 1 :a59 1 - :a60 1 :a61 1 :a62 1 :a63 1 :a64 1 :a65 1 :a66 1 :a67 1 :a68 1 :a69 1 - :a70 1 :a71 1 :a72 1 :a73 1 :a74 1 :a75 1 :a76 1 :a77 1 :a78 1 :a79 1 - :a80 1 :a81 1 :a82 1 :a83 1 :a84 1 :a85 1 :a86 1 :a87 1 :a88 1 :a89 1 - :a90 1 :a91 1 :a92 1 :a93 1 :a94 1 :a95 1 :a96 1 :a97 1 :a98 1 :a99 1))) - + (apply k100 args)))) ;;; -------------------------------- (define (kcall) diff --git a/tools/tests7 b/tools/tests7 index ba03c51..9062735 100755 --- a/tools/tests7 +++ b/tools/tests7 @@ -11,6 +11,7 @@ cp ~/cl/low-primes.scm . cp ~/cl/full-s7test.scm . cp ~/cl/lt.scm . cp ~/cl/peak-phases.scm . +cp ~/cl/arbtest.scm . echo ' ' echo '-------- base case --------' @@ -30,26 +31,35 @@ gcc -o nrepl nrepl.c -g3 -Wall s7.o -I. -Wl,-export-dynamic -lnotcurses-core -lm nrepl s7test.scm echo ' ' -echo '-------- s7-debugging/system-extras --------' +echo '-------- with-gmp --------' echo ' ' -gcc s7.c -c -I. -DS7_DEBUGGING -DWITH_SYSTEM_EXTRAS -g3 -ldl -lm -Wl,-export-dynamic -gcc -o repl repl.c -g3 -Wall s7.o -I. -lm -ldl -Wl,-export-dynamic +gcc s7.c -c -I. -g3 -DWITH_GMP -ldl -lm -Wl,-export-dynamic +gcc -o repl repl.c -g3 -Wall s7.o -I. -lgmp -lmpfr -lmpc -lm -ldl -Wl,-export-dynamic repl s7test.scm -repl t101.scm echo ' ' -echo '-------- with-gmp --------' +echo '-------- with-gmp precision --------' echo ' ' -gcc s7.c -c -I. -g3 -DWITH_GMP -ldl -lm -Wl,-export-dynamic +gcc s7.c -c -I. -g3 -DWITH_GMP -DDEFAULT_BIGNUM_PRECISION=512 -ldl -lm -Wl,-export-dynamic gcc -o repl repl.c -g3 -Wall s7.o -I. -lgmp -lmpfr -lmpc -lm -ldl -Wl,-export-dynamic repl s7test.scm echo ' ' -echo '-------- with-gmp precision --------' +echo '-------- libarb/flint --------' echo ' ' gcc s7.c -c -I. -g3 -DWITH_GMP -DDEFAULT_BIGNUM_PRECISION=512 -ldl -lm -Wl,-export-dynamic gcc -o repl repl.c -g3 -Wall s7.o -I. -lgmp -lmpfr -lmpc -lm -ldl -Wl,-export-dynamic +gcc -fPIC -c libarb_s7.c +gcc libarb_s7.o -shared -o libarb_s7.so -L/usr/local/lib -lflint +repl arbtest.scm + +echo ' ' +echo '-------- s7-debugging/system-extras --------' +echo ' ' +gcc s7.c -c -I. -DS7_DEBUGGING -DWITH_SYSTEM_EXTRAS -g3 -ldl -lm -Wl,-export-dynamic +gcc -o repl repl.c -g3 -Wall s7.o -I. -lm -ldl -Wl,-export-dynamic repl s7test.scm +repl t101.scm echo ' ' echo '-------- with-pure-s7 --------' diff --git a/tools/tfft.scm b/tools/tfft.scm index 0067716..496bace 100644 --- a/tools/tfft.scm +++ b/tools/tfft.scm @@ -150,8 +150,8 @@ (rl (make-float-vector dims)) (im (make-float-vector dims)) (out (make-float-vector dims)) - (xw 0) - (yh 0)) + (xw 0.0) + (yh 0.0)) (do ((yout 0 (+ yout 1))) ((= yout h) (do ((i 0 (+ i 1))) @@ -353,9 +353,9 @@ (rl (make-float-vector dims)) (im (make-float-vector dims)) (out (make-float-vector dims)) - (zd 0) - (xw 0) - (yh 0)) + (zd 0.0) + (xw 0.0) + (yh 0.0)) (do ((yout 0 (+ yout 1))) ((= yout h) (do ((i 0 (+ i 1))) diff --git a/tools/tgsl.scm b/tools/tgsl.scm index 39051c0..7f5f9e8 100644 --- a/tools/tgsl.scm +++ b/tools/tgsl.scm @@ -94,476 +94,482 @@ expr) (define (testrst) - (do ((i 0 (+ i 1))) - ((= i 3000)) - (num-test (gsl_sf_airy_Ai -500.0 GSL_MODE_DEFAULT) 0.07259012010418163) - (num-test (gsl_sf_airy_Bi -500.0 GSL_MODE_DEFAULT) -0.0946885701328829) - (num-test (gsl_sf_airy_Ai_scaled -5.0 GSL_MODE_DEFAULT) 0.3507610090241141) - (num-test (gsl_sf_airy_Bi_scaled -5.0 GSL_MODE_DEFAULT) -0.1383691349016009) - (num-test (gsl_sf_airy_Ai_deriv -5.0 GSL_MODE_DEFAULT) 0.3271928185544435) - (num-test (gsl_sf_airy_Bi_deriv -5.0 GSL_MODE_DEFAULT) 0.778411773001899) - (num-test (gsl_sf_airy_Ai_deriv_scaled -5.0 GSL_MODE_DEFAULT) 0.3271928185544435) - (num-test (gsl_sf_airy_Bi_deriv_scaled -5.0 GSL_MODE_DEFAULT) 0.778411773001899) - (num-test (gsl_sf_airy_zero_Ai_deriv 2) -3.248197582179837) - (num-test (gsl_sf_airy_zero_Bi_deriv 2) -4.073155089071828) - (num-test (gsl_sf_bessel_J0 1.0) 0.7651976865579666) - (num-test (let ((sfr (gsl_sf_result.make))) (gsl_sf_bessel_J0_e 1.0 sfr) (gsl_sf_result.val sfr)) 0.7651976865579666) - (num-test (let ((sfr (gsl_sf_result.make))) (gsl_sf_bessel_J0_e 1.0 sfr) (gsl_sf_result.err sfr)) 6.72613016567227e-16) - (num-test (gsl_sf_bessel_J0 .1) 0.9975015620660401) - (num-test (gsl_sf_bessel_J1 .1) 0.049937526036242) - (num-test (gsl_sf_bessel_Jn 45 900.0) 0.02562434700634277) - (num-test (gsl_sf_bessel_Y0 .1) -1.534238651350367) - (num-test (gsl_sf_bessel_Y1 .1) -6.458951094702027) - (num-test (gsl_sf_bessel_Yn 4 .1) -305832.2979335312) - (num-test (gsl_sf_bessel_I0_scaled .1) 0.9071009257823011) - (num-test (gsl_sf_bessel_I1_scaled .1) 0.04529844680880932) - (num-test (gsl_sf_bessel_In_scaled 4 .1) 2.35752586200546e-07) - (num-test (gsl_sf_bessel_I0 .1) 1.002501562934096) - (num-test (gsl_sf_bessel_I1 .1) 0.05006252604709269) - (num-test (gsl_sf_bessel_In 4 .1) 2.605469021299657e-07) - (num-test (gsl_sf_bessel_K0_scaled .1) 2.682326102262894) - (num-test (gsl_sf_bessel_K1_scaled .1) 10.8901826830497) - (num-test (gsl_sf_bessel_Kn_scaled 4 .1) 530040.2483725621) - (num-test (gsl_sf_bessel_K0 .1) 2.427069024702016) - (num-test (gsl_sf_bessel_K1 .1) 9.853844780870606) - (num-test (gsl_sf_bessel_Kn 4 .1) 479600.2497925678) - (num-test (gsl_sf_bessel_j0 1.0) 0.8414709848078965) - (num-test (gsl_sf_bessel_j1 1.0) 0.3011686789397567) - (num-test (gsl_sf_bessel_j2 1.0) 0.06203505201137386) - (num-test (gsl_sf_bessel_jl 5 1.0) 9.256115861125814e-05) - (num-test (gsl_sf_bessel_zero_J0 1) 2.404825557695771) - (num-test (gsl_sf_bessel_zero_Jnu 5 5) 22.21779994656127) - (num-test (gsl_sf_hydrogenicR_1 3 2) 0.02575994825614847) - (num-test (gsl_sf_dilog -3.0) -1.939375420766708) - (let ((s1 (gsl_sf_result.make)) - (s2 (gsl_sf_result.make))) + (let ((sfr (gsl_sf_result.make)) + (s1 (gsl_sf_result.make)) + (s2 (gsl_sf_result.make)) + (gs (gsl_cheb_alloc 40)) + (g1 (gsl_vector_alloc 3)) + (g2 (gsl_vector_alloc 3)) + (step_size (gsl_vector_alloc 2)) + (v1 (gsl_vector_alloc 2)) + (v2 (gsl_vector_alloc 2)) + (c1 (gsl_multiset_calloc 4 2)) + ) + (do ((i 0 (+ i 1))) + ((= i 3000)) + (num-test (gsl_sf_airy_Ai -500.0 GSL_MODE_DEFAULT) 0.07259012010418163) + (num-test (gsl_sf_airy_Bi -500.0 GSL_MODE_DEFAULT) -0.0946885701328829) + (num-test (gsl_sf_airy_Ai_scaled -5.0 GSL_MODE_DEFAULT) 0.3507610090241141) + (num-test (gsl_sf_airy_Bi_scaled -5.0 GSL_MODE_DEFAULT) -0.1383691349016009) + (num-test (gsl_sf_airy_Ai_deriv -5.0 GSL_MODE_DEFAULT) 0.3271928185544435) + (num-test (gsl_sf_airy_Bi_deriv -5.0 GSL_MODE_DEFAULT) 0.778411773001899) + (num-test (gsl_sf_airy_Ai_deriv_scaled -5.0 GSL_MODE_DEFAULT) 0.3271928185544435) + (num-test (gsl_sf_airy_Bi_deriv_scaled -5.0 GSL_MODE_DEFAULT) 0.778411773001899) + (num-test (gsl_sf_airy_zero_Ai_deriv 2) -3.248197582179837) + (num-test (gsl_sf_airy_zero_Bi_deriv 2) -4.073155089071828) + (num-test (gsl_sf_bessel_J0 1.0) 0.7651976865579666) + (num-test (begin (gsl_sf_bessel_J0_e 1.0 sfr) (gsl_sf_result.val sfr)) 0.7651976865579666) + (num-test (begin (gsl_sf_bessel_J0_e 1.0 sfr) (gsl_sf_result.err sfr)) 6.72613016567227e-16) + (num-test (gsl_sf_bessel_J0 .1) 0.9975015620660401) + (num-test (gsl_sf_bessel_J1 .1) 0.049937526036242) + (num-test (gsl_sf_bessel_Jn 45 900.0) 0.02562434700634277) + (num-test (gsl_sf_bessel_Y0 .1) -1.534238651350367) + (num-test (gsl_sf_bessel_Y1 .1) -6.458951094702027) + (num-test (gsl_sf_bessel_Yn 4 .1) -305832.2979335312) + (num-test (gsl_sf_bessel_I0_scaled .1) 0.9071009257823011) + (num-test (gsl_sf_bessel_I1_scaled .1) 0.04529844680880932) + (num-test (gsl_sf_bessel_In_scaled 4 .1) 2.35752586200546e-07) + (num-test (gsl_sf_bessel_I0 .1) 1.002501562934096) + (num-test (gsl_sf_bessel_I1 .1) 0.05006252604709269) + (num-test (gsl_sf_bessel_In 4 .1) 2.605469021299657e-07) + (num-test (gsl_sf_bessel_K0_scaled .1) 2.682326102262894) + (num-test (gsl_sf_bessel_K1_scaled .1) 10.8901826830497) + (num-test (gsl_sf_bessel_Kn_scaled 4 .1) 530040.2483725621) + (num-test (gsl_sf_bessel_K0 .1) 2.427069024702016) + (num-test (gsl_sf_bessel_K1 .1) 9.853844780870606) + (num-test (gsl_sf_bessel_Kn 4 .1) 479600.2497925678) + (num-test (gsl_sf_bessel_j0 1.0) 0.8414709848078965) + (num-test (gsl_sf_bessel_j1 1.0) 0.3011686789397567) + (num-test (gsl_sf_bessel_j2 1.0) 0.06203505201137386) + (num-test (gsl_sf_bessel_jl 5 1.0) 9.256115861125814e-05) + (num-test (gsl_sf_bessel_zero_J0 1) 2.404825557695771) + (num-test (gsl_sf_bessel_zero_Jnu 5 5) 22.21779994656127) + (num-test (gsl_sf_hydrogenicR_1 3 2) 0.02575994825614847) + (num-test (gsl_sf_dilog -3.0) -1.939375420766708) (gsl_sf_complex_dilog_e 0.99999 (/ pi 2) s1 s2) (num-test (gsl_sf_result.val s1) -0.2056132926277968) - (num-test (gsl_sf_result.val s2) 0.9159577401813151)) - (let ((s1 (gsl_sf_result.make)) - (s2 (gsl_sf_result.make))) + (num-test (gsl_sf_result.val s2) 0.9159577401813151) (gsl_sf_complex_spence_xy_e 0.5 0.0 s1 s2) (num-test (gsl_sf_result.val s1) 0.5822405264650126) - (num-test (gsl_sf_result.val s2) 0.0)) - (num-test (gsl_sf_lngamma -0.1) 2.368961332728787) - (num-test (gsl_sf_gamma 9.0) 40320.0) - (num-test (gsl_sf_gammastar 9.0) 1.009298426421819) - (num-test (gsl_sf_gammainv -1.0) 0.0) - (let ((s1 (gsl_sf_result.make)) - (s2 (gsl_sf_result.make))) + (num-test (gsl_sf_result.val s2) 0.0) + (num-test (gsl_sf_lngamma -0.1) 2.368961332728787) + (num-test (gsl_sf_gamma 9.0) 40320.0) + (num-test (gsl_sf_gammastar 9.0) 1.009298426421819) + (num-test (gsl_sf_gammainv -1.0) 0.0) (gsl_sf_lngamma_complex_e 5.0 2.0 s1 s2) (num-test (gsl_sf_result.val s1) 2.748701756133804) - (num-test (gsl_sf_result.val s2) 3.073843410049702)) - (num-test (gsl_sf_taylorcoeff 10 5) 2.691144455467373) - (num-test (gsl_sf_choose 7 3) 35.0) - (num-test (gsl_sf_poch 7 3) 504.0000000000001) - (num-test (gsl_sf_gamma_inc_P 1.0 10.0) 0.9999546000702381) - (num-test (gsl_sf_lnbeta 0.1 1.0) 2.302585092994044) - (num-test (gsl_sf_beta 100.1 -1.2) 1203.895236907804) - (num-test (gsl_sf_hyperg_0F1 1 0.5) 1.56608292975635) - (num-test (gsl_sf_hyperg_1F1 1 1.5 1) 2.030078469278705) - (num-test (gsl_sf_hyperg_U_int 100 100 1) 0.009998990209084679) - (num-test (gsl_sf_hyperg_2F1 1 1 1 0.5) 2.0) - (num-test (gsl_sf_legendre_P1 -0.5) -0.5) - (num-test (gsl_sf_legendre_sphPlm 10 0 -0.5) -0.2433270236930014) - (num-test (gsl_sf_legendre_Q0 -0.5) -0.5493061443340549) - (num-test (gsl_sf_clausen (+ (* 2 pi) (/ pi 3))) 1.014941606409653) - (num-test (gsl_sf_coupling_3j 0 1 1 0 1 -1) 0.7071067811865476) - (num-test (gsl_sf_dawson 0.5) 0.4244363835020223) - (num-test (gsl_sf_multiply -3 2) -6.0) - (num-test (gsl_sf_ellint_E (/ pi 2) 0.5 GSL_MODE_DEFAULT) 1.467462209339427) - (num-test (gsl_sf_erfc -10) 2.0) - (num-test (gsl_sf_exp_mult 10 -2) -44052.93158961344) - (num-test (gsl_sf_expm1 -.001) -0.0009995001666250082) - (num-test (gsl_sf_Shi -1) -1.057250875375728) - (num-test (gsl_sf_fermi_dirac_0 -1) 0.3132616875182229) - (num-test (gsl_sf_gegenpoly_1 1.0 1.0) 2.0) - - (let ((p (float-vector 1.0 -2.0 1.0)) (res (vector 0.0 0.0))) - (gsl_poly_complex_solve (wrap-double* p) 3 res) - (test res #(1.0 1.0))) - (let ((p (float-vector 1 -1 1 -1 1 -1 1 -1 1 -1 1))) - (num-test (gsl_poly_eval (wrap-double* p) 11 1.0) 1.0)) - (let ((p (float-vector 2.1 -1.34 0.76 0.45))) - (num-test (gsl_poly_complex_eval (wrap-double* p) 4 0.49+0.95i) 0.3959142999999998-0.6433305000000001i)) - (let ((res (float-vector 0.0 0.0))) - (let ((err (gsl_poly_solve_quadratic 4.0 -20.0 26.0 (wrap-double* res)))) - (test err 0))) - (let ((res (float-vector 0.0 0.0))) - (let ((err (gsl_poly_solve_quadratic 4.0 -20.0 21.0 (wrap-double* res)))) - (test res (float-vector 1.5 3.5)))) - (let ((res (float-vector 0.0 0.0 0.0))) - (let ((err (gsl_poly_solve_cubic -51 867 -4913 (wrap-double* res)))) - (test res (float-vector 17.0 17.0 17.0)))) - (let ((res (vector 0.0 0.0))) - (let ((err (gsl_poly_complex_solve_quadratic 4.0 -20.0 26.0 res))) - (test res #(2.5-0.5i 2.5+0.5i)))) - (let ((res (vector 0.0 0.0 0.0))) ; workspace handling is internal - (let ((err (gsl_poly_complex_solve_cubic -51 867 -4913 res))) - (test res #(17.0 17.0 17.0)))) - - (num-test (gsl_hypot3 1.0 1.0 1.0) (sqrt 3)) - (num-test (gsl_hypot 1.0 1.0) (sqrt 2)) - (test (nan? (gsl_nan)) #t) - (test (infinite? (gsl_posinf)) #t) - (test (gsl_frexp 2.0) '(0.5 2)) - (num-test (gsl_pow_2 4) 16.0) - - (num-test (gsl_cdf_ugaussian_P 0.0) 0.5) - (num-test (gsl_cdf_ugaussian_P 0.5) 0.691462461274013) - (num-test (gsl_cdf_ugaussian_Q 0.5) 0.3085375387259869) - (num-test (gsl_cdf_ugaussian_Pinv 0.5) 0.0) - (num-test (gsl_cdf_ugaussian_Qinv 0.5) 0.0) - (num-test (gsl_cdf_exponential_P 0.1 0.7) 0.1331221002498184) - (num-test (gsl_cdf_exponential_Q 0.1 0.7) 0.8668778997501816) - (num-test (gsl_cdf_exponential_Pinv 0.13 0.7) 0.09748344713345537) - (num-test (gsl_cdf_exponential_Qinv 0.86 0.7) 0.1055760228142086) - (num-test (gsl_cdf_exppow_P -0.1 0.7 1.8) 0.4205349082867516) - (num-test (gsl_cdf_exppow_Q -0.1 0.7 1.8) 0.5794650917132484) - (num-test (gsl_cdf_tdist_P 0.0 1.0) 0.5) - (num-test (gsl_cdf_tdist_Q 0.0 1.0) 0.5) - (num-test (gsl_cdf_fdist_P 0.0 1.0 1.3) 0.0) - (num-test (gsl_cdf_fdist_Q 0.0 1.0 1.3) 1.0) - (num-test (gsl_cdf_fdist_Pinv 0.0 1.0 1.3) 0.0) - (num-test (gsl_cdf_fdist_Qinv 1.0 1.0 1.3) 0.0) - (num-test (gsl_cdf_gamma_P 0 1 1) 0.0) - (num-test (gsl_cdf_gamma_Q 0 1 1) 1.0) - (num-test (gsl_cdf_chisq_P 0 13) 0.0) - (num-test (gsl_cdf_chisq_Q 0 13) 1.0) - (num-test (gsl_cdf_beta_P 0 1.2 1.3) 0.0) - (num-test (gsl_cdf_beta_Q 0 1.2 1.3) 1.0) - - (num-test (gsl_stats_mean (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 2.5) - (num-test (gsl_stats_skew (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 0.0) - (num-test (gsl_stats_max (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 4.0) - - (let ((rng (gsl_rng_alloc gsl_rng_default))) - (test (real? (gsl_ran_exponential rng 1.0)) #t) - (gsl_rng_free rng)) - - (num-test (gsl_complex_log 1+i) (log 1+i)) - (num-test (gsl_complex_abs 1+i) (magnitude 1+i)) - (num-test (gsl_complex_sin 1+i) (sin 1+i)) - - (let ((gs (gsl_cheb_alloc 40))) + (num-test (gsl_sf_result.val s2) 3.073843410049702) + (num-test (gsl_sf_taylorcoeff 10 5) 2.691144455467373) + (num-test (gsl_sf_choose 7 3) 35.0) + (num-test (gsl_sf_poch 7 3) 504.0000000000001) + (num-test (gsl_sf_gamma_inc_P 1.0 10.0) 0.9999546000702381) + (num-test (gsl_sf_lnbeta 0.1 1.0) 2.302585092994044) + (num-test (gsl_sf_beta 100.1 -1.2) 1203.895236907804) + (num-test (gsl_sf_hyperg_0F1 1 0.5) 1.56608292975635) + (num-test (gsl_sf_hyperg_1F1 1 1.5 1) 2.030078469278705) + (num-test (gsl_sf_hyperg_U_int 100 100 1) 0.009998990209084679) + (num-test (gsl_sf_hyperg_2F1 1 1 1 0.5) 2.0) + (num-test (gsl_sf_legendre_P1 -0.5) -0.5) + (num-test (gsl_sf_legendre_sphPlm 10 0 -0.5) -0.2433270236930014) + (num-test (gsl_sf_legendre_Q0 -0.5) -0.5493061443340549) + (num-test (gsl_sf_clausen (+ (* 2 pi) (/ pi 3))) 1.014941606409653) + (num-test (gsl_sf_coupling_3j 0 1 1 0 1 -1) 0.7071067811865476) + (num-test (gsl_sf_dawson 0.5) 0.4244363835020223) + (num-test (gsl_sf_multiply -3 2) -6.0) + (num-test (gsl_sf_ellint_E (/ pi 2) 0.5 GSL_MODE_DEFAULT) 1.467462209339427) + (num-test (gsl_sf_erfc -10) 2.0) + (num-test (gsl_sf_exp_mult 10 -2) -44052.93158961344) + (num-test (gsl_sf_expm1 -.001) -0.0009995001666250082) + (num-test (gsl_sf_Shi -1) -1.057250875375728) + (num-test (gsl_sf_fermi_dirac_0 -1) 0.3132616875182229) + (num-test (gsl_sf_gegenpoly_1 1.0 1.0) 2.0) + + (let ((p (float-vector 1.0 -2.0 1.0)) (res (vector 0.0 0.0))) + (gsl_poly_complex_solve (wrap-double* p) 3 res) + (test res #(1.0 1.0))) + (let ((p (float-vector 1 -1 1 -1 1 -1 1 -1 1 -1 1))) + (num-test (gsl_poly_eval (wrap-double* p) 11 1.0) 1.0)) + (let ((p (float-vector 2.1 -1.34 0.76 0.45))) + (num-test (gsl_poly_complex_eval (wrap-double* p) 4 0.49+0.95i) 0.3959142999999998-0.6433305000000001i)) + (let ((res (float-vector 0.0 0.0))) + (let ((err (gsl_poly_solve_quadratic 4.0 -20.0 26.0 (wrap-double* res)))) + (test err 0))) + (let ((res (float-vector 0.0 0.0))) + (let ((err (gsl_poly_solve_quadratic 4.0 -20.0 21.0 (wrap-double* res)))) + (test res (float-vector 1.5 3.5)))) + (let ((res (float-vector 0.0 0.0 0.0))) + (let ((err (gsl_poly_solve_cubic -51 867 -4913 (wrap-double* res)))) + (test res (float-vector 17.0 17.0 17.0)))) + (let ((res (vector 0.0 0.0))) + (let ((err (gsl_poly_complex_solve_quadratic 4.0 -20.0 26.0 res))) + (test res #(2.5-0.5i 2.5+0.5i)))) + (let ((res (vector 0.0 0.0 0.0))) ; workspace handling is internal + (let ((err (gsl_poly_complex_solve_cubic -51 867 -4913 res))) + (test res #(17.0 17.0 17.0)))) + + (num-test (gsl_hypot3 1.0 1.0 1.0) (sqrt 3)) + (num-test (gsl_hypot 1.0 1.0) (sqrt 2)) + (test (nan? (gsl_nan)) #t) + (test (infinite? (gsl_posinf)) #t) + (test (gsl_frexp 2.0) '(0.5 2)) + (num-test (gsl_pow_2 4) 16.0) + + (num-test (gsl_cdf_ugaussian_P 0.0) 0.5) + (num-test (gsl_cdf_ugaussian_P 0.5) 0.691462461274013) + (num-test (gsl_cdf_ugaussian_Q 0.5) 0.3085375387259869) + (num-test (gsl_cdf_ugaussian_Pinv 0.5) 0.0) + (num-test (gsl_cdf_ugaussian_Qinv 0.5) 0.0) + (num-test (gsl_cdf_exponential_P 0.1 0.7) 0.1331221002498184) + (num-test (gsl_cdf_exponential_Q 0.1 0.7) 0.8668778997501816) + (num-test (gsl_cdf_exponential_Pinv 0.13 0.7) 0.09748344713345537) + (num-test (gsl_cdf_exponential_Qinv 0.86 0.7) 0.1055760228142086) + (num-test (gsl_cdf_exppow_P -0.1 0.7 1.8) 0.4205349082867516) + (num-test (gsl_cdf_exppow_Q -0.1 0.7 1.8) 0.5794650917132484) + (num-test (gsl_cdf_tdist_P 0.0 1.0) 0.5) + (num-test (gsl_cdf_tdist_Q 0.0 1.0) 0.5) + (num-test (gsl_cdf_fdist_P 0.0 1.0 1.3) 0.0) + (num-test (gsl_cdf_fdist_Q 0.0 1.0 1.3) 1.0) + (num-test (gsl_cdf_fdist_Pinv 0.0 1.0 1.3) 0.0) + (num-test (gsl_cdf_fdist_Qinv 1.0 1.0 1.3) 0.0) + (num-test (gsl_cdf_gamma_P 0 1 1) 0.0) + (num-test (gsl_cdf_gamma_Q 0 1 1) 1.0) + (num-test (gsl_cdf_chisq_P 0 13) 0.0) + (num-test (gsl_cdf_chisq_Q 0 13) 1.0) + (num-test (gsl_cdf_beta_P 0 1.2 1.3) 0.0) + (num-test (gsl_cdf_beta_Q 0 1.2 1.3) 1.0) + + (num-test (gsl_stats_mean (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 2.5) + (num-test (gsl_stats_skew (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 0.0) + (num-test (gsl_stats_max (wrap-double* (float-vector 1.0 2.0 3.0 4.0)) 1 4) 4.0) + + (let ((rng (gsl_rng_alloc gsl_rng_default))) + (test (real? (gsl_ran_exponential rng 1.0)) #t) + (gsl_rng_free rng)) + + (num-test (gsl_complex_log 1+i) (log 1+i)) + (num-test (gsl_complex_abs 1+i) (magnitude 1+i)) + (num-test (gsl_complex_sin 1+i) (sin 1+i)) + (gsl_cheb_init gs (lambda (x) x) -1.0 1.0) (num-test (gsl_cheb_eval gs -1.0) -1.0) (num-test (gsl_cheb_eval gs 0.0) 0.0) (num-test (gsl_cheb_eval gs 1.0) 1.0) - (gsl_cheb_free gs)) - - (let ((x (float-vector 0.0)) - (y (float-vector 0.0))) - (gsl_deriv_central (lambda (x) (expt x 1.5)) 2.0 1e-8 (wrap-double* x) (wrap-double* y)) - (num-test (x 0) (* 1.5 (sqrt 2))) - (gsl_deriv_forward (lambda (x) (expt x 1.5)) 0.0 1e-8 (wrap-double* x) (wrap-double* y)) - (test (< (x 0) 1e-5) #t)) - - (let ((f (float-vector -1 3 0 4 2 6))) - (gsl_sort (wrap-double* f) 1 6) - (test f (float-vector -1 0 2 3 4 6))) - - (let ((g1 (gsl_vector_alloc 3)) - (g2 (gsl_vector_alloc 3)) - (f1 (make-float-vector 3))) - (gsl_vector_add (float-vector->gsl_vector (float-vector 0 1 2) g1) - (float-vector->gsl_vector (float-vector 3 4 5) g2)) - (gsl_vector->float-vector g1 f1) - (gsl_vector_free g1) - (gsl_vector_free g2) - (test f1 (float-vector 3 5 7))) - - (let ((f (make-float-vector '(3 3)))) - (let ((g (gsl_matrix_alloc 3 3))) - (gsl_matrix_set_identity g) - (do ((i 0 (+ i 1))) - ((= i 3) - (gsl_matrix_free g)) - (do ((j 0 (+ j 1))) - ((= j 3)) - (set! (f i j) (gsl_matrix_get g i j))))) - (test (equivalent? f #2d((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))) #t)) - - (let ((f (make-vector '(3 3)))) - (let ((g (gsl_matrix_complex_alloc 3 3))) - (gsl_matrix_complex_set_identity g) - (gsl_matrix_complex_scale g 1+i) - (do ((i 0 (+ i 1))) - ((= i 3) - (gsl_matrix_complex_free g)) - (do ((j 0 (+ j 1))) - ((= j 3)) - (set! (f i j) (gsl_matrix_complex_get g i j))))) - (test (equivalent? f #2d((1+i 0.0 0.0) (0.0 1+i 0.0) (0.0 0.0 1+i))) #t)) - - (let ((Y (float-vector 0.554)) - (A (float-vector -0.047)) - (X (float-vector 0.672))) - (cblas_dgemv 101 111 1 1 -0.3 (wrap-double* A) 1 (wrap-double* X) -1 -1 (wrap-double* Y) -1) - (num-test (Y 0) -0.5445248)) - - (let ((Y (float-vector 0.348 0.07)) - (A (float-vector 0.932 -0.724)) - (X (float-vector 0.334 -0.317)) - (alpha (float-vector 0 .1)) - (beta (float-vector 1 0))) - (cblas_zgemv 101 111 1 1 (wrap-double* alpha) (wrap-double* A) 1 (wrap-double* X) -1 (wrap-double* beta) (wrap-double* Y) -1) - (num-test (Y 0) 0.401726) - (num-test (Y 1) 0.078178)) - - (test (let ((f (float-vector 0 1 2 3 4))) (gsl_interp_bsearch (wrap-double* f) 1.5 0 4)) 1) - - (let ((x (make-float-vector 10)) - (y (make-float-vector 10))) - (do ((i 0 (+ i 1))) - ((= i 10)) - (set! (x i) (+ i (* 0.5 (sin i)))) - (set! (y i) (+ i (cos (* i i))))) - (let ((acc (gsl_interp_accel_alloc)) - (spline (gsl_spline_alloc gsl_interp_cspline 10))) - (gsl_spline_init spline (wrap-double* x) (wrap-double* y) 10) - (let ((res (gsl_spline_eval spline (x 5) acc))) - (gsl_spline_free spline) - (gsl_interp_accel_free acc) - (num-test res 5.991202811863474)))) - - (let ((c (gsl_combination_alloc 6 3)) - (data #2d((0 1 2) (0 1 3) (0 1 4) (0 1 5) - (0 2 3) (0 2 4) (0 2 5) (0 3 4) - (0 3 5) (0 4 5) (1 2 3) (1 2 4) - (1 2 5) (1 3 4) (1 3 5) (1 4 5) - (2 3 4) (2 3 5) (2 4 5) (3 4 5))) - (iv (make-int-vector 3 0))) - (gsl_combination_init_first c) - (do ((i 0 (+ i 1))) - ((= i 20)) - ((*libgsl* 'gsl_combination->int-vector) c iv) - (if (not (equivalent? iv (data i))) - (format *stderr* ";gsl_combination: ~A ~A~%" iv (data i))) - (gsl_combination_next c)) - (gsl_combination_free c)) - - (let ((p (gsl_permutation_alloc 3)) - (data (make-int-vector 18 0))) - (gsl_permutation_init p) - (do ((pp GSL_SUCCESS (gsl_permutation_next p)) - (i 0 (+ i 3))) - ((not (= pp GSL_SUCCESS))) - (set! (data i) (gsl_permutation_get p 0)) - (set! (data (+ i 1)) (gsl_permutation_get p 1)) - (set! (data (+ i 2)) (gsl_permutation_get p 2))) - (gsl_permutation_free p) - (test (equivalent? data #(0 1 2 0 2 1 1 0 2 1 2 0 2 0 1 2 1 0)) #t)) - - (let ((N 50)) - (let ((t (make-float-vector N 0.0))) - (do ((i 0 (+ i 1))) - ((= i N)) - (set! (t i) (/ 1.0 (* (+ i 1) (+ i 1))))) - (let ((zeta_2 (/ (* pi pi) 6.0))) - (let ((accel (float-vector 0.0)) - (err (float-vector 0.0)) - (w (gsl_sum_levin_u_alloc N))) - (gsl_sum_levin_u_accel (wrap-double* t) N w (wrap-double* accel) (wrap-double* err)) - (num-test zeta_2 (accel 0)) - (gsl_sum_levin_u_free w))))) - - (let ((data (float-vector 0 0 1 0 1 1 0 -1)) ; complex data as rl+im coming and going - (output (make-float-vector 8 0.0))) - (gsl_dft_complex_forward (wrap-double* data) 1 4 (wrap-double* output)) - ;; = -1 in snd terminology: (cfft! (vector 0 1 1+i 0-i) 4 -1): #(2.0 0-2i 0+2i -2.0) - (test (equivalent? output (float-vector 2.0 0.0 0.0 -2.0 0.0 2.0 -2.0 0.0)) #t)) - (let ((data (float-vector 0 0 1 0 1 1 0 -1))) ; complex data as rl+im coming and going - (gsl_fft_complex_radix2_forward (wrap-double* data) 1 4) - (test (equivalent? data (float-vector 2.0 0.0 0.0 -2.0 0.0 2.0 -2.0 0.0)) #t)) - - (let ((data (make-float-vector 256)) - (w (gsl_wavelet_alloc gsl_wavelet_daubechies 4)) - (work (gsl_wavelet_workspace_alloc 256))) - (do ((i 0 (+ i 1))) - ((= i 256)) - (set! (data i) (sin (* i (/ pi 128))))) - (gsl_wavelet_transform_forward w (wrap-double* data) 1 256 work) - (gsl_wavelet_transform_inverse w (wrap-double* data) 1 256 work) - (gsl_wavelet_free w) - (gsl_wavelet_workspace_free work) - data) - - (let ((h (gsl_histogram_alloc 10)) - (data (make-int-vector 10))) - (gsl_histogram_set_ranges_uniform h 0.0 1.0) - (do ((i 0 (+ i 1))) - ((= i 50)) - (gsl_histogram_increment h (random 1.0))) - (do ((i 0 (+ i 1))) - ((= i 10)) - (set! (data i) (round (gsl_histogram_get h i)))) - (gsl_histogram_free h) - data) - - (let ((a_data (float-vector 0.18 0.60 0.57 0.96 0.41 0.24 0.99 0.58 0.14 0.30 0.97 0.66 0.51 0.13 0.19 0.85)) - (b_data (float-vector 1 2 3 4))) - (let ((m (gsl_matrix_alloc 4 4)) - (b (gsl_vector_alloc 4))) - (let ((x (gsl_vector_alloc 4)) - (p (gsl_permutation_alloc 4))) + + (let ((x (float-vector 0.0)) + (y (float-vector 0.0))) + (gsl_deriv_central (lambda (x) (expt x 1.5)) 2.0 1e-8 (wrap-double* x) (wrap-double* y)) + (num-test (x 0) (* 1.5 (sqrt 2))) + (gsl_deriv_forward (lambda (x) (expt x 1.5)) 0.0 1e-8 (wrap-double* x) (wrap-double* y)) + (test (< (x 0) 1e-5) #t)) + + (let ((f (float-vector -1 3 0 4 2 6))) + (gsl_sort (wrap-double* f) 1 6) + (test f (float-vector -1 0 2 3 4 6))) + + (let ((f1 (make-float-vector 3))) + (gsl_vector_add (float-vector->gsl_vector (float-vector 0 1 2) g1) + (float-vector->gsl_vector (float-vector 3 4 5) g2)) + (gsl_vector->float-vector g1 f1) + (test f1 (float-vector 3 5 7))) + + (let ((f (make-float-vector '(3 3)))) + (let ((g (gsl_matrix_alloc 3 3))) + (gsl_matrix_set_identity g) (do ((i 0 (+ i 1))) - ((= i 4)) + ((= i 3) + (gsl_matrix_free g)) (do ((j 0 (+ j 1))) - ((= j 4)) - (gsl_matrix_set m i j (a_data (+ j (* i 4)))))) - (do ((i 0 (+ i 1))) - ((= i 4)) - (gsl_vector_set b i (b_data i))) - (gsl_linalg_LU_decomp m p) ; int-by-ref is internal - (gsl_linalg_LU_solve m p b x) - (do ((i 0 (+ i 1))) - ((= i 4)) - (set! (b_data i) (gsl_vector_get x i))) - (gsl_permutation_free p) - (gsl_vector_free x) - b_data))) - - (when (>= gsl-version 1.16) - (let () - (define (dofit T X y c cov) - (let ((work (gsl_multifit_robust_alloc T (car (gsl_matrix_size X)) (cdr (gsl_matrix_size X))))) - (let ((s (gsl_multifit_robust X y c cov work))) - (gsl_multifit_robust_free work) - s))) - (let* ((n 30) - (p 2) - (a 1.45) - (b 3.88) - (X (gsl_matrix_alloc n p)) - (x (gsl_vector_alloc n)) - (y (gsl_vector_alloc n)) - (c (gsl_vector_alloc p)) - (c_ols (gsl_vector_alloc p)) - (cov (gsl_matrix_alloc p p)) - (gv (gsl_vector_alloc p)) - (r (gsl_rng_alloc gsl_rng_default))) - (do ((i 0 (+ i 1))) - ((= i (- n 3))) - (let* ((dx (/ 10.0 (- n 1.0))) - (ei (gsl_rng_uniform r)) - (xi (+ -5.0 (* i dx))) - (yi (+ b (* a xi)))) - (gsl_vector_set x i xi) - (gsl_vector_set y i (+ yi ei)))) - (gsl_vector_set x (- n 3) 4.7) - (gsl_vector_set y (- n 3) -8.3) - (gsl_vector_set x (- n 2) 3.5) - (gsl_vector_set y (- n 2) -6.7) - (gsl_vector_set x (- n 1) 4.1) - (gsl_vector_set y (- n 1) -6.0) - (do ((i 0 (+ i 1))) - ((= i n)) - (let ((xi (gsl_vector_get x i))) - (gsl_matrix_set X i 0 1.0) - (gsl_matrix_set X i 1 xi))) - (dofit gsl_multifit_robust_ols X y c_ols cov) - (dofit gsl_multifit_robust_bisquare X y c cov) + ((= j 3)) + (set! (f i j) (gsl_matrix_get g i j))))) + (test (equivalent? f #2d((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))) #t)) + + (let ((f (make-vector '(3 3)))) + (let ((g (gsl_matrix_complex_alloc 3 3))) + (gsl_matrix_complex_set_identity g) + (gsl_matrix_complex_scale g 1+i) (do ((i 0 (+ i 1))) - ((= i n)) - (let ((xi (gsl_vector_get x i)) - (yi (gsl_vector_get y i)) - (y_ols (float-vector 0.0)) - (y_rob (float-vector 0.0)) - (y_err (float-vector 0.0))) - (gsl_vector_set gv 0 (gsl_matrix_get X i 0)) - (gsl_vector_set gv 1 (gsl_matrix_get X i 1)) - (gsl_multifit_robust_est gv c cov (wrap-double* y_rob) (wrap-double* y_err)) - (gsl_multifit_robust_est gv c_ols cov (wrap-double* y_ols) (wrap-double* y_err)))) - (gsl_matrix_free X) - (gsl_matrix_free cov) - (gsl_vector_free x) - (gsl_vector_free y) - (gsl_vector_free c) - (gsl_vector_free gv) - (gsl_rng_free r)))) - - (let () - (gsl_rng_env_setup) - (let* ((T gsl_rng_default) - (r (gsl_rng_alloc T)) - (x 0) - (y 0) - (dx (float-vector 0.0)) - (dy (float-vector 0.0))) + ((= i 3) + (gsl_matrix_complex_free g)) + (do ((j 0 (+ j 1))) + ((= j 3)) + (set! (f i j) (gsl_matrix_complex_get g i j))))) + (test (equivalent? f #2d((1+i 0.0 0.0) (0.0 1+i 0.0) (0.0 0.0 1+i))) #t)) + + (let ((Y (float-vector 0.554)) + (A (float-vector -0.047)) + (X (float-vector 0.672))) + (cblas_dgemv 101 111 1 1 -0.3 (wrap-double* A) 1 (wrap-double* X) -1 -1 (wrap-double* Y) -1) + (num-test (Y 0) -0.5445248)) + + (let ((Y (float-vector 0.348 0.07)) + (A (float-vector 0.932 -0.724)) + (X (float-vector 0.334 -0.317)) + (alpha (float-vector 0 .1)) + (beta (float-vector 1 0))) + (cblas_zgemv 101 111 1 1 (wrap-double* alpha) (wrap-double* A) 1 (wrap-double* X) -1 (wrap-double* beta) (wrap-double* Y) -1) + (num-test (Y 0) 0.401726) + (num-test (Y 1) 0.078178)) + + (test (let ((f (float-vector 0 1 2 3 4))) (gsl_interp_bsearch (wrap-double* f) 1.5 0 4)) 1) + + (let ((x (make-float-vector 10)) + (y (make-float-vector 10))) (do ((i 0 (+ i 1))) ((= i 10)) - (gsl_ran_dir_2d r (wrap-double* dx) (wrap-double* dy)) - (set! x (+ x (dx 0))) - (set! y (+ y (dy 0)))) - (gsl_rng_free r))) - - (let ((f_size 2) - (T gsl_multimin_fminimizer_nmsimplex)) - (define (simple-abs x) - (let ((u (gsl_vector_get x 0)) - (v (gsl_vector_get x 1))) - (let ((a (- u 1)) - (b (- v 2))) - (+ (abs a) (abs b))))) - (let ((x (gsl_vector_alloc f_size)) - (step_size (gsl_vector_alloc f_size)) - (s (gsl_multimin_fminimizer_alloc T 2))) - (gsl_vector_set x 0 1.0) - (gsl_vector_set x 1 2.0) - (gsl_vector_set step_size 0 1) - (gsl_vector_set step_size 1 1) - (gsl_multimin_fminimizer_set s simple-abs x step_size) + (set! (x i) (+ i (* 0.5 (sin i)))) + (set! (y i) (+ i (cos (* i i))))) + (let ((acc (gsl_interp_accel_alloc)) + (spline (gsl_spline_alloc gsl_interp_cspline 10))) + (gsl_spline_init spline (wrap-double* x) (wrap-double* y) 10) + (let ((res (gsl_spline_eval spline (x 5) acc))) + (gsl_spline_free spline) + (gsl_interp_accel_free acc) + (num-test res 5.991202811863474)))) + + (let ((c (gsl_combination_alloc 6 3)) + (data #2d((0 1 2) (0 1 3) (0 1 4) (0 1 5) + (0 2 3) (0 2 4) (0 2 5) (0 3 4) + (0 3 5) (0 4 5) (1 2 3) (1 2 4) + (1 2 5) (1 3 4) (1 3 5) (1 4 5) + (2 3 4) (2 3 5) (2 4 5) (3 4 5))) + (iv (make-int-vector 3 0))) + (gsl_combination_init_first c) (do ((i 0 (+ i 1))) - ((= i 10)) - (gsl_multimin_fminimizer_iterate s)) - (let ((result (abs (gsl_multimin_fminimizer_fval s)))) - (gsl_multimin_fminimizer_free s) - (gsl_vector_free x) - (gsl_vector_free step_size) - (num-test result 0.0)))) - - (let ((n 4) - (x (float-vector 1970 1980 1990 2000)) - (y (float-vector 12 11 14 13)) - (w (float-vector 0.1 0.2 0.3 0.4)) - (c0 (float-vector 0.0)) - (c1 (float-vector 0.0)) - (cov00 (float-vector 0.0)) - (cov01 (float-vector 0.0)) - (cov11 (float-vector 0.0)) - (chisq (float-vector 0.0))) - (gsl_fit_wlinear (wrap-double* x) 1 (wrap-double* w) 1 (wrap-double* y) 1 n - (wrap-double* c0) (wrap-double* c1) (wrap-double* cov00) (wrap-double* cov01) (wrap-double* cov11) (wrap-double* chisq)) - (num-test (+ (c0 0) (c1 0)) -106.54)) - - (let ((c (gsl_multiset_calloc 4 2))) - (test (list (gsl_multiset_n c) (gsl_multiset_k c)) '(4 2))) - - (let ((x (gsl_vector_alloc 2)) - (factor 1.0) - (T gsl_multiroot_fsolver_dnewton)) - (define (rosenb x f) - (let ((x0 (gsl_vector_get x 0)) - (x1 (gsl_vector_get x 1))) - (let ((y0 (- 1 x0)) - (y1 (* 10 (- x1 (* x0 x0))))) - (gsl_vector_set f 0 y0) - (gsl_vector_set f 1 y1) - GSL_SUCCESS))) - (gsl_vector_set x 0 -1.2) - (gsl_vector_set x 1 1.0) - (let ((s (gsl_multiroot_fsolver_alloc T 2))) - (gsl_multiroot_fsolver_set s rosenb x) + ((= i 20)) + ((*libgsl* 'gsl_combination->int-vector) c iv) + (if (not (equivalent? iv (data i))) + (format *stderr* ";gsl_combination: ~A ~A~%" iv (data i))) + (gsl_combination_next c)) + (gsl_combination_free c)) + + (let ((p (gsl_permutation_alloc 3)) + (data (make-int-vector 18 0))) + (gsl_permutation_init p) + (do ((pp GSL_SUCCESS (gsl_permutation_next p)) + (i 0 (+ i 3))) + ((not (= pp GSL_SUCCESS))) + (set! (data i) (gsl_permutation_get p 0)) + (set! (data (+ i 1)) (gsl_permutation_get p 1)) + (set! (data (+ i 2)) (gsl_permutation_get p 2))) + (gsl_permutation_free p) + (test (equivalent? data #(0 1 2 0 2 1 1 0 2 1 2 0 2 0 1 2 1 0)) #t)) + + (let ((N 50)) + (let ((t (make-float-vector N 0.0))) + (do ((i 0 (+ i 1))) + ((= i N)) + (set! (t i) (/ 1.0 (* (+ i 1) (+ i 1))))) + (let ((zeta_2 (/ (* pi pi) 6.0))) + (let ((accel (float-vector 0.0)) + (err (float-vector 0.0)) + (w (gsl_sum_levin_u_alloc N))) + (gsl_sum_levin_u_accel (wrap-double* t) N w (wrap-double* accel) (wrap-double* err)) + (num-test zeta_2 (accel 0)) + (gsl_sum_levin_u_free w))))) + + (let ((data (float-vector 0 0 1 0 1 1 0 -1)) ; complex data as rl+im coming and going + (output (make-float-vector 8 0.0))) + (gsl_dft_complex_forward (wrap-double* data) 1 4 (wrap-double* output)) + ;; = -1 in snd terminology: (cfft! (vector 0 1 1+i 0-i) 4 -1): #(2.0 0-2i 0+2i -2.0) + (test (equivalent? output (float-vector 2.0 0.0 0.0 -2.0 0.0 2.0 -2.0 0.0)) #t)) + (let ((data (float-vector 0 0 1 0 1 1 0 -1))) ; complex data as rl+im coming and going + (gsl_fft_complex_radix2_forward (wrap-double* data) 1 4) + (test (equivalent? data (float-vector 2.0 0.0 0.0 -2.0 0.0 2.0 -2.0 0.0)) #t)) + + (let ((data (make-float-vector 256)) + (w (gsl_wavelet_alloc gsl_wavelet_daubechies 4)) + (work (gsl_wavelet_workspace_alloc 256))) + (do ((i 0 (+ i 1))) + ((= i 256)) + (set! (data i) (sin (* i (/ pi 128))))) + (gsl_wavelet_transform_forward w (wrap-double* data) 1 256 work) + (gsl_wavelet_transform_inverse w (wrap-double* data) 1 256 work) + (gsl_wavelet_free w) + (gsl_wavelet_workspace_free work) + data) + + (let ((h (gsl_histogram_alloc 10)) + (data (make-int-vector 10))) + (gsl_histogram_set_ranges_uniform h 0.0 1.0) + (do ((i 0 (+ i 1))) + ((= i 50)) + (gsl_histogram_increment h (random 1.0))) (do ((i 0 (+ i 1))) ((= i 10)) - (gsl_multiroot_fsolver_iterate s)) - (let ((residual (abs (gsl_vector_get (gsl_multiroot_fsolver_f s) 0)))) - (gsl_multiroot_fsolver_free s) - (gsl_vector_free x) - (test residual 0.0)))) - )) + (set! (data i) (round (gsl_histogram_get h i)))) + (gsl_histogram_free h) + data) + + (let ((a_data (float-vector 0.18 0.60 0.57 0.96 0.41 0.24 0.99 0.58 0.14 0.30 0.97 0.66 0.51 0.13 0.19 0.85)) + (b_data (float-vector 1 2 3 4))) + (let ((m (gsl_matrix_alloc 4 4)) + (b (gsl_vector_alloc 4))) + (let ((x (gsl_vector_alloc 4)) + (p (gsl_permutation_alloc 4))) + (do ((i 0 (+ i 1))) + ((= i 4)) + (do ((j 0 (+ j 1))) + ((= j 4)) + (gsl_matrix_set m i j (a_data (+ j (* i 4)))))) + (do ((i 0 (+ i 1))) + ((= i 4)) + (gsl_vector_set b i (b_data i))) + (gsl_linalg_LU_decomp m p) ; int-by-ref is internal + (gsl_linalg_LU_solve m p b x) + (do ((i 0 (+ i 1))) + ((= i 4)) + (set! (b_data i) (gsl_vector_get x i))) + (gsl_permutation_free p) + (gsl_vector_free x) + (gsl_matrix_free m) + (gsl_vector_free b) + b_data))) + + (when (>= gsl-version 1.16) + (let () + (define (dofit T X y c cov) + (let ((work (gsl_multifit_robust_alloc T (car (gsl_matrix_size X)) (cdr (gsl_matrix_size X))))) + (let ((s (gsl_multifit_robust X y c cov work))) + (gsl_multifit_robust_free work) + s))) + (let* ((n 30) + (p 2) + (a 1.45) + (b 3.88) + (X (gsl_matrix_alloc n p)) + (x (gsl_vector_alloc n)) + (y (gsl_vector_alloc n)) + (c (gsl_vector_alloc p)) + (c_ols (gsl_vector_alloc p)) + (cov (gsl_matrix_alloc p p)) + (gv (gsl_vector_alloc p)) + (r (gsl_rng_alloc gsl_rng_default))) + (do ((i 0 (+ i 1))) + ((= i (- n 3))) + (let* ((dx (/ 10.0 (- n 1.0))) + (ei (gsl_rng_uniform r)) + (xi (+ -5.0 (* i dx))) + (yi (+ b (* a xi)))) + (gsl_vector_set x i xi) + (gsl_vector_set y i (+ yi ei)))) + (gsl_vector_set x (- n 3) 4.7) + (gsl_vector_set y (- n 3) -8.3) + (gsl_vector_set x (- n 2) 3.5) + (gsl_vector_set y (- n 2) -6.7) + (gsl_vector_set x (- n 1) 4.1) + (gsl_vector_set y (- n 1) -6.0) + (do ((i 0 (+ i 1))) + ((= i n)) + (let ((xi (gsl_vector_get x i))) + (gsl_matrix_set X i 0 1.0) + (gsl_matrix_set X i 1 xi))) + (dofit gsl_multifit_robust_ols X y c_ols cov) + (dofit gsl_multifit_robust_bisquare X y c cov) + (do ((i 0 (+ i 1))) + ((= i n)) + (let ((xi (gsl_vector_get x i)) + (yi (gsl_vector_get y i)) + (y_ols (float-vector 0.0)) + (y_rob (float-vector 0.0)) + (y_err (float-vector 0.0))) + (gsl_vector_set gv 0 (gsl_matrix_get X i 0)) + (gsl_vector_set gv 1 (gsl_matrix_get X i 1)) + (gsl_multifit_robust_est gv c cov (wrap-double* y_rob) (wrap-double* y_err)) + (gsl_multifit_robust_est gv c_ols cov (wrap-double* y_ols) (wrap-double* y_err)))) + (gsl_matrix_free X) + (gsl_matrix_free cov) + (gsl_vector_free x) + (gsl_vector_free y) + (gsl_vector_free c) + (gsl_vector_free gv) + (gsl_vector_free c_ols) + (gsl_rng_free r)))) + + (let () + (gsl_rng_env_setup) + (let* ((T gsl_rng_default) + (r (gsl_rng_alloc T)) + (x 0) + (y 0) + (dx (float-vector 0.0)) + (dy (float-vector 0.0))) + (do ((i 0 (+ i 1))) + ((= i 10)) + (gsl_ran_dir_2d r (wrap-double* dx) (wrap-double* dy)) + (set! x (+ x (dx 0))) + (set! y (+ y (dy 0)))) + (gsl_rng_free r))) + + (let ((T gsl_multimin_fminimizer_nmsimplex)) + (define (simple-abs x) + (let ((u (gsl_vector_get x 0)) + (v (gsl_vector_get x 1))) + (let ((a (- u 1)) + (b (- v 2))) + (+ (abs a) (abs b))))) + (let ((s3 (gsl_multimin_fminimizer_alloc T 2))) + (gsl_vector_set v2 0 1.0) + (gsl_vector_set v2 1 2.0) + (gsl_vector_set step_size 0 1) + (gsl_vector_set step_size 1 1) + (gsl_multimin_fminimizer_set s3 simple-abs v2 step_size) + (do ((i 0 (+ i 1))) + ((= i 10)) + (gsl_multimin_fminimizer_iterate s3)) + (let ((result (abs (gsl_multimin_fminimizer_fval s3)))) + (gsl_multimin_fminimizer_free s3) + (num-test result 0.0)))) + + (let ((n 4) + (x (float-vector 1970 1980 1990 2000)) + (y (float-vector 12 11 14 13)) + (w (float-vector 0.1 0.2 0.3 0.4)) + (c0 (float-vector 0.0)) + (c1 (float-vector 0.0)) + (cov00 (float-vector 0.0)) + (cov01 (float-vector 0.0)) + (cov11 (float-vector 0.0)) + (chisq (float-vector 0.0))) + (gsl_fit_wlinear (wrap-double* x) 1 (wrap-double* w) 1 (wrap-double* y) 1 n + (wrap-double* c0) (wrap-double* c1) (wrap-double* cov00) (wrap-double* cov01) (wrap-double* cov11) (wrap-double* chisq)) + (num-test (+ (c0 0) (c1 0)) -106.54)) + + (test (list (gsl_multiset_n c1) (gsl_multiset_k c1)) '(4 2)) + + (let ((factor 1.0) + (T gsl_multiroot_fsolver_dnewton)) + (define (rosenb x f) + (let ((x0 (gsl_vector_get x 0)) + (x1 (gsl_vector_get x 1))) + (let ((y0 (- 1 x0)) + (y1 (* 10 (- x1 (* x0 x0))))) + (gsl_vector_set f 0 y0) + (gsl_vector_set f 1 y1) + GSL_SUCCESS))) + (gsl_vector_set v1 0 -1.2) + (gsl_vector_set v1 1 1.0) + (let ((s (gsl_multiroot_fsolver_alloc T 2))) + (gsl_multiroot_fsolver_set s rosenb v1) + (do ((i 0 (+ i 1))) + ((= i 10)) + (gsl_multiroot_fsolver_iterate s)) + (let ((residual (abs (gsl_vector_get (gsl_multiroot_fsolver_f s) 0)))) + (gsl_multiroot_fsolver_free s) + (test residual 0.0))))) + (gsl_sf_result.free sfr) + (gsl_sf_result.free s1) + (gsl_sf_result.free s2) + (gsl_cheb_free gs) + (gsl_vector_free g1) + (gsl_vector_free g2) + (gsl_vector_free v1) + (gsl_multiset_free c1) + (gsl_vector_free v2) + (gsl_vector_free step_size) + + )) + (testrst)) diff --git a/tools/thash.scm b/tools/thash.scm index 9be87dc..bff2f30 100644 --- a/tools/thash.scm +++ b/tools/thash.scm @@ -80,14 +80,16 @@ ;;; ---------------------------------------- (let () - (define (hash-ints) + (define (hash-ints calls) (let ((counts (make-hash-table))) (do ((i 0 (+ i 1)) (z (random 100) (random 100))) - ((= i 5000000) counts) + ((= i calls) i) (hash-table-set! counts z (+ (or (hash-table-ref counts z) 0) 1))))) - (hash-ints)) + (let ((val (hash-ints 5000000))) + (unless (= val 5000000) + (format *stderr* "thash hash-ints: ~S?~%" val)))) ;;; ---------------------------------------- diff --git a/tools/tmisc.scm b/tools/tmisc.scm index e843d74..407417e 100644 --- a/tools/tmisc.scm +++ b/tools/tmisc.scm @@ -349,8 +349,8 @@ (test 100000)) -;;; typer optimization tests +;;; typer optimization tests (define typer-size 1000000) diff --git a/tools/tshoot.scm b/tools/tshoot.scm index 30f78d5..8beb135 100644 --- a/tools/tshoot.scm +++ b/tools/tshoot.scm @@ -118,7 +118,7 @@ (substring s (quotient (string-length s) 2)) (substring s 0 (+ 1 (quotient (string-length s) 2))))))))) -(display (string-cat 600000)) (newline) ; 524278 +(display (string-cat 500000)) (newline) ; 524278 ;;; -------------------------------------------------------------------------------- diff --git a/tools/valcall.scm b/tools/valcall.scm index da48aa4..45b6183 100644 --- a/tools/valcall.scm +++ b/tools/valcall.scm @@ -99,8 +99,8 @@ (list "repl" "tread.scm") (list "repl" "trclo.scm") (list "repl" "titer.scm") - (list "repl" "fbench.scm") (list "repl" "tload.scm") + (list "repl" "fbench.scm") (list "repl" "tmat.scm") (list "repl" "tsort.scm") (list "repl" "tobj.scm") @@ -123,9 +123,9 @@ (list "repl" "tset.scm") (list "repl" "trec.scm") (list "repl" "tleft.scm") - (list "repl" "tmisc.scm") (list "repl" "tlamb.scm") (list "repl" "tgc.scm") + (list "repl" "tmisc.scm") (list "repl" "thash.scm") (list "repl" "cb.scm") (list "snd -noinit" "tgen.scm") ; repl here + cload sndlib was slower @@ -19,11 +19,11 @@ (if (= z pi) (copy "pi") (format #f *pretty-print-float-format* z))) - (format #f "~A~A~Ai" + (format #f "~A~A~Ai" (messy-number (real-part z)) (if (negative? (imag-part z)) "-" "+") (messy-number (abs (imag-part z))))))) - + (any-keyword? (lambda (lst) (and (pair? lst) (or (keyword? (car lst)) @@ -35,11 +35,11 @@ (hash-table? (car sequence)) (any-let-or-hash-table? (cdr sequence))))))) (let ((newlines 0)) - - (define (spaces port n) + + (define (spaces port n) (set! newlines (+ newlines 1)) (format port "~%~NC" (+ n *pretty-print-left-margin*) #\space)) - + (define (stacked-list port lst col) (do ((p lst (cdr p)) (added 0 0)) @@ -55,11 +55,11 @@ (set! added (+ 1 len)) (set! p (cdr p)) (set! obj (car p))) ; pair? cdr p above - + (cond ((or (hash-table? obj) (let? obj)) (pretty-print-1 obj port col)) - + ((and (pair? obj) (pair? (cdr obj)) (null? (cddr obj)) @@ -73,10 +73,10 @@ (pretty-print-1 (cadr obj) port (+ col 1)) (if (not (eq? (car obj) 'quote)) (write-char #\) port))) - + (else (pretty-print-1 obj port (+ col added)))))))) - + (define (stacked-split-list port lst col) (if (not (pair? lst)) (write lst port) @@ -92,8 +92,8 @@ (write (cdar p) port)) (write-char #\) port)) (write (car p) port))))) ; pretty-print? (it's always a symbol) - - (let ((writers + + (let ((writers (let ((h (make-hash-table))) ;; -------- quote @@ -103,8 +103,8 @@ (begin (write-char #\' port) (pretty-print-1 (cadr obj) port column)))) - (hash-table-set! h 'quote w-quote) - + (hash-table-set! h 'quote w-quote) ; what about #_quote? + ;; -------- define (define (w-define obj port column) (if (not (pair? (cdr obj))) @@ -125,15 +125,15 @@ (write (cddr obj) port))) (write-char #\) port)))) (hash-table-set! h 'define w-define) - + ;; -------- if - (define (w-if obj port column) + (define (w-if obj port column if-str) (let ((objstr (object->string obj)) (ifcol (+ column 4))) (if (< (length objstr) 40) (display objstr port) (begin - (format port "(if ") + (format port "(~A " if-str) (pretty-print-1 (cadr obj) port ifcol) (when (pair? (cddr obj)) ; might be a messed-up if (spaces port ifcol) @@ -142,33 +142,36 @@ (spaces port ifcol) (pretty-print-1 (cadddr obj) port ifcol))) (write-char #\) port))))) - (hash-table-set! h 'if w-if) - + (hash-table-set! h 'if (lambda (obj port col) (w-if obj port col "if"))) + (hash-table-set! h #_if (lambda (obj port col) (w-if obj port col "#_if"))) + ;; -------- when unless - (define (w-when obj port column) + (define (w-when obj port column str) (let ((objstr (object->string obj))) (if (< (length objstr) 40) (display objstr port) (begin - (format port "(~A " (car obj)) - (pretty-print-1 (cadr obj) port (+ column (if (eq? (car obj) 'when) 6 8))) + (format port "(~A " str) + (pretty-print-1 (cadr obj) port (+ column (+ 2 (string-length str)))) ;(if (eq? (car obj) 'when) 6 8))) (spaces port (+ column *pretty-print-spacing*)) (when (pair? (cddr obj)) (stacked-list port (cddr obj) (+ column *pretty-print-spacing*))) (write-char #\) port))))) - (hash-table-set! h 'when w-when) - (hash-table-set! h 'unless w-when) - + (hash-table-set! h 'when (lambda (obj port col) (w-when obj port col "when"))) + (hash-table-set! h 'unless (lambda (obj port col) (w-when obj port col "unless"))) + (hash-table-set! h #_when (lambda (obj port col) (w-when obj port col "#_when"))) + (hash-table-set! h #_unless (lambda (obj port col) (w-when obj port col "#_unless"))) + ;; -------- let let* letrec letrec* - (define (w-let obj port column) + (define (w-let obj port column let-str) (if (not (and (pair? (cdr obj)) (pair? (cddr obj)))) (write obj port) (begin - (let ((head-len (length (symbol->string (car obj))))) + (let ((head-len (length let-str))) (if (symbol? (cadr obj)) (begin - (format port "(~A ~A (" (car obj) (cadr obj)) + (format port "(~A ~A (" let-str (cadr obj)) (if (pair? (cddr obj)) (if (pair? (caddr obj)) ; (let x () ...) (stacked-split-list port (caddr obj) (+ column head-len (length (symbol->string (cadr obj))) 4)) @@ -177,7 +180,7 @@ (if (not (null? (cddr obj))) (format port " . ~S" (cddr obj))))) (begin - (format port "(~A (" (car obj)) + (format port "(~A (" let-str) (if (pair? (cadr obj)) (stacked-split-list port (cadr obj) (+ column head-len 3)))))) (write-char #\) port) @@ -186,17 +189,19 @@ (stacked-list port ((if (symbol? (cadr obj)) cdddr cddr) obj) (+ column *pretty-print-spacing*))) (write-char #\) port)))) (for-each - (lambda (f) - (hash-table-set! h f w-let)) - '(let let* letrec letrec*)) - + (lambda (f str) + (hash-table-set! h f (lambda (obj port col) (w-let obj port col str)))) + (list 'let 'let* 'letrec 'letrec* #_let #_let* #_letrec #_letrec*) + (list "let" "let*" "letrec" "letrec" "#_let" "#_let*" "#_letrec" "#_letrec*")) + ;; -------- set! - (define (w-set obj port column) + (define (w-set obj port column set-str) (let ((str (object->string obj))) + (if (<= (length str) 60) (display str port) (let ((settee (object->string (cadr obj)))) - (format port "(set! ~A" settee) + (format port "(~A ~A" set-str settee) (if (pair? (cddr obj)) (if (> (length settee) 20) (begin @@ -206,11 +211,12 @@ (write-char #\space port) (pretty-print-1 (caddr obj) port (+ column 7 (length settee)))))) (write-char #\) port))))) - (hash-table-set! h 'set! w-set) - + (hash-table-set! h 'set! (lambda (obj port col) (w-set obj port col "set!"))) + (hash-table-set! h #_set! (lambda (obj port col) (w-set obj port col "#_set!"))) + ;; -------- cond - (define (w-cond obj port column) - (format port "(cond ") + (define (w-cond obj port column cond-str) + (format port "(~A " cond-str) (do ((lst (cdr obj) (cdr lst))) ((not (pair? lst))) (if (not (eq? lst (cdr obj))) @@ -227,7 +233,7 @@ (write-char #\( port) (let ((oldlines newlines)) (pretty-print-1 (caar lst) port (+ column 7)) - (if (or extras + (if (or extras (not (= oldlines newlines)) too-long) (spaces port (+ column 7)) @@ -248,27 +254,30 @@ (stacked-list port (cdar lst) (+ column 7))))) (write-char #\) port))))) (write-char #\) port)) - (hash-table-set! h 'cond w-cond) - + (hash-table-set! h 'cond (lambda (obj port col) (w-cond obj port col "cond"))) + (hash-table-set! h #_cond (lambda (obj port col) (w-cond obj port col "#_cond"))) + ;; -------- and or - (define (w-and obj port column) + (define (w-and obj port column and-str) (if (> (length (object->string obj)) 40) (begin - (format port "(~A " (car obj)) + (format port "(~A " and-str) (stacked-list port (cdr obj) (+ column *pretty-print-spacing* (length (symbol->string (car obj))))) (write-char #\) port)) (write obj port))) - (hash-table-set! h 'and w-and) - (hash-table-set! h 'or w-and) - + (hash-table-set! h 'and (lambda (obj port col) (w-and obj port col "and"))) + (hash-table-set! h 'or (lambda (obj port col) (w-and obj port col "or"))) + (hash-table-set! h #_and (lambda (obj port col) (w-and obj port col "#_and"))) + (hash-table-set! h #_or (lambda (obj port col) (w-and obj port col "#_or"))) + ;; -------- case - (define (w-case obj port column) + (define (w-case obj port column case-str) (if (not (and (pair? (cdr obj)) (pair? (cddr obj)))) (write obj port) (begin - (format port "(case ~A" (cadr obj)) ; send out the selector - (for-each + (format port "(~A ~A" case-str (cadr obj)) ; send out the selector + (for-each (lambda (lst) (spaces port (+ column *pretty-print-spacing*)) (if (not (pair? lst)) @@ -311,29 +320,32 @@ (write-char #\) port)))) (cddr obj)) (write-char #\) port)))) - (hash-table-set! h 'case w-case) - + (hash-table-set! h 'case (lambda (obj port col) (w-case obj port col "case"))) + (hash-table-set! h #_case (lambda (obj port col) (w-case obj port col "#_case"))) + ;; -------- map for-each - (define (w-map obj port column) + (define (w-map obj port column map-str) (let* ((objstr (object->string obj)) (strlen (length objstr))) (if (< (+ column strlen) *pretty-print-length*) (display objstr port) (begin - (format port "(~A" (car obj)) + (format port "(~A" map-str) (when (pair? (cdr obj)) (write-char #\space port) (stacked-list port (cdr obj) (+ column *pretty-print-spacing*))) (write-char #\) port))))) - (hash-table-set! h 'map w-map) - (hash-table-set! h 'for-each w-map) - + (hash-table-set! h 'map (lambda (obj port col) (w-map obj port col "map"))) + (hash-table-set! h 'for-each (lambda (obj port col) (w-map obj port col "for-each"))) + (hash-table-set! h #_map (lambda (obj port col) (w-map obj port col "#_map"))) + (hash-table-set! h #_for-each (lambda (obj port col) (w-map obj port col "#_for-each"))) + ;; -------- do - (define (w-do obj port column) + (define (w-do obj port column do-str) (if (not (pair? (cdr obj))) (write obj port) (begin - (format port "(do ") + (format port "(~A " do-str) (if (list? (cadr obj)) (write-char #\( port) (display (cadr obj) port)) @@ -356,75 +368,80 @@ (spaces port (+ column *pretty-print-spacing*)) (stacked-list port (cdddr obj) (+ column *pretty-print-spacing*)))) (write-char #\) port)))) - (hash-table-set! h 'do w-do) - + (hash-table-set! h 'do (lambda (obj port col) (w-do obj port col "do"))) + (hash-table-set! h #_do (lambda (obj port col) (w-do obj port col "#_do"))) + ;; -------- begin etc - (define (w-begin obj port column) - (format port "(~A" (car obj)) + (define (w-begin obj port column begin-str) + (format port "(~A" begin-str) (when (pair? (cdr obj)) (spaces port (+ column *pretty-print-spacing*)) (stacked-list port (cdr obj) (+ column *pretty-print-spacing*))) (write-char #\) port)) (for-each - (lambda (f) - (hash-table-set! h f w-begin)) - '(begin call-with-exit call/cc call-with-current-continuation - with-baffle with-output-to-string call-with-output-string hash-table inlet)) - + (lambda (f str) + (hash-table-set! h f (lambda (obj port col) (w-begin obj port col str)))) + (list 'begin 'call-with-exit 'call/cc 'call-with-current-continuation 'with-baffle + 'with-output-to-string 'call-with-output-string 'hash-table 'inlet + #_begin #_call-with-exit #_call/cc #_call-with-current-continuation #_with-baffle + #_with-output-to-string #_call-with-output-string #_hash-table #_inlet) + (list "begin" "call-with-exit" "call/cc" "call-with-current-continuation" "with-baffle" + "with-output-to-string" "call-with-output-string" "hash-table" "inlet" + "#_begin" "#_call-with-exit" "#_call/cc" "#_call-with-current-continuation" "#_with-baffle" + "#_with-output-to-string" "#_call-with-output-string" "#_hash-table" "#_inlet")) + ;; -------- dynamic-wind call-with-values - (define (w-dynwind obj port column) - (format port "(~A" (car obj)) + (define (w-dynwind obj port column str) + (format port "(~A" str) (spaces port (+ column *pretty-print-spacing*)) (stacked-list port (cdr obj) (+ column *pretty-print-spacing*)) (write-char #\) port)) - (hash-table-set! h 'dynamic-wind w-dynwind) - (hash-table-set! h 'call-with-values w-dynwind) - + (hash-table-set! h 'dynamic-wind (lambda (obj port col) (w-dynwind obj port col "dynamic-wind"))) + (hash-table-set! h 'call-with-values (lambda (obj port col) (w-dynwind obj port col "call-with-values"))) + (hash-table-set! h #_dynamic-wind (lambda (obj port col) (w-dynwind obj port col "#_dynamic-wind"))) + (hash-table-set! h #_call-with-values (lambda (obj port col) (w-dynwind obj port col "#_call-with-values"))) + ;; -------- lambda etc - (define (w-lambda obj port column) + (define (w-lambda obj port column str) (if (not (and (pair? (cdr obj)) (pair? (cddr obj)))) (write obj port) (begin - (format port "(~A " (car obj)); (cadr obj)) - (pretty-print-1 (cadr obj) port (+ column *pretty-print-spacing* (length (symbol->string (car obj))))) + (format port "(~A " str) + (pretty-print-1 (cadr obj) port (+ column *pretty-print-spacing* (length str))) (spaces port (+ column *pretty-print-spacing*)) (stacked-list port (cddr obj) (+ column *pretty-print-spacing*)) (write-char #\) port)))) (for-each - (lambda (f) - (hash-table-set! h f w-lambda)) - '(lambda lambda* define* define-macro define-macro* define-bacro define-bacro* with-let - call-with-input-string call-with-input-file call-with-output-file - with-input-from-file with-input-from-string with-output-to-file - let-temporarily)) - - ;; -------- defmacro defmacro* - (define (w-defmacro obj port column) - (if (not (and (pair? (cdr obj)) - (pair? (cddr obj)))) - (write obj port) - (begin - (format port "(~A ~A ~A" (car obj) (cadr obj) (caddr obj)) - (spaces port (+ column *pretty-print-spacing*)) - (stacked-list port (cdddr obj) (+ column *pretty-print-spacing*)) - (write-char #\) port)))) - (hash-table-set! h 'defmacro w-defmacro) - (hash-table-set! h 'defmacro* w-defmacro) - + (lambda (f str) + (hash-table-set! h f (lambda (obj port col) (w-lambda obj port col str)))) + (list 'lambda 'lambda* 'define* 'define-macro 'define-macro* 'define-bacro 'define-bacro* 'with-let + 'call-with-input-string 'call-with-input-file 'call-with-output-file 'with-input-from-file + 'with-input-from-string 'with-output-to-file 'let-temporarily + #_lambda #_lambda* #_define* #_define-macro #_define-macro* #_define-bacro #_define-bacro* #_with-let + #_call-with-input-string #_call-with-input-file #_call-with-output-file #_with-input-from-file + #_with-input-from-string #_with-output-to-file #_let-temporarily) + (list "lambda" "lambda*" "define*" "define-macro" "define-macro*" "define-bacro" "define-bacro*" "with-let" + "call-with-input-string" "call-with-input-file" "call-with-output-file" "with-input-from-file" + "with-input-from-string" "with-output-to-file" "let-temporarily" + "#_lambda" "#_lambda*" "#_define*" "#_define-macro" "#_define-macro*" "#_define-bacro" "#_define-bacro*" "#_with-let" + "#_call-with-input-string" "#_call-with-input-file" "#_call-with-output-file" "#_with-input-from-file" + "#_with-input-from-string" "#_with-output-to-file" "#_let-temporarily")) + ;; -------- catch - (define (w-catch obj port column) + (define (w-catch obj port column str) (if (not (pair? (cdr obj))) ; (catch) or (catch . 1) (write obj port) (begin - (format port "(~A ~S" catch (cadr obj)) + (format port "(~A ~S" str (cadr obj)) (spaces port (+ column *pretty-print-spacing*)) (stacked-list port (cddr obj) (+ column *pretty-print-spacing*)) (write-char #\) port)))) - (hash-table-set! h 'catch w-catch) - + (hash-table-set! h 'catch (lambda (obj port col) (w-catch obj port col "catch"))) + (hash-table-set! h #_catch (lambda (obj port col) (w-catch obj port col "#_catch"))) + h))) - + ;; pretty-print-1 (lambda (obj port column) @@ -464,7 +481,7 @@ (display #\space port))) (display numstr port) (set! col (+ col numlen 1))))))))) - + ((and *pretty-print-cycles* (pair? (cyclic-sequences obj))) (format port "~W" obj)) @@ -478,7 +495,7 @@ (pretty-print-1 (cdr field) port (+ column 4 (length symstr))))) obj) (write-char #\) port)) - + ((let? obj) (if (and (openlet? obj) (defined? 'pretty-print obj #t)) ; #t = locally defined @@ -492,7 +509,7 @@ (pretty-print-1 (cdr field) port (+ column 4 (length symstr))))) obj) (write-char #\) port)))) - + ((vector? obj) (if (> (vector-rank obj) 1) (write obj port) @@ -522,13 +539,13 @@ (display #\space port))) (pretty-print-1 (obj i) port col) (set! col (+ col olen 1))))))))) - + ((not (pair? obj)) (write obj port)) - ((hash-table-ref writers (car obj)) + ((hash-table-ref writers (car obj)) => (lambda (f) (f obj port column))) - + ((any-let-or-hash-table? obj) (let ((first #t)) (write-char #\( port) @@ -537,7 +554,7 @@ (pretty-print-1 p port (+ column 4))) obj) (write-char #\) port))) - + (else (let* ((objstr (object->string obj)) (strlen (length objstr))) @@ -553,11 +570,11 @@ ;; and here (lambda (f obj port column) (f=display obj=objstr port)? (let ((lstlen (length obj))) - + (cond ((or (infinite? lstlen) (not (positive? lstlen))) (display objstr port)) - + ((and (symbol? (car obj)) (> (length (symbol->string (car obj))) 12) (pair? (cdr obj)) @@ -568,7 +585,7 @@ (spaces port (+ column 2)) (stacked-list port (cdr obj) (+ column 2)) (write-char #\) port)) - + ((= lstlen 1) (if (pair? (car obj)) (begin @@ -576,7 +593,7 @@ (pretty-print-1 (car obj) port (+ column 1)) (write-char #\) port)) (display objstr port))) - + ((and (pair? (car obj)) (memq (caar obj) '(lambda lambda* let let* letrec letrec* cond if case))) (write-char #\( port) @@ -594,7 +611,7 @@ (write-char #\space port))) (stacked-list port (cdr obj) (+ column 1))) (write-char #\) port)) - + (else (let* ((carstr (object->string (car obj))) (carstrlen (length carstr))) @@ -611,11 +628,11 @@ ((2) (write-char #\space port) (pretty-print-1 (cadr obj) port line-start)) - + ((3) (write-char #\space port) (stacked-list port (cdr obj) line-start)) - + (else (do ((obj-start line-start) (lst (cdr obj) (cdr lst))) @@ -641,7 +658,7 @@ (display str port))))))))))) (if (not (eq? (car obj) 'quote)) (write-char #\) port))))))))))))))) - + ;; pretty-print (lambda* (obj (port (current-output-port)) (column 0)) (let ((old-port port)) @@ -702,7 +719,7 @@ ;;; pretty-print method: -(let ((v (openlet (inlet 'value #(0 1 2 3) +(let ((v (openlet (inlet 'value #(0 1 2 3) 'pretty-print (lambda (obj port column) (display "#(... 2 ...)" port)))))) (pretty-print (list 1 v 3))) |