diff options
| -rw-r--r-- | HISTORY.Snd | 1 | ||||
| -rw-r--r-- | NEWS | 9 | ||||
| -rw-r--r-- | README.Snd | 3 | ||||
| -rwxr-xr-x | configure | 20 | ||||
| -rw-r--r-- | configure.ac | 4 | ||||
| -rw-r--r-- | debian/changelog | 7 | ||||
| -rw-r--r-- | debian/upstream-changelog | 11 | ||||
| -rw-r--r-- | mockery.scm | 10 | ||||
| -rw-r--r-- | s7.c | 353 | ||||
| -rw-r--r-- | s7.h | 2 | ||||
| -rw-r--r-- | s7.html | 2 | ||||
| -rw-r--r-- | s7test.scm | 46 | ||||
| -rw-r--r-- | snd-motif.c | 3 | ||||
| -rw-r--r-- | snd-motif.scm | 26 | ||||
| -rw-r--r-- | snd-region.c | 4 | ||||
| -rw-r--r-- | snd-select.c | 10 | ||||
| -rw-r--r-- | snd.h | 6 | ||||
| -rw-r--r-- | sndinfo.c | 4 | ||||
| -rw-r--r-- | tools/auto-tester.scm | 95 |
19 files changed, 371 insertions, 245 deletions
diff --git a/HISTORY.Snd b/HISTORY.Snd index 7fb12a0..0235a72 100644 --- a/HISTORY.Snd +++ b/HISTORY.Snd @@ -1,5 +1,6 @@ Snd change log + 6-Aug: Snd 23.6. 1-Jul: Snd 23.5. 25-May: Snd 23.4. 20-Apr: Snd 23.3. @@ -1,7 +1,8 @@ -Snd 23.5 +Snd 23.6: -s7: various small bugs and optimizations. +various small improvements and bugfixes in Snd and s7. -checked: sbcl 2.3.5|6 +checked: sbcl 2.3.7 + +Thanks!: Kenneth Flak -Thanks!: Anders Vinjar, Todd Ingalls, johnm, Kjetil Matheussen @@ -48,6 +48,9 @@ The configure script has a bunch of arguments: in Debian, apt-get install libmotif4, libmotif-dev, libxt-dev, libxpm-dev in Ubuntu 21.04 the Motif libraries appear to be libmotif-common libxm4 libmotif-dev and X11/extensions/shape.h is in libxext-dev + Also the X miscellaneous fonts package, Fedora: xorg-x11-fonts-misc, + Fedora: xorg-x11-fonts-misc + Arch: https://archlinux.org/packages/extra/any/xorg-fonts-misc/ --with-gui make Snd with graphics support (actually intended for use as --without-gui) @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for snd 23.5. +# Generated by GNU Autoconf 2.71 for snd 23.6. # # 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.5' -PACKAGE_STRING='snd 23.5' +PACKAGE_VERSION='23.6' +PACKAGE_STRING='snd 23.6' 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.5 to adapt to many kinds of systems. +\`configure' configures snd 23.6 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.5:";; + short | recursive ) echo "Configuration of snd 23.6:";; 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.5 +snd configure 23.6 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.5, which was +It was created by snd $as_me 23.6, 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.5 +VERSION=23.6 #-------------------------------------------------------------------------------- # 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 23.5, which was +This file was extended by snd $as_me 23.6, 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.5 +snd config.status 23.6 configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index ffafec1..28636be 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ # gmp, mpfr, and mpc deliberately have none! -AC_INIT(snd, 23.5, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-23.tar.gz) +AC_INIT(snd, 23.6, 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.5 +VERSION=23.6 #-------------------------------------------------------------------------------- # configuration options diff --git a/debian/changelog b/debian/changelog index 7fcb525..7259840 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +snd (23.6-1) unstable; urgency=medium + + * New upstream version 23.6 + + Update d/upstream-changelog + + -- IOhannes m zmölnig (Debian/GNU) <umlaeute@debian.org> Sun, 06 Aug 2023 20:08:21 +0200 + snd (23.5-1) unstable; urgency=medium * New upstream version 23.5 diff --git a/debian/upstream-changelog b/debian/upstream-changelog index a200aca..b7c5da9 100644 --- a/debian/upstream-changelog +++ b/debian/upstream-changelog @@ -1,3 +1,14 @@ +Snd 23.6: + +various small improvements and bugfixes in Snd and s7. + +checked: sbcl 2.3.7 + +Thanks!: Kenneth Flak + + +=============================================================================== + Snd 23.5 s7: various small bugs and optimizations. diff --git a/mockery.scm b/mockery.scm index 19cd8ab..91d4a30 100644 --- a/mockery.scm +++ b/mockery.scm @@ -22,6 +22,16 @@ ;;; ;;; There are examples scattered around this file, and a lot more ;;; in s7test.scm. +;;; +;;; currently it is possible to (set! ((*mock-vector* 'mock-vector-class) 'write) hash-table-set!) [or (set! (v 'write) hash-table-set!) I think] +;;; should we call the s7.html vars-immutable (and immutable!) on this internal let? +;;; +;;; also we omit a variety of built-in functions that can work on the underlying value. +;;; given (define v #(0 1)) and (define mv ((*mock-vector* 'mock-vector) 0 1)) +;;; (arity v): '(1 . 536870912), (arity mv): '(1 . 1) +;;; (signature v): '(#t vector? . #1=(integer? . #1#)), (signature mv): '(#t let? . #1=(symbol? . #1#)) +;;; object->let but this needs to be omitted for debugging +;;; and many where the error message is different (should pretty-print know about these?) (provide 'mockery.scm) @@ -3156,7 +3156,7 @@ static void symbol_set_id(s7_pointer p, s7_int id) #if S7_DEBUGGING #define slot_set_value(slot, value) \ do { \ - if (is_immutable_slot(slot)) {fprintf(stderr, "setting immutable slot\n"); if (cur_sc->stop_at_error) abort();} \ + if (is_immutable_slot(slot)) {fprintf(stderr, "setting immutable slot %s\n", symbol_name(slot_symbol(slot))); if (cur_sc->stop_at_error) abort();} \ (T_Slt(slot))->object.slt.val = T_Nmv(value); \ } while (0) #else @@ -6247,7 +6247,7 @@ s7_pointer s7_t(s7_scheme *sc) {return(sc->T);} /* () */ -s7_pointer s7_nil(s7_scheme *sc) {return(sc->nil);} +s7_pointer s7_nil(s7_scheme *sc) {return(sc->nil);} /* should this be "s7_null" ? */ bool s7_is_null(s7_scheme *sc, s7_pointer p) {return(is_null(p));} static bool is_null_b_p(s7_pointer p) {return(type(p) == T_NIL);} /* faster than b_7p because opt_b_p is faster */ @@ -7888,8 +7888,7 @@ static inline void remove_from_heap(s7_scheme *sc, s7_pointer x) /* these need to be GC-protected! */ add_semipermanent_object(sc, x); return; - default: - break; + default: break; } petrify(sc, x); } @@ -9827,21 +9826,25 @@ static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_po ((args % 2) == 0)) { for (s7_pointer p = cdr(expr); is_pair(p); p = cddr(p)) - if (!is_symbol_and_keyword(car(p))) - { - s7_pointer sym; - if (!is_proper_quote(sc, car(p))) /* 'abs etc, but tricky: ':abs */ - return(f); - sym = cadar(p); - if ((!is_symbol(sym)) || - (is_possibly_constant(sym)) || /* define-constant etc */ - (is_syntactic_symbol(sym)) || /* (inlet 'if 3) */ - ((is_slot(global_slot(sym))) && - (is_syntax_or_qq(global_value(sym)))) || /* (inlet 'quasiquote 1) */ - (sym == sc->let_ref_fallback_symbol) || - (sym == sc->let_set_fallback_symbol)) - return(f); - } + { + s7_pointer sym; + if (is_symbol_and_keyword(car(p))) /* (inlet :if ...) */ + sym = keyword_symbol(car(p)); + else + { + if (!is_proper_quote(sc, car(p))) return(f); /* (inlet abs ...) */ + sym = cadar(p); /* looking for (inlet 'a ...) */ + if (!is_symbol(sym)) return(f); /* (inlet '(a . 3) ...) */ + if (is_keyword(sym)) sym = keyword_symbol(sym); /* (inlet ':abs ...) */ + } + if ((is_possibly_constant(sym)) || /* (inlet 'define-constant ...) or (inlet 'pi ...) */ + (is_syntactic_symbol(sym)) || /* (inlet 'if 3) */ + ((is_slot(global_slot(sym))) && + (is_syntax_or_qq(global_value(sym)))) || /* (inlet 'quasiquote 1) */ + (sym == sc->let_ref_fallback_symbol) || + (sym == sc->let_set_fallback_symbol)) + return(f); + } return(sc->simple_inlet); } return(f); @@ -10091,7 +10094,10 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 s7_pointer slot; if (is_constant_symbol(sc, symbol)) /* (let-set! (rootlet) 'pi #f) */ wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_non_constant_symbol_string); - + /* it would be nice if safety>0 to add an error check for bad arity if a built-in method is set (set! (lt 'write) hash-table-set!), + * built_in being is_slot(initial_slot(sym)), but this function is called a ton, and this error can't easily be + * checked by the optimizer (we see the names, but not the values, so bad arity check requires assumptions about those values). + */ slot = global_slot(symbol); if (!is_slot(slot)) error_nr(sc, sc->wrong_type_arg_symbol, @@ -15571,8 +15577,7 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym } break; - default: - break; + default: break; } return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); }} @@ -41157,7 +41162,7 @@ static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args) return(g_make_vector_1(sc, set_plist_2(sc, p, init), sc->make_byte_vector_symbol)); p = make_simple_byte_vector(sc, len); - if ((len > 0) && (is_pair(cdr(args)))) + if (len > 0) /* make-byte-vector 2) should return #u(0 0) so we always need to fill */ local_memset((void *)(byte_vector_bytes(p)), ib, len); return(p); } @@ -45139,7 +45144,7 @@ static s7_pointer procedure_type_to_symbol(s7_scheme *sc, int32_t type) case T_MACRO_STAR: return(sc->macro_star_symbol); case T_BACRO: return(sc->bacro_symbol); case T_BACRO_STAR: return(sc->bacro_star_symbol); - default: if (S7_DEBUGGING) fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); + default: if (S7_DEBUGGING) fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); /* break; ? */ } return(sc->lambda_symbol); } @@ -45170,6 +45175,7 @@ static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args) if (!is_procedure(p)) sole_arg_wrong_type_error_nr(sc, sc->procedure_source_symbol, p, a_procedure_or_a_macro_string); return(sc->nil); + /* perhaps include file/line? perhaps some way to return comments in code -- source code as string exactly as in file? */ } @@ -45699,8 +45705,7 @@ static s7_pointer g_signature(s7_scheme *sc, s7_pointer args) }} break; - default: - break; + default: break; } return(sc->F); } @@ -46549,10 +46554,11 @@ static int32_t arity_to_int(s7_scheme *sc, s7_pointer x) return((args < 0) ? MAX_ARITY : args); case T_C_MACRO: return(c_macro_max_args(x)); - case T_C_OBJECT: return(MAX_ARITY); - /* do vectors et al make sense here? */ + /* case T_C_OBJECT: return(MAX_ARITY); */ /* this currently can't be called */ + /* vectors et al don't make sense here -- this is called only in g_set_setter below where it is restricted to is_any_procedure (type>=T_CLOSURE) */ } - return(-1); + if (S7_DEBUGGING) fprintf(stderr, "%s -1\n", __func__); + return(-1); /* unreachable I think */ } @@ -46817,7 +46823,7 @@ static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer ar set_elist_2(sc, wrap_string(sc, "symbol setter function, ~A, should take 2 or 3 arguments", 56), func)); }} if (slot == global_slot(sym)) - s7_set_setter(sc, sym, func); /* special GC protection for global vars */ + s7_set_setter(sc, sym, func); /* special GC protection for global vars */ else slot_set_setter(slot, func); /* func might be #f */ if (func != sc->F) slot_set_has_setter(slot); @@ -46852,7 +46858,7 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) break; case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: - if (p == global_value(sc->setter_symbol)) + if (p == global_value(sc->setter_symbol)) /* (immutable? (setter setter)) is #t, but we aren't checking immutable? here -- maybe we should? */ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter setter) to ~S", 31), setter)); c_function_set_setter(p, setter); if ((is_any_closure(setter)) || @@ -47759,8 +47765,7 @@ static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_i case T_CLOSURE: case T_CLOSURE_STAR: return(x_seq == y_seq); /* or closure_equal/equivalent? */ - default: - break; + default: break; } return(false); } @@ -51689,7 +51694,7 @@ static bool catch_eval_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_poi } static bool catch_barrier_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ /* can this happen?? read/eval set op_barrier */ +{ /* can this happen? is it doing the right thing? read/eval/call_begin_hook push_stack op_barrier but only s7_read includes a port (this is not hit in s7test.scm) */ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); if (is_input_port(stack_args(sc->stack, i))) { @@ -66848,8 +66853,7 @@ static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer expr) }} break; - default: - break; + default: break; }} return_false(sc, car_x); } @@ -67989,6 +67993,9 @@ static s7_pointer g_map(s7_scheme *sc, s7_pointer args) a list of the results. Its arguments can be lists, vectors, strings, hash-tables, or any applicable objects." #define Q_map s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol) + /* (apply f (map <safe f> ...)) e.g. f=append -> use safe_list for map output list here? also for (<safe-func> (map...)) + * but less savings if mapped func would have used the same safe_list? + */ s7_pointer p, f = car(args); s7_int len; bool got_nil = false; @@ -69637,8 +69644,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer expr, combine_op_t cop, s7_ } return(OP_SAFE_C_PP); - default: - break; + default: break; } return(OP_UNOPT); } @@ -71898,8 +71904,7 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in e = cons(sc, sc->if_keyword, e); break; - default: - break; + default: break; } sc->temp9 = e; @@ -88987,6 +88992,7 @@ static s7_pointer read_expression(s7_scheme *sc) break; case TOKEN_QUOTE: + check_stack_size(sc); /* no speed diff in tload.scm which looks like the worst case */ push_stack_no_let_no_code(sc, OP_READ_QUOTE, sc->nil); sc->tok = token(sc); break; @@ -88999,15 +89005,12 @@ static s7_pointer read_expression(s7_scheme *sc) case TOKEN_COMMA: push_stack_no_let_no_code(sc, OP_READ_UNQUOTE, sc->nil); sc->tok = token(sc); - switch (sc->tok) + if (sc->tok == TOKEN_RIGHT_PAREN) + read_expression_read_error_nr(sc); + if (sc->tok == TOKEN_EOF) { - case TOKEN_EOF: pop_stack(sc); read_error_nr(sc, "stray comma at the end of the input?"); - case TOKEN_RIGHT_PAREN: - read_expression_read_error_nr(sc); - default: - break; } break; @@ -89030,7 +89033,7 @@ static s7_pointer read_expression(s7_scheme *sc) case TOKEN_DOT: /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */ back_up_stack(sc); {int32_t c; do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF));} - read_error_nr(sc, "stray dot in list?"); /* (+ 1 . . ) */ + read_error_nr(sc, "stray dot in list?"); /* (+ 1 . . ) */ case TOKEN_RIGHT_PAREN: /* (catch #t (lambda () '(1 2 . )) (lambda args 'hiho)) */ back_up_stack(sc); @@ -89539,8 +89542,7 @@ static bool op_unknown_s(s7_scheme *sc) case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - default: - break; + default: break; } if ((is_symbol(car(code))) && (!is_slot(s7_slot(sc, car(code))))) @@ -89616,8 +89618,7 @@ static bool op_unknown_a(s7_scheme *sc) return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_A)); } - default: - break; + default: break; } if ((is_symbol(car(code))) && (!is_slot(s7_slot(sc, car(code))))) @@ -89750,8 +89751,7 @@ static bool op_unknown_gg(s7_scheme *sc) case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - default: - break; + default: break; } if ((is_symbol(car(code))) && (!is_slot(s7_slot(sc, car(code))))) @@ -89826,8 +89826,7 @@ static bool op_unknown_ns(s7_scheme *sc) case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); /* PERHAPS: vector, but need op_implicit_vector_ns? */ - default: - break; + default: break; } return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); } @@ -89902,8 +89901,7 @@ static bool op_unknown_aa(s7_scheme *sc) case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - default: - break; + default: break; } if ((is_symbol(car(code))) && (!is_slot(s7_slot(sc, car(code))))) @@ -90031,8 +90029,7 @@ static bool op_unknown_na(s7_scheme *sc) case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); /* implicit vector doesn't happen */ - default: - break; + default: break; } /* closure happens if wrong-number-of-args passed -- probably no need for op_s_na */ /* PERHAPS: vector */ @@ -91246,7 +91243,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) { case goto_do_end_clauses: goto DO_END_CLAUSES; case goto_do_unchecked: goto DO_UNCHECKED; - default: goto EVAL; + default: goto EVAL; } case OP_DOX: @@ -92175,8 +92172,7 @@ static void save_holder_data(s7_scheme *sc, s7_pointer p) mark_stack_holdees(sc, continuation_stack(p), continuation_stack_top(p)); break; - default: /* includes T_C_OBJECT */ - break; + default: break; /* includes T_C_OBJECT */ } } @@ -92918,7 +92914,7 @@ static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice) case SL_ROOTLET_SIZE: return(make_integer(sc, sc->rootlet_entries)); case SL_SAFETY: return(make_integer(sc, sc->safety)); case SL_STACK: return(sl_stack_entries(sc, sc->stack, current_stack_top(sc))); - case SL_STACKTRACE_DEFAULTS: return(sc->stacktrace_defaults); + case SL_STACKTRACE_DEFAULTS: return(copy_proper_list(sc, sc->stacktrace_defaults)); /* if not copied, we can set! entries directly to garbage */ case SL_STACK_SIZE: return(make_integer(sc, sc->stack_size)); case SL_STACK_TOP: return(make_integer(sc, (sc->stack_end - sc->stack_start) / 4)); case SL_UNDEFINED_CONSTANT_WARNINGS: return(s7_make_boolean(sc, sc->undefined_constant_warnings)); @@ -93107,13 +93103,12 @@ static s7_pointer sl_set_gc_info(s7_scheme *sc, s7_pointer sym, s7_pointer val) } else if ((is_pair(val)) && (s7_is_integer(car(val))) && - (is_pair(cdr(val))) && (s7_is_integer(cadr(val))) && - (is_pair(cddr(val))) && (s7_is_integer(caddr(val)))) + (is_pair(cdr(val))) && (s7_is_integer(cadr(val)))) /* caddr is ticks_per_second which can't sensibly be set */ { sc->gc_total_time = s7_integer(car(val)); sc->gc_calls = s7_integer(cadr(val)); } - else s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f or a list of three integers", 30)); + else s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f or a list of two or three integers (the third is ignored)", 60)); return(sc->F); } @@ -93197,12 +93192,14 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val switch (s7_starlet_symbol(sym)) { case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: - if (is_boolean(val)) {sc->accept_all_keyword_arguments = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->accept_all_keyword_arguments = s7_boolean(sc, val); + return(val); case SL_AUTOLOADING: - if (is_boolean(val)) {sc->is_autoloading = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->is_autoloading = s7_boolean(sc, val); + return(val); case SL_BIGNUM_PRECISION: return(sl_set_bignum_precision(sc, sym, val)); @@ -93220,15 +93217,12 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val return(val); case SL_DEFAULT_RANDOM_STATE: - if (is_random_state(val)) - { + if (!is_random_state(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_RANDOM_STATE]); #if (!WITH_GMP) - random_seed(sc->default_random_state) = random_seed(val); - random_carry(sc->default_random_state) = random_carry(val); + random_seed(sc->default_random_state) = random_seed(val); + random_carry(sc->default_random_state) = random_carry(val); #endif - return(val); - } - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_RANDOM_STATE]); + return(val); case SL_DEFAULT_RATIONALIZE_ERROR: sc->default_rationalize_error = s7_real(sl_real_geq_0(sc, sym, val)); @@ -93239,8 +93233,9 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val return(val); case SL_EXPANSIONS: - if (is_boolean(val)) {sc->is_expanding = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->is_expanding = s7_boolean(sc, val); + return(val); case SL_FILE_NAMES: case SL_FILENAMES: sl_unsettable_error_nr(sc, sym); @@ -93284,9 +93279,8 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val return(val); case SL_HISTORY_ENABLED: /* (set! (*s7* 'history-enabled) #f|#t) */ - if (is_boolean(val)) - return(s7_make_boolean(sc, s7_set_history_enabled(sc, s7_boolean(sc, val)))); - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + return(s7_make_boolean(sc, s7_set_history_enabled(sc, s7_boolean(sc, val)))); case SL_HISTORY_SIZE: iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); @@ -93325,15 +93319,17 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val sl_unsettable_error_nr(sc, sym); case SL_MUFFLE_WARNINGS: - if (is_boolean(val)) {sc->muffle_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->muffle_warnings = s7_boolean(sc, val); + return(val); case SL_NUMBER_SEPARATOR: /* I think no PL uses the separator in output */ return(sl_set_number_separator(sc, sym, val)); case SL_OPENLETS: - if (is_boolean(val)) {sc->has_openlets = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->has_openlets = s7_boolean(sc, val); + return(val); case SL_OUTPUT_PORT_DATA_SIZE: sc->output_port_data_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); @@ -93371,12 +93367,14 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val sl_unsettable_error_nr(sc, sym); case SL_UNDEFINED_CONSTANT_WARNINGS: - if (is_boolean(val)) {sc->undefined_constant_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->undefined_constant_warnings = s7_boolean(sc, val); + return(val); case SL_UNDEFINED_IDENTIFIER_WARNINGS: - if (is_boolean(val)) {sc->undefined_identifier_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->undefined_identifier_warnings = s7_boolean(sc, val); + return(val); case SL_VERSION: sl_unsettable_error_nr(sc, sym); @@ -93433,29 +93431,29 @@ static void init_s7_starlet_immutable_field(void) static const char *decoded_name(s7_scheme *sc, const s7_pointer p) { - if (p == sc->value) return("sc->value"); - if (p == sc->args) return("sc->args"); - if (p == sc->code) return("sc->code"); - if (p == sc->cur_code) return("sc->cur_code"); - if (p == sc->curlet) return("sc->curlet"); - if (p == sc->nil) return("()"); - if (p == sc->T) return("#t"); - if (p == sc->F) return("#f"); - if (p == eof_object) return("eof_object"); - if (p == sc->undefined) return("undefined"); - if (p == sc->unspecified) return("unspecified"); - if (p == sc->no_value) return("no_value"); - if (p == sc->unused) return("#<unused>"); - if (p == sc->symbol_table) return("symbol_table"); - if (p == sc->rootlet) return("rootlet"); - if (p == sc->s7_starlet) return("*s7*"); /* this is the function */ - if (p == sc->unlet) return("unlet"); - if (p == sc->error_port) return("error_port"); - if (p == sc->owlet) return("owlet"); - if (p == sc->standard_input) return("*stdin*"); - if (p == sc->standard_output) return("*stdout*"); - if (p == sc->standard_error) return("*stderr*"); - if (p == sc->else_symbol) return("else_symbol"); + if (p == sc->value) return("sc->value"); + if (p == sc->args) return("sc->args"); + if (p == sc->code) return("sc->code"); + if (p == sc->cur_code) return("sc->cur_code"); + if (p == sc->curlet) return("sc->curlet"); + if (p == sc->nil) return("()"); + if (p == sc->T) return("#t"); + if (p == sc->F) return("#f"); + if (p == eof_object) return("eof_object"); + if (p == sc->undefined) return("undefined"); + if (p == sc->unspecified) return("unspecified"); + if (p == sc->no_value) return("no_value"); + if (p == sc->unused) return("#<unused>"); + if (p == sc->symbol_table) return("symbol_table"); + if (p == sc->rootlet) return("rootlet"); + if (p == sc->s7_starlet) return("*s7*"); /* this is the function */ + if (p == sc->unlet) return("unlet"); + if (p == sc->error_port) return("error_port"); + if (p == sc->owlet) return("owlet"); + if (p == sc->standard_input) return("*stdin*"); + if (p == sc->standard_output) return("*stdout*"); + if (p == sc->standard_error) return("*stderr*"); + if (p == sc->else_symbol) return("else_symbol"); if (p == current_input_port(sc)) return("current-input-port"); if (p == current_output_port(sc)) return("current-output-port"); return((p == sc->stack) ? "stack" : NULL); @@ -95234,7 +95232,11 @@ static void init_rootlet(s7_scheme *sc) sc->funclet_symbol = defun("funclet", funclet, 1, 0, false); sc->_function__symbol = defun("*function*", function, 0, 2, false); sc->dilambda_symbol = defun("dilambda", dilambda, 2, 0, false); - s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, H_setter, Q_setter, NULL); + { + s7_pointer get_func; + get_func = s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, H_setter, Q_setter, NULL); + set_immutable(c_function_setter(get_func)); + } sc->arity_symbol = defun("arity", arity, 1, 0, false); sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false); @@ -95914,12 +95916,9 @@ s7_scheme *s7_init(void) #if S7_DEBUGGING s7_define_function(sc, "report-missed-calls", g_report_missed_calls, 0, 0, false, NULL); if (!s7_type_names[0]) {fprintf(stderr, "no type_names\n"); gdb_break();} /* squelch very stupid warnings! */ - if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) - fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]); - if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) - fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]); - if (NUM_OPS != 924) - fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info)); + if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]); + if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]); + if (NUM_OPS != 924) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info)); /* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */ #endif @@ -96283,60 +96282,62 @@ int main(int argc, char **argv) #endif #endif -/* -------------------------------------------------- - * 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 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 - * --------------------------------------------- +/* --------------------------------------------------- + * 20.9 21.0 22.0 23.0 23.6 23.7 + * --------------------------------------------------- + * tpeak 115 114 108 105 102 + * tref 691 687 463 459 459 + * index 1026 1016 973 967 969 + * tmock 1177 1165 1057 1019 1027 + * tvect 2519 2464 1772 1669 1647 + * timp 2637 2575 1930 1694 1716 + * texit ---- ---- 1778 1741 1765 + * s7test 1873 1831 1818 1829 1846 + * thook ---- ---- 2590 2030 2046 + * tauto ---- ---- 2562 2048 2063 + * lt 2187 2172 2150 2185 2199 + * dup 3805 3788 2492 2239 2234 + * tcopy 8035 5546 2539 2375 2380 + * tread 2440 2421 2419 2408 2417 + * fbench 2688 2583 2460 2430 2458 + * trclo 2735 2574 2454 2445 2461 + * titer 2865 2842 2641 2509 2465 + * tload ---- ---- 3046 2404 2531 + * tmat 3065 3042 2524 2578 2828 + * tb 2735 2681 2612 2604 2630 + * tsort 3105 3104 2856 2804 2828 + * tobj 4016 3970 3828 3577 3576 + * teq 4068 4045 3536 3486 3588 + * tio 3816 3752 3683 3620 3616 + * tmac 3950 3873 3033 3677 3688 + * tclo 4787 4735 4390 4384 4448 + * tcase 4960 4793 4439 4430 4448 + * tlet 7775 5640 4450 4427 4452 + * tfft 7820 7729 4755 4476 4511 + * tstar 6139 5923 5519 4449 4554 + * tmap 8869 8774 4489 4541 4618 + * tshoot 5525 5447 5183 5055 5048 + * tstr 6880 6342 5488 5162 5194 + * tform 5357 5348 5307 5316 5402 + * tnum 6348 6013 5433 5396 5410 + * tlamb 6423 6273 5720 5560 5620 + * tmisc 8869 7612 6435 6076 6222 + * tgsl 8485 7802 6373 6282 6229 + * tlist 7896 7546 6558 6240 6284 + * tset ---- ---- ---- 6260 6290 + * tari 13.0 12.7 6827 6543 6490 + * trec 6936 6922 6521 6588 6581 + * tleft 10.4 10.2 7657 7479 7627 + * tgc 11.9 11.1 8177 7857 7958 + * thash 11.8 11.7 9734 9479 9483 + * cb 11.2 11.0 9658 9564 9631 + * tgen 11.2 11.4 12.0 12.1 12.1 + * tall 15.6 15.6 15.6 15.6 15.1 + * calls 36.7 37.5 37.0 37.5 37.1 + * sg ---- ---- 55.9 55.8 55.3 + * lg ---- ---- 105.2 106.4 107.2 + * tbig 177.4 175.8 156.5 148.1 145.8 + * ------------------------------------------------- + * + * 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? */ @@ -2,7 +2,7 @@ #define S7_H #define S7_VERSION "10.6" -#define S7_DATE "3-July-2023" +#define S7_DATE "7-Aug-2023" #define S7_MAJOR_VERSION 10 #define S7_MINOR_VERSION 6 @@ -6006,7 +6006,7 @@ a mistake and "fixed" it; now I'm having second thoughts). <ul style="list-style-type:disc;"> <li>remove even? and odd?, gcd and lcm. <li>remove string-length and vector-length. -<li>remove list-ref|set!, string-ref|set!, vector-ref|set!, hash-table-ref|set!, set-car!|cdr!, and set-current-output|input|error-port. +<!-- <li>remove list-ref, list-set!, string-ref, string-set!, vector-ref, vector-set!, hash-table-ref, hash-table-set!, set-car!, set-cdr!, and set-current-*-port. --> <li>change file-exists? to file? (or omit it and assume the use of libc.scm — why reinvent the wheel?). <li>remove all the conversion and copy functions like vector->list and vector-copy (use copy or map). <li>change string->symbol to symbol (what to do with symbol->string in that case?) @@ -1134,6 +1134,7 @@ static s7_pointer g_block_append(s7_scheme *sc, s7_pointer args) s7_int i, len = 0; s7_pointer p, new_g; g_block *g; + if (s7_is_null(sc, args)) return(s7_nil(sc)); /* (with-let <block...> (append)) ?! */ for (i = 1, p = args; s7_is_pair(p); p = s7_cdr(p), i++) { g_block *g1; @@ -8185,6 +8186,8 @@ i" (lambda (p) (eval (read p)))) pi) (test (make-byte-vector 1 -32) 'error) (test (make-byte-vector 1 256) 'error) (test (make-byte-vector 1 3.0) 'error) +(test (make-byte-vector 2) #u(0 0)) ; make sure it's init is 0 -- g_make_byte_vector bug +(test (make-byte-vector 1) #u(0)) (for-each (lambda (arg) (if (not (eq? 'error (catch #t (lambda () (make-byte-vector arg)) (lambda args 'error)))) @@ -9781,6 +9784,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (set-car! #f 32) 'error) (test (set-car!) 'error) (test (set-car! '(1 2) 1 2) 'error) +(test (set-car! '(1 . 2) 3) 3) ; from bug-guile (test (let ((lst (list 1 2))) (set-car! lst (values 2 3)) lst) 'error) (test (let ((lst '(1 2))) (set-car! lst 32)) 32) (test (let ((lst '(1 2))) (set! (car lst) 32)) 32) @@ -11246,6 +11250,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (append (int-vector 1 2 3) '(1 2 3) #u(101 102)) (int-vector 1 2 3 1 2 3 101 102)) (test (append (hash-table 'c 3 'd 4) (hash-table 'c 3 'd 4) '((e . 5) (f . 6))) (hash-table 'e 5 'f 6 'c 3 'd 4)) (when with-block + (test (null? (with-let (block 1.0) (append))) #t) (test (append (block 1 2) (block 3 4)) (block 1 2 3 4)) (test (let () (define (func) (append (list (list (list 1)) (setter car)) (vector-dimensions (block 0.0)))) (define (hi) (func)) (hi)) (list '((1)) set-car! 1)) (test (append #i2d((101 201) (3 4)) (make-block 2)) 'error) ; #i(101 201 3 4 0 0)) @@ -20462,6 +20467,20 @@ i" (lambda (p) (eval (read p)))) pi) ;;; port-position +(test (port-position) 'error) +(test (port-position (current-output-port)) 'error) +(test (port-position (current-error-port)) 'error) +(test (integer? (port-position (current-input-port))) #t) +(test (port-position (current-input-port) #f) 'error) +(test (call-with-output-file "asdf" (lambda (p) (port-position p))) 'error) +(test (call-with-output-string (lambda (p) (port-position p))) 'error) + +(for-each + (lambda (arg) + (test (port-position arg) 'error)) + (list "hi" () '(1 2) -1 #\a 1 'a-symbol (make-vector 3) abs _ht_ _undef_ _null_ _c_obj_ quasiquote macroexpand 1/0 (log 0) + 3.14 3/4 1.0+1.0i #f #t (if #f #f) #<undefined> (lambda (a) (+ a 1)))) + (test (call-with-input-string "0123456789" (lambda (p) (set! (port-position p) 3) (list (read-char p) (port-position p)))) '(#\3 4)) (test (call-with-input-file "s7test.scm" (lambda (p) (set! (port-position p) 88) (list (read-string 10 p) (port-position p)))) '(";; Paul " 98)) (test (call-with-input-string "0123456789" (lambda (p) (set! (port-position p) -3))) 'error) @@ -45501,6 +45520,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test x 1) (set! x 32) (test (set! x 3.14) 'error) (test x 32)) (test (set! (setter setter) car) 'error) +(test (immutable? (setter setter)) #t) (let ((lst (list 1 2))) (set! (setter (setter car)) (lambda (s v1 v2) (list v1 v2))) @@ -50127,6 +50147,9 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (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)))) @@ -50144,6 +50167,11 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (coverlet (rootlet)) 'error) (test (outlet (rootlet)) (rootlet)) +(let ((x (let ((a 1)) (immutable! 'a) (curlet)))) + (test (set! (x 'a) 3) 'error) + (let ((y (sublet x))) + (test (set! (y 'a) 3) 'error))) + (test (let ((e (inlet 'a 2 'a 1))) (let ((c (copy e))) (list (e 'a) (c 'a)))) @@ -98552,6 +98580,16 @@ etc (test (integer? (*s7* 'gc-freed)) #t) (test (integer? (*s7* 'gc-total-freed)) #t) (test (pair? (*s7* 'gc-info)) #t) +(test (positive? (car (*s7* 'gc-info))) #t) +(test (positive? (cadr (*s7* 'gc-info))) #t) +(set! (*s7* 'gc-info) #f) ; same as (set! (*s7* 'gc-info) '(0 0)) +(test (car (*s7* 'gc-info)) 0) +(test (cadr (*s7* 'gc-info)) 0) +(test (set! (*s7* 'gc-info) ()) 'error) +(test (set! (*s7* 'gc-info) '(0 0)) #f) +(let ((ticks/second (caddr (*s7* 'gc-info)))) + (test (set! (*s7* 'gc-info) '(0 0 -100)) #f) ; make sure third is ignored + (test (caddr (*s7* 'gc-info)) ticks/second)) (test (integer? (*s7* 'gc-temps-size)) #t) (test (real? (*s7* 'gc-resize-heap-fraction)) #t) (test (real? (*s7* 'gc-resize-heap-by-4-fraction)) #t) @@ -98577,6 +98615,9 @@ etc (test (set! (*s7* 'stacktrace-defaults) '(3 45 80.0 45 #f)) 'error) (test (set! (*s7* 'stacktrace-defaults) '(3 45 80 45.0 #f)) 'error) (test (set! (*s7* 'stacktrace-defaults) '(3 45 80 45 12)) 'error) +(let ((L (*s7* 'stacktrace-defaults))) + (set-car! L 1+i) ; make sure (*s7* 'stacktrace-defaults) returns a copy of the list + (test (integer? (car (*s7* 'stacktrace-defaults))) #t)) (catch #t (lambda () (set! (*s7* 'stacktrace-defaults) '(100 #() 1 2 3))) @@ -98660,6 +98701,11 @@ etc (test (defined? 'asdf *s7*) #f) (test (defined? :asdf *s7*) #f) ; maybe inconsistent +(test (setter current-input-port) set-current-input-port) +(set! (setter current-input-port) #f) +(test (setter current-input-port) #f) +(set! (setter current-input-port) set-current-input-port) + (let-temporarily (((*s7* 'default-hash-table-length) 31) ((*s7* 'hash-table-float-epsilon) 1e-4) ((*s7* 'equivalent-float-epsilon) .1) diff --git a/snd-motif.c b/snd-motif.c index d463d0c..19b57b0 100644 --- a/snd-motif.c +++ b/snd-motif.c @@ -30676,7 +30676,8 @@ void snd_doit(int argc, char **argv) (!(set_axis_numbers_font(FALLBACK_FONT)))) fprintf(stderr, "can't find axis numbers font %s", DEFAULT_AXIS_NUMBERS_FONT); - set_listener_font(DEFAULT_LISTENER_FONT); /* we need some sort of font here! */ + if (!set_listener_font(DEFAULT_LISTENER_FONT)) /* we need some sort of font here! */ + fprintf(stderr, "can't find listener font %s", DEFAULT_LISTENER_FONT); ss->orig_axis_label_font = mus_strdup(axis_label_font(ss)); ss->orig_axis_numbers_font = mus_strdup(axis_numbers_font(ss)); diff --git a/snd-motif.scm b/snd-motif.scm index 0b4fe7d..8032ab2 100644 --- a/snd-motif.scm +++ b/snd-motif.scm @@ -170,15 +170,19 @@ (.pixel col)))) '("black" "red" "blue" "orange"))))) (XmRenderTableAddRenditions - #f - (map (lambda (tag pix) - (XmRenditionCreate - (cadr (main-widgets)) - tag - (list XmNrenditionForeground pix - XmNfontName "9x15" - XmNfontType XmFONT_IS_FONT))) - tags pixels) + #f + (let ((font (if (or (string=? (listener-font) "9x15") + (load-font "9x15")) + "9x15" + (listener-font)))) ; was "9x15" + (map (lambda (tag pix) + (XmRenditionCreate + (cadr (main-widgets)) + tag + (list XmNrenditionForeground pix + XmNfontName font + XmNfontType XmFONT_IS_FONT))) + tags pixels)) (length tags) XmMERGE_NEW)))) (XtSetValues dialog @@ -211,7 +215,7 @@ (list XmNrenderTable rendertable)) (XmFileSelectionDoSearch dialog #f))))) - ;; (install-searcher-with-colors (lambda (file) #t)) + ;; ((*motif* 'install-searcher-with-colors) (lambda (file) #t)) ;;; -------- keep-file-dialog-open-upon-ok @@ -807,7 +811,7 @@ (shell ((main-widgets) 1)) (button-fontstruct (XLoadQueryFont (XtDisplay shell) (if (> (length *listener-font*) 0) - *listener-font* + *listener-font* "9x15")))) (set! (.foreground gv) *data-color*) (set! (.background gv) *basic-color*) diff --git a/snd-region.c b/snd-region.c index d12957b..e4a3d7f 100644 --- a/snd-region.c +++ b/snd-region.c @@ -2007,7 +2007,7 @@ static s7_pointer g_save_region(s7_scheme *sc, s7_pointer args) fp = s7_cadr(p); if (fp == Xen_false) - head_type = MUS_NEXT; + head_type = default_output_header_type(ss); /* was MUS_NEXT, 28-Jul-23 */ else { if (!s7_is_integer(fp)) @@ -2061,7 +2061,7 @@ static Xen g_save_region(Xen n, Xen arg1, Xen arg2, Xen arg3, Xen arg4, Xen arg5 const char *file = NULL, *com = NULL; int rg, true_args; mus_sample_t sample_type = MUS_OUT_SAMPLE_TYPE; - mus_header_t header_type = MUS_NEXT; + mus_header_t header_type = default_output_header_type(ss); /* was MUS_NEXT, 28-Jul-23 */ Xen args[8]; Xen keys[4]; int orig_arg[4] = {0, 0, 0, 0}; diff --git a/snd-select.c b/snd-select.c index b66668b..974453f 100644 --- a/snd-select.c +++ b/snd-select.c @@ -374,7 +374,7 @@ static int mix_selection(chan_info *cp, sync_info *si_out, mus_long_t beg, io_er io_error_t io_err; tempfile = snd_tempnam(); - io_err = save_selection(tempfile, snd_srate(cp->sound), MUS_OUT_SAMPLE_TYPE, MUS_NEXT, NULL, SAVE_ALL_CHANS); + io_err = save_selection(tempfile, snd_srate(cp->sound), MUS_OUT_SAMPLE_TYPE, MUS_NEXT, NULL, SAVE_ALL_CHANS); /* should this use DEFAULT_OUTPUT_HEADER_TYPE? */ if (io_err == IO_NO_ERROR) { char *origin = NULL; @@ -438,7 +438,7 @@ static io_error_t insert_selection(chan_info *cp, sync_info *si_out, mus_long_t mus_sample_t out_format = MUS_OUT_SAMPLE_TYPE; io_error_t io_err = IO_NO_ERROR; - if (mus_header_writable(MUS_NEXT, cp->sound->hdr->sample_type)) + if (mus_header_writable(MUS_NEXT, cp->sound->hdr->sample_type)) /* should these use DEFAULT_OUTPUT_HEADER_TYPE? */ out_format = cp->sound->hdr->sample_type; tempfile = snd_tempnam(); @@ -996,7 +996,7 @@ static Xen s7_xen_selection_copy(s7_scheme *sc, Xen args) snd_info *sp; char *name; name = snd_tempnam(); - save_selection(name, selection_srate(), MUS_OUT_SAMPLE_TYPE, MUS_NEXT, NULL, SAVE_ALL_CHANS); + save_selection(name, selection_srate(), MUS_OUT_SAMPLE_TYPE, MUS_NEXT, NULL, SAVE_ALL_CHANS); /* should this use DEFAULT_OUTPUT_HEADER_TYPE? */ sp = snd_open_file(name, FILE_READ_WRITE); free(name); return(new_xen_sound(sp->index)); @@ -1101,7 +1101,7 @@ io_error_t save_selection(const char *ofile, int srate, mus_sample_t samp_type, { if ((sp) && (mus_header_writable(sp->hdr->type, MUS_IGNORE_SAMPLE))) head_type = sp->hdr->type; - else head_type = MUS_NEXT; + else head_type = default_output_header_type(ss) ; /* was MUS_NEXT, 28-Jul-23 */ } if (samp_type == MUS_UNKNOWN_SAMPLE) { @@ -1415,7 +1415,7 @@ static Xen g_selection_to_mix(void) cp = si_out->cps[0]; tempfile = snd_tempnam(); - io_err = save_selection(tempfile, snd_srate(cp->sound), MUS_OUT_SAMPLE_TYPE, MUS_NEXT, NULL, SAVE_ALL_CHANS); + io_err = save_selection(tempfile, snd_srate(cp->sound), MUS_OUT_SAMPLE_TYPE, MUS_NEXT, NULL, SAVE_ALL_CHANS); /* should this use DEFAULT_OUTPUT_HEADER_TYPE? */ if (is_serious_io_error(io_err)) { if (tempfile) free(tempfile); @@ -47,11 +47,11 @@ #include "snd-strings.h" -#define SND_DATE "3-July-23" +#define SND_DATE "7-Aug-23" #ifndef SND_VERSION -#define SND_VERSION "23.5" +#define SND_VERSION "23.6" #endif #define SND_MAJOR_VERSION "23" -#define SND_MINOR_VERSION "5" +#define SND_MINOR_VERSION "6" #endif @@ -45,7 +45,7 @@ int main(int argc, char *argv[]) mus_sample_t samp_type; mus_header_t type; mus_long_t samples; - float length = 0.0; + double length = 0.0; time_t date; int *loops = NULL; char *comment, *header_name; @@ -68,7 +68,7 @@ int main(int argc, char *argv[]) samples = mus_sound_samples(argv[ctr]); comment = mus_sound_comment(argv[ctr]); if ((chans > 0) && (srate > 0)) - length = (float)((double)samples / (double)(chans * srate)); + length = ((double)samples / (double)(chans * srate)); loops = mus_sound_loop_info(argv[ctr]); type = mus_sound_header_type(argv[ctr]); header_name = (char *)mus_header_type_name(type); diff --git a/tools/auto-tester.scm b/tools/auto-tester.scm index a4ba066..b8b1ace 100644 --- a/tools/auto-tester.scm +++ b/tools/auto-tester.scm @@ -26,7 +26,9 @@ 1893513180 1631296680 2131995753 2083801278 1873196400 1554115554) ;; possibly problematic: 2083801278 (random 20)))) - (random-state seed carry))) + (if (provided? 'gmp) + (random-state seed) + (random-state seed carry)))) (unless (file-exists? "~/cl/tmp1.r5rs") (system "touch ~/cl/tmp1.r5rs")) @@ -107,6 +109,11 @@ (define-constant mock-port (*mock-port* 'mock-port)) (define-constant mock-random-state (*mock-random-state* 'mock-random-state))) +;(define-constant _mv_ (if with-mock-data (mock-vector 1 2) (vector 1 2))) +;(define-constant _v_ #(1 2)) +(define-constant _mv_ (if with-mock-data (mock-number 1) 1)) +(define-constant _v_ 1) + (set! (*s7* 'safety) 1) ; protect copy (in define-expansion evaluation) from circular lists (set! (*s7* 'max-stack-size) (* 4 32768)) @@ -467,6 +474,28 @@ (error 'wrong-number-of-args "no value") (set! (_h_ (car key/value)) (cadr key/value)))))) +(define (checked-stacktrace . args) + (string? (apply stacktrace args))) +(define (checked-random . args) + (number? (apply random args))) +(define (checked-random-state . args) + (random-state? (apply random-state args))) +(define (checked-random-state->list . args) + (list? (apply random-state->list args))) +(define (checked-make-string . args) + (let-temporarily ((*s7* max-string-length 12)) + (string? (apply make-string args)))) +(define (checked-current-input-port . args) + (input-port? (apply current-input-port args))) +(define (checked-current-error-port . args) + (input-port? (apply current-error-port args))) +(define (checked-funclet . args) + (let? (apply funclet . args))) +(define (checked-hash-code . args) + (integer? (apply hash-code args))) +(define (checked-*function* . args) + (procedure? (apply *function* args))) + (define (checked-read-char . args) (with-input-from-string "0123" (lambda () (apply read-char args)))) (define (checked-read-byte . args) (with-input-from-string "0123" (lambda () (apply read-byte args)))) (define (checked-read-line . args) (with-input-from-file "s7test.scm" (lambda () (apply read-line args)))) @@ -817,8 +846,8 @@ (set! (hook-functions *read-error-hook*) ()) - -(let ((functions (vector 'not '= '+ 'cdr 'real? 'rational? 'number? '> '- 'integer? 'apply 'subvector? 'subvector-position 'subvector-vector +(when (not (defined? 'loading-t718)) +(let ((functions (reverse (vector 'not '= '+ 'cdr 'real? 'rational? 'number? '> '- 'integer? 'apply 'subvector? 'subvector-position 'subvector-vector 'abs '* 'null? 'imag-part '/ 'vector-set! 'equal? 'magnitude 'real-part 'pair? 'max 'nan? 'string->number 'list 'negative? 'cons 'string-set! 'list-ref 'eqv? 'positive? '>= 'expt 'number->string 'zero? 'floor 'denominator 'integer->char 'string? 'min '<= 'char->integer 'cos 'rationalize 'cadr 'sin 'char=? @@ -853,7 +882,8 @@ 'with-input-from-file 'type-of 'vector-fill! 'vector-typer 'hash-table-key-typer 'hash-table-value-typer 'peek-char - 'make-hash-table 'make-weak-hash-table 'weak-hash-table? ;'hash-code + 'make-hash-table 'make-weak-hash-table 'weak-hash-table? + 'hash-code 'macro? 'quasiquote 'immutable? 'char-position 'string-position @@ -866,7 +896,8 @@ 'output-port? 'input-port? ;'provide 'call-with-output-string - 'checked-hash-table + 'checked-hash-table 'checked-stacktrace 'checked-random 'checked-random-state 'checked-random-state->list 'checked-make-string + 'checked-current-input-port 'checked-current-error-port 'checked-funclet 'checked-hash-code 'with-output-to-string 'dilambda? 'hook-functions @@ -877,7 +908,7 @@ 'let 'let* 'letrec 'letrec* ;'lambda 'lambda* ; these cause built-ins to become locals if with-method=#f? ;'macro 'macro* 'bacro 'bacro* ; -- same as lambda above - ;'define* 'define-macro 'define-macro* 'define-bacro 'define-bacro* + ;'define* 'define-macro 'define-macro* 'define-bacro 'define-bacro* 'define 'define-constant ;'multiple-value-bind ; (multiple-value-bind (if) ...) gets all kinds of trouble 'call-with-values 'object->let @@ -885,7 +916,6 @@ 'open-input-string 'open-output-string 'open-input-file 'open-input-function 'open-output-function - ;'define 'newline ;'random-state ; pointless diffs 'gensym @@ -906,7 +936,7 @@ 'call-with-output-file 'with-output-to-file ;'read-char 'read-byte 'read-line 'read-string 'read ; stdin=>hangs 'checked-read-char 'checked-read-line 'checked-read-string 'checked-read-byte ;'checked-read - 'checked-reverse! 'checked-port-line-number + 'checked-reverse! 'checked-port-line-number 'checked-*function* 'close-input-port ;'current-input-port ;-- too many (read...) ;'set-current-input-port ; -- collides with rd8 etc @@ -919,7 +949,6 @@ 'current-output-port 'cutlet ;'set-current-error-port ;-- too many bogus eq? complaints - ;'define-constant ;'curlet ; (length (curlet)) too many times ;'open-output-file ;'delete-file 'set-current-output-port @@ -973,7 +1002,7 @@ 'apply-values 'values 'byte-vector-ref 'file-exists? 'make-int-vector 'string-downcase 'string-upcase - 'byte-vector 'equivalent? + 'byte-vector 'equivalent? 'make-byte-vector 'c-pointer? 'int-vector-ref 'float? 'list-values 'byte-vector? 'openlet? 'iterator? @@ -1034,20 +1063,19 @@ 'bignum 'symbol 'count-if 'pretty-print 'tree-member 'funclet? 'bignum? 'copy-tree ;'dynamic-unwind ; many swaps that are probably confused - ;'function-open-output 'function-close-output 'function-open-input 'function-get-output + ;'function-open-output 'function-open-input 'function-get-output 'function-close-output ;see s7test - )) + ))) (args (vector "-123" "1234" "-3/4" "-1" "1/2" "1+i" "1-i" "0+i" "0-i" "(expt 2 32)" "4294967297" "1001" "10001" - "3441313796169221281/1720656898084610641" "1855077841/1311738121" "4478554083/3166815962" "20057446674355970889/10028723337177985444" "(cosh 128)" "(cosh (bignum 128.0))" "(bignum -1/2)" "123456789.123456789" "(bignum 1234)" "(bignum 1234.1234)" "(bignum 1+i)" "(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 ())" - "#f" "#t" "()" "#()" "\"\"" "#()" ; ":write" -- not this because sr2 calls write and this can be an arg to sublet redefining write - ":readable" ":rest" ":allow-other-keys" ":a" ":frequency" ":scaler" ; for blocks5 s7test.scm + "#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" ":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" @@ -1213,7 +1241,7 @@ "catch" "call-with-exit" "map" "for-each" ;"lambda*" "lambda" ;-- cyclic body etc "let" "let*" ;"do" - "set!" "with-let" ;"define" "define*" "define-macro" "define-macro*" "define-bacro" "define-bacro*" + ;"set!" "with-let" ;"define" "define*" "define-macro" "define-macro*" "define-bacro" "define-bacro*" "(let ((L (list 1))) (set-cdr! L L) L)" "(let ((L (list 1 2))) (set-cdr! (cdr L) L) L)" @@ -1266,19 +1294,19 @@ (reader-cond ((provided? 'debugging) "(when ((*s7* 'heap-size) < (ash 1 21)) (heap-analyze) (heap-scan 47))")) ;(+ 1 (random 47))))")) "(map (lambda (x) (catch #t (lambda () (vector->list x)) (lambda (t i) 'err))) (list #(1 2) 1))" + "(symbol-table)" "(cons-r 0 0 6)" "(list-r 0 0 6)" - ;"(*s7* 'catches)" + ;"(*s7* 'gc-info)" ;"(*s7* 'cpu-time)" ; variable "(*s7* 'c-types)" ;"(copy (*s7* 'file-names))" ; one is *stdin* which can hang if read* gets it as the port ;"(*s7* 'gc-freed)" "(*s7* 'gc-total-freed)" "(*s7* 'free-heap-size)" ; variable - ;"(*s7* 'gc-protected-objects)" ; access + element set => not protected! perhaps copy it? + "(copy (*s7* 'gc-protected-objects))" ; access + element set => not protected! perhaps copy it? ;"(pp (*s7* 'memory-usage))" ; variable - ;"(*s7* 'most-negative-fixnum)" - ;"(*s7* 'most-positive-fixnum)" + ;"(*s7* 'most-negative-fixnum)" "(*s7* 'most-positive-fixnum)" "(*s7* 'rootlet-size)" ;"(*s7* 'stack)" "(*s7* 'stack-size)" ; variable, and stack can contain e.g. #<unused> "(*s7* 'version)" @@ -1287,8 +1315,7 @@ "(let loop ((i 2)) (if (> i 0) (loop (- i 1)) i))" ;"(rootlet)" ;"(curlet)" - ;"(make-simple-block 3)" - ;"*s7*" + ;"*s7*" ;variable "(symbol (make-string 130 #\\a))" "(symbol \"a\" \"b\")" "(symbol \"1\\\\\")" "#\\xff" "#\\backspace" ":0" "(list (list 1 2) (cons 1 2))" @@ -1301,11 +1328,12 @@ "my-let" "my-with-baffle" "fvset" "htset" "(catch #t (lambda () (+ 1 #(2))) (lambda (type info) 0))" "~/cl/tmp1.r5rs" + (reader-cond (with-mock-data "(if (> (random 1.0) 0.5) _v_ _mv_)")) #f #f #f ; cyclic here (see get-arg) )) - (codes (vector + (codes (reverse (vector (list (lambda (s) (string-append "(do ((x 0.0 (+ x 0.1)) (i 0 (+ i 1))) ((>= x .1) " s "))")) (lambda (s) (string-append "(let ((x 0.1) (i 1)) " s ")"))) (list (lambda (s) (string-append "(do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x " s "))")) @@ -1441,9 +1469,11 @@ (lambda (s) (string-append "(list (let ((old #f)) (dynamic-wind (lambda () (set! old (*s7* 'safety))) (lambda () " s ") (lambda () (set! (*s7* 'safety) old)))))"))) ;;; (+ (dynamic-wind (lambda () #f) (lambda () (values 1 2 3)) (lambda () #f))): 6 - )) - (chars (vector #\( #\( #\) #\space))) ; #\' #\/ #\# #\, #\` #\@ #\. #\:)) ; #\\ #\> #\space)) + ;; perhaps function port (see _rd3_ for open-input-string), gmp? + ))) + + (chars (vector #\( #\( #\) #\space))) ; #\' #\/ #\# #\, #\` #\@ #\. #\:)) ; #\\ #\> #\space (let ((clen (length chars)) (flen (length functions)) @@ -1451,7 +1481,7 @@ (codes-len (length codes)) (args-ran (+ 1 (random 5))) (both-ran (+ 3 (random 8)))) - + (define (get-arg) (let ((str (args (random alen)))) (if (string? str) ; else #f -> cyclic struct @@ -1471,7 +1501,7 @@ (define (fix-op op) (case op - ((set!) "set! _definee_") ;"set!") + ;((set!) "set! _definee_") ;"set!") ; block set! of our vars?? ((let) "let ()") ; need to block infinite loops like (let abs () (abs)) ((let*) "let* ()") ((do) "_do3_") @@ -1878,3 +1908,14 @@ )) (test-it))) +) + +#| +functions currently omitted (from functions vector): +unlet owlet *read-error-hook* set-current-output-port immutable! set-cdr! system close-output-port exit symbol->dynamic-value +rootlet port-filename load string->keyword make-hook provide dynamic-unwind emergency-exit read set-current-error-port *autoload-hook* +gc abort open-output-file set-current-input-port pair-line-number pair-filename coverlet delete-file curlet + +[read-line] [funclet] [port-line-number] [read-string] [varlet] [random-state] [random] [hash-code] [random-state->list] [current-input-port] +[make-string] [symbol-table] [current-error-port] [eval] [read-byte] [stacktrace] [read-char] [reverse!] [procedure-source] [*function*] +|# |