diff options
| author | IOhannes m zmölnig <zmoelnig@umlautT.umlaeute.mur.at> | 2023-07-02 21:21:55 +0200 |
|---|---|---|
| committer | IOhannes m zmölnig <zmoelnig@umlautT.umlaeute.mur.at> | 2023-07-02 21:21:55 +0200 |
| commit | 394168214e8322de7c05fb068510413b58ae4cb8 (patch) | |
| tree | d6849b97dbeefbd0fabab308fb7713a36e6d2dd9 | |
| parent | 179c94e4e7330cb08925c1a6c58089cf87b7be6c (diff) | |
New upstream version 23.5
| -rw-r--r-- | HISTORY.Snd | 2 | ||||
| -rw-r--r-- | NEWS | 8 | ||||
| -rwxr-xr-x | configure | 22 | ||||
| -rw-r--r-- | configure.ac | 6 | ||||
| -rw-r--r-- | heart.scm | 16 | ||||
| -rw-r--r-- | s7.c | 511 | ||||
| -rw-r--r-- | s7.h | 2 | ||||
| -rw-r--r-- | s7.html | 2 | ||||
| -rw-r--r-- | s7test.scm | 33 | ||||
| -rw-r--r-- | s7webserver/Makefile | 6 | ||||
| -rw-r--r-- | snd-dac.c | 2 | ||||
| -rw-r--r-- | snd-motif.c | 4 | ||||
| -rw-r--r-- | snd.h | 6 | ||||
| -rw-r--r-- | sndlib.html | 2 | ||||
| -rw-r--r-- | sndscm.html | 6 | ||||
| -rwxr-xr-x | tools/compsnd | 6 | ||||
| -rw-r--r-- | xen.c | 11 | ||||
| -rw-r--r-- | xen.h | 5 |
18 files changed, 364 insertions, 286 deletions
diff --git a/HISTORY.Snd b/HISTORY.Snd index f66d427..7fb12a0 100644 --- a/HISTORY.Snd +++ b/HISTORY.Snd @@ -1,5 +1,7 @@ Snd change log + 1-Jul: Snd 23.5. + 25-May: Snd 23.4. 20-Apr: Snd 23.3. 13-Mar: Snd 23.2. 10-Feb: Snd 23.1. @@ -1,7 +1,7 @@ -Snd 23.3 +Snd 23.5 -s7: autoload bugfix +s7: various small bugs and optimizations. -checked: sbcl 2.3.3 +checked: sbcl 2.3.5|6 -Thanks!: john M693, Todd Ingalls +Thanks!: Anders Vinjar, Todd Ingalls, johnm, Kjetil Matheussen @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for snd 23.4. +# Generated by GNU Autoconf 2.71 for snd 23.5. # # 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-23.tar.gz' -PACKAGE_VERSION='23.4' -PACKAGE_STRING='snd 23.4' +PACKAGE_VERSION='23.5' +PACKAGE_STRING='snd 23.5' 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 23.4 to adapt to many kinds of systems. +\`configure' configures snd 23.5 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 23.4:";; + short | recursive ) echo "Configuration of snd 23.5:";; 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 23.4 +snd configure 23.5 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 23.4, which was +It was created by snd $as_me 23.5, 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=23.4 +VERSION=23.5 #-------------------------------------------------------------------------------- # configuration options @@ -6861,7 +6861,7 @@ if test "$with_webserver" = yes ; then WEBSERVER_FILES="s7webserver/s7webserver.o s7webserver/qhttpserver-master/lib/libqhttpserver.a" - WEBSERVER_LIBS="`pkg-config --libs QtNetwork` -lstdc++" + WEBSERVER_LIBS="`pkg-config --libs Qt5Network` -lstdc++" RANDOM_FEATURES="$RANDOM_FEATURES webserver" fi @@ -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 23.4, which was +This file was extended by snd $as_me 23.5, 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 23.4 +snd config.status 23.5 configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index 1a13805..5111ff2 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ # gmp, mpfr, and mpc deliberately have none! -AC_INIT(snd, 23.4, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-23.tar.gz) +AC_INIT(snd, 23.5, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-23.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=23.4 +VERSION=23.5 #-------------------------------------------------------------------------------- # configuration options @@ -787,7 +787,7 @@ if test "$with_webserver" = yes ; then AC_DEFINE(ENABLE_WEBSERVER) WEBSERVER_FILES="s7webserver/s7webserver.o s7webserver/qhttpserver-master/lib/libqhttpserver.a" - WEBSERVER_LIBS="`pkg-config --libs QtNetwork` -lstdc++" + WEBSERVER_LIBS="`pkg-config --libs Qt5Network` -lstdc++" RANDOM_FEATURES="$RANDOM_FEATURES webserver" fi @@ -16,7 +16,7 @@ (let ((hpsum 0) ; for average readings (lpsum 0)) (let ((ind (find-sound - (with-sound (:channels 6 :sample-type mus-lfloat) + (with-sound (:channels 4 :sample-type mus-lfloat) (let ((samp 0)) (call-with-input-file (list-ref (script-args) 1) ; invocation arg = text file of data ("snd heart.scm data.txt") @@ -27,7 +27,7 @@ (or (eof-object? line) (do ((len (length line)) (i 0 (+ 1 i))) - ((>= i (- len 14)) + ((>= i (- len 12)) (loop (read-line file #t))) (when (and (char=? (line i) #\[) (char=? (line (+ i 3)) #\m) @@ -40,16 +40,16 @@ (set! lpsum (+ lpsum lp)) (out-any samp hp 0) ; output the readings (out-any samp lp 1) - (out-any samp 120 2) - (out-any samp 80 3) - (out-any samp (max 90 (moving-average average (* 0.5 (+ lp hp)))) 4) - (out-any samp (max 90 (moving-average average1 (* 0.5 (+ lp hp)))) 5) + (out-any samp 125 2) + (out-any samp 83 3) + ;(out-any samp (max 90 (moving-average average (* 0.5 (+ lp hp)))) 4) + ;(out-any samp (max 90 (moving-average average1 (* 0.5 (+ lp hp)))) 5) (set! samp (+ 1 samp)))))))))))))))) - ;; now display the data with y-axis bounds between 50 and 150, both traces in the same graph, x-axis in "samples" (readings) + ;; now display the data with y-axis bounds between 65 and 150, both traces in the same graph, x-axis in "samples" (readings) (set! (channel-style ind) channels-superimposed) (do ((chan 0 (+ 1 chan))) - ((= chan 6)) + ((= chan 4)) (set! (x-axis-style ind chan) x-axis-in-samples) (set! (x-axis-label ind chan) "days") (set! (y-bounds ind chan) (list 65 150))) @@ -3079,7 +3079,7 @@ static void init_types(void) #define is_symbol(p) (type(p) == T_SYMBOL) #define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p))) -#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(lookup_slot_from(p, sc->curlet)))) +#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(s7_slot(sc, p)))) #define symbol_name_cell(p) T_Str((T_Sym(p))->object.sym.name) #define symbol_set_name_cell(p, S) (T_Sym(p))->object.sym.name = T_Str(S) #define symbol_name(p) string_value(symbol_name_cell(p)) @@ -6327,7 +6327,7 @@ static inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) /* inline: return(true); if (is_possibly_constant(sym)) { - s7_pointer slot = lookup_slot_from(sym, sc->curlet); + s7_pointer slot = s7_slot(sc, sym); return((is_slot(slot)) && (is_immutable_slot(slot))); } return(false); @@ -6373,7 +6373,7 @@ static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) s7_pointer p = car(args); if (is_symbol(p)) { - s7_pointer slot = lookup_slot_from(p, sc->curlet); + s7_pointer slot = s7_slot(sc, p); if (is_slot(slot)) { set_immutable_slot(slot); @@ -10427,6 +10427,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));} s7_pointer s7_slot_value(s7_pointer slot) {return(slot_value(slot));} @@ -10447,7 +10448,7 @@ static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_poin s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym) { - s7_pointer x = lookup_slot_from(sym, sc->curlet); + s7_pointer x = s7_slot(sc, sym); return((is_slot(x)) ? slot_value(x) : sc->undefined); } @@ -10522,7 +10523,7 @@ symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32" s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val) { - s7_pointer x = lookup_slot_from(sym, sc->curlet); /* if immutable should this return an error? */ + s7_pointer x = s7_slot(sc, sym); /* if immutable should this return an error? */ if (is_slot(x)) slot_set_value(x, val); /* with_hook? */ return(val); @@ -10601,7 +10602,7 @@ static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) { return((is_slot(global_slot(sym))) || (direct_assq(sym, e)) || - (is_slot(lookup_slot_from(sym, sc->curlet)))); + (is_slot(s7_slot(sc, sym)))); } static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) @@ -10611,7 +10612,7 @@ static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) if (is_null(e)) e = sc->rootlet; return((!is_with_let_let(e)) && - (is_slot(lookup_slot_from(sym, sc->curlet)))); + (is_slot(s7_slot(sc, sym)))); } static bool let_symbol_is_safe_or_listed(s7_scheme *sc, s7_pointer sym, s7_pointer e) @@ -10624,7 +10625,7 @@ static bool let_star_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) { return((symbol_is_in_list(sc, sym)) || (is_slot(global_slot(sym))) || - ((is_let(e)) && (!is_with_let_let(e)) && (is_slot(lookup_slot_from(sym, sc->curlet))))); + ((is_let(e)) && (!is_with_let_let(e)) && (is_slot(s7_slot(sc, sym))))); } static bool pair_symbol_is_safe(s7_scheme *unused_sc, s7_pointer sym, s7_pointer e) @@ -11066,7 +11067,7 @@ Only the let is searched if ignore-globals is not #f." return(sc->T); return((b == sc->T) ? sc->F : make_boolean(sc, is_slot(global_slot(sym)))); } - return((is_global(sym)) ? sc->T : make_boolean(sc, is_slot(lookup_slot_from(sym, sc->curlet)))); + return((is_global(sym)) ? sc->T : make_boolean(sc, is_slot(s7_slot(sc, sym)))); } static s7_pointer g_is_defined_in_rootlet(s7_scheme *sc, s7_pointer args) @@ -11096,13 +11097,13 @@ bool s7_is_defined(s7_scheme *sc, const char *name) { s7_pointer x = s7_symbol_table_find_name(sc, name); if (!x) return(false); - return(is_slot(lookup_slot_from(x, sc->curlet))); + return(is_slot(s7_slot(sc, x))); } static bool is_defined_b_7p(s7_scheme *sc, s7_pointer p) { if (!is_symbol(p)) return(method_or_bust(sc, p, sc->is_defined_symbol, set_plist_1(sc, p), sc->type_names[T_SYMBOL], 1) != sc->F); - return(is_slot(lookup_slot_from(p, sc->curlet))); + return(is_slot(s7_slot(sc, p))); } static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer p, s7_pointer e) {return(g_is_defined(sc, set_plist_2(sc, p, e)) != sc->F);} @@ -30915,7 +30916,7 @@ static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) s7_warn(sc, 256, "provide: *features* is immutable!\n"); else { - s7_pointer lst = slot_value(lookup_slot_from(sc->features_symbol, sc->curlet)); /* in either case, we want the current *features* list */ + s7_pointer lst = slot_value(s7_slot(sc, sc->features_symbol)); /* in either case, we want the current *features* list */ if (p == sc->undefined) add_slot_checked_with_id(sc, sc->curlet, sc->features_symbol, cons(sc, sym, lst)); else @@ -31469,6 +31470,24 @@ static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer obj) static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer obj) { + /* this can be confusing: below a hash-table is the "function", and a function is the "iterator" only because with-let exports +iterator+=#t -> infinite loop! + (with-let + (let ((+iterator+ #t)) + (lambda () #<eof>)) ; this works because a function has an associated let?? with-let first arg should be a let. + (for-each + (make-hash-table) ; (hash-table) -- ((hash-table) ()) is #f (not an error) + ;(vector 1) ; error: vector-ref second argument, (), is nil but should be an integer + ;(vector) ; error: for-each first argument #() called with 1 argument? + ;(list) ; for-each first argument, (), is nil but should be a procedure or something applicable + (lambda args args) ; function as iterator because local +iterator+ above is #t, never returns #<eof> (always () because iterator func takes no args) + ;(lambda (asd) ()) ; error: make-iterator argument, #<lambda (asd)>, is a function but should be a thunk + )) + * similarly: + (with-let + (let ((+documentation+ "hiho")) (curlet)) + (define (f) 1) ; (define (f) "a string" 1) would return doc as "a string" + (display (documentation f)) (newline)) ; "hiho" -- should we block +documentation+ in with-let? + */ s7_pointer result = s7_call(sc, iterator_sequence(obj), sc->nil); /* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */ if (result == ITERATOR_END) @@ -45670,7 +45689,7 @@ static s7_pointer g_signature(s7_scheme *sc, s7_pointer args) case T_SYMBOL: /* this used to get the symbol's value and call g_signature on that */ { - s7_pointer slot = lookup_slot_from(p, sc->curlet); + s7_pointer slot = s7_slot(sc, p); if ((is_slot(slot)) && (slot_has_setter(slot))) { s7_pointer setter = slot_setter(slot); @@ -46299,7 +46318,7 @@ static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer if (closure_arity_unknown(x)) closure_set_arity(x, s7_list_length(sc, x_args)); len = closure_arity(x); - if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ + if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ return(cons(sc, make_integer(sc, -len), max_arity)); return(cons(sc, make_integer(sc, len), make_integer_unchecked(sc, len))); } @@ -46415,7 +46434,7 @@ static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, if (args == 0) return(!is_pair(x_args)); - if (is_symbol(x_args)) /* any number of args is ok */ + if (is_symbol(x_args)) /* any number of args is ok */ return(true); len = closure_arity(x); @@ -46424,9 +46443,9 @@ static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, len = s7_list_length(sc, x_args); closure_set_arity(x, len); } - if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ - return((-len) <= args); /* so we have enough to take care of the required args */ - return(args == len); /* in a normal lambda list, there are no other possibilities */ + if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ + return((-len) <= args); /* so we have enough to take care of the required args */ + return(args == len); /* in a normal lambda list, there are no other possibilities */ } static bool closure_star_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args) @@ -46655,7 +46674,7 @@ static s7_pointer symbol_setter(s7_scheme *sc, s7_pointer sym, s7_pointer e) { s7_pointer old_e = sc->curlet; set_curlet(sc, e); - slot = lookup_slot_from(sym, sc->curlet); + slot = s7_slot(sc, sym); set_curlet(sc, old_e); } if ((!is_slot(slot)) || (!slot_has_setter(slot))) return(sc->F); @@ -46770,11 +46789,11 @@ static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer ar { 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_from(sym, e); + slot = lookup_slot_with_let(sym, e); }} else { - slot = lookup_slot_from(sym, sc->curlet); /* (set! (setter 'x) (lambda (s v) ...)) */ + slot = s7_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)) */ func = cadr(args); } if (!is_slot(slot)) @@ -47258,8 +47277,7 @@ static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared if (!eqf(sc, hash_entry_value(p), hash_entry_value(y_val), nci)) return(false); } - /* if we get here, every key/value in x has a corresponding key/value in y, and the number of entries match, - * so surely the tables are equal?? + /* if we get here, every key/value in x has a corresponding key/value in y, and the number of entries match, so surely the tables are equal?? * if ci not null or hash-table-checker is equal/eqivalent, can't use hf? */ return(true); @@ -48155,39 +48173,39 @@ static bool random_state_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared static void init_equals(void) { for (int32_t i = 0; i < NUM_TYPES; i++) {equals[i] = eq_equal; equivalents[i] = eq_equal;} - equals[T_SYMBOL] = eq_equal; - equals[T_C_POINTER] = c_pointer_equal; - equals[T_UNSPECIFIED] = unspecified_equal; - equals[T_UNDEFINED] = undefined_equal; - equals[T_STRING] = string_equal; - equals[T_SYNTAX] = syntax_equal; - equals[T_C_OBJECT] = c_objects_are_equal; - equals[T_RANDOM_STATE] = random_state_equal; - equals[T_ITERATOR] = iterator_equal; - equals[T_INPUT_PORT] = port_equal; - equals[T_OUTPUT_PORT] = port_equal; - equals[T_MACRO] = closure_equal; - equals[T_MACRO_STAR] = closure_equal; - equals[T_BACRO] = closure_equal; - equals[T_BACRO_STAR] = closure_equal; - equals[T_CLOSURE] = closure_equal; - equals[T_CLOSURE_STAR] = closure_equal; - equals[T_HASH_TABLE] = hash_table_equal; - equals[T_LET] = let_equal; - equals[T_PAIR] = pair_equal; - equals[T_VECTOR] = vector_equal; - equals[T_INT_VECTOR] = int_vector_equal; - equals[T_BYTE_VECTOR] = byte_vector_equal; - equals[T_FLOAT_VECTOR] = float_vector_equal; - equals[T_INTEGER] = integer_equal; - equals[T_RATIO] = fraction_equal; - equals[T_REAL] = real_equal; - equals[T_COMPLEX] = complex_equal; + equals[T_SYMBOL] = eq_equal; + equals[T_C_POINTER] = c_pointer_equal; + equals[T_UNSPECIFIED] = unspecified_equal; + equals[T_UNDEFINED] = undefined_equal; + equals[T_STRING] = string_equal; + equals[T_SYNTAX] = syntax_equal; + equals[T_C_OBJECT] = c_objects_are_equal; + equals[T_RANDOM_STATE] = random_state_equal; + equals[T_ITERATOR] = iterator_equal; + equals[T_INPUT_PORT] = port_equal; + equals[T_OUTPUT_PORT] = port_equal; + equals[T_MACRO] = closure_equal; + equals[T_MACRO_STAR] = closure_equal; + equals[T_BACRO] = closure_equal; + equals[T_BACRO_STAR] = closure_equal; + equals[T_CLOSURE] = closure_equal; + equals[T_CLOSURE_STAR] = closure_equal; + equals[T_HASH_TABLE] = hash_table_equal; + equals[T_LET] = let_equal; + equals[T_PAIR] = pair_equal; + equals[T_VECTOR] = vector_equal; + equals[T_INT_VECTOR] = int_vector_equal; + equals[T_BYTE_VECTOR] = byte_vector_equal; + equals[T_FLOAT_VECTOR] = float_vector_equal; + equals[T_INTEGER] = integer_equal; + equals[T_RATIO] = fraction_equal; + equals[T_REAL] = real_equal; + equals[T_COMPLEX] = complex_equal; #if WITH_GMP - equals[T_BIG_INTEGER] = big_integer_equal; - equals[T_BIG_RATIO] = big_ratio_equal; - equals[T_BIG_REAL] = big_real_equal; - equals[T_BIG_COMPLEX] = big_complex_equal; + equals[T_BIG_INTEGER] = big_integer_equal; + equals[T_BIG_RATIO] = big_ratio_equal; + equals[T_BIG_REAL] = big_real_equal; + equals[T_BIG_COMPLEX] = big_complex_equal; #endif equivalents[T_SYMBOL] = symbol_equivalent; equivalents[T_C_POINTER] = c_pointer_equivalent; @@ -48576,11 +48594,11 @@ static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer s { case T_PAIR: { - s7_pointer pd, ps; + s7_pointer pd = dest, ps = source; s7_int i; - for (ps = source, i = 0; i < source_start; i++) + for (i = 0; i < source_start; i++) ps = cdr(ps); - for (pd = dest, i = 0; i < dest_start; i++) + for (i = 0; i < dest_start; i++) pd = cdr(pd); for (; (i < dest_end) && is_pair(ps) && is_pair(pd); i++, ps = cdr(ps), pd = cdr(pd)) set_car(pd, car(ps)); @@ -49570,12 +49588,11 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) { s7_pointer np = any_list_reverse_in_place(sc, sc->nil, p); if (is_null(np)) - wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a mutable, proper list", 22)); - /* this is not ideal: car(args) here is the changed list: - * (reverse! '(3 2 . 1) -> error: reverse! first argument, (3), is a pair but should be a mutable, proper list - * and (here) the real problem is that it is not a proper list: (reverse! '(3 2 1)) -> '(1 2 3) - * but (define L (immutable! (cons 3 (immutable! (cons 2 ()))))) (reverse! L) -> error: can't reverse! (3 2) (it is immutable) - */ + { + if (!s7_is_proper_list(sc, p)) + wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a proper list", 13)); + wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a mutable proper list", 21)); + } return(np); } /* (reverse! p) is supposed to change p directly and lisp programmers expect reverse! to be fast @@ -51777,7 +51794,7 @@ static bool catch_dynamic_unwind_function(s7_scheme *sc, s7_int i, s7_pointer ty */ if (sc->debug > 0) { - s7_pointer spaces = lookup_slot_from(make_symbol(sc, "*debug-spaces*", 14), stack_let(sc->stack, i)); + s7_pointer spaces = lookup_slot_with_let(make_symbol(sc, "*debug-spaces*", 14), stack_let(sc->stack, i)); if (is_slot(spaces)) slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */ } @@ -52569,7 +52586,6 @@ s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args) push_stack_direct(sc, OP_EVAL_DONE); sc->code = fnc; sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; - /* fprintf(stderr, "apply %s %s\n", display(sc->code), display(sc->args)); */ eval(sc, OP_APPLY); /* we're limited in choices here -- the caller might be (say) car(sc->t1_1) = fn_proc(...) where the fn_proc * happens to fallback on a method -- we can't just push OP_APPLY and drop back into the evaluator normally. @@ -53168,7 +53184,7 @@ static s7_pointer g_abort(s7_scheme *sc, s7_pointer args) {abort(); return(NULL) #if S7_DEBUGGING static void check_t_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) { - if (let_slots(e) != lookup_slot_from(var, sc->curlet)) + if (let_slots(e) != s7_slot(sc, var)) { fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(sc->curlet), (tis_slot(let_slots(e))) ? display(let_slots(e)) : "no slots", UNBOLD_TEXT); @@ -53190,7 +53206,7 @@ static s7_pointer T_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, static void check_u_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) { - if (next_slot(let_slots(e)) != lookup_slot_from(var, sc->curlet)) + if (next_slot(let_slots(e)) != s7_slot(sc, var)) { 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(next_slot(let_slots(e)))) ? display(next_slot(let_slots(e))) : "no next slot", UNBOLD_TEXT); @@ -53212,7 +53228,7 @@ static s7_pointer U_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, static void check_v_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) { - if (next_slot(next_slot(let_slots(e))) != lookup_slot_from(var, sc->curlet)) + if (next_slot(next_slot(let_slots(e))) != s7_slot(sc, var)) { 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(next_slot(next_slot(let_slots(e))))) ? display(next_slot(next_slot(let_slots(e)))) : "no next slot", UNBOLD_TEXT); @@ -53234,8 +53250,8 @@ 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 = lookup_slot_from(var, sc->curlet); - if (lookup_slot_from(var, e) != slot) + s7_pointer slot = s7_slot(sc, var); + if (lookup_slot_with_let(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); @@ -53284,6 +53300,7 @@ static s7_pointer fx_T(s7_scheme *sc, s7_pointer arg) {return(T_lookup(sc, T_Sym static s7_pointer fx_U(s7_scheme *sc, s7_pointer arg) {return(U_lookup(sc, T_Sym(arg), arg));} static s7_pointer fx_V(s7_scheme *sc, s7_pointer arg) {return(V_lookup(sc, T_Sym(arg), arg));} static s7_pointer fx_c_nc(s7_scheme *sc, s7_pointer arg) {return(fc_call(sc, arg));} +static s7_pointer fx_c_0c(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, sc->nil));} static s7_pointer fx_cons_cc(s7_scheme *sc, s7_pointer arg) {return(cons(sc, cadr(arg), caddr(arg)));} static s7_pointer fx_curlet(s7_scheme *sc, s7_pointer arg) {return(sc->curlet);} @@ -53468,6 +53485,7 @@ static s7_pointer fx_add_i_random(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_add_sf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))), 1));} static s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)), 2));} static s7_pointer fx_add_tf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))), 1));} +static s7_pointer fx_add_ft(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, opt2_sym(cdr(arg)), arg), real(cadr(arg)), 2));} #define fx_add_si_any(Name, Lookup) \ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ @@ -53772,6 +53790,14 @@ fx_iterate_s_any(fx_iterate_s, s_lookup) fx_iterate_s_any(fx_iterate_o, o_lookup) fx_iterate_s_any(fx_iterate_T, T_lookup) +static s7_pointer fx_read_char_0(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer port = input_port_if_not_loading(sc); + if (!port) return(eof_object); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string)); + return(chars[port_read_character(port)(sc, port)]); +} static s7_pointer fx_length_s(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, lookup(sc, cadr(arg))));} static s7_pointer fx_length_t(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, t_lookup(sc, cadr(arg), arg)));} @@ -56421,7 +56447,8 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer cur_en { switch (optimize_op(arg)) { - case HOP_SAFE_C_NC: + case HOP_SAFE_C_NC: /* includes 0-arg cases, newline/current-input|output-port, [make-]hash-table?, read-line, [float-]vector/list, gensym */ + if (cdr(arg) == sc->nil) return((fn_proc(arg) == g_read_char) ? fx_read_char_0 : fx_c_0c); #if (!WITH_GMP) if (fn_proc(arg) == g_add_i_random) return(fx_add_i_random); #endif @@ -57411,6 +57438,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point { if ((car(p) == sc->cons_symbol) && (is_unchanged_global(sc->cons_symbol))) return(with_fx(tree, fx_cons_ct)); if (fx_proc(tree) == fx_multiply_is) return(with_fx(tree, fx_multiply_it)); + if (fx_proc(tree) == fx_add_fs) return(with_fx(tree, fx_add_ft)); if (fx_proc(tree) == fx_c_cs) { if (is_global_and_has_func(car(p), s7_p_pp_function)) @@ -58207,7 +58235,7 @@ static s7_pointer opt_integer_symbol(s7_scheme *sc, s7_pointer sym) { if (is_symbol(sym)) { - s7_pointer p = lookup_slot_from(sym, sc->curlet); + s7_pointer p = s7_slot(sc, sym); if ((is_slot(p)) && (is_t_integer(slot_value(p)))) return(p); @@ -58219,7 +58247,7 @@ static s7_pointer opt_real_symbol(s7_scheme *sc, s7_pointer sym) { if (is_symbol(sym)) { - s7_pointer p = lookup_slot_from(sym, sc->curlet); + s7_pointer p = s7_slot(sc, sym); if ((is_slot(p)) && (is_small_real(slot_value(p)))) return(p); @@ -58231,7 +58259,7 @@ static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) { if (is_symbol(sym)) { - s7_pointer p = lookup_slot_from(sym, sc->curlet); + s7_pointer p = s7_slot(sc, sym); if ((is_slot(p)) && (is_t_real(slot_value(p)))) return(p); @@ -58241,7 +58269,7 @@ static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) static s7_pointer opt_simple_symbol(s7_scheme *sc, s7_pointer sym) { - s7_pointer p = lookup_slot_from(sym, sc->curlet); + s7_pointer p = s7_slot(sc, sym); if ((is_slot(p)) && (!has_methods(slot_value(p)))) return(p); @@ -58251,7 +58279,7 @@ static s7_pointer opt_simple_symbol(s7_scheme *sc, s7_pointer sym) static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sym) { s7_pointer checker = s7_symbol_value(sc, check); - s7_pointer slot = lookup_slot_from(sym, sc->curlet); + s7_pointer slot = s7_slot(sc, sym); if (is_slot(slot)) { s7_pointer obj = slot_value(slot); @@ -58902,7 +58930,7 @@ static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) { - s7_pointer settee = lookup_slot_from(v, sc->curlet); + s7_pointer settee = s7_slot(sc, v); if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) { @@ -59054,7 +59082,7 @@ static bool i_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point (is_target_or_its_alias(car(car_x), s_func, sc->byte_vector_set_symbol))) return(opt_int_vector_set(sc, (car(car_x) == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x))); - settee = lookup_slot_from(cadr(car_x), sc->curlet); + settee = s7_slot(sc, cadr(car_x)); if (is_slot(settee)) { s7_pointer vect = slot_value(settee); @@ -59215,7 +59243,7 @@ static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) s7_pointer settee; if (is_immutable(cadr(car_x))) return_false(sc, car_x); - settee = lookup_slot_from(cadr(car_x), sc->curlet); + settee = s7_slot(sc, cadr(car_x)); if ((is_slot(settee)) && (is_t_integer(slot_value(settee))) && (!is_immutable_slot(settee)) && @@ -59510,7 +59538,7 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_symbol(cadr(car_x))) /* (float-vector-ref v i) */ { s7_pointer arg2, p, obj; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, cadr(car_x)); if (!is_slot(opc->v[1].p)) return_false(sc, car_x); @@ -59584,7 +59612,7 @@ static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[3].d_ip_f = pfunc; opc->v[1].p = p; - opc->v[2].p = lookup_slot_from(caddr(car_x), sc->curlet); + opc->v[2].p = s7_slot(sc, caddr(car_x)); if (is_slot(opc->v[2].p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ { opc->v[0].fd = opt_d_ip_ss; @@ -59607,7 +59635,7 @@ static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer p, arg2 = caddr(car_x); int32_t start = sc->pc; opc->v[3].d_pd_f = func; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, cadr(car_x)); if (!is_slot(opc->v[1].p)) return_false(sc, car_x); p = opt_float_symbol(sc, arg2); @@ -59729,7 +59757,7 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[0].fd = opt_d_vd_c; return_true(sc, car_x); } - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); + opc->v[2].p = s7_slot(sc, arg2); if (is_slot(opc->v[2].p)) { if (is_t_real(slot_value(opc->v[2].p))) @@ -60761,7 +60789,7 @@ static bool d_7pid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe if (is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), NULL, NULL, cdddr(car_x))); - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, cadr(car_x)); opc->v[10].o1 = sc->opts[start]; if (is_slot(opc->v[1].p)) { @@ -60833,7 +60861,7 @@ static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe { s7_pointer slot; int32_t start = sc->pc; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, cadr(car_x)); if ((!is_slot(opc->v[1].p)) || (!is_float_vector(slot_value(opc->v[1].p))) || (vector_rank(slot_value(opc->v[1].p)) != 2)) @@ -60945,7 +60973,7 @@ static bool d_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point (is_symbol(cadr(car_x)))) { s7_pointer slot; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, cadr(car_x)); if ((!is_slot(opc->v[1].p)) || (!is_float_vector(slot_value(opc->v[1].p))) || (vector_rank(slot_value(opc->v[1].p)) != 3)) @@ -61008,7 +61036,7 @@ static bool d_7piiid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer indexp3, s7_pointer valp) { - s7_pointer settee = lookup_slot_from(v, sc->curlet); + s7_pointer settee = s7_slot(sc, v); if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) { @@ -61375,7 +61403,7 @@ static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) s7_pointer settee; if (is_immutable(cadr(car_x))) return_false(sc, car_x); - settee = lookup_slot_from(cadr(car_x), sc->curlet); + settee = s7_slot(sc, cadr(car_x)); if ((is_slot(settee)) && (is_t_real(slot_value(settee))) && (!is_immutable_slot(settee)) && @@ -61580,7 +61608,7 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin opc->v[2].b_i_f = bif; if (is_symbol(cadr(car_x))) { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, cadr(car_x)); opc->v[0].fb = opt_b_i_s; return_true(sc, car_x); } @@ -61611,7 +61639,7 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_poin opc->v[2].b_d_f = bdf; if (is_symbol(cadr(car_x))) { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, cadr(car_x)); opc->v[0].fb = (bdf == is_positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; return_true(sc, car_x); } @@ -61662,7 +61690,7 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) { if ((is_global(car(arg))) || ((is_slot(global_slot(car(arg)))) && - (lookup_slot_from(car(arg), sc->curlet) == global_slot(car(arg))))) + (s7_slot(sc, car(arg)) == global_slot(car(arg))))) { s7_pointer a_func = global_value(car(arg)); if (is_c_function(a_func)) @@ -61700,7 +61728,7 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) (is_pair(cdr(arg)))) return(s7_type_of(sc, cadr(arg))); } - slot = lookup_slot_from(car(arg), sc->curlet); + slot = s7_slot(sc, car(arg)); if ((is_slot(slot)) && (is_sequence(slot_value(slot)))) { @@ -61935,7 +61963,7 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[10].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); + opc->v[1].p = s7_slot(sc, arg2); if ((!is_slot(opc->v[1].p)) || (has_methods(slot_value(opc->v[1].p)))) return_false(sc, car_x); @@ -61984,7 +62012,7 @@ static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[11].fp = opc->v[10].o1->v[0].fp; if (is_symbol(arg2)) { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); /* slot checked in opt_arg_type */ + opc->v[1].p = s7_slot(sc, arg2); /* slot checked in opt_arg_type */ opc->v[0].fb = (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; return_true(sc, car_x); } @@ -62037,10 +62065,10 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[3].b_dd_f = bif; if (is_symbol(arg1)) { - opc->v[1].p = lookup_slot_from(arg1, sc->curlet); + opc->v[1].p = s7_slot(sc, arg1); if (is_symbol(arg2)) { - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); + opc->v[2].p = s7_slot(sc, arg2); opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_ss_lt : ((bif == gt_b_dd) ? opt_b_dd_ss_gt : opt_b_dd_ss); return_true(sc, car_x); } @@ -62064,7 +62092,7 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[11].fd = opc->v[10].o1->v[0].fd; if (is_symbol(arg2)) { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); + opc->v[1].p = s7_slot(sc, arg2); opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; return_true(sc, car_x); } @@ -62138,10 +62166,10 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (bif) opc->v[3].b_ii_f = bif; else opc->v[3].b_7ii_f = b7if; if (is_symbol(arg1)) { - opc->v[1].p = lookup_slot_from(arg1, sc->curlet); + opc->v[1].p = s7_slot(sc, arg1); if (is_symbol(arg2)) { - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); + opc->v[2].p = s7_slot(sc, arg2); opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt : ((bif == leq_b_ii) ? opt_b_ii_ss_leq : @@ -62181,7 +62209,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (!int_optimize(sc, cdr(car_x))) return_false(sc, car_x); opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); + opc->v[2].p = s7_slot(sc, arg2); opc->v[0].fb = opt_b_ii_fs; return_true(sc, car_x); } @@ -63083,7 +63111,7 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi opc->v[3].call = cf_call(sc, car_x, s_func, 2); if (is_symbol(cadr(car_x))) { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, cadr(car_x)); if ((is_slot(opc->v[1].p)) && (!has_methods(slot_value(opc->v[1].p)))) { @@ -63228,7 +63256,7 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer checker = cadr(sig); /* here we know cadr is a symbol */ - slot1 = lookup_slot_from(cadr(car_x), sc->curlet); + slot1 = s7_slot(sc, cadr(car_x)); if ((!is_slot(slot1)) || (has_methods(slot_value(slot1))) || (is_immutable(slot_value(slot1)))) @@ -63412,7 +63440,7 @@ static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe if ((func) && (s_func == global_value(sc->vector_set_symbol)) && (is_symbol(cadr(car_x)))) { s7_pointer obj; - s7_pointer slot1 = lookup_slot_from(cadr(car_x), sc->curlet); + s7_pointer slot1 = s7_slot(sc, cadr(car_x)); if (!is_slot(slot1)) return_false(sc, car_x); obj = slot_value(slot1); @@ -63454,7 +63482,7 @@ static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer (is_symbol(cadr(car_x)))) { s7_pointer obj; - s7_pointer slot1 = lookup_slot_from(cadr(car_x), sc->curlet); + s7_pointer slot1 = s7_slot(sc, cadr(car_x)); if (!is_slot(slot1)) return_false(sc, car_x); obj = slot_value(slot1); @@ -63570,7 +63598,7 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_pointer obj; opt_info *o1; - s7_pointer slot = lookup_slot_from(arg1, sc->curlet); + s7_pointer slot = s7_slot(sc, arg1); if ((!is_slot(slot)) || (has_methods(slot_value(slot)))) return_false(sc, car_x); @@ -63931,7 +63959,7 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in /* now v3.p_pi|pp.f is set */ if (is_symbol(cadr(car_x))) { - s7_pointer slot = lookup_slot_from(cadr(car_x), sc->curlet); + s7_pointer slot = s7_slot(sc, cadr(car_x)); if (is_slot(slot)) { opc->v[2].p = slot; @@ -64287,7 +64315,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy ((is_slot(global_slot(target))) && (slot_has_setter(global_slot(target))))) return_false(sc, car_x); - settee = lookup_slot_from(target, sc->curlet); + settee = s7_slot(sc, target); if ((is_slot(settee)) && (!is_immutable_slot(settee)) && (!is_syntax(slot_value(settee)))) @@ -64393,7 +64421,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy (is_pair(cdr(target))) && ((is_null(cddr(target))) || (is_null(cdddr(target))) || (is_null(cddddr(target))))) { - s7_pointer obj, index, s_slot = lookup_slot_from(car(target), sc->curlet); + s7_pointer obj, index, s_slot = s7_slot(sc, car(target)); if (!is_slot(s_slot)) return_false(sc, car_x); @@ -65367,7 +65395,7 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le int32_t i; s7_pointer p; opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = lookup_slot_from(caaadr(car_x), sc->curlet); + opc->v[1].p = s7_slot(sc, caaadr(car_x)); if (!is_slot(opc->v[1].p)) return_false(sc, car_x); @@ -65926,7 +65954,7 @@ static bool all_integers(s7_scheme *sc, s7_pointer expr) s7_pointer p; for (p = cdr(expr); is_pair(p); p = cdr(p)) if (!((is_t_integer(car(p))) || - ((is_symbol(car(p))) && (is_t_integer(slot_value(lookup_slot_from(car(p), sc->curlet))))) || + ((is_symbol(car(p))) && (is_t_integer(slot_value(s7_slot(sc, car(p)))))) || ((is_pair(car(p))) && (all_integers(sc, car(p)))))) break; return(is_null(p)); @@ -65941,7 +65969,7 @@ static bool all_floats(s7_scheme *sc, s7_pointer expr) s7_pointer p; for (p = cdr(expr); is_pair(p); p = cdr(p)) if (!((is_t_real(car(p))) || - ((is_symbol(car(p))) && (is_t_real(slot_value(lookup_slot_from(car(p), sc->curlet))))) || + ((is_symbol(car(p))) && (is_t_real(slot_value(s7_slot(sc, car(p)))))) || ((is_pair(car(p))) && (all_floats(sc, car(p)))))) break; return(is_null(p)); @@ -66024,7 +66052,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) * and in some contexts might access variables that aren't set up yet. So, we kludge around... */ if (is_symbol(cadr(var))) - slot_set_value(slot, slot_value(lookup_slot_from(cadr(var), sc->curlet))); + slot_set_value(slot, slot_value(s7_slot(sc, cadr(var)))); else if (!is_pair(cadr(var))) slot_set_value(slot, cadr(var)); @@ -66299,7 +66327,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer slot = let_slots(let); let_set_dox_slot1(let, slot); - let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? lookup_slot_from(caddr(end), sc->curlet) : sc->undefined); + let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? s7_slot(sc, caddr(end)) : sc->undefined); slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); opc->v[4].i = body_index; if (body_len == 1) /* opt_do_1 */ @@ -66391,7 +66419,7 @@ static bool float_optimize_1(s7_scheme *sc, s7_pointer expr) (is_syntactic_pair(car_x))) return(d_syntax_ok(sc, car_x, len)); - s_slot = lookup_slot_from(head, sc->curlet); + s_slot = s7_slot(sc, head); if (!is_slot(s_slot)) return_false(sc, car_x); s_func = slot_value(s_slot); } @@ -66476,7 +66504,7 @@ static bool int_optimize_1(s7_scheme *sc, s7_pointer expr) if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x))) return(i_syntax_ok(sc, car_x, len)); - s_slot = lookup_slot_from(head, sc->curlet); + s_slot = s7_slot(sc, head); if (!is_slot(s_slot)) return_false(sc, car_x); s_func = slot_value(s_slot); } @@ -66690,7 +66718,7 @@ static bool cell_optimize_1(s7_scheme *sc, s7_pointer expr) (is_syntactic_pair(car_x))) /* this can be wrong! */ return(p_syntax(sc, car_x, len)); - s_slot = lookup_slot_from(head, sc->curlet); + s_slot = s7_slot(sc, head); if (!is_slot(s_slot)) return_false(sc, car_x); s_func = slot_value(s_slot); } @@ -67524,7 +67552,7 @@ Each object can be a list, string, vector, hash-table, or any other sequence." if ((!arity_ok) && (!s7_is_aritable(sc, f, len))) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "for-each ~A: ~A argument~P?", 27), f, wrap_integer(sc, len), wrap_integer(sc, len))); + set_elist_4(sc, wrap_string(sc, "for-each first argument ~A called with ~A argument~P?", 53), f, wrap_integer(sc, len), wrap_integer(sc, len))); if (for_each_arg_is_null(sc, cdr(args))) return(sc->unspecified); @@ -69291,9 +69319,15 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ if ((result == sc->undefined) && (e) && (is_let(e))) { + /* the current_let refs here are trying to handle local autoloads, but that is problematic -- we'd need to + * save the autoload curlet when autoload is called, and hope the current reference can still access that let? + * but if the same symbol is autloaded in several lets, we are in trouble, and how to handle a function that + * has an autoload? I think I'll just assume rootlet, even though that is not very elegant. Actually in the + * libgsl case, we're trying to export a name from *libgsl* -- should that be done with define rather than autoload? + */ result = let_ref(sc, e, sym); /* add '(sym . result) to current_let (was sc->nil, s7_load can set sc->curlet to sc->nil) */ if (result != sc->undefined) - s7_define(sc, current_let, sym, result); + s7_define(sc, sc->nil /* current_let */, sym, result); }}} #endif if (result == sc->undefined) @@ -69326,7 +69360,7 @@ static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) { result = let_ref(sc, e, sym); if (result != sc->undefined) - s7_define(sc, current_let, sym, result); /* as above, was sc->nil -- s7_load above can set sc->curlet to sc->nil */ + s7_define(sc, sc->nil /* current_let */, sym, result); /* as above, was sc->nil -- s7_load above can set sc->curlet to sc->nil */ }} #endif /* check *unbound-variable-hook* */ @@ -69613,7 +69647,7 @@ static bool arg_findable(s7_scheme *sc, s7_pointer arg1, s7_pointer e) { if (pair_symbol_is_safe(sc, arg1, e)) return(true); /* includes global_slot check */ return((!sc->in_with_let) && - (is_slot(lookup_slot_from(arg1, sc->curlet)))); + (is_slot(s7_slot(sc, arg1)))); } static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int32_t hop) @@ -72774,7 +72808,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at if ((is_slot(global_slot(expr))) && (is_syntax(global_value(expr)))) return(UNSAFE_BODY); /* syntax hidden behind some other name */ - f_slot = lookup_slot_from(expr, sc->curlet); + f_slot = s7_slot(sc, expr); if (!is_slot(f_slot)) return(UNSAFE_BODY); f = slot_value(f_slot); @@ -76133,7 +76167,7 @@ static goto_t op_let_temp_init2(s7_scheme *sc) push_stack_direct(sc, OP_LET_TEMP_INIT2); return(goto_set_unchecked); } - slot = lookup_slot_from(settee, sc->curlet); + slot = s7_slot(sc, settee); if (!is_slot(slot)) unbound_variable_error_nr(sc, settee); if (is_immutable_slot(slot)) immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); if (is_symbol(new_value)) new_value = lookup_checked(sc, new_value); @@ -76180,7 +76214,7 @@ static bool op_let_temp_done1(s7_scheme *sc) else sc->code = set_plist_3(sc, sc->set_symbol, settee, sc->value); return(false); /* goto set_unchecked */ } - slot = lookup_slot_from(settee, sc->curlet); + slot = s7_slot(sc, settee); if (is_immutable_slot(slot)) immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); if (slot_has_setter(slot)) /* maybe setter changed in let-temp body? else setter has already checked the init value */ @@ -76277,7 +76311,7 @@ static bool op_let_temp_na(s7_scheme *sc) /* all entries are of the form (symbol { s7_pointer var = car(p); s7_pointer settee = car(var); - slot = lookup_slot_from(settee, sc->curlet); + slot = s7_slot(sc, settee); if (!is_slot(slot)) unbound_variable_error_nr(sc, settee); if (is_immutable_slot(slot)) @@ -76303,7 +76337,7 @@ static bool op_let_temp_a(s7_scheme *sc) /* one entry */ sc->code = cdr(sc->code); var = caar(sc->code); settee = car(var); - slot = lookup_slot_from(settee, sc->curlet); + slot = s7_slot(sc, settee); if (!is_slot(slot)) unbound_variable_error_nr(sc, settee); if (is_immutable_slot(slot)) @@ -76334,7 +76368,7 @@ static bool op_let_temp_setter(s7_scheme *sc) var = caaar(sc->code); sym = fx_call(sc, cdr(var)); set_curlet(sc, fx_call(sc, cddr(var))); - slot = lookup_slot_from(sym, sc->curlet); + slot = s7_slot(sc, sym); set_curlet(sc, e); push_stack(sc, OP_LET_TEMP_SETTER_UNWIND, slot_setter(slot), slot); slot_set_setter(slot, sc->F); @@ -77304,7 +77338,7 @@ static void op_define_constant1(s7_scheme *sc) sc->code = car(sc->code); /* (define-constant (ex3 a)...) */ if (is_symbol(sc->code)) { - s7_pointer slot = lookup_slot_from(sc->code, sc->curlet); + s7_pointer slot = s7_slot(sc, sc->code); set_possibly_constant(sc->code); set_immutable_slot(slot); if (is_any_closure(slot_value(slot))) @@ -77530,7 +77564,7 @@ static goto_t op_expansion(s7_scheme *sc) if ((symbol_id(symbol) == 0) || (sc->curlet == sc->nil)) slot = global_slot(symbol); - else slot = lookup_slot_from(symbol, sc->curlet); + else slot = s7_slot(sc, symbol); sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined; if ((!is_either_macro(sc->code)) || (!is_expansion(sc->code))) @@ -77726,10 +77760,12 @@ static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), car(code))); } val = let_ref(sc, e, sym); /* (with-let e s) -> (let-ref e s), "s" unevalled? */ - if (val == sc->undefined) + if (val == sc->undefined) /* but sym can have the value #<undefined>: (with-let (inlet 'x #<undefined>) x) */ { 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))) + return(sc->undefined); unbound_variable_error_nr(sc, sym); } return(val); @@ -78270,14 +78306,14 @@ static void check_set(s7_scheme *sc) if (is_symbol(car(code))) { s7_pointer settee = car(code), value = cadr(code); - s7_pointer slot = lookup_slot_from(settee, sc->curlet); + s7_pointer slot = s7_slot(sc, settee); if ((is_slot(slot)) && (!slot_has_setter(slot)) && (!is_syntactic_symbol(settee))) { if (is_normal_symbol(value)) { - s7_pointer slot1 = lookup_slot_from(value, sc->curlet); + s7_pointer slot1 = s7_slot(sc, value); if ((is_slot(slot1)) && (!slot_has_setter(slot1))) { pair_set_syntax_op(form, OP_SET_S_S); @@ -78371,7 +78407,7 @@ static void check_set(s7_scheme *sc) static void op_set_s_c(s7_scheme *sc) { - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); + s7_pointer slot = T_Slt(s7_slot(sc, cadr(sc->code))); if (is_immutable(slot)) error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); slot_set_value(slot, sc->value = opt2_con(cdr(sc->code))); @@ -78379,7 +78415,7 @@ static void op_set_s_c(s7_scheme *sc) static inline void op_set_s_s(s7_scheme *sc) { - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); + s7_pointer slot = T_Slt(s7_slot(sc, cadr(sc->code))); if (is_immutable(slot)) error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); slot_set_value(slot, sc->value = lookup(sc, opt2_sym(cdr(sc->code)))); @@ -78387,7 +78423,7 @@ static inline void op_set_s_s(s7_scheme *sc) static Inline void op_set_s_a(s7_scheme *sc) { - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); + s7_pointer slot = T_Slt(s7_slot(sc, cadr(sc->code))); if (is_immutable(slot)) error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code))); @@ -78402,7 +78438,7 @@ static void op_set_s_p(s7_scheme *sc) static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check for immutable slot */ { - s7_pointer slot = lookup_slot_from(sc->code, sc->curlet); + s7_pointer slot = s7_slot(sc, sc->code); if (is_slot(slot)) { if (is_immutable_slot(slot)) @@ -78418,7 +78454,7 @@ static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check static void op_set_from_let_temp(s7_scheme *sc) { s7_pointer settee = sc->code; - s7_pointer slot = lookup_slot_from(settee, sc->curlet); + s7_pointer slot = s7_slot(sc, settee); if (!is_slot(slot)) unbound_variable_error_nr(sc, settee); if (is_immutable_slot(slot)) @@ -78428,7 +78464,7 @@ static void op_set_from_let_temp(s7_scheme *sc) static inline void op_set_cons(s7_scheme *sc) { - s7_pointer slot = lookup_slot_from(cadr(sc->code), sc->curlet); + s7_pointer slot = s7_slot(sc, cadr(sc->code)); slot_set_value(slot, sc->value = cons(sc, lookup(sc, opt2_sym(cdr(sc->code))), slot_value(slot))); /* ([set!] bindings (cons v bindings)) */ } @@ -78436,7 +78472,7 @@ static void op_increment_saa(s7_scheme *sc) { s7_pointer slot, arg, val; sc->code = cdr(sc->code); - slot = lookup_slot_from(car(sc->code), sc->curlet); + slot = s7_slot(sc, car(sc->code)); arg = opt2_pair(sc->code); /* cddr(value) */ val = fx_call(sc, cdr(arg)); set_car(sc->t3_2, fx_call(sc, arg)); @@ -78449,7 +78485,7 @@ static void op_increment_sa(s7_scheme *sc) { s7_pointer slot, arg; sc->code = cdr(sc->code); - slot = lookup_slot_from(car(sc->code), sc->curlet); + slot = s7_slot(sc, car(sc->code)); arg = opt2_pair(sc->code); set_car(sc->t2_2, fx_call(sc, arg)); set_car(sc->t2_1, slot_value(slot)); @@ -78830,7 +78866,7 @@ static bool op_set_opsaaq_p_1(s7_scheme *sc) static bool op_set1(s7_scheme *sc) { - s7_pointer lx = lookup_slot_from(sc->code, sc->curlet); /* if unbound variable hook here, we need the binding, not the current value */ + s7_pointer lx = s7_slot(sc, sc->code); /* if unbound variable hook here, we need the binding, not the current value */ if (is_slot(lx)) { if (is_immutable_slot(lx)) @@ -78945,7 +78981,7 @@ static bool op_set_normal(s7_scheme *sc) static Inline void inline_op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) -- why is this always inlined? saves 22 in concordance */ { - s7_pointer val, y = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); + s7_pointer val, y = T_Slt(s7_slot(sc, cadr(sc->code))); val = slot_value(y); if (is_t_integer(val)) sc->value = make_integer(sc, integer(val) + 1); @@ -78974,7 +79010,7 @@ static Inline void inline_op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ct static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ { - s7_pointer val, y = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); + s7_pointer val, y = T_Slt(s7_slot(sc, cadr(sc->code))); val = slot_value(y); if (is_t_integer(val)) sc->value = make_integer(sc, integer(val) - 1); /* increment (set!) returns the new value in sc->value */ @@ -79675,7 +79711,7 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) .. caar_code = caar(sc->code); if (is_symbol(caar_code)) { - obj = lookup_slot_from(caar_code, sc->curlet); + obj = s7_slot(sc, caar_code); obj = (is_slot(obj)) ? slot_value(obj) : unbound_variable(sc, caar_code); } else @@ -80598,7 +80634,7 @@ static bool copy_if_end_ok(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7 { if ((fn_proc(endp) == g_num_eq_2) && (is_symbol(cadr(endp))) && (is_symbol(caddr(endp)))) { - s7_pointer end_slot = lookup_slot_from((cadr(endp) == slot_symbol(stepper)) ? caddr(endp) : cadr(endp), sc->curlet); + s7_pointer end_slot = s7_slot(sc, (cadr(endp) == slot_symbol(stepper)) ? caddr(endp) : cadr(endp)); if ((is_slot(end_slot)) && (is_t_integer(slot_value(end_slot)))) { copy_to_same_type(sc, dest, source, i, integer(slot_value(end_slot)), i); @@ -80637,7 +80673,7 @@ static goto_t op_dox_no_body_1(s7_scheme *sc, s7_pointer slots, s7_pointer end, { s7_function endf = fx_proc(end); s7_pointer endp = car(end); - if (endf == fx_c_nc) + if ((endf == fx_c_nc) || (endf == fx_c_0c)) { endf = fn_proc(endp); endp = cdr(endp); @@ -80646,7 +80682,7 @@ static goto_t op_dox_no_body_1(s7_scheme *sc, s7_pointer slots, s7_pointer end, { s7_function f = fx_proc(slot_expression(stepper)); /* e.g. fx_add_s1 */ s7_pointer a = car(slot_expression(stepper)); - if (f == fx_c_nc) + if ((f == fx_c_nc) || (f == fx_c_0c)) { f = fn_proc(a); a = cdr(a); @@ -80708,7 +80744,7 @@ static goto_t op_dox_no_body_1(s7_scheme *sc, s7_pointer slots, s7_pointer end, sc->code = cdr(end); if (!is_symbol(car(sc->code))) return(goto_do_end_clauses); - step1 = lookup_slot_from(car(sc->code), sc->curlet); + step1 = s7_slot(sc, car(sc->code)); sc->value = slot_value(step1); if (is_t_real(sc->value)) clear_mutable_number(sc->value); @@ -80955,7 +80991,7 @@ static goto_t op_dox(s7_scheme *sc) { s7_pointer val = cddr(body), stepa; s7_function stepf, valf; - s7_pointer slot = lookup_slot_from(cadr(body), sc->curlet); + s7_pointer slot = s7_slot(sc, cadr(body)); if (!has_fx(val)) set_fx(val, fx_choose(sc, val, sc->curlet, let_symbol_is_safe)); valf = fx_proc(val); @@ -81686,7 +81722,7 @@ static bool op_simple_do(s7_scheme *sc) let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), sc->value)); if (is_symbol(end)) - let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); + let_set_dox_slot2(sc->curlet, s7_slot(sc, end)); else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); set_car(sc->t2_1, let_dox1_value(sc->curlet)); set_car(sc->t2_2, let_dox2_value(sc->curlet)); @@ -82412,7 +82448,7 @@ static goto_t op_safe_do(s7_scheme *sc) } if (is_symbol(end)) - let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); + let_set_dox_slot2(sc->curlet, s7_slot(sc, end)); else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); sc->args = let_dox_slot2(sc->curlet); /* the various safe steps assume sc->args is the end slot */ @@ -82447,7 +82483,7 @@ static goto_t op_safe_do(s7_scheme *sc) { s7_int endi = integer(let_dox2_value(sc->curlet)); s7_pointer fx_p = cddr(body); - s7_pointer val_slot = lookup_slot_from(cadr(body), sc->curlet); + s7_pointer val_slot = s7_slot(sc, cadr(body)); s7_int step = integer(slot_value(step_slot)); s7_pointer step_val = make_mutable_integer(sc, step); slot_set_value(step_slot, step_val); @@ -82478,7 +82514,7 @@ static goto_t op_dotimes_p(s7_scheme *sc) set_opt2_pair(code, caadr(code)); if (is_symbol(end)) { - slot = lookup_slot_from(end, sc->curlet); + slot = s7_slot(sc, end); end_val = slot_value(slot); } else @@ -83074,10 +83110,7 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc) s7_pointer sym = keyword_symbol(arg_val); if (lambda_star_argument_set_value(sc, sym, cadr(arg_vals), slot, true) == sc->no_value) { - /* if default value is a key, go ahead and use this value. - * (define* (f (a :b)) a) (f :c) - * this has become much trickier than I anticipated... - */ + /* if default value is a key, go ahead and use this value. (define* (f (a :b)) a) (f :c), this has become much trickier than I anticipated... */ if (allow_other_keys) /* in CL: (defun hi (&key (a 1) &allow-other-keys) a) (hi :b :a :a 3) -> 3 * in s7: (define* (hi (a 1) :allow-other-keys) a) (hi :b :a :a 3) -> 3 @@ -83100,7 +83133,7 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc) } slot = next_slot(slot); } - else /* not a key/value pair */ + else /* not a key/value pair */ { if (is_checked_slot(slot)) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); @@ -83611,7 +83644,7 @@ static bool op_define1(s7_scheme *sc) define1_caller(sc), define1_caller(sc), sc->code, sc->value)); if (is_constant_symbol(sc, sc->code)) /* (define pi 3) or (define (pi a) a) */ { - x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : lookup_slot_from(sc->code, sc->curlet); + x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : s7_slot(sc, sc->code); /* local_slot can be free even if sc->code is immutable (local constant now defunct) */ if (!((is_slot(x)) && @@ -83623,7 +83656,7 @@ static bool op_define1(s7_scheme *sc) (sc->cur_op == OP_DEFINE)) s7_warn(sc, 256, "(define %s %s), but %s is a constant\n", display(sc->code), display(sc->value), display(sc->code)); } - else x = lookup_slot_from(sc->code, sc->curlet); + else x = s7_slot(sc, sc->code); if ((is_slot(x)) && (slot_has_setter(x))) { sc->value = bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER, sc->code, sc->value); @@ -86147,7 +86180,7 @@ static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op, s7_ if ((is_symbol(c_op)) && ((is_global(c_op)) || ((is_slot(global_slot(c_op))) && - (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) + (s7_slot(sc, c_op) == global_slot(c_op))))) { s7_pointer s_func = global_value(c_op), slot = let_slots(sc->curlet); if (is_c_function(s_func)) @@ -86452,7 +86485,7 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) if ((is_symbol(c_op)) && ((is_global(c_op)) || ((is_slot(global_slot(c_op))) && - (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) + (s7_slot(sc, c_op) == global_slot(c_op))))) { s7_pointer s_func = global_value(c_op); s7_pointer slot = let_slots(sc->curlet); @@ -88097,7 +88130,7 @@ static bool op_pair_pair(s7_scheme *sc) return(false); } if (sc->stack_end >= (sc->stack_resize_trigger - 8)) - check_for_cyclic_code(sc, sc->code); /* calls resize_stack */ + check_for_cyclic_code(sc, sc->code); /* calls resize_stack */ push_stack_no_args_direct(sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */ /* don't put check_stack_size here! */ push_stack_no_args(sc, OP_EVAL_ARGS, car(sc->code)); @@ -89268,7 +89301,7 @@ static bool fixup_unknown_op(s7_scheme *sc, s7_pointer code, s7_pointer func, op static bool unknown_unknown(s7_scheme *sc, s7_pointer code, opcode_t op) { if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + (!is_slot(s7_slot(sc, car(code))))) unbound_variable_error_nr(sc, car(code)); set_optimize_op(code, op); return(true); @@ -89283,7 +89316,7 @@ static bool is_immutable_and_stable(s7_scheme *sc, s7_pointer func) for (s7_pointer p = sc->curlet; is_let(p); p = let_outlet(p)) if ((is_funclet(p)) && (funclet_function(p) != func)) return(false); - return(is_immutable_slot(lookup_slot_from(func, sc->curlet))); + return(is_immutable_slot(s7_slot(sc, func))); } static bool op_unknown(s7_scheme *sc) @@ -89337,7 +89370,7 @@ static bool op_unknown(s7_scheme *sc) default: if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + (!is_slot(s7_slot(sc, car(code))))) unbound_variable_error_nr(sc, car(code)); } return(fixup_unknown_op(sc, code, f, OP_S)); @@ -89433,7 +89466,7 @@ static bool op_unknown_s(s7_scheme *sc) if ((S7_DEBUGGING) && (!is_normal_symbol(cadr(code)))) fprintf(stderr, "%s[%d]: not a symbol: %s\n", __func__, __LINE__, display(code)); if ((!is_any_macro(f)) && /* if f is a macro, its argument can be unbound legitimately */ - (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) + (!is_slot(s7_slot(sc, cadr(code))))) return(unknown_unknown(sc, sc->code, (is_normal_symbol(cadr(sc->code))) ? OP_CLEAR_OPTS : OP_S_G)); if ((is_unknopt(code)) && (!is_closure(f))) @@ -89510,7 +89543,7 @@ static bool op_unknown_s(s7_scheme *sc) break; } if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + (!is_slot(s7_slot(sc, car(code))))) unbound_variable_error_nr(sc, car(code)); return(fixup_unknown_op(sc, code, f, OP_S_G)); } @@ -89587,7 +89620,7 @@ static bool op_unknown_a(s7_scheme *sc) break; } if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + (!is_slot(s7_slot(sc, car(code))))) unbound_variable_error_nr(sc, car(code)); return(fixup_unknown_op(sc, code, f, OP_S_A)); /* closure with methods etc */ } @@ -89603,10 +89636,10 @@ static bool op_unknown_gg(s7_scheme *sc) s2 = is_normal_symbol(caddr(code)); if ((s1) && - (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) + (!is_slot(s7_slot(sc, cadr(code))))) return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); if ((s2) && - (!is_slot(lookup_slot_from(caddr(code), sc->curlet)))) + (!is_slot(s7_slot(sc, caddr(code))))) return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); switch (type(f)) @@ -89721,7 +89754,7 @@ static bool op_unknown_gg(s7_scheme *sc) break; } if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + (!is_slot(s7_slot(sc, car(code))))) unbound_variable_error_nr(sc, car(code)); fx_annotate_args(sc, cdr(code), sc->curlet); return(fixup_unknown_op(sc, code, f, OP_S_AA)); @@ -89736,7 +89769,7 @@ static bool op_unknown_ns(s7_scheme *sc) if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); for (s7_pointer arg = cdr(code); is_pair(arg); arg = cdr(arg)) - if (!is_slot(lookup_slot_from(car(arg), sc->curlet))) + if (!is_slot(s7_slot(sc, car(arg)))) unbound_variable_error_nr(sc, car(arg)); switch (type(f)) @@ -89873,7 +89906,7 @@ static bool op_unknown_aa(s7_scheme *sc) break; } if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + (!is_slot(s7_slot(sc, car(code))))) unbound_variable_error_nr(sc, car(code)); return(fixup_unknown_op(sc, code, f, OP_S_AA)); } @@ -89882,7 +89915,7 @@ static bool is_normal_happy_symbol(s7_scheme *sc, s7_pointer sym) { if (!is_normal_symbol(sym)) return(false); - if (!is_slot(lookup_slot_from(sym, sc->curlet))) + if (!is_slot(s7_slot(sc, sym))) unbound_variable_error_nr(sc, sym); return(true); } @@ -91767,8 +91800,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_LAMBDA: sc->value = op_lambda(sc, sc->code); continue; case OP_LAMBDA_UNCHECKED: sc->value = op_lambda_unchecked(sc, sc->code); continue; - case OP_LAMBDA_STAR: op_lambda_star(sc); continue; - case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc); continue; + case OP_LAMBDA_STAR: op_lambda_star(sc); continue; + case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc); continue; case OP_CASE: /* car(sc->code) is the selector */ @@ -93057,10 +93090,12 @@ static s7_pointer sl_set_gc_stats(s7_scheme *sc, s7_pointer sym, s7_pointer val) if (!s7_is_integer(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); sc->gc_stats = s7_integer_clamped_if_gmp(sc, val); - if (sc->gc_stats < 16) /* gc_stats is uint32_t */ - return(val); - sc->gc_stats = 0; - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between 0 and 15", 29)); + if (sc->gc_stats >= 16) /* gc_stats is uint32_t */ + { + sc->gc_stats = 0; + s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between 0 and 15", 29)); + } + return(val); } static s7_pointer sl_set_gc_info(s7_scheme *sc, s7_pointer sym, s7_pointer val) /* ticks_per_second is not settable */ @@ -94426,7 +94461,7 @@ static s7_pointer make_unique(s7_scheme *sc, const char* name, uint64_t typ) static s7_pointer symbol_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) { - s7_pointer slot = lookup_slot_from(sym, sc->curlet); + s7_pointer slot = s7_slot(sc, sym); if (!is_slot(slot)) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "set!: '~S is unbound", 20), sym)); if (is_immutable_slot(slot)) @@ -95181,7 +95216,7 @@ static void init_rootlet(s7_scheme *sc) sc->catch_symbol = semisafe_defun("catch", catch, 3, 0, false); sc->throw_symbol = unsafe_defun("throw", throw, 1, 0, true); sc->error_symbol = unsafe_defun("error", error, 1, 0, true); /* was 0,0 -- 1-Aug-22 */ - /* not safe in catch if macro as error handler, (define-macro (m . args) `(apply ,(car args) ',(cadr args))) (catch #t (lambda () (error abs -1)) m) */ + /* unsafe example: catch if macro as error handler, (define-macro (m . args) `(apply ,(car args) ',(cadr args))) (catch #t (lambda () (error abs -1)) m) */ sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false); /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true); /* values_symbol set above for signatures, not semisafe! */ @@ -96248,60 +96283,60 @@ int main(int argc, char **argv) #endif #endif -/* ------------------------------------------------------ - * 20.9 21.0 22.0 23.0 23.2 23.3 - * ------------------------------------------------------ - * tpeak 115 114 108 105 105 102 +/* -------------------------------------------------- + * 20.9 21.0 22.0 23.0 23.4 23.5 + * -------------------------------------------------- + * tpeak 115 114 108 105 102 102 * tref 691 687 463 459 459 459 - * index 1026 1016 973 967 967 970 - * tmock 1177 1165 1057 1019 1019 1026 - * tvect 2519 2464 1772 1669 1669 1647 - * timp 2637 2575 1930 1694 1694 1709 - * texit ---- ---- 1778 1741 1741 1765 - * s7test 1873 1831 1818 1829 1829 1854 - * thook ---- ---- 2590 2030 2028 2046 - * tauto ---- ---- 2562 2048 2048 2062 - * lt 2187 2172 2150 2185 2185 2195 - * dup 3805 3788 2492 2239 2236 2240 - * tcopy 8035 5546 2539 2375 2375 2379 - * tread 2440 2421 2419 2408 2403 2417 - * fbench 2688 2583 2460 2430 2430 2458 - * trclo 2735 2574 2454 2445 2445 2461 - * titer 2865 2842 2641 2509 2509 2465 - * tload ---- ---- 3046 2404 2537 2530 - * tmat 3065 3042 2524 2578 2569 2585 - * tb 2735 2681 2612 2604 2601 2632 - * tsort 3105 3104 2856 2804 2804 2828 - * tobj 4016 3970 3828 3577 3603 3572 - * teq 4068 4045 3536 3486 3486 3588 - * tio 3816 3752 3683 3620 3620 3623 - * tmac 3950 3873 3033 3677 3682 3688 - * tclo 4787 4735 4390 4384 4384 4450 - * tcase 4960 4793 4439 4430 4426 4445 - * tlet 7775 5640 4450 4427 4422 4452 - * tfft 7820 7729 4755 4476 4475 4510 - * tstar 6139 5923 5519 4449 4449 4556 - * tmap 8869 8774 4489 4541 4541 4618 - * tshoot 5525 5447 5183 5055 5055 5048 - * tstr 6880 6342 5488 5162 5165 5194 - * tform 5357 5348 5307 5316 5321 5393 - * tnum 6348 6013 5433 5396 5396 5409 - * tlamb 6423 6273 5720 5560 5552 5620 - * tmisc 8869 7612 6435 6076 6074 6224 - * tgsl 8485 7802 6373 6282 6282 6228 - * tlist 7896 7546 6558 6240 6240 6281 - * tset ---- ---- ---- 6260 6258 6293 - * tari 13.0 12.7 6827 6543 6541 6491 - * trec 6936 6922 6521 6588 6588 6581 - * tleft 10.4 10.2 7657 7479 7479 7626 - * tgc 11.9 11.1 8177 7857 7897 7957 - * thash 11.8 11.7 9734 9479 9479 9484 - * cb 11.2 11.0 9658 9564 9559 9632 - * tgen 11.2 11.4 12.0 12.1 12.2 12.1 - * tall 15.6 15.6 15.6 15.6 15.6 15.1 - * calls 36.7 37.5 37.0 37.5 37.7 37.0 - * sg ---- ---- 55.9 55.8 55.8 55.1 - * lg ---- ---- 105.2 106.4 106.4 107.1 - * tbig 177.4 175.8 156.5 148.1 148.1 145.8 - * ------------------------------------------------------ + * index 1026 1016 973 967 970 970 + * tmock 1177 1165 1057 1019 1026 1026 + * tvect 2519 2464 1772 1669 1647 1647 + * timp 2637 2575 1930 1694 1709 1707 + * texit ---- ---- 1778 1741 1765 1765 + * s7test 1873 1831 1818 1829 1854 1847 + * thook ---- ---- 2590 2030 2046 2045 + * tauto ---- ---- 2562 2048 2062 2063 + * lt 2187 2172 2150 2185 2195 2200 + * dup 3805 3788 2492 2239 2240 2240 + * tcopy 8035 5546 2539 2375 2379 2379 + * tread 2440 2421 2419 2408 2417 2418 + * fbench 2688 2583 2460 2430 2458 2459 + * trclo 2735 2574 2454 2445 2461 2461 + * titer 2865 2842 2641 2509 2465 2465 + * tload ---- ---- 3046 2404 2530 2530 + * tmat 3065 3042 2524 2578 2585 2585 + * tb 2735 2681 2612 2604 2630 2630 + * tsort 3105 3104 2856 2804 2828 2828 + * tobj 4016 3970 3828 3577 3572 3575 + * teq 4068 4045 3536 3486 3588 3588 + * tio 3816 3752 3683 3620 3616 3616 + * tmac 3950 3873 3033 3677 3688 3688 + * tclo 4787 4735 4390 4384 4450 4450 + * tcase 4960 4793 4439 4430 4445 4447 + * tlet 7775 5640 4450 4427 4452 4452 + * tfft 7820 7729 4755 4476 4510 4512 + * tstar 6139 5923 5519 4449 4556 4554 + * tmap 8869 8774 4489 4541 4618 4618 + * tshoot 5525 5447 5183 5055 5048 5047 + * tstr 6880 6342 5488 5162 5194 5197 + * tform 5357 5348 5307 5316 5393 5398 + * tnum 6348 6013 5433 5396 5409 5410 + * tlamb 6423 6273 5720 5560 5620 5622 + * tmisc 8869 7612 6435 6076 6224 6223 + * tgsl 8485 7802 6373 6282 6228 6228 + * tlist 7896 7546 6558 6240 6281 6280 + * tset ---- ---- ---- 6260 6293 6289 + * tari 13.0 12.7 6827 6543 6491 6490 + * trec 6936 6922 6521 6588 6581 6581 + * tleft 10.4 10.2 7657 7479 7611 7611 + * tgc 11.9 11.1 8177 7857 7957 7958 + * thash 11.8 11.7 9734 9479 9484 9483 + * cb 11.2 11.0 9658 9564 9632 9632 + * tgen 11.2 11.4 12.0 12.1 12.1 12.1 + * tall 15.6 15.6 15.6 15.6 15.2 15.1 + * calls 36.7 37.5 37.0 37.5 37.5 37.1 + * sg ---- ---- 55.9 55.8 55.9 55.4 + * lg ---- ---- 105.2 106.4 107.1 107.2 + * tbig 177.4 175.8 156.5 148.1 145.8 145.8 + * --------------------------------------------- */ @@ -2,7 +2,7 @@ #define S7_H #define S7_VERSION "10.6" -#define S7_DATE "26-May-2023" +#define S7_DATE "3-July-2023" #define S7_MAJOR_VERSION 10 #define S7_MINOR_VERSION 6 @@ -4485,7 +4485,7 @@ adds: (delete-file str) ; try to delete the file, return 0 is successful, else -1 (getenv var) ; return the value of an environment variable: (getenv "HOME") (directory->list dir) ; return contents of directory as a list of strings (if HAVE_DIRENT_H) -(system command) ; execute command +(system command) ; execute command, if optional second arg is #t output is returned as a string </pre> <p>But maybe this is not needed; see <a href="#cload">cload.scm</a> below for @@ -4040,6 +4040,7 @@ void block_init(s7_scheme *sc) (let () (define (fc) (do ((count 0) (i 7 (+ i 1))) ((= i 10) count) (set! count (ash i (+ i 1))))) (num-test (fc) (ash 9 10))) (let () (define (fc) (do ((count 0) (i 7 (+ i 1))) ((= i 10) count) (set! count (ash (+ i 1) (- i 1))))) (num-test (fc) (ash 10 8))) (let () (define (fc) (do ((count 0) (j 3) (i 7 (+ i 1))) ((= i 10) count) (set! count (quotient i j)))) (num-test (fc) (quotient 9 3))) +(let () (define (fc) (do ((count 0.0) (i 7.0 (+ 1.0 i))) ((>= i 10.0) count) (set! count (quotient i 3.0)))) (num-test (fc) (quotient 9.0 3.0))) ; fx_add_ft (let () (define (fc) (do ((count 0.0) (i 7.0 (+ i 1.0))) ((>= i 10.0) count) (set! count (quotient i 3.0)))) (num-test (fc) (quotient 9.0 3.0))) (let () (define (fc) (do ((count 0) (i 7 (+ i 1))) ((= i 10) count) (set! count (remainder i 3)))) (test (fc) (remainder 9 3))) (let () (define (fc) (do ((count 0.0) (i 7.0 (+ i 1.0))) ((>= i 10.0) count) (set! count (remainder i 3.0)))) (test (fc) (remainder 9.0 3.0))) @@ -19923,7 +19924,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (defined? 'j0) #f) (test (autoload 'j0 "libm.scm") "libm.scm") (test (j0 0.0) 1.0)) - (test (defined? 'j0) #f) + ;(test (defined? 'j0) #f) ; this changes -- currently autoload always defines its symbol globally (let () (test (autoload 'ho "s7test.scm") "s7test.scm") @@ -24331,6 +24332,8 @@ so anything that quotes ` is not going to equal quote quasiquote ;;; these are from the r7rs discussions (test (let ((a'b 3)) a'b) 3) ; allow variable names like "can't-go-on" or "don't-ask" +(test (symbol? 'a'b'c) #t) ; these two from HN +(test (let ((a 1)) (list #\)a)) (list #\) 1)) (test (let () (define (f x y) (+ x y)) (let ((a 3) (b 4)) (f a, b))) 'error) ; unbound variable a, (test (let () (define (f x y) (+ x y)) (let ((a 3) (b 4)) (f a ,b))) 'error) ; unquote outside quasiquote @@ -27402,6 +27405,13 @@ c" (test (let () (define (f1) (let ((!x! (map (lambda (!a!) (inlet 'pi 1)) '(0)))) (car !x!))) (f1)) 'error) (test (let () (define (func) (map (lambda (call/cc (lambda (r) 123)) 123) (make-iterator #r()) 3/4)) (func)) 'error) (test (map (make-hash-table) (hash-table 'b 2)) '(#f)) +(test (let* ((H (make-hash-table)) + (I (make-iterator H)) + (R ())) + (hash-table-set! H 'a 1) + (for-each (lambda (obj) (set! R (cons obj R))) I) + R) + '((a . 1))) (let () (define* (feclo (a 0) (b 1)) (+ a b)) @@ -50150,6 +50160,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (let () (define (func) (with-let (inlet 'a 1) else)) (func) (func)) else) (test (defined? 'else (inlet 'a 1) #t) #f) (test (let ((a (inlet))) (define (func) (catch #t (lambda () (with-let a _!asdf!_) :oops) (lambda (type info) 'error))) (func) (func)) 'error) +(test (with-let (let ((+documentation+ "hiho")) (curlet)) (define (f) 1) (documentation f)) "hiho") (test (equivalent? (sublet (inlet) 'a 1 (inlet 'b 2)) (inlet 'b 2 'a 1)) #t) (test (equivalent? (sublet (inlet) (inlet 'b 2)) (inlet 'b 2)) #t) @@ -98597,6 +98608,8 @@ etc (let ((__s7__ *s7*)) (test (__s7__ 'heap-size) (*s7* 'heap-size))) (test (let () (define (func) (with-let *s7* letrec*)) (func) (func)) letrec*) ; fx_with_let_s bug +(test (let () (define (f) (with-let (inlet 'x #<undefined>) x)) (f) (f)) #<undefined>) +(test (let ((I (inlet 'x #<undefined>))) (define (f) (with-let I x)) (f) (f)) #<undefined>) (let-temporarily (((*s7* 'safety) -1)) (test (*s7* 'safety) -1)) @@ -101275,6 +101288,24 @@ etc (test residual 0.0)))) )))) +#| +;;; test of local autoload from johnm (no good way to test this here -- maybe set up a dummy library?): +(autoload 'gsl_integration_qags "libgsl.scm") +(autoload 'gsl_integration_workspace_alloc "libgsl.scm") +(autoload 'gsl_integration_workspace_free "libgsl.scm") +(autoload 'double* "libgsl.scm") + +(define (integrate f) + (let ((workspace (gsl_integration_workspace_alloc 1000))) + (gsl_integration_workspace_free workspace))) + +(define (f x) + (/ (log x) (sqrt x))) + +(test (integrate f) #<unspecified>) +(test (integrate f) #<unspecified>) ; this call is not redundant +|# + (test (defined? 'CLOCKS_PER_SEC (rootlet)) #f) ; autoloader can cause endless confusion here! diff --git a/s7webserver/Makefile b/s7webserver/Makefile index 724050e..910ee40 100644 --- a/s7webserver/Makefile +++ b/s7webserver/Makefile @@ -4,8 +4,8 @@ QTVERSION=5 CC ?= gcc CCC ?= g++ PKG ?= pkg-config -MOC ?= moc-qt$(QTVERSION) -QMAKE ?= qmake-qt$(QTVERSION) +MOC ?= moc #-qt$(QTVERSION) +QMAKE ?= qmake #-qt$(QTVERSION) QTLDFLAGS=`$(PKG) --libs Qt$(QTVERSION)Network` QTCFLAGS=`$(PKG) --cflags Qt$(QTVERSION)Network` @@ -21,7 +21,7 @@ s7webserver: s7webserver.o qhttpserver-master/lib/libqhttpserver.a s7.o mus-conf $(CCC) s7webserver.o $(QTLDFLAGS) qhttpserver-master/lib/libqhttpserver.a s7.o -ldl -o s7webserver s7webserver.o: s7webserver.h s7webserver.cpp moc_s7webserver.cpp qhttpserver-master/lib/libqhttpserver.a mus-config.h - $(CCC) -c s7webserver.cpp $(QTCFLAGS) $(OPTIMIZE) -Iqhttpserver-master/src -DWITH_MAIN -I. -I.. -Wall -Werror -Wno-error=unused-variable -Wno-error=unused-function -fPIC + $(CCC) -c s7webserver.cpp $(QTCFLAGS) $(OPTIMIZE) -Iqhttpserver-master/src -I. -I.. -Wall -Werror -Wno-error=unused-variable -Wno-error=unused-function -fPIC moc_s7webserver.cpp: s7webserver.h qhttpserver-master/lib/libqhttpserver.a mus-config.h $(MOC) -DCOMPILING_S7WEBSERVER s7webserver.h -o moc_s7webserver.cpp @@ -2272,7 +2272,7 @@ static bool start_audio_output_1(void) return(false); } } - snd_dacp->devices = (alloc_devs > 1000000) ? 1000000 : alloc_devs; /* placate damned gcc */ + snd_dacp->devices = (alloc_devs <= 0) ? 1 : ((alloc_devs > 1000000) ? 1000000 : alloc_devs); /* placate damned gcc */ /* for now assume all are same number of chans */ snd_dacp->chans_per_device = (int *)calloc(snd_dacp->devices, sizeof(int)); for (i = 0; i < snd_dacp->devices; i++) diff --git a/snd-motif.c b/snd-motif.c index c7e317c..d463d0c 100644 --- a/snd-motif.c +++ b/snd-motif.c @@ -30849,6 +30849,10 @@ void snd_doit(int argc, char **argv) ss->startup_errors = NULL; } +#if (ENABLE_WEBSERVER) && (USE_MOTIF) + xen_s7_setup_webserver_background_callback(); +#endif + XtAppMainLoop(app); } @@ -47,11 +47,11 @@ #include "snd-strings.h" -#define SND_DATE "26-May-23" +#define SND_DATE "3-July-23" #ifndef SND_VERSION -#define SND_VERSION "23.4" +#define SND_VERSION "23.5" #endif #define SND_MAJOR_VERSION "23" -#define SND_MINOR_VERSION "4" +#define SND_MINOR_VERSION "5" #endif diff --git a/sndlib.html b/sndlib.html index 2f487ad..c686d44 100644 --- a/sndlib.html +++ b/sndlib.html @@ -197,7 +197,7 @@ is printed; to customize error handling, use mus_set_error_handler and mus_set_p </pre> <p>To decode the error indication, use:</p> <pre> - char *mus_error_to_string(int err); + char *mus_error_type_to_string(int err); </pre> <p>Header data is cached internally, so the actual header is read diff --git a/sndscm.html b/sndscm.html index c464e70..049449a 100644 --- a/sndscm.html +++ b/sndscm.html @@ -5642,9 +5642,9 @@ match-sound-files applies 'func' to each sound file in 'dir' and returns a list <pre class="indented"> (for-each-sound-file (lambda (n) - (if (> (<a class=quiet href="extsnd.html#mussoundduration">mus-sound-duration</a> n) 10.0) - (<a class=quiet href="extsnd.html#sndprint">snd-print</a> n))) - (<a class=quiet href="extsnd.html#soundfilesindirectory">sound-files-in-directory</a> ".")) + (when (> (<a class=quiet href="extsnd.html#mussoundduration">mus-sound-duration</a> n) 10.0) + (<a class=quiet href="extsnd.html#sndprint">snd-print</a> (format #f "~%~A" n)))) + ".") </pre> <div class="spacer"></div> diff --git a/tools/compsnd b/tools/compsnd index 170332e..f03318e 100755 --- a/tools/compsnd +++ b/tools/compsnd @@ -1,6 +1,8 @@ #!/bin/csh -f cp ~/cl/snd . +cp ~/cl/oboe.snd . + /home/bil/cl/snd tools/va.scm echo ' ' @@ -164,9 +166,9 @@ rm -f config.cache echo ' ' echo ' ' echo ' -------------------------------------------------------------------------------- ' -echo ' ----- --without-gui --with-oss --with-s7-profiling|history ---- ' +echo ' ----- --without-gui --with-oss --with-s7-history ---- ' echo ' -------------------------------------------------------------------------------- ' -./configure --quiet CFLAGS="-Wall -Wno-restrict -Wno-maybe-uninitialized -Wno-array-bounds -Wno-stringop-overflow -Wno-parentheses" --without-gui --with-oss --with-s7-profiling --with-s7-history +./configure --quiet CFLAGS="-Wall -Wno-restrict -Wno-maybe-uninitialized -Wno-array-bounds -Wno-stringop-overflow -Wno-parentheses" --without-gui --with-oss --with-s7-history make snd echo ' ' echo ' ' @@ -1702,15 +1702,17 @@ Xen_wrap_1_arg(g_ftell_w, g_ftell) Xen_wrap_no_args(g_gc_off_w, g_gc_off) Xen_wrap_no_args(g_gc_on_w, g_gc_on) -#if ENABLE_WEBSERVER - #if USE_MOTIF +#if (ENABLE_WEBSERVER) && (USE_MOTIF) #include "snd.h" static idle_func_t called_periodically(any_pointer_t pet) { s7webserver_call_very_often(); return(BACKGROUND_CONTINUE); } - #endif + void xen_s7_setup_webserver_background_callback(void) + { + BACKGROUND_ADD(called_periodically, NULL); + } #endif @@ -1734,9 +1736,6 @@ s7_scheme *s7_xen_initialize(s7_scheme *sc) if (!s7webserver) fprintf(stderr, "Unable to start web server. Port 6080 may be in use\n"); else fprintf(stdout, "Started s7 webserver at port %d\n", s7webserver_get_portnumber(s7webserver)); -#if USE_MOTIF - BACKGROUND_ADD(called_periodically, NULL); -#endif } #endif } @@ -15,6 +15,7 @@ /* HISTORY: * + * 16-Jun: added xen_s7_setup_webserver_background_callback. * 3-May-23: clm_complex_i: we want a double here not the float _Complex_I * -------- * 10-Apr: s7_apply_*. @@ -1273,6 +1274,10 @@ void xen_s7_set_repl_prompt(const char *new_prompt); XEN xen_set_assoc(s7_scheme *sc, s7_pointer key, s7_pointer val, s7_pointer alist); XEN xen_assoc(s7_scheme *sc, XEN key, XEN alist); +#if (ENABLE_WEBSERVER) && (USE_MOTIF) + void xen_s7_setup_webserver_background_callback(void); +#endif + #ifdef __cplusplus } #endif |