diff options
| -rw-r--r-- | HISTORY.Snd | 1 | ||||
| -rw-r--r-- | NEWS | 19 | ||||
| -rw-r--r-- | README.Snd | 2 | ||||
| -rwxr-xr-x | configure | 20 | ||||
| -rw-r--r-- | configure.ac | 4 | ||||
| -rw-r--r-- | debian/changelog | 9 | ||||
| -rw-r--r-- | debian/control | 4 | ||||
| -rw-r--r-- | debian/upstream-changelog | 13 | ||||
| -rw-r--r-- | libc.scm | 1 | ||||
| -rw-r--r-- | lint.scm | 32 | ||||
| -rw-r--r-- | notcurses_s7.c | 52 | ||||
| -rw-r--r-- | nrepl-bits.h | 34 | ||||
| -rw-r--r-- | nrepl.c | 3 | ||||
| -rw-r--r-- | nrepl.scm | 32 | ||||
| -rw-r--r-- | r7rs.scm | 3 | ||||
| -rw-r--r-- | repl.c | 3 | ||||
| -rw-r--r-- | s7.c | 4559 | ||||
| -rw-r--r-- | s7.h | 10 | ||||
| -rw-r--r-- | s7.html | 25 | ||||
| -rw-r--r-- | s7test.scm | 184 | ||||
| -rw-r--r-- | snd-snd.c | 10 | ||||
| -rw-r--r-- | snd.h | 6 | ||||
| -rw-r--r-- | stuff.scm | 7 | ||||
| -rw-r--r-- | tools/fbench.scm | 22 | ||||
| -rw-r--r-- | tools/ffitest.c | 31 | ||||
| -rw-r--r-- | tools/t101.scm | 7 | ||||
| -rw-r--r-- | tools/tari.scm | 240 | ||||
| -rw-r--r-- | tools/tgsl.scm | 11 | ||||
| -rw-r--r-- | tools/titer.scm | 4 | ||||
| -rw-r--r-- | tools/tload.scm | 247 | ||||
| -rw-r--r-- | tools/tmap.scm | 24 | ||||
| -rwxr-xr-x | tools/tmat.scm | 2 | ||||
| -rw-r--r-- | tools/tmisc.scm | 71 | ||||
| -rw-r--r-- | tools/valcall.scm | 12 |
34 files changed, 3420 insertions, 2284 deletions
diff --git a/HISTORY.Snd b/HISTORY.Snd index c063f55..790f2a8 100644 --- a/HISTORY.Snd +++ b/HISTORY.Snd @@ -1,5 +1,6 @@ Snd change log + 6-Sep: Snd 21.7. 3-Aug: Snd 21.6. 1-Jul: Snd 21.5. 25-May: Snd 21.4. @@ -1,15 +1,10 @@ -Snd 21.6: +Snd 21.7 -s7.h: added s7_is_random_state, s7_make_normal_vector, s7_array_to_list +s7: added (*s7* 'muffle-warnings?) and s7_output_string + bool s7_flush_output_port (was void) -s7.c: I changed the default heap size to 64k (half its previous size) -- - my timing tests and benchmarks seem to indicate that this is usually - faster (perhaps cache-related?). Pushing it down to 32k doesn't - affect runtimes very much. To get the old size back, - (set! (*s7* 'heap-size) 128000). - -Checked: sbcl 2.1.7 - -Thanks!: Daniel Hensel, Brad Christensen, James Hearon, Christos Vagias, - Tito Latini, Elijah Stone, Kjetil Matheussen, Woody Douglass +checked: notcurses 2.3.13, sbcl 2.1.8 + notcurses 2.3.17 behaves very strangely in row 0, so I've covered row 0 + with a header box. It's probably some new notcurses configuration option. +Thanks!: Brad Christensen, Woody Douglass, JGM, Anders Vinjar @@ -46,6 +46,8 @@ The configure script has a bunch of arguments: in FC, install the motif, motif-devel, and libXpm-devel packages. in *BSD, pkg install open-motif, or perhaps use pkgin? 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 --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.69 for snd 21.6. +# Generated by GNU Autoconf 2.69 for snd 21.7. # # Report bugs to <bil@ccrma.stanford.edu>. # @@ -580,8 +580,8 @@ MAKEFLAGS= # Identity of this package. PACKAGE_NAME='snd' PACKAGE_TARNAME='ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-21.tar.gz' -PACKAGE_VERSION='21.6' -PACKAGE_STRING='snd 21.6' +PACKAGE_VERSION='21.7' +PACKAGE_STRING='snd 21.7' PACKAGE_BUGREPORT='bil@ccrma.stanford.edu' PACKAGE_URL='' @@ -1323,7 +1323,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 21.6 to adapt to many kinds of systems. +\`configure' configures snd 21.7 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1394,7 +1394,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of snd 21.6:";; + short | recursive ) echo "Configuration of snd 21.7:";; esac cat <<\_ACEOF @@ -1513,7 +1513,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -snd configure 21.6 +snd configure 21.7 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1974,7 +1974,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 21.6, which was +It was created by snd $as_me 21.7, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -3321,7 +3321,7 @@ LOCAL_LANGUAGE="None" GRAPHICS_TOOLKIT="None" PACKAGE=Snd -VERSION=21.6 +VERSION=21.7 #-------------------------------------------------------------------------------- # configuration options @@ -6913,7 +6913,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 21.6, which was +This file was extended by snd $as_me 21.7, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -6975,7 +6975,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -snd config.status 21.6 +snd config.status 21.7 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index cd26653..b9c8a44 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ # gmp, mpfr, and mpc deliberately have none! -AC_INIT(snd, 21.6, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-21.tar.gz) +AC_INIT(snd, 21.7, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-21.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=21.6 +VERSION=21.7 #-------------------------------------------------------------------------------- # configuration options diff --git a/debian/changelog b/debian/changelog index 54bef07..7bc9725 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,12 @@ +snd (21.7-1) unstable; urgency=medium + + * New upstream version 21.7 + * Update d/upstream-changelog + * Mark 'snd' as 'meta package' + * Bump standards version to 4.6.0 + + -- IOhannes m zmölnig (Debian/GNU) <umlaeute@debian.org> Mon, 27 Sep 2021 16:02:30 +0200 + snd (21.6-1) unstable; urgency=medium * New upstream version 21.6 diff --git a/debian/control b/debian/control index 08657c2..4bf5ca1 100644 --- a/debian/control +++ b/debian/control @@ -20,7 +20,7 @@ Build-Depends: libasound2-dev [linux-any], libmpc-dev, bzip2, -Standards-Version: 4.5.1 +Standards-Version: 4.6.0 Rules-Requires-Root: no Vcs-Git: https://salsa.debian.org/multimedia-team/snd.git Vcs-Browser: https://salsa.debian.org/multimedia-team/snd @@ -33,7 +33,7 @@ Depends: ${misc:Depends}, snd-common, Recommends: snd-doc, -Description: Sound file editor +Description: Sound file editor (metapackage) Snd is a powerful sound file editor that can be customized and extended using the Scheme programming language. . diff --git a/debian/upstream-changelog b/debian/upstream-changelog index cfac05e..d49f186 100644 --- a/debian/upstream-changelog +++ b/debian/upstream-changelog @@ -1,3 +1,16 @@ +Snd 21.7 + +s7: added (*s7* 'muffle-warnings?) and s7_output_string + bool s7_flush_output_port (was void) + +checked: notcurses 2.3.13, sbcl 2.1.8 + notcurses 2.3.17 behaves very strangely in row 0, so I've covered row 0 + with a header box. It's probably some new notcurses configuration option. + +Thanks!: Brad Christensen, Woody Douglass, JGM, Anders Vinjar + +=============================================================================== + Snd 21.6: s7.h: added s7_is_random_state, s7_make_normal_vector, s7_array_to_list @@ -1,7 +1,6 @@ ;;; libc.scm ;;; ;;; tie the C library into the *libc* environment - (provide 'libc.scm) ;; if loading from a different directory, pass that info to C @@ -80,7 +80,7 @@ ;(define-macro (reader-cond . clauses) `(values)) ; clobber reader-cond to avoid (incorrect) unbound-variable errors #| -;; debugging version -- does not work in repl's listener +;; debugging version -- does not work in repl's listener (repl has its own top-level let) (define-expansion (lint-format str caller . args) `(begin (format outport "lint.scm line ~A~%" ,(port-line-number)) @@ -2081,9 +2081,14 @@ (let ((type (if (pair? expr) (return-type (car expr) ()) (->lint-type expr)))) - (and (symbol? type) - (not (symbol? expr)) - (not (memq type '(boolean? values))))))) + (or (and (symbol? type) + (not (symbol? expr)) + (not (memq type '(not boolean? values)))) + (and (pair? type) + (not (memq #t type)) + (not (memq 'boolean? type)) + (not (memq 'not type)) + (not (memq 'values type))))))) (define (never-true expr) (or (not expr) @@ -14418,15 +14423,14 @@ (set! sig (make-list len #t)) (if (< (length sig) len) (set! sig (copy sig (make-list len #t))))) - (let ((siglist (cdr sig))) - (for-each - (lambda (arg) - (if (memq arg unused) - (set-car! siglist 'unused-parameter?) - (if (memq arg set) - (set-car! siglist 'unused-set-parameter?))) - (set! siglist (cdr siglist))) - proper-args)) + (do ((siglist (cdr sig) (cdr siglist)) + (arg proper-args (cdr arg))) + ((null? arg)) + (if (memq (car arg) unused) + (set-car! siglist 'unused-parameter?) + (if (memq (car arg) set) + (set-car! siglist 'unused-set-parameter?)))) + (set! (var-signature fvar) sig)))))) (cons fvar env)))))))) @@ -23768,4 +23772,4 @@ #f)) |# -;;; 54 896368, 53 874874, 52 871075 +;;; 54 896368, 53 874874, 52 871075, 54 889347 diff --git a/notcurses_s7.c b/notcurses_s7.c index fb8149d..2a59f54 100644 --- a/notcurses_s7.c +++ b/notcurses_s7.c @@ -176,6 +176,17 @@ static s7_pointer g_ncdirect_inputready_fd(s7_scheme *sc, s7_pointer args) return(s7_make_integer(sc, ncdirect_inputready_fd((struct ncdirect *)s7_c_pointer_with_type(sc, s7_car(args), ncdirect_symbol, __func__, 1)))); } + +#if (NC_CURRENT_VERSION >= NC_VERSION(2, 3, 12)) +static s7_pointer g_ncdirect_get(s7_scheme *sc, s7_pointer args) +{ + /* returns char32_t! */ + return(s7_make_integer(sc, ncdirect_get((struct ncdirect *)s7_c_pointer_with_type(sc, s7_car(args), ncdirect_symbol, __func__, 1), + (const struct timespec *)s7_c_pointer_with_type(sc, s7_cadr(args), timespec_symbol, __func__, 2), + (ncinput *)s7_c_pointer_with_type(sc, s7_caddr(args), ncinput_symbol, __func__, 3)))); + +} +#else static s7_pointer g_ncdirect_getc(s7_scheme *sc, s7_pointer args) { /* returns char32_t! */ @@ -185,6 +196,7 @@ static s7_pointer g_ncdirect_getc(s7_scheme *sc, s7_pointer args) (ncinput *)s7_c_pointer_with_type(sc, s7_cadddr(args), ncinput_symbol, __func__, 4)))); } +#endif static s7_pointer g_ncdirect_set_fg_default(s7_scheme *sc, s7_pointer args) { @@ -733,6 +745,14 @@ static s7_pointer g_notcurses_canutf8(s7_scheme *sc, s7_pointer args) return(s7_make_boolean(sc, notcurses_canutf8((const struct notcurses *)s7_c_pointer_with_type(sc, s7_car(args), notcurses_symbol, __func__, 1)))); } +#if (NC_CURRENT_VERSION >= NC_VERSION(2, 3, 12)) +static s7_pointer g_notcurses_get(s7_scheme *sc, s7_pointer args) +{ + return(s7_make_integer(sc, notcurses_get((struct notcurses *)s7_c_pointer_with_type(sc, s7_car(args), notcurses_symbol, __func__, 1), + (const struct timespec *)s7_c_pointer_with_type(sc, s7_cadr(args), timespec_symbol, __func__, 2), + (ncinput *)s7_c_pointer_with_type(sc, s7_caddr(args), ncinput_symbol, __func__, 3)))); +} +#else static s7_pointer g_notcurses_getc(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, notcurses_getc((struct notcurses *)s7_c_pointer_with_type(sc, s7_car(args), notcurses_symbol, __func__, 1), @@ -740,6 +760,7 @@ static s7_pointer g_notcurses_getc(s7_scheme *sc, s7_pointer args) (sigset_t *)s7_c_pointer_with_type(sc, s7_caddr(args), sigset_t_symbol, __func__, 3), (ncinput *)s7_c_pointer_with_type(sc, s7_cadddr(args), ncinput_symbol, __func__, 4)))); } +#endif static s7_pointer g_notcurses_refresh(s7_scheme *sc, s7_pointer args) { @@ -3545,11 +3566,6 @@ static s7_pointer g_ncvisual_decode(s7_scheme *sc, s7_pointer args) return(s7_make_integer(sc, ncvisual_decode((struct ncvisual *)s7_c_pointer_with_type(sc, s7_car(args), ncvisual_symbol, __func__, 1)))); } -static s7_pointer g_ncvisual_subtitle(s7_scheme *sc, s7_pointer args) -{ - return(s7_make_string(sc, ncvisual_subtitle((const struct ncvisual *)s7_c_pointer_with_type(sc, s7_car(args), ncvisual_symbol, __func__, 1)))); -} - static s7_pointer g_ncvisual_rotate(s7_scheme *sc, s7_pointer args) { return(s7_make_integer(sc, ncvisual_rotate((struct ncvisual *)s7_c_pointer_with_type(sc, s7_car(args), ncvisual_symbol, __func__, 1), @@ -3829,6 +3845,7 @@ void notcurses_s7_init(s7_scheme *sc) nc_int(NCOPTION_NO_ALTERNATE_SCREEN); nc_int(NCOPTION_NO_FONT_CHANGES); +#if (NC_CURRENT_VERSION < NC_VERSION(2, 3, 5)) nc_int(CELL_BGDEFAULT_MASK); nc_int(CELL_FGDEFAULT_MASK); nc_int(CELL_BG_RGB_MASK); @@ -3842,7 +3859,21 @@ void notcurses_s7_init(s7_scheme *sc) nc_int(CELL_ALPHA_TRANSPARENT); nc_int(CELL_ALPHA_BLEND); nc_int(CELL_ALPHA_OPAQUE); - +#else + nc_int(NC_BGDEFAULT_MASK); + nc_int(NC_FGDEFAULT_MASK); + nc_int(NC_BG_RGB_MASK); + nc_int(NC_FG_RGB_MASK); + nc_int(NC_BG_PALETTE); + nc_int(NC_FG_PALETTE); + nc_int(NC_BG_ALPHA_MASK); + nc_int(NC_FG_ALPHA_MASK); + + nc_int(NCALPHA_HIGHCONTRAST); + nc_int(NCALPHA_TRANSPARENT); + nc_int(NCALPHA_BLEND); + nc_int(NCALPHA_OPAQUE); +#endif nc_int(NCPLANE_OPTION_HORALIGNED); nc_int(NCSTYLE_MASK); @@ -3993,7 +4024,11 @@ void notcurses_s7_init(s7_scheme *sc) nc_func(ncdirect_palette_size, 1, 0, false); nc_func(ncdirect_flush, 1, 0, false); nc_func(ncdirect_inputready_fd, 1, 0, false); +#if (NC_CURRENT_VERSION >= NC_VERSION(2, 3, 12)) + nc_func(ncdirect_get, 3, 0, false); +#else nc_func(ncdirect_getc, 4, 0, false); +#endif nc_func(ncdirect_dim_x, 1, 0, false); nc_func(ncdirect_dim_y, 1, 0, false); nc_func(ncdirect_cursor_enable, 1, 0, false); @@ -4064,7 +4099,11 @@ void notcurses_s7_init(s7_scheme *sc) nc_func(notcurses_stdplane_const, 1, 0, false); nc_func(notcurses_cursor_enable, 3, 0, false); nc_func(notcurses_cursor_disable, 1, 0, false); +#if (NC_CURRENT_VERSION >= NC_VERSION(2, 3, 12)) + nc_func(notcurses_get, 3, 0, false); +#else nc_func(notcurses_getc, 4, 0, false); +#endif nc_func(notcurses_refresh, 1, 0, false); nc_func(notcurses_at_yx, 5, 0, false); nc_func(notcurses_lex_margins, 2, 0, false); @@ -4422,7 +4461,6 @@ void notcurses_s7_init(s7_scheme *sc) nc_func(ncvisual_from_plane, 6, 0, false); nc_func(ncvisual_destroy, 1, 0, false); nc_func(ncvisual_decode, 1, 0, false); - nc_func(ncvisual_subtitle, 1, 0, false); nc_func(ncvisual_rotate, 2, 0, false); nc_func(ncvisual_resize, 3, 0, false); nc_func(ncvisual_polyfill_yx, 4, 0, false); diff --git a/nrepl-bits.h b/nrepl-bits.h index 1fbe59f..42fb206 100644 --- a/nrepl-bits.h +++ b/nrepl-bits.h @@ -18,11 +18,17 @@ unsigned char nrepl_scm[] = { 0x28, 0x75, 0x6e, 0x6c, 0x65, 0x73, 0x73, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x64, 0x3f, 0x20, 0x27, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x73, 0x74, 0x79, 0x6c, 0x65, 0x6d, 0x61, 0x73, 0x6b, 0x29, 0x20, 0x20, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x73, 0x74, 0x79, 0x6c, 0x65, 0x6d, 0x61, 0x73, 0x6b, 0x20, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x73, 0x74, 0x79, 0x6c, 0x65, 0x6d, 0x61, 0x73, 0x6b, 0x29, 0x29, 0xa, 0x28, 0x75, 0x6e, 0x6c, 0x65, 0x73, 0x73, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x64, 0x3f, 0x20, 0x27, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x73, 0x5f, 0x64, 0x6f, 0x75, 0x62, 0x6c, 0x65, 0x5f, 0x62, 0x6f, 0x78, 0x29, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x73, 0x5f, 0x64, 0x6f, 0x75, 0x62, 0x6c, 0x65, 0x5f, 0x62, 0x6f, 0x78, 0x20, 0x63, 0x65, 0x6c, 0x6c, 0x73, 0x5f, 0x64, 0x6f, 0x75, 0x62, 0x6c, 0x65, 0x5f, 0x62, 0x6f, 0x78, 0x29, 0x29, 0xa, 0xa, + 0x28, 0x75, 0x6e, 0x6c, 0x65, 0x73, 0x73, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x64, 0x3f, 0x20, 0x27, 0x43, 0x45, 0x4c, 0x4c, 0x5f, 0x46, 0x47, 0x44, 0x45, 0x46, 0x41, 0x55, 0x4c, 0x54, 0x5f, 0x4d, 0x41, 0x53, 0x4b, 0x29, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x43, 0x45, 0x4c, 0x4c, 0x5f, 0x46, 0x47, 0x44, 0x45, 0x46, 0x41, 0x55, 0x4c, 0x54, 0x5f, 0x4d, 0x41, 0x53, 0x4b, 0x20, 0x4e, 0x43, 0x5f, 0x46, 0x47, 0x44, 0x45, 0x46, 0x41, 0x55, 0x4c, 0x54, 0x5f, 0x4d, 0x41, 0x53, 0x4b, 0x29, 0x29, 0xa, + 0x28, 0x75, 0x6e, 0x6c, 0x65, 0x73, 0x73, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x64, 0x3f, 0x20, 0x27, 0x43, 0x45, 0x4c, 0x4c, 0x5f, 0x42, 0x47, 0x44, 0x45, 0x46, 0x41, 0x55, 0x4c, 0x54, 0x5f, 0x4d, 0x41, 0x53, 0x4b, 0x29, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x43, 0x45, 0x4c, 0x4c, 0x5f, 0x42, 0x47, 0x44, 0x45, 0x46, 0x41, 0x55, 0x4c, 0x54, 0x5f, 0x4d, 0x41, 0x53, 0x4b, 0x20, 0x4e, 0x43, 0x5f, 0x42, 0x47, 0x44, 0x45, 0x46, 0x41, 0x55, 0x4c, 0x54, 0x5f, 0x4d, 0x41, 0x53, 0x4b, 0x29, 0x29, 0xa, + 0xa, + 0x28, 0x75, 0x6e, 0x6c, 0x65, 0x73, 0x73, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x64, 0x3f, 0x20, 0x27, 0x6e, 0x6f, 0x74, 0x63, 0x75, 0x72, 0x73, 0x65, 0x73, 0x5f, 0x67, 0x65, 0x74, 0x63, 0x29, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x6e, 0x6f, 0x74, 0x63, 0x75, 0x72, 0x73, 0x65, 0x73, 0x5f, 0x67, 0x65, 0x74, 0x63, 0x20, 0x61, 0x20, 0x62, 0x20, 0x63, 0x20, 0x64, 0x29, 0x20, 0x28, 0x6e, 0x6f, 0x74, 0x63, 0x75, 0x72, 0x73, 0x65, 0x73, 0x5f, 0x67, 0x65, 0x74, 0x20, 0x61, 0x20, 0x62, 0x20, 0x64, 0x29, 0x29, 0x29, 0xa, + 0xa, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x64, 0x72, 0x6f, 0x70, 0x2d, 0x69, 0x6e, 0x74, 0x6f, 0x2d, 0x72, 0x65, 0x70, 0x6c, 0x20, 0x63, 0x61, 0x6c, 0x6c, 0x20, 0x65, 0x29, 0xa, 0x20, 0x20, 0x28, 0x28, 0x2a, 0x6e, 0x72, 0x65, 0x70, 0x6c, 0x2a, 0x20, 0x27, 0x72, 0x75, 0x6e, 0x29, 0x20, 0x22, 0x62, 0x72, 0x65, 0x61, 0x6b, 0x3e, 0x22, 0x20, 0x28, 0x6f, 0x62, 0x6a, 0x65, 0x63, 0x74, 0x2d, 0x3e, 0x73, 0x74, 0x72, 0x69, 0x6e, 0x67, 0x20, 0x63, 0x61, 0x6c, 0x6c, 0x29, 0x20, 0x65, 0x29, 0x29, 0xa, 0xa, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x64, 0x69, 0x73, 0x70, 0x6c, 0x61, 0x79, 0x2d, 0x64, 0x65, 0x62, 0x75, 0x67, 0x2d, 0x69, 0x6e, 0x66, 0x6f, 0x20, 0x63, 0x69, 0x6e, 0x74, 0x29, 0x20, 0x23, 0x66, 0x29, 0x20, 0x3b, 0x20, 0x72, 0x65, 0x70, 0x6c, 0x61, 0x63, 0x65, 0x64, 0x20, 0x6c, 0x61, 0x74, 0x65, 0x72, 0xa, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x72, 0x65, 0x6d, 0x6f, 0x76, 0x65, 0x2d, 0x77, 0x61, 0x74, 0x63, 0x68, 0x65, 0x72, 0x20, 0x76, 0x61, 0x72, 0x29, 0x20, 0x23, 0x66, 0x29, 0xa, + 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x6e, 0x72, 0x65, 0x70, 0x6c, 0x2d, 0x6c, 0x6f, 0x6f, 0x6b, 0x75, 0x70, 0x20, 0x73, 0x79, 0x6d, 0x62, 0x6f, 0x6c, 0x29, 0x20, 0x28, 0x28, 0x28, 0x2a, 0x6e, 0x72, 0x65, 0x70, 0x6c, 0x2a, 0x20, 0x27, 0x74, 0x6f, 0x70, 0x2d, 0x6c, 0x65, 0x76, 0x65, 0x6c, 0x2d, 0x6c, 0x65, 0x74, 0x29, 0x20, 0x27, 0x72, 0x75, 0x6e, 0x2d, 0x6c, 0x65, 0x74, 0x29, 0x20, 0x73, 0x79, 0x6d, 0x62, 0x6f, 0x6c, 0x29, 0x29, 0xa, 0xa, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x64, 0x65, 0x62, 0x75, 0x67, 0x2e, 0x73, 0x63, 0x6d, 0x2d, 0x69, 0x6e, 0x69, 0x74, 0x29, 0xa, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x64, 0x65, 0x62, 0x75, 0x67, 0x2d, 0x72, 0x65, 0x70, 0x6c, 0x29, 0xa, @@ -78,6 +84,7 @@ unsigned char nrepl_scm[] = { 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x3a, 0x6e, 0x63, 0x70, 0x2d, 0x6c, 0x65, 0x74, 0x20, 0x23, 0x66, 0xa, 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x3a, 0x64, 0x69, 0x73, 0x70, 0x6c, 0x61, 0x79, 0x2d, 0x73, 0x74, 0x61, 0x74, 0x75, 0x73, 0x20, 0x23, 0x66, 0xa, 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x3a, 0x73, 0x74, 0x61, 0x74, 0x75, 0x73, 0x2d, 0x74, 0x65, 0x78, 0x74, 0x20, 0x22, 0x22, 0xa, + 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x3a, 0x72, 0x75, 0x6e, 0x2d, 0x6c, 0x65, 0x74, 0x20, 0x23, 0x66, 0xa, 0xa, 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x3a, 0x73, 0x37, 0x2d, 0x76, 0x65, 0x72, 0x73, 0x69, 0x6f, 0x6e, 0x20, 0x28, 0x6c, 0x61, 0x6d, 0x62, 0x64, 0x61, 0x20, 0x28, 0x29, 0x20, 0x28, 0x2a, 0x73, 0x37, 0x2a, 0x20, 0x27, 0x76, 0x65, 0x72, 0x73, 0x69, 0x6f, 0x6e, 0x29, 0x29, 0xa, 0xa, @@ -345,6 +352,7 @@ unsigned char nrepl_scm[] = { 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x69, 0x66, 0x20, 0x28, 0x61, 0x6e, 0x64, 0x20, 0x77, 0x63, 0x20, 0x28, 0x3d, 0x20, 0x79, 0x20, 0x28, 0x2b, 0x20, 0x77, 0x61, 0x74, 0x63, 0x68, 0x2d, 0x72, 0x6f, 0x77, 0x20, 0x31, 0x29, 0x29, 0x29, 0xa, 0x9, 0x9, 0x9, 0x9, 0x9, 0x20, 0x28, 0x6d, 0x69, 0x6e, 0x20, 0x28, 0x2d, 0x20, 0x77, 0x61, 0x74, 0x63, 0x68, 0x2d, 0x63, 0x6f, 0x6c, 0x20, 0x31, 0x29, 0x20, 0x28, 0x2b, 0x20, 0x78, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x63, 0x6f, 0x6c, 0x29, 0x29, 0xa, 0x9, 0x9, 0x9, 0x9, 0x9, 0x20, 0x28, 0x2b, 0x20, 0x78, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x63, 0x6f, 0x6c, 0x29, 0x29, 0x29, 0x29, 0xa, + 0x9, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x74, 0x6f, 0x70, 0x2d, 0x6c, 0x65, 0x76, 0x65, 0x6c, 0x2d, 0x6c, 0x65, 0x74, 0x20, 0x3a, 0x72, 0x75, 0x6e, 0x2d, 0x6c, 0x65, 0x74, 0x29, 0x20, 0x28, 0x63, 0x75, 0x72, 0x6c, 0x65, 0x74, 0x29, 0x29, 0xa, 0x9, 0x20, 0x20, 0x28, 0x77, 0x68, 0x65, 0x6e, 0x20, 0x68, 0x65, 0x61, 0x64, 0x65, 0x72, 0xa, 0x9, 0x20, 0x20, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x68, 0x63, 0x2d, 0x63, 0x65, 0x6c, 0x6c, 0x73, 0x20, 0x28, 0x76, 0x65, 0x63, 0x74, 0x6f, 0x72, 0x20, 0x28, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x6d, 0x61, 0x6b, 0x65, 0x29, 0x20, 0x28, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x6d, 0x61, 0x6b, 0x65, 0x29, 0x20, 0x28, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x6d, 0x61, 0x6b, 0x65, 0x29, 0x20, 0x28, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x6d, 0x61, 0x6b, 0x65, 0x29, 0x20, 0x28, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x6d, 0x61, 0x6b, 0x65, 0x29, 0x20, 0x28, 0x6e, 0x63, 0x63, 0x65, 0x6c, 0x6c, 0x5f, 0x6d, 0x61, 0x6b, 0x65, 0x29, 0x29, 0x29, 0xa, 0x9, 0x20, 0x20, 0x20, 0x20, 0x28, 0x6c, 0x65, 0x74, 0x20, 0x28, 0x28, 0x6e, 0x65, 0x77, 0x6c, 0x69, 0x6e, 0x65, 0x2d, 0x70, 0x6f, 0x73, 0x20, 0x28, 0x63, 0x68, 0x61, 0x72, 0x2d, 0x70, 0x6f, 0x73, 0x69, 0x74, 0x69, 0x6f, 0x6e, 0x20, 0x23, 0x5c, 0x6e, 0x65, 0x77, 0x6c, 0x69, 0x6e, 0x65, 0x20, 0x68, 0x65, 0x61, 0x64, 0x65, 0x72, 0x29, 0x29, 0x29, 0xa, @@ -977,7 +985,7 @@ unsigned char nrepl_scm[] = { 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x70, 0x72, 0x65, 0x76, 0x69, 0x6f, 0x75, 0x73, 0x6c, 0x79, 0x2d, 0x73, 0x65, 0x6c, 0x65, 0x63, 0x74, 0x65, 0x64, 0x20, 0x23, 0x66, 0x29, 0xa, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x6a, 0x75, 0x73, 0x74, 0x2d, 0x73, 0x65, 0x6c, 0x65, 0x63, 0x74, 0x65, 0x64, 0x20, 0x23, 0x66, 0x29, 0xa, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x63, 0x6f, 0x6e, 0x74, 0x72, 0x6f, 0x6c, 0x2d, 0x6b, 0x65, 0x79, 0x20, 0x28, 0x61, 0x73, 0x68, 0x20, 0x31, 0x20, 0x33, 0x33, 0x29, 0x29, 0xa, - 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x6d, 0x65, 0x74, 0x61, 0x2d, 0x6b, 0x65, 0x79, 0x20, 0x28, 0x61, 0x73, 0x68, 0x20, 0x31, 0x20, 0x33, 0x34, 0x29, 0x29, 0x29, 0x20, 0x20, 0x20, 0x20, 0x3b, 0x20, 0x6e, 0x6f, 0x74, 0x63, 0x75, 0x72, 0x73, 0x65, 0x73, 0x20, 0x67, 0x65, 0x74, 0x63, 0x20, 0x72, 0x65, 0x74, 0x75, 0x72, 0x6e, 0x73, 0x20, 0x33, 0x32, 0x20, 0x62, 0x69, 0x74, 0x73, 0xa, + 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x6d, 0x65, 0x74, 0x61, 0x2d, 0x6b, 0x65, 0x79, 0x20, 0x28, 0x61, 0x73, 0x68, 0x20, 0x31, 0x20, 0x33, 0x34, 0x29, 0x29, 0x29, 0x20, 0x20, 0x20, 0x20, 0x3b, 0x20, 0x6e, 0x6f, 0x74, 0x63, 0x75, 0x72, 0x73, 0x65, 0x73, 0x20, 0x67, 0x65, 0x74, 0x20, 0x72, 0x65, 0x74, 0x75, 0x72, 0x6e, 0x73, 0x20, 0x33, 0x32, 0x20, 0x62, 0x69, 0x74, 0x73, 0xa, 0xa, 0x9, 0x9, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x74, 0x6f, 0x70, 0x2d, 0x6c, 0x65, 0x76, 0x65, 0x6c, 0x2d, 0x6c, 0x65, 0x74, 0x20, 0x27, 0x6e, 0x63, 0x70, 0x2d, 0x6c, 0x65, 0x74, 0x29, 0x20, 0x28, 0x63, 0x75, 0x72, 0x6c, 0x65, 0x74, 0x29, 0x29, 0xa, 0x9, 0x9, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x64, 0x69, 0x73, 0x70, 0x6c, 0x61, 0x79, 0x2d, 0x64, 0x65, 0x62, 0x75, 0x67, 0x2d, 0x69, 0x6e, 0x66, 0x6f, 0x20, 0x6c, 0x6f, 0x63, 0x61, 0x6c, 0x2d, 0x64, 0x65, 0x62, 0x75, 0x67, 0x2d, 0x69, 0x6e, 0x66, 0x6f, 0x29, 0xa, @@ -1170,7 +1178,7 @@ unsigned char nrepl_scm[] = { 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x6a, 0x75, 0x73, 0x74, 0x2d, 0x73, 0x65, 0x6c, 0x65, 0x63, 0x74, 0x65, 0x64, 0x20, 0x23, 0x74, 0x29, 0x29, 0x29, 0xa, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x63, 0x68, 0x61, 0x72, 0x2d, 0x73, 0x65, 0x70, 0x61, 0x72, 0x61, 0x74, 0x6f, 0x72, 0x3f, 0x20, 0x63, 0x29, 0xa, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x63, 0x68, 0x61, 0x72, 0x2d, 0x70, 0x6f, 0x73, 0x69, 0x74, 0x69, 0x6f, 0x6e, 0x20, 0x63, 0x20, 0x22, 0x20, 0x28, 0x29, 0x60, 0x27, 0x2c, 0x5c, 0x22, 0x23, 0x22, 0x29, 0x29, 0xa, - 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x77, 0x6f, 0x72, 0x64, 0x2d, 0x62, 0x61, 0x63, 0x6b, 0x2d, 0x78, 0x29, 0xa, + 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x64, 0x65, 0x66, 0x69, 0x6e, 0x65, 0x20, 0x28, 0x77, 0x6f, 0x72, 0x64, 0x2d, 0x62, 0x61, 0x63, 0x6b, 0x2d, 0x78, 0x29, 0x20, 0x3b, 0x3b, 0x20, 0x73, 0x6f, 0x6d, 0x65, 0x20, 0x6f, 0x66, 0x20, 0x74, 0x68, 0x65, 0x73, 0x65, 0x20, 0x61, 0x72, 0x65, 0x20, 0x63, 0x6f, 0x75, 0x72, 0x74, 0x65, 0x73, 0x79, 0x20, 0x6f, 0x66, 0x20, 0x45, 0x6c, 0x69, 0x6a, 0x61, 0x68, 0x20, 0x53, 0x74, 0x6f, 0x6e, 0x65, 0xa, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x6c, 0x65, 0x74, 0x20, 0x6c, 0x6f, 0x6f, 0x70, 0x20, 0x28, 0x28, 0x63, 0x6f, 0x6c, 0x20, 0x28, 0x6d, 0x61, 0x78, 0x20, 0x28, 0x62, 0x6f, 0x6c, 0x73, 0x20, 0x72, 0x6f, 0x77, 0x29, 0x20, 0x28, 0x2d, 0x20, 0x63, 0x6f, 0x6c, 0x20, 0x31, 0x29, 0x29, 0x29, 0x29, 0xa, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x69, 0x66, 0x20, 0x28, 0x3d, 0x20, 0x63, 0x6f, 0x6c, 0x20, 0x28, 0x62, 0x6f, 0x6c, 0x73, 0x20, 0x72, 0x6f, 0x77, 0x29, 0x29, 0xa, 0x9, 0x9, 0x9, 0x20, 0x20, 0x63, 0x6f, 0x6c, 0xa, @@ -1355,14 +1363,14 @@ unsigned char nrepl_scm[] = { 0x9, 0x9, 0x9, 0x9, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x62, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x63, 0x6f, 0x70, 0x79, 0x20, 0x62, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x6d, 0x61, 0x6b, 0x65, 0x2d, 0x69, 0x6e, 0x74, 0x2d, 0x76, 0x65, 0x63, 0x74, 0x6f, 0x72, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x72, 0x6f, 0x77, 0x73, 0x29, 0x29, 0x29, 0xa, 0x9, 0x9, 0x9, 0x9, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x63, 0x6f, 0x70, 0x79, 0x20, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x6d, 0x61, 0x6b, 0x65, 0x2d, 0x69, 0x6e, 0x74, 0x2d, 0x76, 0x65, 0x63, 0x74, 0x6f, 0x72, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x72, 0x6f, 0x77, 0x73, 0x29, 0x29, 0x29, 0x29, 0xa, 0xa, - 0x9, 0x9, 0x9, 0x9, 0x28, 0x64, 0x6f, 0x20, 0x28, 0x28, 0x69, 0x20, 0x28, 0x2b, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x6d, 0x61, 0x78, 0x2d, 0x72, 0x6f, 0x77, 0x20, 0x31, 0x29, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x29, 0x29, 0xa, - 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x28, 0x28, 0x3d, 0x20, 0x69, 0x20, 0x28, 0x2b, 0x20, 0x72, 0x6f, 0x77, 0x20, 0x31, 0x29, 0x29, 0xa, - 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x6d, 0x61, 0x78, 0x2d, 0x72, 0x6f, 0x77, 0x20, 0x28, 0x2b, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x6d, 0x61, 0x78, 0x2d, 0x72, 0x6f, 0x77, 0x20, 0x31, 0x29, 0x29, 0x29, 0xa, - 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x28, 0x6c, 0x65, 0x74, 0x20, 0x28, 0x28, 0x63, 0x6f, 0x6e, 0x74, 0x65, 0x6e, 0x74, 0x73, 0x20, 0x28, 0x6e, 0x63, 0x70, 0x6c, 0x61, 0x6e, 0x65, 0x5f, 0x63, 0x6f, 0x6e, 0x74, 0x65, 0x6e, 0x74, 0x73, 0x20, 0x6e, 0x63, 0x70, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x20, 0x30, 0x20, 0x31, 0x20, 0x28, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x29, 0x29, 0x29, 0x29, 0xa, - 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x28, 0x63, 0x6c, 0x65, 0x61, 0x72, 0x2d, 0x6c, 0x69, 0x6e, 0x65, 0x20, 0x69, 0x29, 0xa, - 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x28, 0x6e, 0x63, 0x2d, 0x64, 0x69, 0x73, 0x70, 0x6c, 0x61, 0x79, 0x20, 0x69, 0x20, 0x30, 0x20, 0x63, 0x6f, 0x6e, 0x74, 0x65, 0x6e, 0x74, 0x73, 0x29, 0x29, 0x20, 0x3b, 0x20, 0x73, 0x68, 0x6f, 0x75, 0x6c, 0x64, 0x20, 0x74, 0x68, 0x69, 0x73, 0x20, 0x62, 0x65, 0x20, 0x69, 0x6e, 0x64, 0x65, 0x6e, 0x74, 0x65, 0x64, 0x3f, 0xa, - 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x69, 0x29, 0x20, 0x28, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x29, 0x29, 0xa, - 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x62, 0x6f, 0x6c, 0x73, 0x20, 0x69, 0x29, 0x20, 0x28, 0x62, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x29, 0x29, 0x29, 0x29, 0xa, + 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x28, 0x64, 0x6f, 0x20, 0x28, 0x28, 0x69, 0x20, 0x28, 0x2b, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x6d, 0x61, 0x78, 0x2d, 0x72, 0x6f, 0x77, 0x20, 0x31, 0x29, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x29, 0x29, 0xa, + 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x28, 0x28, 0x3d, 0x20, 0x69, 0x20, 0x28, 0x2b, 0x20, 0x72, 0x6f, 0x77, 0x20, 0x31, 0x29, 0x29, 0xa, + 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x6d, 0x61, 0x78, 0x2d, 0x72, 0x6f, 0x77, 0x20, 0x28, 0x2b, 0x20, 0x6e, 0x63, 0x70, 0x2d, 0x6d, 0x61, 0x78, 0x2d, 0x72, 0x6f, 0x77, 0x20, 0x31, 0x29, 0x29, 0x29, 0xa, + 0x9, 0x9, 0x9, 0x9, 0x28, 0x6c, 0x65, 0x74, 0x20, 0x28, 0x28, 0x63, 0x6f, 0x6e, 0x74, 0x65, 0x6e, 0x74, 0x73, 0x20, 0x28, 0x6e, 0x63, 0x70, 0x6c, 0x61, 0x6e, 0x65, 0x5f, 0x63, 0x6f, 0x6e, 0x74, 0x65, 0x6e, 0x74, 0x73, 0x20, 0x6e, 0x63, 0x70, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x20, 0x30, 0x20, 0x31, 0x20, 0x28, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x29, 0x29, 0x29, 0x29, 0xa, + 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x28, 0x63, 0x6c, 0x65, 0x61, 0x72, 0x2d, 0x6c, 0x69, 0x6e, 0x65, 0x20, 0x69, 0x29, 0xa, + 0x9, 0x9, 0x9, 0x9, 0x20, 0x20, 0x28, 0x6e, 0x63, 0x2d, 0x64, 0x69, 0x73, 0x70, 0x6c, 0x61, 0x79, 0x20, 0x69, 0x20, 0x30, 0x20, 0x63, 0x6f, 0x6e, 0x74, 0x65, 0x6e, 0x74, 0x73, 0x29, 0x29, 0x20, 0x3b, 0x20, 0x73, 0x68, 0x6f, 0x75, 0x6c, 0x64, 0x20, 0x74, 0x68, 0x69, 0x73, 0x20, 0x62, 0x65, 0x20, 0x69, 0x6e, 0x64, 0x65, 0x6e, 0x74, 0x65, 0x64, 0x3f, 0xa, + 0x9, 0x9, 0x9, 0x9, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x69, 0x29, 0x20, 0x28, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x29, 0x29, 0xa, + 0x9, 0x9, 0x9, 0x9, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x62, 0x6f, 0x6c, 0x73, 0x20, 0x69, 0x29, 0x20, 0x28, 0x62, 0x6f, 0x6c, 0x73, 0x20, 0x28, 0x2d, 0x20, 0x69, 0x20, 0x31, 0x29, 0x29, 0x29, 0x29, 0x29, 0xa, 0xa, 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x28, 0x6e, 0x63, 0x2d, 0x64, 0x69, 0x73, 0x70, 0x6c, 0x61, 0x79, 0x20, 0x72, 0x6f, 0x77, 0x20, 0x63, 0x6f, 0x6c, 0x20, 0x28, 0x6d, 0x61, 0x6b, 0x65, 0x2d, 0x73, 0x74, 0x72, 0x69, 0x6e, 0x67, 0x20, 0x28, 0x2d, 0x20, 0x28, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x72, 0x6f, 0x77, 0x29, 0x20, 0x63, 0x6f, 0x6c, 0x29, 0x20, 0x23, 0x5c, 0x73, 0x70, 0x61, 0x63, 0x65, 0x29, 0x29, 0xa, 0x9, 0x9, 0x9, 0x20, 0x20, 0x20, 0x20, 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x65, 0x6f, 0x6c, 0x73, 0x20, 0x72, 0x6f, 0x77, 0x29, 0x20, 0x63, 0x6f, 0x6c, 0x29, 0xa, @@ -1720,7 +1728,9 @@ unsigned char nrepl_scm[] = { 0xa, 0x20, 0x20, 0x28, 0x77, 0x69, 0x74, 0x68, 0x2d, 0x6c, 0x65, 0x74, 0x20, 0x2a, 0x6e, 0x72, 0x65, 0x70, 0x6c, 0x2a, 0xa, 0x20, 0x20, 0x20, 0x20, 0x28, 0x73, 0x74, 0x61, 0x72, 0x74, 0x29, 0xa, - 0x20, 0x20, 0x20, 0x20, 0x28, 0x72, 0x75, 0x6e, 0x29, 0xa, + 0x20, 0x20, 0x20, 0x20, 0x28, 0x69, 0x66, 0x20, 0x28, 0x73, 0x74, 0x72, 0x69, 0x6e, 0x67, 0x3d, 0x3f, 0x20, 0x28, 0x6e, 0x6f, 0x74, 0x63, 0x75, 0x72, 0x73, 0x65, 0x73, 0x5f, 0x76, 0x65, 0x72, 0x73, 0x69, 0x6f, 0x6e, 0x29, 0x20, 0x22, 0x32, 0x2e, 0x33, 0x2e, 0x31, 0x37, 0x22, 0x29, 0xa, + 0x9, 0x28, 0x72, 0x75, 0x6e, 0x20, 0x22, 0x3e, 0x22, 0x20, 0x22, 0x76, 0x65, 0x72, 0x73, 0x69, 0x6f, 0x6e, 0x20, 0x32, 0x2e, 0x33, 0x2e, 0x31, 0x37, 0x20, 0x6e, 0x65, 0x65, 0x64, 0x73, 0x20, 0x74, 0x68, 0x69, 0x73, 0x20, 0x68, 0x65, 0x61, 0x64, 0x65, 0x72, 0x21, 0x22, 0x29, 0x20, 0x3b, 0x20, 0x73, 0x75, 0x72, 0x65, 0x6c, 0x79, 0x20, 0x74, 0x68, 0x69, 0x73, 0x20, 0x69, 0x73, 0x20, 0x61, 0x20, 0x62, 0x75, 0x67, 0x21, 0xa, + 0x9, 0x28, 0x72, 0x75, 0x6e, 0x29, 0x29, 0xa, 0x20, 0x20, 0x20, 0x20, 0x28, 0x73, 0x74, 0x6f, 0x70, 0x29, 0x29, 0x29, 0xa, 0xa, 0x3b, 0x3b, 0x20, 0x73, 0x65, 0x6c, 0x65, 0x63, 0x74, 0x69, 0x6f, 0x6e, 0x20, 0x28, 0x62, 0x6f, 0x74, 0x68, 0x20, 0x77, 0x61, 0x79, 0x73, 0x29, 0x3a, 0xa, @@ -1741,4 +1751,4 @@ unsigned char nrepl_scm[] = { 0x28, 0x73, 0x65, 0x74, 0x21, 0x20, 0x28, 0x2a, 0x73, 0x37, 0x2a, 0x20, 0x27, 0x64, 0x65, 0x62, 0x75, 0x67, 0x29, 0x20, 0x6f, 0x6c, 0x64, 0x2d, 0x64, 0x65, 0x62, 0x75, 0x67, 0x29, 0xa, 0x2a, 0x6e, 0x72, 0x65, 0x70, 0x6c, 0x2a, 0xa, 0}; -unsigned int nrepl_scm_len = 65637; +unsigned int nrepl_scm_len = 66199; @@ -324,9 +324,10 @@ static int nrepl(s7_scheme *sc) return(0); } fprintf(stderr, "load %s\n", argv[1]); + errno = 0; if (!s7_load(sc, argv[1])) { - fprintf(stderr, "can't load %s\n", argv[1]); + fprintf(stderr, "%s: %s\n", strerror(errno), argv[1]); return(2); } } @@ -17,11 +17,17 @@ (unless (defined? 'nccell_stylemask) (define nccell_stylemask cell_stylemask)) (unless (defined? 'nccells_double_box) (define nccells_double_box cells_double_box)) +(unless (defined? 'CELL_FGDEFAULT_MASK) (define CELL_FGDEFAULT_MASK NC_FGDEFAULT_MASK)) +(unless (defined? 'CELL_BGDEFAULT_MASK) (define CELL_BGDEFAULT_MASK NC_BGDEFAULT_MASK)) + +(unless (defined? 'notcurses_getc) (define (notcurses_getc a b c d) (notcurses_get a b d))) + (define (drop-into-repl call e) ((*nrepl* 'run) "break>" (object->string call) e)) (define (display-debug-info cint) #f) ; replaced later (define (remove-watcher var) #f) +(define (nrepl-lookup symbol) (((*nrepl* 'top-level-let) 'run-let) symbol)) (define (debug.scm-init) (set! (debug-repl) @@ -77,6 +83,7 @@ :ncp-let #f :display-status #f :status-text "" + :run-let #f :s7-version (lambda () (*s7* 'version)) @@ -344,6 +351,7 @@ (if (and wc (= y (+ watch-row 1))) (min (- watch-col 1) (+ x ncp-col)) (+ x ncp-col)))) + (set! (top-level-let :run-let) (curlet)) (when header (set! hc-cells (vector (nccell_make) (nccell_make) (nccell_make) (nccell_make) (nccell_make) (nccell_make))) (let ((newline-pos (char-position #\newline header))) @@ -976,7 +984,7 @@ (previously-selected #f) (just-selected #f) (control-key (ash 1 33)) - (meta-key (ash 1 34))) ; notcurses getc returns 32 bits + (meta-key (ash 1 34))) ; notcurses get returns 32 bits (set! (top-level-let 'ncp-let) (curlet)) (set! display-debug-info local-debug-info) @@ -1169,7 +1177,7 @@ (set! just-selected #t))) (define (char-separator? c) (char-position c " ()`',\"#")) - (define (word-back-x) + (define (word-back-x) ;; some of these are courtesy of Elijah Stone (let loop ((col (max (bols row) (- col 1)))) (if (= col (bols row)) col @@ -1354,14 +1362,14 @@ (set! bols (copy bols (make-int-vector ncp-rows))) (set! eols (copy eols (make-int-vector ncp-rows)))) - (do ((i (+ ncp-max-row 1) (- i 1))) - ((= i (+ row 1)) - (set! ncp-max-row (+ ncp-max-row 1))) - (let ((contents (ncplane_contents ncp (- i 1) 0 1 (eols (- i 1))))) - (clear-line i) - (nc-display i 0 contents)) ; should this be indented? - (set! (eols i) (eols (- i 1))) - (set! (bols i) (bols (- i 1))))) + (do ((i (+ ncp-max-row 1) (- i 1))) + ((= i (+ row 1)) + (set! ncp-max-row (+ ncp-max-row 1))) + (let ((contents (ncplane_contents ncp (- i 1) 0 1 (eols (- i 1))))) + (clear-line i) + (nc-display i 0 contents)) ; should this be indented? + (set! (eols i) (eols (- i 1))) + (set! (bols i) (bols (- i 1))))) (nc-display row col (make-string (- (eols row) col) #\space)) (set! (eols row) col) @@ -1719,7 +1727,9 @@ (with-let *nrepl* (start) - (run) + (if (string=? (notcurses_version) "2.3.17") + (run ">" "version 2.3.17 needs this header!") ; surely this is a bug! 2.3.13 seems to be ok + (run)) (stop))) ;; selection (both ways): @@ -97,8 +97,7 @@ (define (close-port p) ((if (input-port? p) close-input-port close-output-port) p)) (define open-binary-input-file open-input-file) (define open-binary-output-file open-output-file) -(define (call-with-port port proc) ((if (input-port? port) call-with-input-file call-with-output-file) port proc)) - +(define (call-with-port port proc) (let ((res (proc port))) (if res (close-port port)) res)) (define bytevector-u8-ref byte-vector-ref) (define bytevector-u8-set! byte-vector-set!) @@ -66,9 +66,10 @@ int main(int argc, char **argv) return(0); } fprintf(stderr, "load %s\n", argv[1]); /* repl test.scm */ + errno = 0; if (!s7_load(sc, argv[1])) { - fprintf(stderr, "can't load %s\n", argv[1]); + fprintf(stderr, "%s: %s\n", strerror(errno), argv[1]); return(2); } } @@ -259,6 +259,11 @@ /* debugging aid if using s7 in a multithreaded program -- this code courtesy of Kjetil Matheussen */ #endif +#ifndef WITH_WARNINGS + #define WITH_WARNINGS 0 + /* int+int overflows to real, etc: this adds warnings which are expensive even though they are never called (procedure overhead) */ +#endif + #ifndef S7_DEBUGGING #define S7_DEBUGGING 0 #endif @@ -435,8 +440,8 @@ typedef intptr_t opcode_t; #define WRITE_REAL_PRECISION 16 typedef long double long_double; -#define print_s7_int PRId64 -#define print_pointer PRIdPTR +#define ld64 PRId64 +#define p64 PRIdPTR #define MAX_FLOAT_FORMAT_PRECISION 128 @@ -966,8 +971,8 @@ typedef struct s7_cell { struct { /* additional object types (C) */ s7_int type; - void *value; /* the value the caller associates with the c_object */ - s7_pointer e; /* the method list, if any (openlet) */ + void *value; /* the value the caller associates with the c_object */ + s7_pointer e; /* the method list, if any (openlet) */ s7_scheme *sc; } c_obj; @@ -1121,8 +1126,9 @@ struct s7_scheme { uint32_t gc_stats, gensym_counter, f_class, add_class, multiply_class, subtract_class, num_eq_class; int32_t format_column; uint64_t capture_let_counter; - bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments, got_tc, got_rec, not_tc; - s7_int rec_tc_args; + bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments, muffle_warnings; + bool got_tc, got_rec, not_tc; + s7_int rec_tc_args, continuation_counter; int64_t let_number; s7_double default_rationalize_error, equivalent_float_epsilon, hash_table_float_epsilon; s7_int default_hash_table_length, initial_string_port_length, print_length, objstr_max_len, history_size, true_history_size, output_port_data_size; @@ -1167,8 +1173,8 @@ struct s7_scheme { s7_int read_line_buf_size; s7_pointer u, v, w, x, y, z; /* evaluator local vars */ - s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, temp10, temp_cell_2; - s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, z2_1, z2_2, t4_1, u1_1; + s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, temp_cell_2; + s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, z2_1, z2_2, t4_1, u1_1, u2_1, u2_2; Jmp_Buf goto_start; bool longjmp_ok; @@ -1343,7 +1349,7 @@ struct s7_scheme { memq_2, memq_3, memq_4, memq_any, tree_set_memq_syms, simple_inlet, profile_out, lint_let_ref, lint_let_set, geq_2, add_i_random, is_defined_in_rootlet; - s7_pointer multiply_2, invert_1, invert_x, divide_2, divide_by_2, + s7_pointer multiply_2, invert_1, invert_x, divide_2, divide_by_2, max_2, min_2, max_3, min_3, num_eq_2, num_eq_xi, num_eq_ix, less_xi, less_xf, less_x0, less_2, greater_xi, greater_xf, greater_2, leq_xi, leq_2, leq_ixx, geq_xi, geq_xf, random_i, random_f, random_1, mul_2_ff, mul_2_ii, mul_2_if, mul_2_fi, mul_2_xi, mul_2_ix, mul_2_fx, mul_2_xf, @@ -1869,8 +1875,6 @@ static void init_types(void) #endif } -void s7_show_history(s7_scheme *sc); - #if WITH_HISTORY #define current_code(Sc) car(Sc->cur_code) #define set_current_code(Sc, Code) do {Sc->cur_code = cdr(Sc->cur_code); set_car(Sc->cur_code, T_Pos(Code));} while (0) @@ -2368,7 +2372,7 @@ void s7_show_history(s7_scheme *sc); #define T_NUMBER_NAME T_SAFE_STEPPER #define has_number_name(p) has_type_bit(T_Num(p), T_NUMBER_NAME) #define set_has_number_name(p) set_type_bit(T_Num(p), T_NUMBER_NAME) -/* marks numbers that have a saved version of their string representation */ +/* marks numbers that have a saved version of their string representation; this only matters in teq.scm, maybe tread.scm */ #define T_MAYBE_SAFE T_SAFE_STEPPER #define is_maybe_safe(p) has_type_bit(T_Fnc(p), T_MAYBE_SAFE) @@ -2448,10 +2452,18 @@ void s7_show_history(s7_scheme *sc); #define step_end_ok(p) has_type_bit(T_Pair(p), T_STEP_END_OK) #define set_step_end_ok(p) set_type_bit(T_Pair(p), T_STEP_END_OK) +#define T_IMPLICIT_SET_OK T_ITER_OK +#define implicit_set_ok(p) has_type_bit(T_Pair(p), T_IMPLICIT_SET_OK) +#define set_implicit_set_ok(p) set_type_bit(T_Pair(p), T_IMPLICIT_SET_OK) + #define T_IN_ROOTLET T_ITER_OK #define in_rootlet(p) has_type_bit(T_Slt(p), T_IN_ROOTLET) #define set_in_rootlet(p) set_type_bit(T_Slt(p), T_IN_ROOTLET) +#define T_BOOL_FUNCTION T_ITER_OK +#define is_bool_function(p) has_type_bit(T_Prc(p), T_BOOL_FUNCTION) +#define set_is_bool_function(p) set_type_bit(T_Fnc(p), T_BOOL_FUNCTION) + /* it's faster here to use the high_flag bits rather than typeflag bits */ #define BIT_ROOM 16 #define T_FULL_SYMCONS (1LL << (TYPE_BITS + BIT_ROOM + 24)) @@ -2541,9 +2553,9 @@ void s7_show_history(s7_scheme *sc); #define is_definer_or_binder(p) has_type1_bit(T_Sym(p), T_DEFINER | T_BINDER) /* this marks "binders" like let */ -#define T_SEMISAFE T_BINDER -#define is_semisafe(p) has_type1_bit(T_Fnc(p), T_SEMISAFE) -#define set_is_semisafe(p) set_type1_bit(T_Fnc(p), T_SEMISAFE) +#define T_SEMISAFE T_BINDER +#define is_semisafe(p) has_type1_bit(T_Fnc(p), T_SEMISAFE) +#define set_is_semisafe(p) set_type1_bit(T_Fnc(p), T_SEMISAFE) /* #define T_TREE_COLLECTED T_FULL_BINDER */ #define T_SHORT_TREE_COLLECTED T_BINDER @@ -2632,7 +2644,7 @@ void s7_show_history(s7_scheme *sc); #define is_safety_checked(p) has_type1_bit(T_Pair(p), T_SAFETY_CHECKED) #define set_safety_checked(p) set_type1_bit(T_Pair(p), T_SAFETY_CHECKED) -#define T_FULL_HAS_FN (1LL << (TYPE_BITS + BIT_ROOM + 36)) +#define T_FULL_HAS_FN (1LL << (TYPE_BITS + BIT_ROOM + 37)) #define T_HAS_FN (1 << 13) #define set_has_fn(p) set_type1_bit(T_Pair(p), T_HAS_FN) #define has_fn(p) has_type1_bit(T_Pair(p), T_HAS_FN) @@ -2984,7 +2996,7 @@ static void symbol_set_id(s7_pointer p, s7_int id) { if (id < symbol_id(p)) { - fprintf(stderr, "id mismatch: sym: %s %" print_s7_int ", let: %" print_s7_int "\n", symbol_name(p), symbol_id(p), id); + fprintf(stderr, "id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", symbol_name(p), symbol_id(p), id); abort(); } (T_Sym(p))->object.sym.id = id; @@ -3176,7 +3188,7 @@ static s7_pointer slot_expression(s7_pointer p) \ #define vector_offset(p, i) vdims_offsets(vector_dimension_info(p))[i] #define vector_offsets(p) vdims_offsets(vector_dimension_info(p)) #define vector_rank(p) ((vector_dimension_info(p)) ? vector_ndims(p) : 1) -#define vector_has_dimensional_info(p) (vector_dimension_info(p)) +#define vector_has_dimension_info(p) (vector_dimension_info(p)) #define subvector_vector(p) T_Vec(((vector_dimension_info(T_SVec(p))) ? vdims_original(vector_dimension_info(p)) : (p)->object.vector.block->nx.ksym)) #define subvector_set_vector(p, vect) (T_SVec(p))->object.vector.block->nx.ksym = T_Vec(vect) @@ -3194,8 +3206,6 @@ static s7_pointer slot_expression(s7_pointer p) \ #define stack_clear_flags(p) (T_Stk(p))->object.stk.flags = 0 #define stack_has_pairs(p) (((T_Stk(p))->object.stk.flags & 1) != 0) #define stack_set_has_pairs(p) (T_Stk(p))->object.stk.flags |= 1 -/* #define stack_has_circles(p) (((T_Stk(p))->object.stk.flags & 4) != 0) */ -/* #define stack_set_has_circles(p) (T_Stk(p))->object.stk.flags |= 4 */ #define stack_has_counters(p) (((T_Stk(p))->object.stk.flags & 2) != 0) #define stack_set_has_counters(p) (T_Stk(p))->object.stk.flags |= 2 @@ -3323,6 +3333,7 @@ static s7_pointer slot_expression(s7_pointer p) \ #define c_function_bool_setter(f) c_function_data(f)->dam.bool_setter #define c_function_set_bool_setter(f, Val) c_function_data(f)->dam.bool_setter = Val + #define c_function_arg_defaults(f) c_function_data(T_Fst(f))->dam.arg_defaults #define c_function_call_args(f) c_function_data(T_Fst(f))->cam.call_args #define c_function_arg_names(f) c_function_data(T_Fst(f))->sam.arg_names @@ -3524,7 +3535,7 @@ static void set_type_1(s7_pointer p, uint64_t f, const char *func, int line) { if (((full_type(p) & T_IMMUTABLE) != 0) && ((full_type(p) != (uint64_t)(f)))) { - fprintf(stderr, "%s[%d]: set immutable %p type %d to %" print_s7_int "\n", __func__, __LINE__, p, unchecked_type(p), (int64_t)(f)); + fprintf(stderr, "%s[%d]: set immutable %p type %d to %" ld64 "\n", __func__, __LINE__, p, unchecked_type(p), (int64_t)(f)); abort(); } if (((full_type(p) & T_UNHEAP) != 0) && (((f) & T_UNHEAP) == 0)) @@ -3749,8 +3760,8 @@ static void try_to_call_gc(s7_scheme *sc); #define make_integer(Sc, N) ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) #define make_real(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) #define make_real_unchecked(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell_no_check(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) -#define make_complex_unchecked(Sc, R, I) ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, I); _C_;}) - /* "unchecked" here means we know the imaginary part is not 0.0 */ + +#define make_complex_not_0i(Sc, R, I) ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, I); _C_;}) #define make_complex(Sc, R, I) \ ({ s7_double _im_; _im_ = (I); ((_im_ == 0.0) ? make_real(Sc, R) : \ ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}) ); }) @@ -3764,22 +3775,21 @@ static void try_to_call_gc(s7_scheme *sc); #define make_real(Sc, X) s7_make_real(Sc, X) #define make_real_unchecked(Sc, X) s7_make_real(Sc, X) #define make_complex(Sc, R, I) s7_make_complex(Sc, R, I) -#define make_complex_unchecked(Sc, R, I) s7_make_complex(Sc, R, I) +#define make_complex_not_0i(Sc, R, I) s7_make_complex(Sc, R, I) #define real_to_double(Sc, X, Caller) s7_number_to_real_with_caller(Sc, X, Caller) #define rational_to_double(Sc, X) s7_number_to_real(Sc, X) #endif -static inline s7_pointer wrap_integer1(s7_scheme *sc, s7_int x) {integer(sc->integer_wrapper1) = x; return(sc->integer_wrapper1);} -static inline s7_pointer wrap_integer2(s7_scheme *sc, s7_int x) {integer(sc->integer_wrapper2) = x; return(sc->integer_wrapper2);} -static inline s7_pointer wrap_integer3(s7_scheme *sc, s7_int x) {integer(sc->integer_wrapper3) = x; return(sc->integer_wrapper3);} +static inline s7_pointer wrap_integer1(s7_scheme *sc, s7_int x) {if (is_small_int(x)) return(small_int(x)); integer(sc->integer_wrapper1) = x; return(sc->integer_wrapper1);} +static inline s7_pointer wrap_integer2(s7_scheme *sc, s7_int x) {if (is_small_int(x)) return(small_int(x)); integer(sc->integer_wrapper2) = x; return(sc->integer_wrapper2);} +static inline s7_pointer wrap_integer3(s7_scheme *sc, s7_int x) {if (is_small_int(x)) return(small_int(x)); integer(sc->integer_wrapper3) = x; return(sc->integer_wrapper3);} static inline s7_pointer wrap_real1(s7_scheme *sc, s7_double x) {real(sc->real_wrapper1) = x; return(sc->real_wrapper1);} static inline s7_pointer wrap_real2(s7_scheme *sc, s7_double x) {real(sc->real_wrapper2) = x; return(sc->real_wrapper2);} /* -------------------------------------------------------------------------------- * local versions of some standard C library functions - * timing tests involving these are very hard to interpret - * local_memset is faster using int64_t than int32_t + * timing tests involving these are very hard to interpret, local_memset is faster using int64_t than int32_t */ static void local_memset(void *s, uint8_t val, size_t n) @@ -3825,7 +3835,7 @@ static char *copy_string_with_length(const char *str, s7_int len) { char *newstr; #if S7_DEBUGGING - if ((len <= 0) || (!str)) fprintf(stderr, "%s[%d]: len: %" print_s7_int ", str: %s\n", __func__, __LINE__, len, str); + if ((len <= 0) || (!str)) fprintf(stderr, "%s[%d]: len: %" ld64 ", str: %s\n", __func__, __LINE__, len, str); #endif if (len > (1LL << 48)) return(NULL); /* squelch an idiotic warning */ newstr = (char *)Malloc(len + 1); @@ -3937,15 +3947,6 @@ static char *pos_int_to_str_direct_1(s7_scheme *sc, s7_int num) return((char *)(p + 1)); } -static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int len); - -#if S7_DEBUGGING - #define wrap_string(Sc, Str, Len) wrap_string_1(Sc, Str, Len, __func__, __LINE__) - static s7_pointer wrap_string_1(s7_scheme *sc, const char *str, s7_int len, const char *func, int line); -#else - static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len); -#endif - #if S7_DEBUGGING && WITH_GCC static s7_pointer lookup_1(s7_scheme *sc, s7_pointer symbol); #define lookup(Sc, Sym) check_null_sym(Sc, lookup_1(Sc, Sym), Sym, __LINE__, __func__) @@ -3966,6 +3967,9 @@ static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int #define lookup_checked(Sc, Sym) lookup(Sc, Sym) #endif +static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e); +static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int len); +static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len); static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b); static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym); static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer let, s7_pointer symbol); @@ -4083,7 +4087,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, OP_MACRO_D, OP_MACRO_STAR_D, OP_WITH_IO, OP_WITH_IO_1, OP_WITH_OUTPUT_TO_STRING, OP_WITH_IO_C, OP_CALL_WITH_OUTPUT_STRING, - OP_S, OP_S_S, OP_S_C, OP_S_A, OP_MAP_OR_FOR_EACH_FA, OP_S_AA, OP_A_A, OP_A_AA, OP_P_S, OP_P_S_1, + OP_S, OP_S_S, OP_S_C, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_P_S, OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA, OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A, OP_IMPLICIT_CONTINUATION_A, OP_IMPLICIT_ITERATE, OP_IMPLICIT_VECTOR_REF_A, OP_IMPLICIT_VECTOR_REF_AA, OP_IMPLICIT_VECTOR_SET_3, OP_IMPLICIT_VECTOR_SET_4, OP_IMPLICIT_STRING_REF_A, OP_IMPLICIT_C_OBJECT_REF_A, OP_IMPLICIT_PAIR_REF_A, OP_IMPLICIT_PAIR_REF_AA, @@ -4131,7 +4135,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_SET_UNCHECKED, OP_SET_SYMBOL_C, OP_SET_SYMBOL_S, OP_SET_SYMBOL_P, OP_SET_SYMBOL_A, OP_SET_NORMAL, OP_SET_PAIR, OP_SET_DILAMBDA, OP_SET_DILAMBDA_P, OP_SET_DILAMBDA_P_1, OP_SET_DILAMBDA_SA_A, OP_SET_PAIR_A, OP_SET_PAIR_P, OP_SET_PAIR_ZA, - OP_SET_PAIR_P_1, OP_SET_FROM_SETTER, OP_SET_PWS, OP_SET_LET_S, OP_SET_LET_FX, OP_SET_SAFE, + OP_SET_PAIR_P_1, OP_SET_FROM_SETTER, OP_SET_FROM_LET_TEMP, OP_SET_PWS, OP_SET_LET_S, OP_SET_LET_FX, OP_SET_SAFE, OP_INCREMENT_BY_1, OP_DECREMENT_BY_1, OP_SET_CONS, OP_INCREMENT_SS, OP_INCREMENT_SP, OP_INCREMENT_SA, OP_INCREMENT_SAA, @@ -4158,7 +4162,8 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot OP_OR_P, OP_OR_P1, OP_OR_AP, OP_OR_2A, OP_OR_3A, OP_OR_N, OP_OR_S_2, OP_OR_S_TYPE_2, OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2A, OP_WHEN_AND_3A, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P, - OP_IF_A_C_C, OP_IF_A_A, OP_IF_A_A_A, OP_IF_S_A_A, OP_IF_AND2_S_A, OP_IF_NOT_A_A, OP_IF_NOT_A_A_A, OP_IF_GT_A, + OP_IF_A_C_C, OP_IF_A_A, OP_IF_A_A_A, OP_IF_S_A_A, OP_IF_AND2_S_A, OP_IF_NOT_A_A, OP_IF_NOT_A_A_A, + OP_IF_B_A, OP_IF_B_P, OP_IF_B_R, OP_IF_B_A_P, OP_IF_B_P_A, OP_IF_B_P_P, OP_IF_B_N_N, OP_IF_A_A_P, OP_IF_A_P_A, OP_IF_S_P_A, OP_IF_IS_TYPE_S_P_A, OP_IF_IS_TYPE_S_A_A, OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N, OP_IF_opSq_P, OP_IF_opSq_P_P, OP_IF_opSq_R, OP_IF_opSq_N, OP_IF_opSq_N_N, @@ -4309,7 +4314,7 @@ static const char* op_names[NUM_OPS] = "apply_ss", "apply_sa", "apply_sl", "macro_d", "macro*_d", "with_input_from_string", "with_input_from_string_1", "with_output_to_string", "with_input_from_string_c", "call_with_output_string", - "s", "s_s", "s_c", "s_a", "map_or_for_each_fa", "s_aa", "a_a", "a_aa", "p_s", "p_s_1", + "s", "s_s", "s_c", "s_a", "s_aa", "a_a", "a_aa", "p_s", "p_s_1", "map_for_each_fa", "map_for_each_faa", "implicit_goto", "implicit_goto_a", "implicit_continuation_a","implicit_iterate", "implicit_vector_ref_a", "implicit_vector_ref_aa", "implicit_vector_set_3", "implicit_vector_set_4", "implicit_string_ref_a", "implicit_c_object_ref_a", "implicit_pair_ref_a", "implicit_pair_ref_aa", @@ -4355,7 +4360,7 @@ static const char* op_names[NUM_OPS] = "set_unchecked", "set_symbol_c", "set_symbol_s", "set_symbol_p", "set_symbol_a", "set_normal", "set_pair", "set_dilambda", "set_dilambda_p", "set_dilambda_p_1", "set_dilambda_sa_a", "set_pair_a", "set_pair_p", "set_pair_za", - "set_pair_p_1", "set_from_setter", "set_pws", "set_let_s", "set_let_fx", "set_safe", + "set_pair_p_1", "set_from_setter", "set_from_let_temp", "set_pws", "set_let_s", "set_let_fx", "set_safe", "increment_1", "decrement_1", "set_cons", "increment_ss", "increment_sp", "increment_sa", "increment_saa", "letrec_unchecked", "letrec*_unchecked", "cond_unchecked", @@ -4381,7 +4386,8 @@ static const char* op_names[NUM_OPS] = "or_p", "or_p1", "or_ap", "or_2a", "or_3a", "or_n", "or_s_2", "or_s_type_2", "when_s", "when_a", "when_p", "when_and_ap", "when_and_2a", "when_and_3a", "unless_s", "unless_a", "unless_p", - "if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a", "if_not_a_a", "if_not_a_a_a", "if_gt_a", + "if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a", "if_not_a_a", "if_not_a_a_a", + "if_b_a", "if_b_p", "if_b_r", "if_b_a_p", "if_b_p_a", "if_b_p_p", "if_b_n_n", "if_a_a_p", "if_a_p_a", "if_s_p_a", "if_is_type_s_p_a", "if_is_type_s_a_a", "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n", "if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n", @@ -4578,69 +4584,69 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S str[0] = '\0'; catstrs(str, 900, /* if debugging, all of these bits are being watched, so we need to access them directly */ - /* bit 0 (the first 8 bits are easy...) */ + /* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */ ((full_typ & T_MULTIFORM) != 0) ? ((is_any_closure(obj)) ? (((full_typ & T_ONE_FORM) != 0) ? " closure-one-form-has-fx" : " closure-multiform") : " ?0?") : "", - /* bit 1 */ + /* bit 9 */ ((full_typ & T_SYNTACTIC) != 0) ? (((is_pair(obj)) || (is_syntax(obj)) || (is_normal_symbol(obj))) ? " syntactic" : " ?1?") : "", - /* bit 2 */ + /* bit 10 */ ((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) ? ((is_pair(obj)) ? " simple-args|in-use" : ((is_any_closure(obj)) ? " closure-one-form" : " ?2?")) : "", - /* bit 3 */ + /* bit 11 */ ((full_typ & T_OPTIMIZED) != 0) ? ((is_c_function(obj)) ? " scope-safe" : ((is_pair(obj)) ? " optimized" : " ?3?")) : "", - /* bit 4 */ + /* bit 12 */ ((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj)) || (is_pair(obj))) ? " safe-closure" : " ?4?") : "", - /* bit 5 */ + /* bit 13 */ ((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj)) || (is_syntax(obj))) ? " dont-eval-args" : " ?5?") : "", - /* bit 6 */ + /* bit 14 */ ((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj)) || (is_either_macro(obj))) ? " expansion" : " ?6?") : "", - /* bit 7 */ + /* bit 15 */ ((full_typ & T_MULTIPLE_VALUE) != 0) ? ((is_symbol(obj)) ? " matched" : ((is_pair(obj)) ? " values|matched" : " ?7?")) : "", - /* bit 8 */ + /* bit 16 */ ((full_typ & T_GLOBAL) != 0) ? ((is_pair(obj)) ? " unsafe-do" : (((is_symbol(obj)) || (is_syntax(obj))) ? " global" : ((is_let(obj)) ? " dox_slot1" : " ?8?"))) : "", - /* bit 9 */ + /* bit 17 */ ((full_typ & T_COLLECTED) != 0) ? " collected" : "", - /* bit 10 */ + /* bit 18 */ ((full_typ & T_LOCATION) != 0) ? ((is_pair(obj)) ? " line-number" : ((is_input_port(obj)) ? " loader-port" : ((is_let(obj)) ? " with-let" : ((is_any_procedure(obj)) ? " simple-defaults" : (((is_normal_symbol(obj)) || (is_slot(obj))) ? " has-setter" : " ?10?"))))) : "", - /* bit 11 */ + /* bit 19 */ ((full_typ & T_SHARED) != 0) ? ((is_sequence(obj)) ? " shared" : " ?11?") : "", - /* bit 12 */ + /* bit 20 */ ((full_typ & T_LOCAL) != 0) ? ((is_normal_symbol(obj)) ? " local" : ((is_pair(obj)) ? " high-c" : " ?12?")) : "", - /* bit 13 */ + /* bit 21 */ ((full_typ & T_SAFE_PROCEDURE) != 0) ? ((is_applicable(obj)) ? " safe-procedure" : " ?13?") : "", - /* bit 14 */ + /* bit 22 */ ((full_typ & T_CHECKED) != 0) ? (((is_pair(obj)) || (is_slot(obj))) ? " checked" : ((is_symbol(obj)) ? " all-integer" : " ?14?")) : "", - /* bit 15 */ + /* bit 23 */ ((full_typ & T_UNSAFE) != 0) ? ((is_symbol(obj)) ? " clean-symbol" : ((is_slot(obj)) ? " has-stepper" : ((is_pair(obj)) ? " unsafely-opt|no-float-opt" : ((is_let(obj)) ? " dox-slot2" : " ?15?")))) : "", - /* bit 16 */ + /* bit 24 */ ((full_typ & T_IMMUTABLE) != 0) ? " immutable" : "", - /* bit 17 */ + /* bit 25 */ ((full_typ & T_SETTER) != 0) ? ((is_normal_symbol(obj)) ? " setter" : ((is_pair(obj)) ? " allow-other-keys|no-int-opt" : ((is_slot(obj)) ? " has-expression" : ((is_c_function_star(obj)) ? " allow-other-keys" : " ?17?")))) : "", - /* bit 18 */ + /* bit 26 */ ((full_typ & T_MUTABLE) != 0) ? ((is_number(obj)) ? " mutable" : ((is_symbol(obj)) ? " has-keyword" : ((is_let(obj)) ? " let-ref-fallback" : @@ -4649,7 +4655,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((is_let(obj)) ? " ref-fallback" : ((is_pair(obj)) ? " no-opt" : " ?18?"))))))) : "", - /* bit 19 */ + /* bit 27 */ ((full_typ & T_SAFE_STEPPER) != 0) ? ((is_let(obj)) ? " set-fallback" : ((is_slot(obj)) ? " safe-stepper" : ((is_c_function(obj)) ? " maybe-safe" : @@ -4659,11 +4665,11 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((is_any_macro(obj)) ? " pair-macro-set" : ((is_symbol(obj)) ? " all-float" : " ?19?")))))))) : "", - /* bit 20, for c_function case see sc->apply */ + /* bit 28, for c_function case see sc->apply */ ((full_typ & T_COPY_ARGS) != 0) ? (((is_pair(obj)) || (is_any_macro(obj)) || (is_syntax(obj)) || (is_any_closure(obj)) || (is_c_function(obj))) ? " copy-args" : " ?20?") : "", - /* bit 21 */ + /* bit 29 */ ((full_typ & T_GENSYM) != 0) ? ((is_let(obj)) ? " funclet" : ((is_normal_symbol(obj)) ? " gensym" : ((is_string(obj)) ? " documented-symbol" : @@ -4673,21 +4679,22 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((is_slot(obj)) ? " has-pending-value" : ((is_any_closure(obj)) ? " unknopt" : " ?21?")))))))) : "", - /* bit 22 */ + /* bit 30 */ ((full_typ & T_HAS_METHODS) != 0) ? (((is_let(obj)) || (is_c_object(obj)) || (is_any_closure(obj)) || (is_any_macro(obj)) || (is_c_pointer(obj))) ? " has-methods" : " ?22?") : "", - /* bit 23 */ + /* bit 31 */ ((full_typ & T_ITER_OK) != 0) ? ((is_iterator(obj)) ? " iter-ok" : - ((is_pair(obj)) ? " step-end-ok" : + ((is_pair(obj)) ? " step-end-ok/set-implicit-ok" : ((is_slot(obj)) ? " in-rootlet" : - " ?23?"))) : "", - /* bit 24+16 */ + ((is_c_function(obj)) ? " bool-function" : + " ?23?")))) : "", + /* bit 24+24 */ ((full_typ & T_FULL_SYMCONS) != 0) ? ((is_symbol(obj)) ? " possibly-constant" : ((is_procedure(obj)) ? " has-let-arg" : ((is_hash_table(obj)) ? " has-value-type" : ((is_pair(obj)) ? " int-optable" : " ?24?")))) : "", - /* bit 25+16 */ + /* bit 25+24 */ ((full_typ & T_FULL_HAS_LET_FILE) != 0) ? ((is_let(obj)) ? " has-let-file" : ((is_any_vector(obj)) ? " typed-vector" : ((is_hash_table(obj)) ? " typed-hash-table" : @@ -4695,7 +4702,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((is_slot(obj)) ? " rest-slot" : (((is_pair(obj)) || (is_closure_star(obj))) ? " no-defaults" : " ?25?")))))) : "", - /* bit 26+16 */ + /* bit 26+24 */ ((full_typ & T_FULL_DEFINER) != 0) ? ((is_normal_symbol(obj)) ? " definer" : ((is_pair(obj)) ? " has-fx" : ((is_slot(obj)) ? " slot-defaults" : @@ -4705,47 +4712,48 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((is_c_function(obj)) ? " func-definer" : ((is_syntax(obj)) ? " syntax-definer" : " ?26?")))))))) : "", - /* bit 27+16 */ + /* bit 27+24 */ ((full_typ & T_FULL_BINDER) != 0) ? ((is_pair(obj)) ? " tree-collected" : ((is_hash_table(obj)) ? " simple-values" : ((is_normal_symbol(obj)) ? " binder" : ((is_c_function(obj)) ? " safe-args" : " ?27?")))) : "", - /* bit 28+16 */ + /* bit 28+24 */ ((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? (((is_pair(obj)) || (is_any_closure(obj))) ? " very-safe-closure" : ((is_let(obj)) ? " baffle-let" : " ?28?")) : "", - /* bit 29+16 */ + /* bit 29+24 */ ((full_typ & T_CYCLIC) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || (is_any_closure(obj))) ? " cyclic" : " ?29?") : "", - /* bit 30+16 */ + /* bit 30+24 */ ((full_typ & T_CYCLIC_SET) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || (is_any_closure(obj))) ? " cyclic-set" : " ?30?") : "", - /* bit 31+16 */ + /* bit 31+24 */ ((full_typ & T_KEYWORD) != 0) ? ((is_symbol(obj)) ? " keyword" : " ?31?") : "", - /* bit 32+16 */ + /* bit 32+24 */ ((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) ? ((is_normal_vector(obj)) ? " simple-elements" : ((is_hash_table(obj)) ? " simple-keys" : ((is_normal_symbol(obj)) ? " safe-setter" : ((is_pair(obj)) ? " float-optable" : ((typ >= T_C_MACRO) ? " function-simple-elements" : " 32?"))))) : "", - /* bit 33+16 */ + /* bit 33+24 */ ((full_typ & T_FULL_CASE_KEY) != 0) ? ((is_symbol(obj)) ? " case-key" : ((is_pair(obj)) ? " opt1-func-listed" : " ?33?")) : "", - /* bit 34+16 */ + /* bit 34+24 */ ((full_typ & T_FULL_HAS_GX) != 0) ? ((is_pair(obj)) ? " has-gx" : " ?34?") : "", - /* bit 35+16 */ + /* bit 35+24 */ ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "", - /* bit 36+16 */ + /* bit 36+24 */ ((full_typ & T_FULL_SAFETY_CHECKED) != 0) ? ((is_pair(obj)) ? " safety-checked" : " ?36?") : "", + /* bit 37+24 */ ((full_typ & T_FULL_HAS_FN) != 0) ? ((is_pair(obj)) ? " has-fn" : " ?37") : "", - ((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "", - /* bit 54 */ + /* bit 62 */ ((full_typ & T_UNHEAP) != 0) ? " unheap" : "", - /* bit 55 */ + /* bit 63 */ ((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "", + ((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "", ((is_symbol(obj)) && (((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) || ((symbol_type(obj) & ~0xffff) != 0))) ? " bad-symbol-type" : "", NULL); @@ -4779,7 +4787,7 @@ static bool has_odd_bits(s7_pointer obj) if (((full_typ & T_EXPANSION) != 0) && (!is_normal_symbol(obj)) && (!is_either_macro(obj))) return(true); if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); if (((full_typ & T_GLOBAL) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_let(obj)) && (!is_syntax(obj))) return(true); - if (((full_typ & T_ITER_OK) != 0) && (!is_iterator(obj)) && (!is_pair(obj)) && (!is_slot(obj))) return(true); + if (((full_typ & T_ITER_OK) != 0) && (!is_iterator(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_c_function(obj))) return(true); if (((full_typ & T_LOCAL) != 0) && (!is_normal_symbol(obj)) && (!is_pair(obj))) return(true); if (((full_typ & T_UNSAFE) != 0) && (!is_symbol(obj)) && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj))) return(true); if (((full_typ & T_VERY_SAFE_CLOSURE) != 0) && (!is_pair(obj)) && (!is_any_closure(obj)) && (!is_let(obj))) return(true); @@ -5109,7 +5117,7 @@ static void print_gc_info(s7_scheme *sc, s7_pointer obj, int32_t line) full_type(obj) = free_type; if (obj->explicit_free_line > 0) snprintf(fline, 128, ", freed at %d, ", obj->explicit_free_line); - fprintf(stderr, "%s%p is free (line %d, alloc type: %s %" print_s7_int " #x%" PRIx64 " (%s)), current: %s[%d], previous: %s[%d], %sgc: %s[%d]%s\n", + fprintf(stderr, "%s%p is free (line %d, alloc type: %s %" ld64 " #x%" PRIx64 " (%s)), current: %s[%d], previous: %s[%d], %sgc: %s[%d]%s\n", BOLD_TEXT, obj, line, s7_type_names[obj->current_alloc_type & 0xff], obj->current_alloc_type, obj->current_alloc_type, @@ -5307,7 +5315,8 @@ static bool f_call_func_mismatch(const char *func) (!safe_strcmp(func, "optimize_func_many_args")) && (!safe_strcmp(func, "optimize_func_three_args")) && (!safe_strcmp(func, "fx_c_ff")) && - (!safe_strcmp(func, "op_map_or_for_each_fa"))); + (!safe_strcmp(func, "op_map_for_each_fa")) && + (!safe_strcmp(func, "op_map_for_each_faa"))); } static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) @@ -5501,7 +5510,7 @@ static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, in s7_pointer slot; char *s; fprintf(stderr, "%s%s[%d]: %s unbound%s\n", BOLD_TEXT, func, line, symbol_name(sym), UNBOLD_TEXT); - fprintf(stderr, " symbol_id: %" print_s7_int ", let_id: %" print_s7_int ", bits: %s", symbol_id(sym), let_id(sc->curlet), s = describe_type_bits(sc, sym)); + fprintf(stderr, " symbol_id: %" ld64 ", let_id: %" ld64 ", bits: %s", symbol_id(sym), let_id(sc->curlet), s = describe_type_bits(sc, sym)); free(s); slot = symbol_to_local_slot(sc, sym, sc->curlet); if (is_slot(slot)) fprintf(stderr, ", slot: %s", display(slot)); @@ -5633,6 +5642,14 @@ static s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2) return(sc->u1_1); } +static s7_pointer set_ulist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) +{ + set_car(sc->u2_1, x1); + set_car(sc->u2_2, x2); + set_cdr(sc->u2_2, x3); + return(sc->u2_1); +} + static int32_t position_of(s7_pointer p, s7_pointer args) { int32_t i; @@ -5807,21 +5824,24 @@ static s7_pointer method_or_bust_with_type_one_arg_p(s7_scheme *sc, s7_pointer o /* #f and #t */ s7_pointer s7_f(s7_scheme *sc) {return(sc->F);} - 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);} 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 */ -static bool is_null_b(s7_pointer p) {return(type(p) == T_NIL);} +static s7_pointer g_is_null(s7_scheme *sc, s7_pointer args) +{ + #define H_is_null "(null? obj) returns #t if obj is the empty list" + #define Q_is_null sc->pl_bt + check_boolean_method(sc, is_null, sc->is_null_symbol, args); +} /* #<undefined> and #<unspecified> */ s7_pointer s7_undefined(s7_scheme *sc) {return(sc->undefined);} - s7_pointer s7_unspecified(s7_scheme *sc) {return(sc->unspecified);} bool s7_is_unspecified(s7_scheme *sc, s7_pointer val) {return(is_unspecified(val));} @@ -5842,7 +5862,7 @@ static s7_pointer g_is_unspecified(s7_scheme *sc, s7_pointer args) /* -------------------------------- eof-object? -------------------------------- */ -s7_pointer eof_object = NULL; /* #<eof> -- a character, an entry in the chars array, so not a part of sc */ +s7_pointer eof_object = NULL; /* #<eof> is an entry in the chars array, so it's not a part of sc */ s7_pointer s7_eof_object(s7_scheme *sc) {return(eof_object);} @@ -5853,10 +5873,14 @@ static s7_pointer g_is_eof_object(s7_scheme *sc, s7_pointer args) check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args); } -static bool s7_is_eof_object(s7_pointer p) {return(p == eof_object);} +static bool is_eof_object_b_p(s7_pointer p) {return(p == eof_object);} /* -------------------------------- not -------------------------------- */ +static bool not_b_7p(s7_scheme *sc, s7_pointer p) {return(p == sc->F);} +bool s7_boolean(s7_scheme *sc, s7_pointer x) {return(x != sc->F);} +s7_pointer s7_make_boolean(s7_scheme *sc, bool x) {return(make_boolean(sc, x));} + static s7_pointer g_not(s7_scheme *sc, s7_pointer args) { #define H_not "(not obj) returns #t if obj is #f, otherwise #t: (not ()) -> #f" @@ -5864,12 +5888,6 @@ static s7_pointer g_not(s7_scheme *sc, s7_pointer args) return((car(args) == sc->F) ? sc->T : sc->F); } -static bool not_b_7p(s7_scheme *sc, s7_pointer p) {return(p == sc->F);} - -bool s7_boolean(s7_scheme *sc, s7_pointer x) {return(x != sc->F);} - -s7_pointer s7_make_boolean(s7_scheme *sc, bool x) {return(make_boolean(sc, x));} - /* -------------------------------- boolean? -------------------------------- */ bool s7_is_boolean(s7_pointer x) {return(type(x) == T_BOOLEAN);} @@ -5883,8 +5901,6 @@ static s7_pointer g_is_boolean(s7_scheme *sc, s7_pointer args) /* -------------------------------- constant? -------------------------------- */ -static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e); - static inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) { if (is_immutable_symbol(sym)) /* for keywords */ @@ -5907,6 +5923,7 @@ static s7_pointer g_is_constant(s7_scheme *sc, s7_pointer args) return(make_boolean(sc, is_constant(sc, car(args)))); } +static bool is_constant_b_7p(s7_scheme *sc, s7_pointer p) {return(is_constant(sc, p));} static s7_pointer is_constant_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_constant(sc, p)));} @@ -5915,17 +5932,19 @@ bool s7_is_immutable(s7_pointer p) {return(is_immutable(p));} static s7_pointer g_is_immutable(s7_scheme *sc, s7_pointer args) { - #define H_is_immutable "(immutable? sequence) returns #t if the sequence is immutable. (This function is work-in-progress)" + #define H_is_immutable "(immutable? sequence) returns #t if the sequence is immutable" #define Q_is_immutable sc->pl_bt s7_pointer p = car(args); +#if 0 /* strikes me as confusing, constant above refers to local define-constant, the symbol itself is always immutable */ if (is_symbol(p)) { s7_pointer slot; slot = lookup_slot_from(p, sc->curlet); if ((is_slot(slot)) && (is_immutable_slot(slot))) return(sc->T); } - if (is_number(p)) return(sc->T); - return((is_immutable(p)) ? sc->T : sc->F); +#endif + if (is_number(p)) return(sc->T); /* should these be marked immutable? should we use (type != SYMBOL) as above? */ + return(make_boolean(sc, is_immutable(p))); } @@ -5954,6 +5973,9 @@ static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) return(p); } +/* there's no way to make a slot setter (as setter) immutable (t_multiform as bit) */ + + /* -------------------------------- GC -------------------------------- */ /* in most code, pairs, lets, and slots dominate the heap -- each about 25% to 40% of the @@ -5963,7 +5985,7 @@ static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) */ #if S7_DEBUGGING -static s7_int s7_gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line) +static s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line) { s7_int loc; loc = s7_gc_protect(sc, x); @@ -5974,9 +5996,9 @@ static s7_int s7_gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line) } return(loc); } -#define s7_gc_protect_1(Sc, X) s7_gc_protect_2(Sc, X, __LINE__) +#define gc_protect_1(Sc, X) gc_protect_2(Sc, X, __LINE__) #else -#define s7_gc_protect_1(Sc, X) s7_gc_protect(Sc, X) +#define gc_protect_1(Sc, X) s7_gc_protect(Sc, X) #endif static void resize_gc_protect(s7_scheme *sc) @@ -6016,7 +6038,7 @@ void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc) if (vector_element(sc->protected_objects, loc) != sc->unused) sc->gpofl[++sc->gpofl_loc] = loc; #if S7_DEBUGGING - else fprintf(stderr, "redundant gc_unprotect_at location %" print_s7_int "\n", loc); + else fprintf(stderr, "redundant gc_unprotect_at location %" ld64 "\n", loc); #endif vector_element(sc->protected_objects, loc) = sc->unused; } @@ -6079,10 +6101,8 @@ static void process_iterator(s7_scheme *sc, s7_pointer s1) h = iterator_sequence(s1); if (unchecked_type(h) == T_HASH_TABLE) { -#if S7_DEBUGGING - if (weak_hash_iters(h) == 0) + if ((S7_DEBUGGING) && (weak_hash_iters(h) == 0)) fprintf(stderr, "in gc weak has iters wrapping under!\n"); -#endif weak_hash_iters(h)--; }} } @@ -6181,7 +6201,6 @@ static void process_continuation(s7_scheme *sc, s7_pointer s1) } #if WITH_GMP - #if ((__GNU_MP_VERSION < 6) || ((__GNU_MP_VERSION == 6) && (__GNU_MP_VERSION_MINOR == 0))) static int mpq_cmp_z(const mpq_t op1, const mpz_t op2) { @@ -6911,8 +6930,10 @@ static s7_pointer make_symbol(s7_scheme *sc, const char *name); static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...); #if S7_DEBUGGING +#define call_gc(Sc) gc(Sc, __func__, __LINE__) static int64_t gc(s7_scheme *sc, const char *func, int line) #else +#define call_gc(Sc) gc(Sc) static int64_t gc(s7_scheme *sc) #endif { @@ -6925,6 +6946,7 @@ static int64_t gc(s7_scheme *sc) #if S7_DEBUGGING sc->last_gc_line = line; #endif + sc->continuation_counter = 0; mark_rootlet(sc); mark_owlet(sc); @@ -6952,7 +6974,6 @@ static int64_t gc(s7_scheme *sc) gc_mark(sc->temp7); gc_mark(sc->temp8); gc_mark(sc->temp9); - gc_mark(sc->temp10); set_mark(current_input_port(sc)); mark_input_port_stack(sc); @@ -6973,6 +6994,7 @@ static int64_t gc(s7_scheme *sc) gc_mark(car(sc->qlist_2)); gc_mark(cadr(sc->qlist_2)); gc_mark(car(sc->qlist_3)); gc_mark(cadr(sc->qlist_3)); gc_mark(caddr(sc->qlist_3)); gc_mark(car(sc->u1_1)); + gc_mark(car(sc->u2_1)); gc_mark(sc->rec_p1); gc_mark(sc->rec_p2); @@ -7105,10 +7127,10 @@ static int64_t gc(s7_scheme *sc) if (show_gc_stats(sc)) { #if (!MS_WINDOWS) - s7_warn(sc, 256, "gc freed %" print_s7_int "/%" print_s7_int " (free: %" print_pointer "), time: %f\n", + s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 " (free: %" p64 "), time: %f\n", sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); #else - s7_warn(sc, 256, "gc freed %" print_s7_int "/%" print_s7_int "\n", sc->gc_freed, sc->heap_size); + s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n", sc->gc_freed, sc->heap_size); #endif } if (show_protected_objects_stats(sc)) @@ -7118,7 +7140,7 @@ static int64_t gc(s7_scheme *sc) for (i = 0, num = 0; i < len; i++) if (vector_element(sc->protected_objects, i) != sc->unused) num++; - s7_warn(sc, 256, "gc-protected-objects: %" print_s7_int " in use of %" print_s7_int "\n", num, len); + s7_warn(sc, 256, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n", num, len); }} sc->previous_free_heap_top = sc->free_heap_top; return(sc->gc_freed); @@ -7152,10 +7174,10 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) if (((2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell))) >= SIZE_MAX) { - s7_warn(sc, 256, "heap size requested, %ld => %ld bytes, is greater than size_t: %ld\n", - (long int)(sc->heap_size), - (long int)((2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell))), - (long int)SIZE_MAX); + s7_warn(sc, 256, "heap size requested, %" ld64 " => %" ld64 " bytes, is greater than size_t: %" ld64 "\n", + sc->heap_size, + (2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell)), + SIZE_MAX); sc->heap_size = old_size + 64000; } @@ -7164,7 +7186,7 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) sc->heap = cp; else { - s7_warn(sc, 256, "heap reallocation failed! tried to get %" print_s7_int " bytes (will retry with a smaller amount)\n", (int64_t)(sc->heap_size * sizeof(s7_cell *))); + s7_warn(sc, 256, "heap reallocation failed! tried to get %" ld64 " bytes (will retry with a smaller amount)\n", (int64_t)(sc->heap_size * sizeof(s7_cell *))); sc->heap_size = old_size + 64000; sc->heap = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *)); } @@ -7194,9 +7216,9 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) char *str; str = string_value(object_to_truncated_string(sc, current_code(sc), 80)); if (size != 0) - s7_warn(sc, 512, "heap grows to %" print_s7_int " (old free/size: %" print_s7_int "/%" print_s7_int ", requested %" print_s7_int ") from %s\n", + s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", requested %" ld64 ") from %s\n", sc->heap_size, old_free, old_size, size, str); - else s7_warn(sc, 512, "heap grows to %" print_s7_int " (old free/size: %" print_s7_int "/%" print_s7_int ") from %s\n", + else s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ") from %s\n", sc->heap_size, old_free, old_size, str); } if (sc->heap_size >= sc->max_heap_size) @@ -7271,11 +7293,7 @@ Evaluation produces a surprising amount of garbage, so don't leave the GC off fo if (sc->gc_off) return(sc->F); } -#if S7_DEBUGGING - gc(sc, __func__, __LINE__); -#else - gc(sc); -#endif + call_gc(sc); return(sc->unspecified); } @@ -7530,10 +7548,12 @@ static void pop_stack_1(s7_scheme *sc, const char *func, int line) sc->cur_op = (opcode_t)(sc->stack_end[3]); if (sc->cur_op >= NUM_OPS) { - fprintf(stderr, "%s%s[%d]: pop_stack invalid opcode: %" print_pointer " %s\n", BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); + fprintf(stderr, "%s%s[%d]: pop_stack invalid opcode: %" p64 " %s\n", BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); if (sc->stop_at_error) abort(); } - if ((!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1])) && (sc->cur_op != OP_ANY_CLOSURE_3P_3)) /* used as third GC protection field */ + if ((sc->cur_op != OP_GC_PROTECT) && + (!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1])) && + (sc->cur_op != OP_ANY_CLOSURE_3P_3)) /* used as third GC protection field */ fprintf(stderr, "%s[%d]: curlet not a let: %s\n", func, line, op_names[sc->cur_op]); } @@ -7547,7 +7567,7 @@ static void pop_stack_no_op_1(s7_scheme *sc, const char *func, int line) if (sc->stop_at_error) abort(); } sc->code = T_Pos(sc->stack_end[0]); - if ((!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1]))) + if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1]))) fprintf(stderr, "%s[%d]: curlet not a let\n", func, line); sc->curlet = T_Pos(sc->stack_end[1]); /* not T_Lid: gc_protect can set this directly (not through push_stack) to anything */ sc->args = sc->stack_end[2]; @@ -7569,7 +7589,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func, line); if (op >= NUM_OPS) { - fprintf(stderr, "%s%s[%d]: push_stack invalid opcode: %" print_pointer " %s\n", BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); + fprintf(stderr, "%s%s[%d]: push_stack invalid opcode: %" p64 " %s\n", BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); if (sc->stop_at_error) abort(); } if (code) sc->stack_end[0] = T_Pos(code); @@ -7579,14 +7599,14 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer sc->stack_end += 4; } -#define push_stack_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, sc->unused) -#define push_stack_no_let_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, sc->unused) -#define push_stack_no_args(Sc, Op, Code) push_stack(Sc, Op, sc->unused, Code) +#define push_stack_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) +#define push_stack_no_let_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) +#define push_stack_no_args(Sc, Op, Code) push_stack(Sc, Op, Sc->unused, Code) #define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code) -#define push_stack_op(Sc, Op) push_stack(Sc, Op, sc->unused, sc->unused) -#define push_stack_op_let(Sc, Op) push_stack(Sc, Op, sc->unused, sc->unused) -#define push_stack_direct(Sc, Op) push_stack(Sc, Op, sc->args, sc->code) -#define push_stack_no_args_direct(Sc, Op) push_stack(Sc, Op, sc->unused, sc->code) +#define push_stack_op(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused) +#define push_stack_op_let(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused) +#define push_stack_direct(Sc, Op) push_stack(Sc, Op, Sc->args, Sc->code) +#define push_stack_no_args_direct(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->code) /* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */ #else @@ -7597,7 +7617,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer #define push_stack(Sc, Op, Args, Code) \ do { \ Sc->stack_end[0] = Code; \ - Sc->stack_end[1] = sc->curlet; \ + Sc->stack_end[1] = Sc->curlet; \ Sc->stack_end[2] = Args; \ Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ @@ -7612,7 +7632,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer #define push_stack_no_code(Sc, Op, Args) \ do { \ - Sc->stack_end[1] = sc->curlet; \ + Sc->stack_end[1] = Sc->curlet; \ Sc->stack_end[2] = Args; \ Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ @@ -7628,7 +7648,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer #define push_stack_no_args(Sc, Op, Code) \ do { \ Sc->stack_end[0] = Code; \ - Sc->stack_end[1] = sc->curlet; \ + Sc->stack_end[1] = Sc->curlet; \ Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) @@ -7656,7 +7676,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer #define push_stack_op_let(Sc, Op) \ do { \ - Sc->stack_end[1] = sc->curlet; \ + Sc->stack_end[1] = Sc->curlet; \ Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) @@ -7775,6 +7795,7 @@ static inline void gc_protect_via_stack(s7_scheme *sc, s7_pointer val) } #define gc_protect_2_via_stack(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y;} while (0) +/* often X and Y are fx_calls, so push X, then set Y */ /* -------------------------------- symbols -------------------------------- */ @@ -8015,9 +8036,7 @@ static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym) set_cdr(y, cdr(x)); return; } -#if S7_DEBUGGING - fprintf(stderr, "could not remove %s?\n", string_value(name)); -#endif + if (S7_DEBUGGING) fprintf(stderr, "could not remove %s?\n", string_value(name)); } } @@ -8043,13 +8062,13 @@ s7_pointer s7_gensym(s7_scheme *sc, const char *prefix) return(x); } -static bool s7_is_gensym(s7_pointer g) {return((is_symbol(g)) && (is_gensym(g)));} +static bool is_gensym_b_p(s7_pointer g) {return((is_symbol(g)) && (is_gensym(g)));} static s7_pointer g_is_gensym(s7_scheme *sc, s7_pointer args) { #define H_is_gensym "(gensym? sym) returns #t if sym is a gensym" #define Q_is_gensym sc->pl_bt - check_boolean_method(sc, s7_is_gensym, sc->is_gensym_symbol, args); + check_boolean_method(sc, is_gensym_b_p, sc->is_gensym_symbol, args); } static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) @@ -8098,21 +8117,17 @@ static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) p = pos_int_to_str(sc, sc->gensym_counter++, &len, '\0'); memcpy((void *)(name + plen + 3), (void *)p, len); nlen = len + plen + 2; -#if S7_DEBUGGING - if ((s7_int)strlen(name) != nlen) - fprintf(stderr, "%s[%d]: %s len: %" print_s7_int " != %" print_s7_int "\n", __func__, __LINE__, name, nlen, (s7_int)strlen(name)); -#endif + if ((S7_DEBUGGING) && ((s7_int)strlen(name) != nlen)) + fprintf(stderr, "%s[%d]: %s len: %" ld64 " != %" ld64 "\n", __func__, __LINE__, name, nlen, (s7_int)strlen(name)); hash = raw_string_hash((const uint8_t *)name, nlen); location = hash % SYMBOL_TABLE_SIZE; - if ((sc->safety > 0) && + if ((WITH_WARNINGS) && (!is_null(symbol_table_find_by_name(sc, name, hash, location, nlen)))) s7_warn(sc, nlen + 32, "%s is already in use!", name); /* make-string for symbol name */ -#if S7_DEBUGGING - full_type(str) = 0; /* here and below, this is needed to avoid set_type check errors (mallocate above) */ -#endif + if (S7_DEBUGGING) full_type(str) = 0; /* here and below, this is needed to avoid set_type check errors (mallocate above) */ set_full_type(str, T_STRING | T_IMMUTABLE | T_UNHEAP); string_length(str) = nlen; string_value(str) = name; @@ -8132,9 +8147,7 @@ static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) gensym_block(x) = b; /* place new symbol in symbol-table */ -#if S7_DEBUGGING - full_type(stc) = 0; -#endif + if (S7_DEBUGGING) full_type(stc) = 0; set_full_type(stc, T_PAIR | T_IMMUTABLE | T_UNHEAP); set_car(stc, x); set_cdr(stc, vector_element(sc->symbol_table, location)); @@ -8221,14 +8234,14 @@ static s7_pointer g_symbol_to_string_uncopied(s7_scheme *sc, s7_pointer args) static s7_pointer symbol_to_string_p_p(s7_scheme *sc, s7_pointer sym) { if (!is_symbol(sym)) - simple_wrong_type_argument(sc, sc->symbol_to_string_symbol, sym, T_SYMBOL); + return(method_or_bust_one_arg(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), T_SYMBOL)); return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); } static s7_pointer symbol_to_string_uncopied_p(s7_scheme *sc, s7_pointer sym) { if (!is_symbol(sym)) - simple_wrong_type_argument(sc, sc->symbol_to_string_symbol, sym, T_SYMBOL); + return(method_or_bust_one_arg(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), T_SYMBOL)); if (is_gensym(sym)) return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); return(symbol_name_cell(sym)); @@ -8243,7 +8256,6 @@ static inline s7_pointer g_string_to_symbol_1(s7_scheme *sc, s7_pointer str, s7_ if (string_length(str) > 0) return(make_symbol_with_length(sc, string_value(str), string_length(str))); return(simple_wrong_type_argument_with_type(sc, caller, str, wrap_string(sc, "a non-null string", 17))); - /* currently if the string has an embedded null, it marks the end of the new symbol name. */ } static s7_pointer g_string_to_symbol(s7_scheme *sc, s7_pointer args) @@ -8892,10 +8904,7 @@ static void init_unlet(s7_scheme *sc) * make-hook hook-functions * if these initial_slot values are added to unlet, they need explicit GC protection. */ -#if S7_DEBUGGING - if (k >= UNLET_ENTRIES) - fprintf(stderr, "unlet overflow\n"); -#endif + if ((S7_DEBUGGING) && (k >= UNLET_ENTRIES)) fprintf(stderr, "unlet overflow\n"); }} } @@ -9345,7 +9354,7 @@ static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) s7_pointer x; if (!is_symbol(symbol)) - return(sublet_1(sc, sc->nil, list_2(sc, symbol, value), sc->inlet_symbol)); + return(sublet_1(sc, sc->nil, set_plist_2(sc, symbol, value), sc->inlet_symbol)); if (is_keyword(symbol)) symbol = keyword_symbol(symbol); if (is_constant_symbol(sc, symbol)) @@ -9940,23 +9949,30 @@ s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e) /* -------------------------------- outlet -------------------------------- */ -s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e) {return((is_let(e)) ? let_outlet(e) : sc->nil);} - -static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args) +s7_pointer s7_outlet(s7_scheme *sc, s7_pointer let) { - #define H_outlet "(outlet let) is the environment that contains let." - #define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol) + if ((let == sc->rootlet) || (is_null(let_outlet(let)))) + return(sc->rootlet); + return(let_outlet(let)); +} - s7_pointer let = car(args); +s7_pointer outlet_p_p(s7_scheme *sc, s7_pointer let) +{ if (!is_let(let)) return(s7_wrong_type_arg_error(sc, "outlet", 1, let, "a let")); /* not a method call here! */ - - if ((let == sc->rootlet) || - (is_null(let_outlet(let)))) + if ((let == sc->rootlet) || (is_null(let_outlet(let)))) return(sc->rootlet); return(let_outlet(let)); } +static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args) +{ + #define H_outlet "(outlet let) is the environment that contains let." + #define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol) + return(outlet_p_p(sc, car(args))); +} + + static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args) { /* (let ((a 1)) (let ((b 2)) (set! (outlet (curlet)) (rootlet)) ((curlet) 'a))) */ @@ -10143,7 +10159,6 @@ symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32" return(s7_symbol_local_value(sc, sym, local_let)); } - if (is_global(sym)) return(global_value(sym)); return(s7_symbol_value(sc, sym)); @@ -10151,8 +10166,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; - /* if immutable should this return an error? */ + s7_pointer x; /* if immutable should this return an error? */ x = lookup_slot_from(sym, sc->curlet); if (is_slot(x)) slot_set_value(x, val); /* with_hook? */ @@ -10164,7 +10178,6 @@ s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val) static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer x, s7_pointer sym, int64_t *id) { for (; symbol_id(sym) < let_id(x); x = let_outlet(x)); - if (let_id(x) == symbol_id(sym)) { (*id) = let_id(x); @@ -10376,9 +10389,7 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) case OP_DEFINE_EXPANSION: typ = T_MACRO | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); break; /* local expansions are just normal macros */ case OP_DEFINE_EXPANSION_STAR: typ = T_MACRO_STAR | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); break; default: -#if S7_DEBUGGING - fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, op_names[op]); -#endif + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, op_names[op]); typ = T_MACRO; break; } @@ -10405,9 +10416,7 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) cx = symbol_to_local_slot(sc, mac_name, sc->curlet); /* returns global_slot(symbol) if sc->curlet == nil */ if (is_slot(cx)) { -#if S7_DEBUGGING - if (sc->curlet == sc->rootlet) fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, __LINE__); -#endif + if ((S7_DEBUGGING) && (sc->curlet == sc->rootlet)) fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, __LINE__); if ((sc->curlet == sc->nil) && (!in_rootlet(cx))) { #if S7_DEBUGGING @@ -10749,8 +10758,7 @@ bool s7_is_defined(s7_scheme *sc, const char *name) static bool is_defined_b_7p(s7_scheme *sc, s7_pointer p) { - if (!is_symbol(p)) - simple_wrong_type_argument(sc, sc->is_defined_symbol, p, T_SYMBOL); + if (!is_symbol(p)) return(method_or_bust(sc, p, sc->is_defined_symbol, set_plist_1(sc, p), T_SYMBOL, 1) != sc->F); return(is_slot(lookup_slot_from(p, sc->curlet))); } @@ -10848,7 +10856,9 @@ s7_pointer s7_make_keyword(s7_scheme *sc, const char *key) slen = (size_t)safe_strlen(key); b = mallocate(sc, slen + 2); name = (char *)block_data(b); - catstrs_direct(name, ":", key, (const char *)NULL); /* use catstrs_direct to get around a bug in gcc 8.1 */ + name[0] = ':'; + memcpy((void *)(name + 1), (void *)key, slen); + name[slen + 1] = '\0'; sym = make_symbol_with_length(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */ liberate(sc, b); return(sym); @@ -10885,7 +10895,7 @@ s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key) {return(keyword_s /* -------------------------------- symbol->keyword -------------------------------- */ -static s7_pointer symbol_to_keyword(s7_scheme *sc, s7_pointer sym) {return(s7_make_keyword(sc, symbol_name(sym)));} +#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym)) static s7_pointer g_symbol_to_keyword(s7_scheme *sc, s7_pointer args) { @@ -11070,7 +11080,7 @@ static s7_pointer g_is_continuation(s7_scheme *sc, s7_pointer args) */ } -static bool s7_is_continuation(s7_pointer p) {return(is_continuation(p));} +static bool is_continuation_b_p(s7_pointer p) {return(is_continuation(p));} #if S7_DEBUGGING static s7_pointer check_wrap_return(s7_pointer lst) @@ -11317,11 +11327,7 @@ static void make_room_for_cc_stack(s7_scheme *sc) if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8)) /* we probably never need this much space -- very often we don't need any */ { int64_t freed_heap; -#if S7_DEBUGGING - freed_heap = gc(sc, __func__, __LINE__); -#else - freed_heap = gc(sc); -#endif + freed_heap = call_gc(sc); if (freed_heap < (int64_t)(sc->heap_size / 8)) resize_heap(sc); } @@ -11333,7 +11339,10 @@ s7_pointer s7_make_continuation(s7_scheme *sc) int64_t loc; block_t *block; + sc->continuation_counter++; make_room_for_cc_stack(sc); + if (sc->continuation_counter > 2000) call_gc(sc); /* gc time up, but run time down -- try big cache */ + loc = current_stack_top(sc); stack = make_simple_vector(sc, loc); set_full_type(stack, T_STACK); @@ -11753,7 +11762,7 @@ static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args) /* (call-wi if ((is_any_c_function(p)) && (s7_is_aritable(sc, p, 1))) { call_exit_active(x) = false; - return((is_c_function(p)) ? c_function_call(p)(sc, list_1_unchecked(sc, x)) : s7_apply_function_star(sc, p, set_plist_1(sc, x))); + return((is_c_function(p)) ? c_function_call(p)(sc, set_plist_1(sc, x)) : s7_apply_function_star(sc, p, set_plist_1(sc, x))); } push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */ push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p); @@ -11850,6 +11859,11 @@ static inline s7_pointer make_simple_ratio(s7_scheme *sc, s7_int num, s7_int den return(x); } +static bool is_zero(s7_scheme *sc, s7_pointer x); +static bool is_positive(s7_scheme *sc, s7_pointer x); +static bool is_negative(s7_scheme *sc, s7_pointer x); +static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b); + static bool is_NaN(s7_double x) {return(x != x);} /* callgrind says this is faster than isnan, I think (very confusing data...) */ @@ -12443,6 +12457,7 @@ static s7_pointer string_to_big_real(s7_scheme *sc, const char *str, int32_t rad } static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow); + static s7_pointer string_to_either_integer(s7_scheme *sc, const char *str, int32_t radix) { s7_int val; @@ -12471,7 +12486,7 @@ static s7_pointer string_to_either_ratio(s7_scheme *sc, const char *nstr, const n = string_to_integer(nstr, radix, &overflow); if (!overflow) - return(s7_make_ratio(sc, n, d)); + return(make_ratio(sc, n, d)); } if (nstr[0] == '+') return(string_to_big_ratio(sc, (const char *)(nstr + 1), radix)); @@ -12533,7 +12548,6 @@ static s7_pointer string_to_either_complex_1(s7_scheme *sc, char *q, char *slash return(NULL); } -static bool s7_is_zero(s7_pointer x); static s7_pointer string_to_either_complex(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1, char *plus, char *slash2, char *ex2, bool has_dec_point2, int32_t radix, int32_t has_plus_or_minus) @@ -12546,7 +12560,7 @@ static s7_pointer string_to_either_complex(s7_scheme *sc, char *q, char *slash1, p_im = string_to_either_complex_1(sc, plus, slash2, ex2, has_dec_point2, radix, &d_im); if ((d_im == 0.0) && /* 1.0+0.0000000000000000000000000000i */ - ((!p_im) || (s7_is_zero(p_im)))) + ((!p_im) || (is_zero(sc, p_im)))) return((p_rl) ? p_rl : make_real(sc, d_rl)); if ((!p_rl) && (!p_im)) @@ -12568,10 +12582,6 @@ static s7_pointer string_to_either_complex(s7_scheme *sc, char *q, char *slash1, static bool big_numbers_are_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) { /* either or both can be big here, but not neither, and types might not match at all */ -#if S7_DEBUGGING - if ((!s7_is_bignum(a)) && (!s7_is_bignum(b))) - fprintf(stderr, "big eqv but neither is big: %s %s, %s %s\n", display(a), s7_type_names[type(a)], display(b), s7_type_names[type(b)]); -#endif switch (type(a)) { case T_INTEGER: @@ -12918,6 +12928,9 @@ static bool c_rationalize(s7_double ux, s7_double error, s7_int *numer, s7_int * { (*numer) = p0; (*denom) = q0; +#if S7_DEBUGGING + if (q0 == 0) fprintf(stderr, "%f %ld/0\n", ux, p0); +#endif } return(true); } @@ -12951,7 +12964,7 @@ s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error) { s7_int numer = 0, denom = 1; if (c_rationalize(x, error, &numer, &denom)) - return(s7_make_ratio(sc, numer, denom)); + return(make_ratio(sc, numer, denom)); return(make_real(sc, x)); } @@ -13029,21 +13042,12 @@ static s7_pointer c_complex_to_s7(s7_scheme *sc, s7_complex z) {return(make_comp static s7_pointer division_by_zero_error(s7_scheme *sc, s7_pointer caller, s7_pointer arg); -s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b) +static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b) { s7_pointer x; - if (b == 0) - return(division_by_zero_error(sc, wrap_string(sc, "make-ratio", 10), set_elist_2(sc, wrap_integer1(sc, a), int_zero))); - if (a == 0) - return(int_zero); - if (a == b) - return(int_one); - if (b == 1) - return(make_integer(sc, a)); - if (b == s7_int_min) { - /* we've got a problem... This should not trigger an error during reading -- we might have the + /* This should not trigger an error during reading -- we might have the * ratio on a switch with-bignums or whatever, so its mere occurrence is just an annoyance. */ if (a & 1) @@ -13051,13 +13055,11 @@ s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b) a /= 2; b /= 2; } - if (b < 0) { a = -a; b = -b; } - if (a == s7_int_min) /* believe it or not, gcc randomly says a != S7_INT64_MIN here but a == s7_int_min even with explicit types! This has to be a bug */ { while (((a & 1) == 0) && ((b & 1) == 0)) @@ -13089,6 +13091,12 @@ s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b) return(x); } +s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b) +{ + if (b == 0) + return(division_by_zero_error(sc, wrap_string(sc, "make-ratio", 10), set_elist_2(sc, wrap_integer1(sc, a), int_zero))); + return(make_ratio(sc, a, b)); +} #define WITH_OVERFLOW_ERROR true #define WITHOUT_OVERFLOW_ERROR false @@ -13186,7 +13194,7 @@ static s7_pointer inexact_to_exact(s7_scheme *sc, s7_pointer x) } /* c_rationalize limit is RATIONALIZE_LIMIT=1e12 currently so this is a tighter limit than DOUBLE_TO_INT64_LIMIT */ if (c_rationalize(val, sc->default_rationalize_error, &numer, &denom)) - return(s7_make_ratio(sc, numer, denom)); + return(make_ratio(sc, numer, denom)); } default: @@ -13302,52 +13310,7 @@ s7_double s7_real(s7_pointer x) return(0.0); } -static bool s7_is_negative(s7_pointer obj) -{ - switch (type(obj)) - { - case T_INTEGER: return(integer(obj) < 0); - case T_RATIO: return(numerator(obj) < 0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(obj), 0) < 0); - case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(obj), 0, 1) < 0); - case T_BIG_REAL: return(mpfr_cmp_ui(big_real(obj), 0) < 0); -#endif - default: return(real(obj) < 0); - } -} - -static bool s7_is_positive(s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x) > 0); - case T_RATIO: return(numerator(x) > 0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) > 0); - case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) > 0); - case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) > 0); -#endif - default: return(real(x) > 0.0); - } -} - -static bool s7_is_zero(s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x) == 0); - case T_REAL: return(real(x) == 0.0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) == 0); - case T_BIG_RATIO: return(false); - case T_BIG_REAL: return(mpfr_zero_p(big_real(x))); -#endif - default: return(false); /* ratios and complex numbers here are already collapsed into integers and reals */ - } -} - -static bool s7_is_one(s7_pointer x) +static bool is_one(s7_pointer x) { return(((is_t_integer(x)) && (integer(x) == 1)) || ((is_t_real(x)) && (real(x) == 1.0))); @@ -13920,8 +13883,8 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt * but then even worse: (format #f "~F" 1e308+1e308i)! */ s7_int len; - - len = ((width + precision) > 512) ? (512 + 2 * (width + precision)) : 1024; + len = width + precision; + len = (len > 512) ? (512 + 2 * len) : 1024; if (len > sc->num_to_str_size) { sc->num_to_str = (sc->num_to_str) ? (char *)Realloc(sc->num_to_str, len) : (char *)Malloc(len); @@ -13929,9 +13892,9 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt } /* bignums can't happen here */ - switch (type(obj)) + if (is_t_integer(obj)) { - case T_INTEGER: + char *p; if (width == 0) { if (has_number_name(obj)) @@ -13941,30 +13904,19 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt } return(integer_to_string(sc, integer(obj), nlen)); } - { - char *p; - p = integer_to_string(sc, integer(obj), &len); - if (width > len) - { - insert_spaces(sc, p, width, len); - (*nlen) = width; - return(sc->num_to_str); - } - (*nlen) = len; - return(p); - } - - case T_RATIO: - len = catstrs_direct(sc->num_to_str, integer_to_string_no_length(sc, numerator(obj)), "/", pos_int_to_str_direct(sc, denominator(obj)), (const char *)NULL); + p = integer_to_string(sc, integer(obj), &len); if (width > len) { - insert_spaces(sc, sc->num_to_str, width, len); + insert_spaces(sc, p, width, len); (*nlen) = width; + return(sc->num_to_str); } - else (*nlen) = len; - return(sc->num_to_str); + (*nlen) = len; + return(p); + } - case T_REAL: + if (is_t_real(obj)) + { if (width == 0) { #if WITH_DTOA @@ -13990,31 +13942,40 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt (*nlen) = len; floatify(sc->num_to_str, nlen); return(sc->num_to_str); + } - default: - { - char *imag; - sc->num_to_str[0] = '\0'; - real(sc->real_wrapper4) = imag_part(obj); - imag = copy_string(number_to_string_base_10(sc, sc->real_wrapper4, 0, precision, float_choice, &len, choice)); + if (is_t_complex(obj)) + { + char *imag; + sc->num_to_str[0] = '\0'; + real(sc->real_wrapper4) = imag_part(obj); + imag = copy_string(number_to_string_base_10(sc, sc->real_wrapper4, 0, precision, float_choice, &len, choice)); - sc->num_to_str[0] = '\0'; - real(sc->real_wrapper3) = real_part(obj); - number_to_string_base_10(sc, sc->real_wrapper3, 0, precision, float_choice, &len, choice); + sc->num_to_str[0] = '\0'; + real(sc->real_wrapper3) = real_part(obj); + number_to_string_base_10(sc, sc->real_wrapper3, 0, precision, float_choice, &len, choice); - sc->num_to_str[len] = '\0'; - len = catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+') || (imag[0] == '-')) ? "" : "+", imag, "i", (char *)NULL); - free(imag); + sc->num_to_str[len] = '\0'; + len = catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+') || (imag[0] == '-')) ? "" : "+", imag, "i", (char *)NULL); + free(imag); - if (width > len) /* (format #f "~20g" 1+i) */ - { - insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */ - (*nlen) = width; - } - else (*nlen) = len; - } - break; + if (width > len) /* (format #f "~20g" 1+i) */ + { + insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */ + (*nlen) = width; + } + else (*nlen) = len; + return(sc->num_to_str); + } + + /* ratio */ + len = catstrs_direct(sc->num_to_str, integer_to_string_no_length(sc, numerator(obj)), "/", pos_int_to_str_direct(sc, denominator(obj)), (const char *)NULL); + if (width > len) + { + insert_spaces(sc, sc->num_to_str, width, len); + (*nlen) = width; } + else (*nlen) = len; return(sc->num_to_str); } @@ -14127,14 +14088,15 @@ static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32 if (ipart >= radix) /* rounding confusion */ ipart = radix - 1; frac_part -= (ipart / base); - d[i] = (ipart < 10) ? (char)('0' + ipart) : (char)('a' + ipart - 10); + /* d[i] = ((const char *)"0123456789abcdef")[ipart]; */ + d[i] = dignum[ipart]; } if (i == 0) d[i++] = '0'; d[i] = '\0'; b = mallocate(sc, 256); p = (char *)block_data(b); - /* much faster in this case (because we know the string lengths) than catstrs */ + /* much faster than catstrs because we know the string lengths */ { char *pt = p; if (sign) {pt[0] = '-'; pt++;} @@ -14154,16 +14116,23 @@ static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32 default: { block_t *n, *d; - char *dp; + char *dp, *pt; + s7_int real_len = 0, imag_len = 0; real(sc->real_wrapper3) = real_part(obj); - n = number_to_string_with_radix(sc, sc->real_wrapper3, radix, 0, precision, float_choice, &len); /* include floatify */ + n = number_to_string_with_radix(sc, sc->real_wrapper3, radix, 0, precision, float_choice, &real_len); /* include floatify */ real(sc->real_wrapper4) = imag_part(obj); - d = number_to_string_with_radix(sc, sc->real_wrapper4, radix, 0, precision, float_choice, &len); + d = number_to_string_with_radix(sc, sc->real_wrapper4, radix, 0, precision, float_choice, &imag_len); dp = (char *)block_data(d); b = mallocate(sc, 512); p = (char *)block_data(b); - p[0] = '\0'; - len = catstrs(p, 512, (char *)block_data(n), ((dp[0] == '+') || (dp[0] == '-')) ? "" : "+", dp, "i", (char *)NULL); + pt = p; + memcpy(pt, (void *)block_data(n), real_len); + pt += real_len; + if ((dp[0] != '+') && (dp[0] != '-')) {pt[0] = '+'; pt++;} + memcpy(pt, dp, imag_len); + pt[imag_len] = 'i'; + pt[imag_len + 1] = '\0'; + len = pt + imag_len + 1 - p; str_len = 512; liberate(sc, n); liberate(sc, d); @@ -14210,7 +14179,7 @@ static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args) char *res; s7_pointer x = car(args); - if (!s7_is_number(x)) + if (!is_number(x)) return(method_or_bust_with_type(sc, x, sc->number_to_string_symbol, args, a_number_string, 1)); if (is_pair(cdr(args))) @@ -14261,7 +14230,7 @@ static s7_pointer number_to_string_p_p(s7_scheme *sc, s7_pointer p) s7_int nlen = 0; char *res; if (!is_number(p)) - return(wrong_type_argument_with_type(sc, sc->number_to_string_symbol, 1, p, a_number_string)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->number_to_string_symbol, a_number_string)); res = number_to_string_base_10(sc, p, 0, sc->float_format_precision, 'g', &nlen, P_WRITE); return(inline_make_string_with_length(sc, res, nlen)); #endif @@ -14448,8 +14417,7 @@ static s7_pointer make_undefined(s7_scheme *sc, const char* name) if (len > 0) memcpy((void *)(newstr + 1), (void *)name, len); newstr[len + 1] = '\0'; - if (sc->undefined_constant_warnings) - s7_warn(sc, len + 32, "%s is undefined\n", newstr); + if (sc->undefined_constant_warnings) s7_warn(sc, len + 32, "%s is undefined\n", newstr); undefined_set_name_length(p, len + 1); undefined_name(p) = newstr; add_undefined(sc, p); @@ -14620,7 +14588,7 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool with_error char buf[256]; size_t len; len = snprintf(buf, 256, "#%s is not a number", name); - s7_error(sc, sc->read_error_symbol, set_elist_1(sc, s7_make_string_with_length(sc, buf, len))); /* can't use wrap_string here */ + s7_error(sc, sc->read_error_symbol, set_elist_1(sc, s7_make_string_with_length(sc, buf, len))); /* can't use wrap_string here (buf is local) */ } return(res); } @@ -15132,7 +15100,7 @@ static s7_pointer nan1_or_bust(s7_scheme *sc, s7_double x, char *p, char *q, int if (p[len - 1] == 'i') /* +nan.0[+/-]...i */ { if (len == 6) /* +nan.0+i */ - return(make_complex_unchecked(sc, x, (p[4] == '+') ? 1.0 : -1.0)); + return(make_complex_not_0i(sc, x, (p[4] == '+') ? 1.0 : -1.0)); if ((len > 5) && (len < 1024)) /* make compiler happy */ { char *ip; @@ -15542,7 +15510,7 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym * but q is the entire number ('/' included) and slash1 is the stuff after the '/', and every * big number comes through here, so there's no clean and safe way to check that q == slash1. */ - return(s7_make_ratio(sc, n, d)); + return(make_ratio(sc, n, d)); } #else return(string_to_either_ratio(sc, q, slash1, radix)); @@ -15568,7 +15536,7 @@ static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix) { s7_pointer x; x = make_atom(sc, str, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); - return((s7_is_number(x)) ? x : sc->F); /* only needed because str might start with '#' and not be a number (#t for example) */ + return((is_number(x)) ? x : sc->F); /* only needed because str might start with '#' and not be a number (#t for example) */ } static s7_pointer string_to_number_p_p(s7_scheme *sc, s7_pointer str1) @@ -15683,7 +15651,7 @@ static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x) } #else if (numerator(x) == S7_INT64_MIN) - return(s7_make_ratio(sc, S7_INT64_MAX, denominator(x))); + return(make_ratio(sc, S7_INT64_MAX, denominator(x))); #endif return(make_simple_ratio(sc, -numerator(x), denominator(x))); @@ -15737,8 +15705,7 @@ static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x) switch (type(x)) { case T_INTEGER: - if (integer(x) == S7_INT64_MIN) - return(make_integer(sc, S7_INT64_MAX)); + if (integer(x) == S7_INT64_MIN) return(mostfix); /* (magnitude -9223372036854775808) -> -9223372036854775808 * same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808 */ @@ -16067,7 +16034,7 @@ static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args) if (fabs(rat) < fabs(err)) return(int_zero); - return((c_rationalize(rat, err, &numer, &denom)) ? s7_make_ratio(sc, numer, denom) : sc->F); + return((c_rationalize(rat, err, &numer, &denom)) ? make_ratio(sc, numer, denom) : sc->F); }} return(sc->F); /* make compiler happy */ } @@ -16077,12 +16044,12 @@ static s7_pointer rationalize_p_i(s7_scheme *sc, s7_int x) {return(make_integer( static s7_pointer rationalize_p_d(s7_scheme *sc, s7_double x) { if ((is_NaN(x)) || (is_inf(x))) - return(out_of_range(sc, sc->rationalize_symbol, int_one, make_real(sc, x), a_normal_real_string)); + return(out_of_range(sc, sc->rationalize_symbol, int_one, wrap_real1(sc, x), a_normal_real_string)); /* was make_real, also below */ if (fabs(x) > RATIONALIZE_LIMIT) #if WITH_GMP return(big_rationalize(sc, set_plist_1(sc, wrap_real1(sc, x)))); #else - return(out_of_range(sc, sc->rationalize_symbol, int_one, make_real(sc, x), its_too_large_string)); + return(out_of_range(sc, sc->rationalize_symbol, int_one, wrap_real1(sc, x), its_too_large_string)); #endif return(s7_rationalize(sc, x, sc->default_rationalize_error)); } @@ -16222,7 +16189,7 @@ static s7_pointer g_complex(s7_scheme *sc, s7_pointer args) case T_RATIO: switch (type(x)) { - case T_INTEGER: return(s7_make_complex(sc, (s7_double)integer(x), (s7_double)fraction(y))); + case T_INTEGER: return(s7_make_complex(sc, (s7_double)integer(x), (s7_double)fraction(y))); /* can fraction be 0.0? */ case T_RATIO: return(s7_make_complex(sc, (s7_double)fraction(x), (s7_double)fraction(y))); case T_REAL: return(s7_make_complex(sc, real(x), (s7_double)fraction(y))); default: return(method_or_bust(sc, x, sc->complex_symbol, args, T_REAL, 1)); @@ -16244,12 +16211,12 @@ static s7_pointer g_complex(s7_scheme *sc, s7_pointer args) static s7_pointer complex_p_ii(s7_scheme *sc, s7_int x, s7_int y) { - return((y == 0) ? make_integer(sc, x) : make_complex_unchecked(sc, (s7_double)x, (s7_double)y)); + return((y == 0) ? make_integer(sc, x) : make_complex_not_0i(sc, (s7_double)x, (s7_double)y)); } static s7_pointer complex_p_dd(s7_scheme *sc, s7_double x, s7_double y) { - return((y == 0) ? make_real(sc, x) : make_complex_unchecked(sc, x, y)); + return((y == 0) ? make_real(sc, x) : make_complex_not_0i(sc, x, y)); } @@ -16414,13 +16381,13 @@ static s7_pointer big_log(s7_scheme *sc, s7_pointer args) { s7_pointer p0 = car(args), p1 = NULL, res; - if (!s7_is_number(p0)) + if (!is_number(p0)) return(method_or_bust_with_type(sc, p0, sc->log_symbol, args, a_number_string, 1)); if (is_pair(cdr(args))) { p1 = cadr(args); - if (!s7_is_number(p1)) + if (!is_number(p1)) return(method_or_bust_with_type(sc, p1, sc->log_symbol, args, a_number_string, 2)); } @@ -16428,9 +16395,9 @@ static s7_pointer big_log(s7_scheme *sc, s7_pointer args) { res = any_real_to_mpfr(sc, p0, sc->mpfr_1); if (res == real_NaN) return(res); - if ((s7_is_positive(p0)) && + if ((is_positive(sc, p0)) && ((!p1) || - ((s7_is_real(p1)) && (s7_is_positive(p1))))) + ((s7_is_real(p1)) && (is_positive(sc, p1))))) { if (res) return(res); mpfr_log(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); @@ -16460,8 +16427,8 @@ static s7_pointer big_log(s7_scheme *sc, s7_pointer args) res = any_number_to_mpc(sc, p0, sc->mpc_1); if (res) { - if ((res == real_infinity) && (p1) && ((s7_is_negative(p0)))) - return(make_complex_unchecked(sc, INFINITY, -NAN)); + if ((res == real_infinity) && (p1) && ((is_negative(sc, p0)))) + return(make_complex_not_0i(sc, INFINITY, -NAN)); return((res == real_NaN) ? complex_NaN : res); } mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN); @@ -16482,7 +16449,7 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args) #define Q_log sc->pcl_n s7_pointer x = car(args); - if (!s7_is_number(x)) + if (!is_number(x)) return(method_or_bust_with_type(sc, x, sc->log_symbol, args, a_number_string, 1)); #if WITH_GMP @@ -16491,7 +16458,7 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args) if (is_pair(cdr(args))) { s7_pointer y = cadr(args); - if (!(s7_is_number(y))) + if (!(is_number(y))) return(method_or_bust_with_type(sc, y, sc->log_symbol, args, a_number_string, 2)); #if WITH_GMP @@ -16521,7 +16488,7 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args) #endif }} if ((s7_is_real(x)) && - (s7_is_positive(x))) + (is_positive(sc, x))) return(make_real(sc, log(s7_real(x)) * LOG_2)); return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) * LOG_2)); } @@ -16530,7 +16497,7 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args) return(int_zero); /* (log 1 0) must be 0 since everyone says (expt 0 0) is 1 */ - if (s7_is_zero(y)) + if (is_zero(sc, y)) { if ((is_t_integer(y)) && (is_t_integer(x)) && (integer(x) == 1)) return(y); @@ -16539,13 +16506,13 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args) if ((is_t_real(x)) && (is_NaN(real(x)))) return(real_NaN); - if (s7_is_one(y)) /* this used to raise an error, but the bignum case is simpler if we return inf */ - return((s7_is_one(x)) ? real_zero : real_infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */ + if (is_one(y)) /* this used to raise an error, but the bignum case is simpler if we return inf */ + return((is_one(x)) ? real_zero : real_infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */ if ((s7_is_real(x)) && (s7_is_real(y)) && - (s7_is_positive(x)) && - (s7_is_positive(y))) + (is_positive(sc, x)) && + (is_positive(sc, y))) { if ((s7_is_rational(x)) && (s7_is_rational(y))) @@ -16579,9 +16546,9 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args) if (!s7_is_real(x)) return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)))); - if (s7_is_positive(x)) + if (is_positive(sc, x)) return(make_real(sc, log(s7_real(x)))); - return(s7_make_complex(sc, log(-s7_real(x)), M_PI)); + return(make_complex_not_0i(sc, log(-s7_real(x)), M_PI)); } @@ -16843,7 +16810,7 @@ static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x) case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS if (imag_part(x) > 350.0) - return(s7_make_complex(sc, 0.0, 1.0)); + return(make_complex_not_0i(sc, 0.0, 1.0)); return((imag_part(x) < -350.0) ? s7_make_complex(sc, 0.0, -1.0) : c_complex_to_s7(sc, ctan(to_c_complex(x)))); #else return(out_of_range(sc, sc->tan_symbol, int_one, x, no_complex_numbers_string)); @@ -16866,9 +16833,9 @@ static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x) case T_BIG_COMPLEX: if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, 350))) > 0) - return(s7_make_complex(sc, 0.0, 1.0)); + return(make_complex_not_0i(sc, 0.0, 1.0)); if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, -350))) < 0) - return(s7_make_complex(sc, 0.0, -1.0)); + return(make_complex_not_0i(sc, 0.0, -1.0)); mpc_tan(sc->mpc_1, big_complex(x), MPC_RNDNN); if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); @@ -16948,8 +16915,8 @@ static s7_pointer asin_p_p(s7_scheme *sc, s7_pointer p) if (mpfr_inf_p(big_real(p))) { if (mpfr_cmp_ui(big_real(p), 0) < 0) - return(make_complex_unchecked(sc, NAN, INFINITY)); /* match non-bignum choice */ - return(make_complex_unchecked(sc, NAN, -INFINITY)); + return(make_complex_not_0i(sc, NAN, INFINITY)); /* match non-bignum choice */ + return(make_complex_not_0i(sc, NAN, -INFINITY)); } mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); ASIN_BIG_REAL: @@ -17042,8 +17009,8 @@ static s7_pointer acos_p_p(s7_scheme *sc, s7_pointer p) if (mpfr_inf_p(big_real(p))) { if (mpfr_cmp_ui(big_real(p), 0) < 0) - return(make_complex_unchecked(sc, -NAN, -INFINITY)); /* match non-bignum choice */ - return(make_complex_unchecked(sc, -NAN, INFINITY)); + return(make_complex_not_0i(sc, -NAN, -INFINITY)); /* match non-bignum choice */ + return(make_complex_not_0i(sc, -NAN, INFINITY)); } mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); ACOS_BIG_REAL: @@ -17377,7 +17344,7 @@ static s7_pointer g_tanh(s7_scheme *sc, s7_pointer args) (mpfr_inf_p(mpc_imagref(big_complex(x))))) { if (mpfr_cmp_ui(mpc_realref(big_complex(x)), 0) == 0) - return(make_complex_unchecked(sc, 0.0, NAN)); /* match non-bignum choice */ + return(make_complex_not_0i(sc, 0.0, NAN)); /* match non-bignum choice */ return(complex_NaN); } @@ -17405,13 +17372,10 @@ static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args) { case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, asinh((s7_double)integer(x)))); - case T_RATIO: return(make_real(sc, asinh(fraction(x)))); - case T_REAL: return(make_real(sc, asinh(real(x)))); - case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS #if (defined(__OpenBSD__)) || (defined(__NetBSD__)) @@ -17428,16 +17392,13 @@ static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args) mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: mpfr_asinh(sc->mpfr_1, big_real(x), MPFR_RNDN); return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: mpc_asinh(sc->mpc_1, big_complex(x), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); @@ -17459,7 +17420,6 @@ static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args) { case T_INTEGER: if (integer(x) == 1) return(int_zero); - case T_REAL: case T_RATIO: { @@ -17467,7 +17427,6 @@ static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args) if (x1 >= 1.0) return(make_real(sc, acosh(x1))); } - case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS #ifdef __OpenBSD__ @@ -17485,22 +17444,18 @@ static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args) mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: mpc_set_fr(sc->mpc_1, big_real(x), MPC_RNDNN); mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: mpc_acosh(sc->mpc_1, big_complex(x), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); #endif - default: return(method_or_bust_with_type_one_arg_p(sc, x, sc->acosh_symbol, a_number_string)); } @@ -17626,7 +17581,7 @@ static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p) { s7_int dn = (s7_int)sqrt(denominator(p)); if (dn * dn == denominator(p)) - return(s7_make_ratio(sc, nm, dn)); + return(make_ratio(sc, nm, dn)); } return(make_real(sc, sqrt((s7_double)fraction(p)))); } @@ -17641,7 +17596,7 @@ static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p) return(real_NaN); if (real(p) >= 0.0) return(make_real(sc, sqrt(real(p)))); - return(s7_make_complex(sc, 0.0, sqrt(-real(p)))); + return(make_complex_not_0i(sc, 0.0, sqrt(-real(p)))); case T_COMPLEX: /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */ #if HAVE_COMPLEX_NUMBERS @@ -17748,27 +17703,27 @@ static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2); static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) { s7_pointer x = car(args), y, res; - if (!s7_is_number(x)) + if (!is_number(x)) return(method_or_bust_with_type(sc, x, sc->expt_symbol, args, a_number_string, 1)); y = cadr(args); - if (!s7_is_number(y)) + if (!is_number(y)) return(method_or_bust_with_type(sc, y, sc->expt_symbol, args, a_number_string, 2)); - if (s7_is_zero(x)) + if (is_zero(sc, x)) { if ((s7_is_integer(x)) && (s7_is_integer(y)) && - (s7_is_zero(y))) + (is_zero(sc, y))) return(int_one); if (s7_is_real(y)) { - if (s7_is_negative(y)) + if (is_negative(sc, y)) return(division_by_zero_error(sc, sc->expt_symbol, args)); } else - if (s7_is_negative(real_part_p_p(sc, y))) /* handle big_complex as well as complex */ + if (is_negative(sc, real_part_p_p(sc, y))) /* handle big_complex as well as complex */ return(division_by_zero_error(sc, sc->expt_symbol, args)); if ((s7_is_rational(x)) && @@ -17788,7 +17743,7 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) return(x); if ((!is_big_number(x)) && - ((s7_is_one(x)) || (s7_is_zero(x)))) + ((is_one(x)) || (is_zero(sc, x)))) return(x); if ((yval < S7_INT32_MAX) && @@ -17872,36 +17827,36 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) res = any_number_to_mpc(sc, y, sc->mpc_2); if (res == real_infinity) { - if (s7_is_one(x)) return(int_one); - if (!s7_is_real(x)) return((s7_is_negative(y)) ? real_zero : complex_NaN); - if (s7_is_zero(x)) + if (is_one(x)) return(int_one); + if (!s7_is_real(x)) return((is_negative(sc, y)) ? real_zero : complex_NaN); + if (is_zero(sc, x)) { - if (s7_is_negative(y)) return(division_by_zero_error(sc, sc->expt_symbol, args)); + if (is_negative(sc, y)) return(division_by_zero_error(sc, sc->expt_symbol, args)); return(real_zero); } if (lt_b_pi(sc, x, 0)) { if (lt_b_pi(sc, x, -1)) - return((s7_is_positive(y)) ? real_infinity : real_zero); - return((s7_is_positive(y)) ? real_zero : real_infinity); + return((is_positive(sc, y)) ? real_infinity : real_zero); + return((is_positive(sc, y)) ? real_zero : real_infinity); } if (lt_b_pi(sc, x, 1)) - return((s7_is_positive(y)) ? real_zero : real_infinity); - return((s7_is_positive(y)) ? real_infinity : real_zero); + return((is_positive(sc, y)) ? real_zero : real_infinity); + return((is_positive(sc, y)) ? real_infinity : real_zero); } if (res) return(complex_NaN); if ((s7_is_real(x)) && (s7_is_real(y)) && - (s7_is_positive(x))) + (is_positive(sc, x))) { res = any_real_to_mpfr(sc, x, sc->mpfr_1); if (res) { if (res == real_infinity) { - if (s7_is_negative(y)) return(real_zero); - return((s7_is_zero(y)) ? real_one : real_infinity); + if (is_negative(sc, y)) return(real_zero); + return((is_zero(sc, y)) ? real_one : real_infinity); } return(complex_NaN); } @@ -17914,8 +17869,8 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) { if ((res == real_infinity) && (s7_is_real(y))) { - if (s7_is_negative(y)) return(real_zero); - return((s7_is_zero(y)) ? real_one : real_infinity); + if (is_negative(sc, y)) return(real_zero); + return((is_zero(sc, y)) ? real_one : real_infinity); } return(complex_NaN); } @@ -17959,21 +17914,16 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args) /* big_expt sometimes chooses a different value: g_expt (expt -1 1/3) is -1, but big_expt (expt -1 (bignum 1/3)) is (complex 1/2 (/ (sqrt 3) 2)) */ #endif - if (!s7_is_number(n)) + if (!is_number(n)) return(method_or_bust_with_type(sc, n, sc->expt_symbol, args, a_number_string, 1)); pw = cadr(args); - if (!s7_is_number(pw)) + if (!is_number(pw)) return(method_or_bust_with_type(sc, pw, sc->expt_symbol, args, a_number_string, 2)); - /* this provides more than 2 args to expt: - * if (is_not_null(cddr(args))) return(g_expt(sc, list_2(sc, car(args), g_expt(sc, cdr(args))))); - * but it's unusual in scheme to process args in reverse order, and the syntax by itself is ambiguous (does (expt 2 2 3) = 256 or 64?) - */ - - if (s7_is_zero(n)) + if (is_zero(sc, n)) { - if (s7_is_zero(pw)) + if (is_zero(sc, pw)) { if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* (expt 0 0) -> 1 */ return(int_one); @@ -17981,7 +17931,7 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args) } if (s7_is_real(pw)) { - if (s7_is_negative(pw)) /* (expt 0 -1) */ + if (is_negative(sc, pw)) /* (expt 0 -1) */ return(division_by_zero_error(sc, sc->expt_symbol, args)); /* (Clisp gives divide-by-zero error here, Guile returns inf.0) */ @@ -18001,7 +17951,7 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args) return(real_zero); /* (expt 0.0 123123) */ } - if (s7_is_one(pw)) + if (is_one(pw)) { if (s7_is_integer(pw)) /* (expt x 1) */ return(n); @@ -18048,7 +17998,7 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args) { if (y > 0) return(make_integer(sc, int_to_int(x, y))); - return(s7_make_ratio(sc, 1, int_to_int(x, -y))); + return(make_ratio(sc, 1, int_to_int(x, -y))); }} break; @@ -18067,7 +18017,7 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args) (int_pow_ok(dn, s7_int_abs(y)))) { if (y > 0) - return(s7_make_ratio(sc, int_to_int(nm, y), int_to_int(dn, y))); + return(make_ratio(sc, int_to_int(nm, y), int_to_int(dn, y))); return(s7_make_ratio(sc, int_to_int(dn, -y), int_to_int(nm, -y))); }} break; @@ -18100,9 +18050,9 @@ static s7_pointer g_expt(s7_scheme *sc, s7_pointer args) switch (s7_int_abs(y) % 4) { case 0: return(real_one); - case 1: return(s7_make_complex(sc, 0.0, (yp == np) ? 1.0 : -1.0)); + case 1: return(make_complex_not_0i(sc, 0.0, (yp == np) ? 1.0 : -1.0)); case 2: return(make_real(sc, -1.0)); - case 3: return(s7_make_complex(sc, 0.0, (yp == np) ? -1.0 : 1.0)); + case 3: return(make_complex_not_0i(sc, 0.0, (yp == np) ? -1.0 : 1.0)); }} #else return(out_of_range(sc, sc->expt_symbol, int_two, n, no_complex_numbers_string)); @@ -18162,27 +18112,22 @@ static s7_pointer big_lcm(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); mpz_set_si(sc->mpz_4, 1); break; - case T_RATIO: mpz_set_si(sc->mpz_1, numerator(rat)); mpz_set_si(sc->mpz_2, denominator(rat)); mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); mpz_gcd(sc->mpz_4, sc->mpz_4, sc->mpz_2); break; - case T_BIG_INTEGER: mpz_lcm(sc->mpz_3, sc->mpz_3, big_integer(rat)); mpz_set_si(sc->mpz_4, 1); break; - case T_BIG_RATIO: mpz_lcm(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); mpz_gcd(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); break; - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(x, args), rat, a_rational_string)); - default: return(method_or_bust_with_type(sc, rat, sc->lcm_symbol, set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), @@ -18303,7 +18248,6 @@ static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args) case T_BIG_RATIO: return(big_lcm(sc, n, d, p)); #endif - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: return(wrong_type_argument_with_type(sc, sc->lcm_symbol, position_of(p, args), x, a_rational_string)); @@ -18335,26 +18279,21 @@ static s7_pointer big_gcd(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args mpz_set_si(sc->mpz_1, integer(rat)); mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); break; - case T_RATIO: mpz_set_si(sc->mpz_1, numerator(rat)); mpz_set_si(sc->mpz_2, denominator(rat)); mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); mpz_lcm(sc->mpz_4, sc->mpz_4, sc->mpz_2); break; - case T_BIG_INTEGER: mpz_gcd(sc->mpz_3, sc->mpz_3, big_integer(rat)); break; - case T_BIG_RATIO: mpz_gcd(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); mpz_lcm(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); break; - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: return(wrong_type_argument_with_type(sc, sc->gcd_symbol, position_of(x, args), rat, a_rational_string)); - default: return(method_or_bust_with_type(sc, rat, sc->gcd_symbol, set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), @@ -18447,7 +18386,6 @@ static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) { case T_INTEGER: return(x); - case T_RATIO: { s7_int val = numerator(x) / denominator(x); @@ -18459,7 +18397,6 @@ static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) */ return((numerator(x) < 0) ? make_integer(sc, val - 1) : make_integer(sc, val)); /* not "val" because it might be truncated to 0 */ } - case T_REAL: { s7_double z = real(x); @@ -18481,15 +18418,12 @@ static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) return(make_integer(sc, (s7_int)floor(z))); /* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */ } - #if WITH_GMP case T_BIG_INTEGER: return(x); - case T_BIG_RATIO: mpz_fdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: if (mpfr_nan_p(big_real(x))) return(simple_out_of_range(sc, sc->floor_symbol, x, its_nan_string)); @@ -18497,12 +18431,10 @@ static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) return(simple_out_of_range(sc, sc->floor_symbol, x, its_infinite_string)); mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDD); return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: #endif case T_COMPLEX: return(s7_wrong_type_arg_error(sc, "floor", 0, x, "a real number")); - default: return(method_or_bust_one_arg_p(sc, x, sc->floor_symbol, T_REAL)); } @@ -18543,23 +18475,17 @@ static s7_int floor_i_7p(s7_scheme *sc, s7_pointer p) /* -------------------------------- ceiling -------------------------------- */ -static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args) +static s7_pointer ceiling_p_p(s7_scheme *sc, s7_pointer x) { - #define H_ceiling "(ceiling x) returns the integer closest to x toward inf" - #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - - s7_pointer x = car(args); switch (type(x)) { case T_INTEGER: return(x); - case T_RATIO: { s7_int val = numerator(x) / denominator(x); return((numerator(x) < 0) ? make_integer(sc, val) : make_integer(sc, val + 1)); } - case T_REAL: { s7_double z = real(x); @@ -18580,15 +18506,12 @@ static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args) #endif return(make_integer(sc, (s7_int)ceil(real(x)))); } - #if WITH_GMP case T_BIG_INTEGER: return(x); - case T_BIG_RATIO: mpz_cdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: if (mpfr_nan_p(big_real(x))) return(simple_out_of_range(sc, sc->ceiling_symbol, x, its_nan_string)); @@ -18596,15 +18519,22 @@ static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args) return(simple_out_of_range(sc, sc->ceiling_symbol, x, its_infinite_string)); mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDU); return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: #endif case T_COMPLEX: + return(s7_wrong_type_arg_error(sc, "ceiling", 0, x, "a real number")); default: - return(method_or_bust_one_arg(sc, x, sc->ceiling_symbol, args, T_REAL)); + return(method_or_bust_one_arg_p(sc, x, sc->ceiling_symbol, T_REAL)); } } +static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args) +{ + #define H_ceiling "(ceiling x) returns the integer closest to x toward inf" + #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) + return(ceiling_p_p(sc, car(args))); +} + static s7_int ceiling_i_i(s7_int i) {return(i);} #if (!WITH_GMP) @@ -18635,10 +18565,8 @@ static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x) { case T_INTEGER: return(x); - case T_RATIO: return(make_integer(sc, (s7_int)(numerator(x) / denominator(x)))); /* C "/" already truncates (but this divide is not accurate over e13) */ - case T_REAL: { s7_double z = real(x); @@ -18659,15 +18587,12 @@ static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x) #endif return((z > 0.0) ? make_integer(sc, (s7_int)floor(z)) : make_integer(sc, (s7_int)ceil(z))); } - #if WITH_GMP case T_BIG_INTEGER: return(x); - case T_BIG_RATIO: mpz_tdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: if (mpfr_nan_p(big_real(x))) return(simple_out_of_range(sc, sc->truncate_symbol, x, its_nan_string)); @@ -18675,10 +18600,10 @@ static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x) return(simple_out_of_range(sc, sc->truncate_symbol, x, its_infinite_string)); mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDZ); return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: #endif case T_COMPLEX: + return(s7_wrong_type_arg_error(sc, "truncate", 0, x, "a real number")); default: return(method_or_bust_one_arg_p(sc, x, sc->truncate_symbol, T_REAL)); } @@ -18718,17 +18643,12 @@ static s7_double r5rs_round(s7_double x) return((fmod(fl, 2.0) == 0.0) ? fl : ce); } -static s7_pointer g_round(s7_scheme *sc, s7_pointer args) +static s7_pointer round_p_p(s7_scheme *sc, s7_pointer x) { - #define H_round "(round x) returns the integer closest to x" - #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - - s7_pointer x = car(args); switch (type(x)) { case T_INTEGER: return(x); - case T_RATIO: { s7_int truncated = numerator(x) / denominator(x), remains = numerator(x) % denominator(x); @@ -18740,7 +18660,6 @@ static s7_pointer g_round(s7_scheme *sc, s7_pointer args) return((numerator(x) < 0) ? make_integer(sc, truncated - 1) : make_integer(sc, truncated + 1)); return(make_integer(sc, truncated)); } - case T_REAL: { s7_double z = real(x); @@ -18762,11 +18681,9 @@ static s7_pointer g_round(s7_scheme *sc, s7_pointer args) #endif return(make_integer(sc, (s7_int)r5rs_round(z))); } - #if WITH_GMP case T_BIG_INTEGER: return(x); - case T_BIG_RATIO: { int32_t rnd; @@ -18782,7 +18699,6 @@ static s7_pointer g_round(s7_scheme *sc, s7_pointer args) mpz_add_ui(sc->mpz_1, sc->mpz_1, 1); return(mpz_to_integer(sc, sc->mpz_1)); } - case T_BIG_REAL: if (mpfr_nan_p(big_real(x))) return(simple_out_of_range(sc, sc->round_symbol, x, its_nan_string)); @@ -18792,15 +18708,22 @@ static s7_pointer g_round(s7_scheme *sc, s7_pointer args) mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); return(mpz_to_integer(sc, sc->mpz_3)); - case T_BIG_COMPLEX: #endif case T_COMPLEX: + return(s7_wrong_type_arg_error(sc, "round", 0, x, "a real number")); default: - return(method_or_bust_one_arg(sc, x, sc->round_symbol, args, T_REAL)); + return(method_or_bust_one_arg_p(sc, x, sc->round_symbol, T_REAL)); } } +static s7_pointer g_round(s7_scheme *sc, s7_pointer args) +{ + #define H_round "(round x) returns the integer closest to x" + #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) + return(round_p_p(sc, car(args))); +} + static s7_int round_i_i(s7_int i) {return(i);} #if (!WITH_GMP) @@ -18831,7 +18754,10 @@ static inline s7_pointer add_if_overflow_to_real_or_big_integer(s7_scheme *sc, s return(mpz_to_big_integer(sc, sc->mpz_1)); } #else - return(make_real(sc, (long_double)x + (long_double)y)); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y); + return(make_real(sc, (long_double)x + (long_double)y)); + } #endif return(make_integer(sc, val)); #else @@ -18855,11 +18781,14 @@ static s7_pointer integer_ratio_add_if_overflow_to_real_or_rational(s7_scheme *s return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, (long_double)integer(x) + fraction(y))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer + ratio overflow: (+ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); + return(make_real(sc, (long_double)integer(x) + fraction(y))); + } #endif - return(s7_make_ratio(sc, z, denominator(y))); + return(make_ratio(sc, z, denominator(y))); #else - return(s7_make_ratio(sc, integer(x) * denominator(y) + numerator(y), denominator(y))); + return(make_ratio(sc, integer(x) * denominator(y) + numerator(y), denominator(y))); #endif } @@ -18905,7 +18834,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) #endif return(make_real(sc, (long_double)integer(x) + real(y))); case T_COMPLEX: - return(s7_make_complex(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y))); + return(make_complex_not_0i(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y))); #if WITH_GMP case T_BIG_INTEGER: mpz_set_si(sc->mpz_1, integer(x)); @@ -18949,7 +18878,10 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, ((long_double)n1 + (long_double)n2) / (long_double)d1)); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (/ (+ %" ld64 " %" ld64 ") %" ld64 ")\n", n1, n2, d1); + return(make_real(sc, ((long_double)n1 + (long_double)n2) / (long_double)d1)); + } #endif return(s7_make_ratio(sc, q, d1)); #else @@ -18972,7 +18904,10 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, ((long_double)n1 / (long_double)d1) + ((long_double)n2 / (long_double)d2))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (+ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, ((long_double)n1 / (long_double)d1) + ((long_double)n2 / (long_double)d2))); + } #endif return(s7_make_ratio(sc, q, d1d2)); } @@ -18983,7 +18918,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_REAL: return(make_real(sc, fraction(x) + real(y))); case T_COMPLEX: - return(s7_make_complex(sc, fraction(x) + real_part(y), imag_part(y))); + return(make_complex_not_0i(sc, fraction(x) + real_part(y), imag_part(y))); #if WITH_GMP case T_BIG_INTEGER: mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); @@ -19026,7 +18961,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_REAL: return(make_real(sc, real(x) + real(y))); case T_COMPLEX: - return(s7_make_complex(sc, real(x) + real_part(y), imag_part(y))); + return(make_complex_not_0i(sc, real(x) + real_part(y), imag_part(y))); #if WITH_GMP case T_BIG_INTEGER: mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); @@ -19052,11 +18987,11 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) switch (type(y)) { case T_INTEGER: - return(s7_make_complex(sc, real_part(x) + integer(y), imag_part(x))); + return(make_complex_not_0i(sc, real_part(x) + integer(y), imag_part(x))); case T_RATIO: - return(s7_make_complex(sc, real_part(x) + fraction(y), imag_part(x))); + return(make_complex_not_0i(sc, real_part(x) + fraction(y), imag_part(x))); case T_REAL: - return(s7_make_complex(sc, real_part(x) + real(y), imag_part(x))); + return(make_complex_not_0i(sc, real_part(x) + real(y), imag_part(x))); case T_COMPLEX: return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); #if WITH_GMP @@ -19240,7 +19175,7 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) } } -static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) +static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) { #if HAVE_OVERFLOW_CHECKS && (!WITH_GMP) if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) @@ -19249,6 +19184,7 @@ static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointe if ((!add_overflow(integer(x), integer(y), &val)) && (!add_overflow(val, integer(z), &val))) return(make_integer(sc, val)); + if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", integer(x), integer(y), integer(z)); return(make_real(sc, (long_double)integer(x) + (long_double)integer(y) + (long_double)integer(z))); } #endif @@ -19300,6 +19236,7 @@ static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args) mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); return(mpz_to_integer(sc, sc->mpz_1)); #else + if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", integer(p0), integer(p1), integer(p2)); return(make_real(sc, (long_double)integer(p0) + (long_double)integer(p1) + (long_double)integer(p2))); #endif #else @@ -19323,7 +19260,7 @@ static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, int pos) { case T_RATIO: return(add_p_pp(sc, x, int_one)); case T_REAL: return(make_real(sc, real(x) + 1.0)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + 1.0, imag_part(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x))); #if WITH_GMP case T_BIG_INTEGER: mpz_set_si(sc->mpz_1, 1); @@ -19350,7 +19287,7 @@ static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) s7_pointer x = car(args); if (is_t_integer(x)) return(make_integer(sc, integer(x) + 1)); if (is_t_real(x)) return(make_real(sc, real(x) + 1.0)); - if (is_t_complex(x)) return(s7_make_complex(sc, real_part(x) + 1.0, imag_part(x))); + if (is_t_complex(x)) return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x))); return(add_p_pp(sc, x, int_one)); } #endif @@ -19365,7 +19302,7 @@ static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y) { case T_RATIO: return(add_p_pp(sc, x, wrap_integer1(sc, y))); case T_REAL: return(make_real(sc, real(x) + y)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + y, imag_part(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); #if WITH_GMP case T_BIG_INTEGER: mpz_set_si(sc->mpz_1, y); @@ -19388,10 +19325,10 @@ static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y) { case T_INTEGER: return(make_real(sc, integer(x) + y)); case T_RATIO: return(make_real(sc, fraction(x) + y)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) + y, imag_part(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); #if WITH_GMP case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(add_p_pp(sc, x, wrap_real1(sc, y))); + return(add_p_pp(sc, x, wrap_real2(sc, y))); #endif default: return(method_or_bust_with_type_pf(sc, x, sc->add_symbol, x, y, a_number_string)); } @@ -19571,7 +19508,7 @@ static s7_pointer negate_p_p(s7_scheme *sc, s7_pointer p) /* can't use "nega case T_RATIO: return(make_simple_ratio(sc, -numerator(p), denominator(p))); case T_REAL: return(make_real(sc, -real(p))); - case T_COMPLEX: return(s7_make_complex(sc, -real_part(p), -imag_part(p))); + case T_COMPLEX: return(make_complex_not_0i(sc, -real_part(p), -imag_part(p))); #if WITH_GMP case T_BIG_INTEGER: @@ -19605,7 +19542,10 @@ static inline s7_pointer subtract_if_overflow_to_real_or_big_integer(s7_scheme * return(mpz_to_big_integer(sc, sc->mpz_1)); } #else - return(make_real(sc, (double)x - (double)y)); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y); + return(make_real(sc, (long_double)x - (long_double)y)); + } #endif return(make_integer(sc, val)); #else @@ -19641,11 +19581,14 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, (long_double)integer(x) - fraction(y))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer - ratio overflow: (- %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); + return(make_real(sc, (long_double)integer(x) - fraction(y))); + } #endif - return(s7_make_ratio(sc, z, denominator(y))); + return(make_ratio(sc, z, denominator(y))); #else - return(s7_make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y))); + return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y))); #endif } case T_REAL: @@ -19659,7 +19602,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) #endif return(make_real(sc, (long_double)integer(x) - real(y))); case T_COMPLEX: - return(s7_make_complex(sc, (long_double)integer(x) - real_part(y), -imag_part(y))); + return(make_complex_not_0i(sc, (long_double)integer(x) - real_part(y), -imag_part(y))); #if WITH_GMP case T_BIG_INTEGER: mpz_set_si(sc->mpz_1, integer(x)); @@ -19700,11 +19643,14 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, fraction(x) - (long_double)integer(y))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - integer overflow: (- %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); + return(make_real(sc, fraction(x) - (long_double)integer(y))); + } #endif - return(s7_make_ratio(sc, z, denominator(x))); + return(make_ratio(sc, z, denominator(x))); #else - return(s7_make_ratio(sc, numerator(x) - (integer(y) * denominator(x)), denominator(x))); + return(make_ratio(sc, numerator(x) - (integer(y) * denominator(x)), denominator(x))); #endif } case T_RATIO: @@ -19724,11 +19670,14 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, ((long_double)n1 - (long_double)n2) / (long_double)d1)); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, ((long_double)n1 - (long_double)n2) / (long_double)d1)); + } #endif return(s7_make_ratio(sc, q, d1)); #else - return(s7_make_ratio(sc, numerator(x) - numerator(y), denominator(x))); + return(make_ratio(sc, numerator(x) - numerator(y), denominator(x))); #endif } @@ -19747,7 +19696,10 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, ((long_double)n1 / (long_double)d1) - ((long_double)n2 / (long_double)d2))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, ((long_double)n1 / (long_double)d1) - ((long_double)n2 / (long_double)d2))); + } #endif return(s7_make_ratio(sc, q, d1d2)); } @@ -19758,7 +19710,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_REAL: return(make_real(sc, fraction(x) - real(y))); case T_COMPLEX: - return(s7_make_complex(sc, fraction(x) - real_part(y), -imag_part(y))); + return(make_complex_not_0i(sc, fraction(x) - real_part(y), -imag_part(y))); #if WITH_GMP case T_BIG_INTEGER: mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); @@ -19802,7 +19754,7 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_REAL: return(make_real(sc, real(x) - real(y))); case T_COMPLEX: - return(s7_make_complex(sc, real(x) - real_part(y), -imag_part(y))); + return(make_complex_not_0i(sc, real(x) - real_part(y), -imag_part(y))); #if WITH_GMP case T_BIG_INTEGER: mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); @@ -19828,11 +19780,11 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) switch (type(y)) { case T_INTEGER: - return(s7_make_complex(sc, real_part(x) - integer(y), imag_part(x))); + return(make_complex_not_0i(sc, real_part(x) - integer(y), imag_part(x))); case T_RATIO: - return(s7_make_complex(sc, real_part(x) - fraction(y), imag_part(x))); + return(make_complex_not_0i(sc, real_part(x) - fraction(y), imag_part(x))); case T_REAL: - return(s7_make_complex(sc, real_part(x) - real(y), imag_part(x))); + return(make_complex_not_0i(sc, real_part(x) - real(y), imag_part(x))); case T_COMPLEX: return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y))); #if WITH_GMP @@ -20041,7 +19993,7 @@ static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x) case T_INTEGER: return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); case T_RATIO: return(subtract_p_pp(sc, x, int_one)); case T_REAL: return(make_real(sc, real(x) - 1.0)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - 1.0, imag_part(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - 1.0, imag_part(x))); #if WITH_GMP case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: return(subtract_p_pp(sc, x, int_one)); @@ -20070,7 +20022,7 @@ static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */ { case T_INTEGER: return(make_real(sc, integer(x) - n)); case T_RATIO: return(make_real(sc, fraction(x) - n)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - n, imag_part(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - n, imag_part(x))); #if WITH_GMP case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: return(subtract_p_pp(sc, x, cadr(args))); @@ -20091,7 +20043,7 @@ static s7_pointer g_subtract_f2(s7_scheme *sc, s7_pointer args) /* (- f x) */ { case T_INTEGER: return(make_real(sc, n - integer(x))); case T_RATIO: return(make_real(sc, n - fraction(x))); - case T_COMPLEX: return(s7_make_complex(sc, n - real_part(x), -imag_part(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); #if WITH_GMP case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: return(subtract_p_pp(sc, car(args), x)); @@ -20121,9 +20073,9 @@ static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y) switch (type(x)) { - case T_RATIO: return(s7_make_ratio(sc, numerator(x) - (y * denominator(x)), denominator(x))); + case T_RATIO: return(make_ratio(sc, numerator(x) - (y * denominator(x)), denominator(x))); case T_REAL: return(make_real(sc, real(x) - y)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - y, imag_part(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - y, imag_part(x))); #if WITH_GMP case T_BIG_INTEGER: mpz_set_si(sc->mpz_1, y); @@ -20176,7 +20128,10 @@ static inline s7_pointer multiply_if_overflow_to_real_or_big_integer(s7_scheme * return(mpz_to_big_integer(sc, sc->mpz_1)); } #else - return(make_real(sc, (double)x * (double)y)); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); + return(make_real(sc, (double)x * (double)y)); + } #endif return(make_integer(sc, val)); #else @@ -20198,11 +20153,14 @@ static s7_pointer integer_ratio_multiply_if_overflow_to_real_or_ratio(s7_scheme return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, (double)x * fraction(y))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer * ratio overflow: (* %" ld64 " %" ld64 "/%" ld64 ")\n", x, numerator(y), denominator(y)); + return(make_real(sc, (double)x * fraction(y))); + } #endif - return(s7_make_ratio(sc, z, denominator(y))); + return(make_ratio(sc, z, denominator(y))); #else - return(s7_make_ratio(sc, x * numerator(y), denominator(y))); + return(make_ratio(sc, x * numerator(y), denominator(y))); #endif } @@ -20271,7 +20229,10 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, fraction(x) * fraction(y))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio * ratio overflow: (* %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, fraction(x) * fraction(y))); + } #endif return(s7_make_ratio(sc, n1n2, d1d2)); } @@ -20687,7 +20648,10 @@ static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args) #if HAVE_OVERFLOW_CHECKS s7_int val, x = integer(car(args)), y = integer(cadr(args)); if (multiply_overflow(x, y, &val)) - return(make_real(sc, (double)x * (double)y)); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); + return(make_real(sc, (double)x * (double)y)); + } return(make_integer(sc, val)); #else return(make_integer(sc, integer(car(args)) * integer(cadr(args)))); @@ -20700,7 +20664,10 @@ static s7_int multiply_i_ii(s7_int i1, s7_int i2) #if HAVE_OVERFLOW_CHECKS s7_int val; if (multiply_overflow(i1, i2, &val)) - return(S7_INT64_MAX); /* this is inconsistent with other unopt cases where an overflow -> double result */ + { + if (WITH_WARNINGS) s7_warn(cur_sc, 64, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", i1, i2); + return(S7_INT64_MAX); /* this is inconsistent with other unopt cases where an overflow -> double result */ + } /* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((= j 1)) (even? (* (ash 1 43) (ash 1 43)))))) (define (hi) (func)) (hi)) */ return(val); #else @@ -20712,10 +20679,12 @@ static s7_int multiply_i_iii(s7_int i1, s7_int i2, s7_int i3) { #if HAVE_OVERFLOW_CHECKS s7_int val1, val2; - if (multiply_overflow(i1, i2, &val1)) - return(S7_INT64_MAX); - if (multiply_overflow(val1, i3, &val2)) - return(S7_INT64_MAX); + if ((multiply_overflow(i1, i2, &val1)) || + (multiply_overflow(val1, i3, &val2))) + { + if (WITH_WARNINGS) s7_warn(cur_sc, 64, "integer multiply overflow: (* %" ld64 " %" ld64 " %" ld64 ")\n", i1, i2, i3); + return(S7_INT64_MAX); + } return(val2); #else return(i1 * i2 * i3); @@ -20848,7 +20817,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y))); if (integer(x) == 1) /* mainly to handle (/ 1 -9223372036854775808) correctly! */ return(invert_p_p(sc, y)); - return(s7_make_ratio(sc, integer(x), integer(y))); + return(make_ratio(sc, integer(x), integer(y))); case T_RATIO: #if HAVE_OVERFLOW_CHECKS @@ -20863,7 +20832,10 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, integer(x) * inverted_fraction(y))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer / ratio overflow: (/ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); + return(make_real(sc, integer(x) * inverted_fraction(y))); + } #endif return(s7_make_ratio(sc, dn, numerator(y))); } @@ -20942,7 +20914,10 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, (long_double)numerator(x) / ((long_double)denominator(x) * (long_double)integer(y)))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio / integer overflow: (/ %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); + return(make_real(sc, (long_double)numerator(x) / ((long_double)denominator(x) * (long_double)integer(y)))); + } #endif return(s7_make_ratio(sc, numerator(x), dn)); } @@ -20967,6 +20942,7 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) return(mpq_to_rational(sc, sc->mpq_1)); #else s7_double r1, r2; + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio / ratio overflow: (/ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", numerator(x), denominator(x), numerator(y), denominator(y)); r1 = fraction(x); r2 = inverted_fraction(y); return(make_real(sc, r1 * r2)); @@ -21430,18 +21406,21 @@ static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) return(mpq_to_rational(sc, sc->mpq_1)); } #else - return(make_real(sc, ((long_double)numerator(num) * 0.5) / (long_double)denominator(num))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio / 2 overflow: (/ %" ld64 "/%" ld64 " 2)\n", numerator(num), denominator(num)); + return(make_real(sc, ((long_double)numerator(num) * 0.5) / (long_double)denominator(num))); + } #endif - return(s7_make_ratio(sc, numerator(num) / 2, denominator(num))); + return(make_ratio(sc, numerator(num) / 2, denominator(num))); } return(s7_make_ratio(sc, numerator(num), dn)); } #else - return(s7_make_ratio(sc, numerator(num), denominator(num) * 2)); + return(make_ratio(sc, numerator(num), denominator(num) * 2)); #endif case T_REAL: return(make_real(sc, real(num) * 0.5)); - case T_COMPLEX: return(make_complex_unchecked(sc, real_part(num) * 0.5, imag_part(num) * 0.5)); + case T_COMPLEX: return(make_complex_not_0i(sc, real_part(num) * 0.5, imag_part(num) * 0.5)); #if WITH_GMP case T_BIG_INTEGER: @@ -21490,7 +21469,7 @@ static s7_double divide_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) return(x1 / x2); } -static s7_pointer divide_p_ii(s7_scheme *sc, s7_int x, s7_int y) {return(s7_make_ratio(sc, x, y));} /* make-ratio checks for y==0 */ +static s7_pointer divide_p_ii(s7_scheme *sc, s7_int x, s7_int y) {return(s7_make_ratio(sc, x, y));} /* s7_make-ratio checks for y==0 */ static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(s7_make_ratio(sc, 1, x));} static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) @@ -21548,7 +21527,7 @@ static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) #if WITH_GMP if ((s7_is_real(x)) && (s7_is_real(y))) { - if (s7_is_zero(y)) + if (is_zero(sc, y)) division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y)); if ((s7_is_integer(x)) && (s7_is_integer(y))) { @@ -21768,7 +21747,7 @@ static s7_double remainder_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { #if WITH_GMP - if (s7_is_zero(y)) + if (is_zero(sc, y)) division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, x, y)); return(big_mod_or_rem(sc, x, y, false)); #else @@ -21896,7 +21875,7 @@ static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) case T_REAL: if (((is_inf(real(x))) || (is_NaN(real(x)))) && (s7_is_real(y))) { - if (s7_is_zero(y)) + if (is_zero(sc, y)) return(division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, x, y))); return(real_NaN); } @@ -21994,7 +21973,7 @@ static s7_double modulo_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) c = x1 / x2; if ((c > 1e19) || (c < -1e19)) simple_out_of_range(sc, sc->modulo_symbol, - list_3(sc, sc->divide_symbol, wrap_real1(sc, x1), wrap_real2(sc, x2)), + set_elist_3(sc, sc->divide_symbol, wrap_real1(sc, x1), wrap_real2(sc, x2)), intermediate_too_large_string); return(x1 - x2 * (s7_int)floor(c)); } @@ -22007,7 +21986,7 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) * quotient is truncate_p_p(sc, divide_p_pp(sc, x, y)) * remainder is subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y))) */ - if (!s7_is_zero(y)) return(big_mod_or_rem(sc, x, y, true)); + if (!is_zero(sc, y)) return(big_mod_or_rem(sc, x, y, true)); if (s7_is_real(x)) return(x); return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, T_REAL, 1)); #else @@ -22057,7 +22036,7 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if ((n2 < 0) && (n1 < 0) && (n2 < n1)) return(x); if (n2 == S7_INT64_MIN) return(simple_out_of_range(sc, sc->modulo_symbol, - list_3(sc, sc->divide_symbol, x, y), + set_elist_3(sc, sc->divide_symbol, x, y), intermediate_too_large_string)); /* the problem here is that (modulo 3/2 most-negative-fixnum) * will segfault with signal SIGFPE, Arithmetic exception, so try to trap it. @@ -22117,7 +22096,7 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) } #endif return(simple_out_of_range(sc, sc->modulo_symbol, - list_3(sc, sc->divide_symbol, x, y), + set_elist_3(sc, sc->divide_symbol, x, y), intermediate_too_large_string)); case T_REAL: b = real(y); @@ -22166,7 +22145,7 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) c = a / b; if (fabs(c) > 1e19) return(simple_out_of_range(sc, sc->modulo_symbol, - list_3(sc, sc->divide_symbol, x, y), + set_elist_3(sc, sc->divide_symbol, x, y), intermediate_too_large_string)); return(make_real(sc, a - b * (s7_int)floor(c))); @@ -22391,6 +22370,10 @@ static s7_pointer g_max(s7_scheme *sc, s7_pointer args) return(x); } +static s7_pointer g_max_2(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, car(args), cadr(args)));} +static s7_pointer g_max_3(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, max_p_pp(sc, car(args), cadr(args)), caddr(args)));} +static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) {return((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : f));} + static s7_int max_i_ii(s7_int i1, s7_int i2) {return((i1 > i2) ? i1 : i2);} static s7_int max_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 > i2) ? ((i1 > i3) ? i1 : i3) : ((i2 > i3) ? i2 : i3));} static s7_double max_d_dd(s7_double x1, s7_double x2) {if (is_NaN(x1)) return(x1); return((x1 > x2) ? x1 : x2);} @@ -22581,6 +22564,10 @@ static s7_pointer g_min(s7_scheme *sc, s7_pointer args) return(x); } +static s7_pointer g_min_2(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, car(args), cadr(args)));} +static s7_pointer g_min_3(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, min_p_pp(sc, car(args), cadr(args)), caddr(args)));} +static s7_pointer min_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) {return((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : f));} + static s7_int min_i_ii(s7_int i1, s7_int i2) {return((i1 < i2) ? i1 : i2);} static s7_int min_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 < i2) ? ((i1 < i3) ? i1 : i3) : ((i2 < i3) ? i2 : i3));} static s7_double min_d_dd(s7_double x1, s7_double x2) {if (is_NaN(x1)) return(x1); return((x1 < x2) ? x1 : x2);} @@ -22806,7 +22793,7 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) static bool is_number_via_method(s7_scheme *sc, s7_pointer p) { - if (s7_is_number(p)) + if (is_number(p)) return(true); if (has_active_methods(sc, p)) { @@ -22874,6 +22861,7 @@ static bool num_eq_b_pi(s7_scheme *sc, s7_pointer x, s7_int y) #endif if (!is_number(x)) /* complex/ratio */ simple_wrong_type_argument_with_type(sc, sc->num_eq_symbol, x, a_number_string); + /* return(eq_out_x(sc, x, make_integer(sc, y))); */ /* much slower? see thash */ return(false); } @@ -23113,7 +23101,7 @@ static s7_pointer g_less_x0(s7_scheme *sc, s7_pointer args) if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 0)); if (is_small_real(x)) - return(make_boolean(sc, s7_is_negative(x))); + return(make_boolean(sc, is_negative(sc, x))); #if WITH_GMP if (is_t_big_integer(x)) return(make_boolean(sc, mpz_cmp_si(big_integer(x), 0) < 0)); @@ -23194,8 +23182,7 @@ static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) if (is_t_big_ratio(p1)) return(mpq_cmp_si(big_ratio(p1), p2, 1) < 0); #endif - simple_wrong_type_argument(sc, sc->lt_symbol, p1, T_REAL); - return(false); + return(lt_out_x(sc, p1, make_integer(sc, p2))); } static s7_pointer g_less_2(s7_scheme *sc, s7_pointer args) {return(lt_p_pp(sc, car(args), cadr(args)));} @@ -23458,8 +23445,7 @@ static bool leq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) if (is_t_big_ratio(p1)) return(mpq_cmp_si(big_ratio(p1), p2, 1) <= 0); #endif - simple_wrong_type_argument(sc, sc->leq_symbol, p1, T_REAL); - return(false); + return(leq_out_x(sc, p1, make_integer(sc, p2))); } static s7_pointer leq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, leq_b_pi(sc, p1, p2)));} @@ -23750,8 +23736,7 @@ static bool gt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) if (is_t_big_ratio(p1)) return(mpq_cmp_si(big_ratio(p1), p2, 1) > 0); #endif - simple_wrong_type_argument(sc, sc->gt_symbol, p1, T_REAL); - return(false); + return(gt_out_x(sc, p1, make_integer(sc, p2))); } static s7_pointer gt_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, gt_b_pi(sc, p1, p2)));} @@ -24055,8 +24040,7 @@ static bool geq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) if (is_t_big_ratio(p1)) return(mpq_cmp_si(big_ratio(p1), p2, 1) >= 0); #endif - simple_wrong_type_argument(sc, sc->geq_symbol, p1, T_REAL); - return(false); + return(geq_out_x(sc, p1, make_integer(sc, p2))); } static s7_pointer geq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, geq_b_pi(sc, p1, p2)));} @@ -24105,18 +24089,14 @@ s7_double s7_real_part(s7_pointer x) static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p) { + if (is_t_complex(p)) return(make_real(sc, real_part(p))); switch (type(p)) { case T_INTEGER: case T_RATIO: case T_REAL: return(p); - - case T_COMPLEX: - return(make_real(sc, real_part(p))); - #if WITH_GMP case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: return(p); - case T_BIG_COMPLEX: { s7_pointer x; @@ -24154,26 +24134,18 @@ s7_double s7_imag_part(s7_pointer x) static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer p) { - switch (type(p)) + if (is_t_complex(p)) return(make_real(sc, imag_part(p))); + switch (type(p)) { - case T_INTEGER: - case T_RATIO: + case T_INTEGER: case T_RATIO: return(int_zero); - case T_REAL: return(real_zero); - - case T_COMPLEX: - return(make_real(sc, imag_part(p))); - #if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: + case T_BIG_INTEGER: case T_BIG_RATIO: return(int_zero); - case T_BIG_REAL: return(real_zero); - case T_BIG_COMPLEX: { s7_pointer x; @@ -24348,7 +24320,7 @@ static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x) case T_BIG_COMPLEX: return((mpfr_nan_p(mpc_realref(big_complex(x))) != 0) || (mpfr_nan_p(mpc_imagref(big_complex(x))) != 0)); #endif default: - if (s7_is_number(x)) + if (is_number(x)) return(method_or_bust_with_type_one_arg_p(sc, x, sc->is_nan_symbol, a_number_string) != sc->F); } return(false); @@ -24380,7 +24352,7 @@ static bool is_infinite_b_7p(s7_scheme *sc, s7_pointer x) (mpfr_inf_p(mpc_imagref(big_complex(x))) != 0)); #endif default: - if (s7_is_number(x)) + if (is_number(x)) return(method_or_bust_with_type_one_arg_p(sc, x, sc->is_infinite_symbol, a_number_string) != sc->F); } return(false); @@ -24403,8 +24375,7 @@ static bool is_even_b_7p(s7_scheme *sc, s7_pointer p) if (is_t_big_integer(p)) return(mpz_even_p(big_integer(p))); #endif - simple_wrong_type_argument(sc, sc->is_even_symbol, p, T_INTEGER); - return(false); + return(method_or_bust_one_arg_p(sc, p, sc->is_even_symbol, T_INTEGER) != sc->F); } static bool is_even_i(s7_int i1) {return((i1 & 1) == 0);} @@ -24413,33 +24384,10 @@ static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args) { #define H_is_even "(even? int) returns #t if the integer int32_t is even" #define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) - - s7_pointer p = car(args); - if (is_t_integer(p)) - return(make_boolean(sc, ((integer(p) & 1) == 0))); -#if WITH_GMP - if (is_t_big_integer(p)) - return(make_boolean(sc, mpz_even_p(big_integer(p)))); -#endif - return(method_or_bust_one_arg_p(sc, p, sc->is_even_symbol, T_INTEGER)); + return(make_boolean(sc, is_even_b_7p(sc, car(args)))); } -static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args) -{ - #define H_is_odd "(odd? int) returns #t if the integer int32_t is odd" - #define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) - - s7_pointer p = car(args); - if (is_t_integer(p)) - return(make_boolean(sc, ((integer(p) & 1) == 1))); -#if WITH_GMP - if (is_t_big_integer(p)) - return(make_boolean(sc, mpz_odd_p(big_integer(p)))); -#endif - return(method_or_bust_one_arg_p(sc, p, sc->is_odd_symbol, T_INTEGER)); -} - static bool is_odd_b_7p(s7_scheme *sc, s7_pointer p) { if (is_t_integer(p)) @@ -24448,177 +24396,127 @@ static bool is_odd_b_7p(s7_scheme *sc, s7_pointer p) if (is_t_big_integer(p)) return(mpz_odd_p(big_integer(p))); #endif - simple_wrong_type_argument(sc, sc->is_odd_symbol, p, T_INTEGER); - return(false); + return(method_or_bust_one_arg_p(sc, p, sc->is_odd_symbol, T_INTEGER) != sc->F); } static bool is_odd_i(s7_int i1) {return((i1 & 1) == 1);} +static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args) +{ + #define H_is_odd "(odd? int) returns #t if the integer int32_t is odd" + #define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) + return(make_boolean(sc, is_odd_b_7p(sc, car(args)))); +} + /* ---------------------------------------- zero? ---------------------------------------- */ -static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args) +static bool is_zero(s7_scheme *sc, s7_pointer x) { - #define H_is_zero "(zero? num) returns #t if the number num is zero" - #define Q_is_zero sc->pl_bn - - s7_pointer x = car(args); switch (type(x)) { - case T_INTEGER: return(make_boolean(sc, integer(x) == 0)); - case T_REAL: return(make_boolean(sc, real(x) == 0.0)); - case T_RATIO: - case T_COMPLEX: return(sc->F); /* ratios and complex numbers are already collapsed into integers and reals */ + case T_INTEGER: return(integer(x) == 0); + case T_REAL: return(real(x) == 0.0); #if WITH_GMP - case T_BIG_INTEGER: return(make_boolean(sc, mpz_cmp_ui(big_integer(x), 0) == 0)); - case T_BIG_REAL: return(make_boolean(sc, mpfr_zero_p(big_real(x)))); - case T_BIG_RATIO: - case T_BIG_COMPLEX: return(sc->F); + case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) == 0); + case T_BIG_REAL: return(mpfr_zero_p(big_real(x))); #endif default: - return(method_or_bust_with_type_one_arg_p(sc, x, sc->is_zero_symbol, a_number_string)); + return(false); /* ratios and complex numbers here are already collapsed into integers and reals */ } } static bool is_zero_b_7p(s7_scheme *sc, s7_pointer p) { -#if WITH_GMP - if (!s7_is_number(p)) - simple_wrong_type_argument_with_type(sc, sc->is_zero_symbol, p, a_number_string); - return(s7_is_zero(p)); -#else - if (is_t_integer(p)) - return(integer(p) == 0); - if (is_t_real(p)) - return(real(p) == 0.0); - if (!is_number(p)) - simple_wrong_type_argument_with_type(sc, sc->is_zero_symbol, p, a_number_string); - return(false); -#endif + if (is_t_integer(p)) return(integer(p) == 0); + if (is_t_real(p)) return(real(p) == 0.0); + if (is_number(p)) return(is_zero(sc, p)); + return(method_or_bust_with_type_one_arg_p(sc, p, sc->is_zero_symbol, a_number_string) != sc->F); } -static s7_pointer is_zero_p_p(s7_scheme *sc, s7_pointer p) +static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args) { -#if WITH_GMP - if (!s7_is_number(p)) - simple_wrong_type_argument_with_type(sc, sc->is_zero_symbol, p, a_number_string); - return(make_boolean(sc, s7_is_zero(p))); -#else - if (is_t_integer(p)) - return(make_boolean(sc, integer(p) == 0)); - if (is_t_real(p)) - return(make_boolean(sc, real(p) == 0.0)); - if (!is_number(p)) - simple_wrong_type_argument_with_type(sc, sc->is_zero_symbol, p, a_number_string); - return(sc->F); -#endif + #define H_is_zero "(zero? num) returns #t if the number num is zero" + #define Q_is_zero sc->pl_bn + return(make_boolean(sc, is_zero_b_7p(sc, car(args)))); } +static s7_pointer is_zero_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_zero_b_7p(sc, p)));} static bool is_zero_i(s7_int p) {return(p == 0);} static bool is_zero_d(s7_double p) {return(p == 0.0);} /* -------------------------------- positive? -------------------------------- */ -static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args) +static bool is_positive(s7_scheme *sc, s7_pointer x) { - #define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)" - #define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args); switch (type(x)) { - case T_INTEGER: return(make_boolean(sc, integer(x) > 0)); - case T_RATIO: return(make_boolean(sc, numerator(x) > 0)); - case T_REAL: return(make_boolean(sc, real(x) > 0.0)); + case T_INTEGER: return(integer(x) > 0); + case T_RATIO: return(numerator(x) > 0); + case T_REAL: return(real(x) > 0.0); #if WITH_GMP - case T_BIG_INTEGER: return(make_boolean(sc, (mpz_cmp_ui(big_integer(x), 0) > 0))); - case T_BIG_RATIO: return(make_boolean(sc, (mpq_cmp_ui(big_ratio(x), 0, 1) > 0))); - case T_BIG_REAL: return(make_boolean(sc, (mpfr_cmp_ui(big_real(x), 0) > 0))); + case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) > 0); + case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) > 0); + case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) > 0); #endif default: - return(method_or_bust_one_arg_p(sc, x, sc->is_positive_symbol, T_REAL)); + return(simple_wrong_type_argument(sc, sc->is_positive_symbol, x, T_REAL)); } } static bool is_positive_b_7p(s7_scheme *sc, s7_pointer p) { -#if WITH_GMP - if (!s7_is_real(p)) - simple_wrong_type_argument(sc, sc->is_positive_symbol, p, T_REAL); - return(s7_is_positive(p)); -#else - if (is_t_integer(p)) - return(integer(p) > 0); - if (is_t_real(p)) - return(real(p) > 0.0); - if (!is_small_real(p)) - simple_wrong_type_argument(sc, sc->is_positive_symbol, p, T_REAL); - return(numerator(p) > 0); -#endif + if (is_t_integer(p)) return(integer(p) > 0); + if (is_t_real(p)) return(real(p) > 0.0); + if (is_number(p)) return(is_positive(sc, p)); + return(method_or_bust_one_arg_p(sc, p, sc->is_positive_symbol, T_REAL) != sc->F); } -static s7_pointer is_positive_p_p(s7_scheme *sc, s7_pointer p) +static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args) { -#if WITH_GMP - if (!s7_is_real(p)) - simple_wrong_type_argument(sc, sc->is_positive_symbol, p, T_REAL); - return(make_boolean(sc, s7_is_positive(p))); -#else - if (is_t_integer(p)) - return((integer(p) > 0) ? sc->T : sc->F); - if (is_t_real(p)) - return((real(p) > 0.0) ? sc->T : sc->F); - if (!is_small_real(p)) - simple_wrong_type_argument(sc, sc->is_positive_symbol, p, T_REAL); - return((numerator(p) > 0) ? sc->T : sc->F); -#endif + #define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)" + #define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) + return(make_boolean(sc, is_positive_b_7p(sc, car(args)))); } +static s7_pointer is_positive_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_positive_b_7p(sc, p)));} static bool is_positive_i(s7_int p) {return(p > 0);} static bool is_positive_d(s7_double p) {return(p > 0.0);} /* -------------------------------- negative? -------------------------------- */ -static s7_pointer is_negative_p_p(s7_scheme *sc, s7_pointer x) +static bool is_negative(s7_scheme *sc, s7_pointer x) { switch (type(x)) { - case T_INTEGER: return(make_boolean(sc, integer(x) < 0)); - case T_RATIO: return(make_boolean(sc, numerator(x) < 0)); - case T_REAL: return(make_boolean(sc, real(x) < 0.0)); + case T_INTEGER: return(integer(x) < 0); + case T_RATIO: return(numerator(x) < 0); + case T_REAL: return(real(x) < 0.0); #if WITH_GMP - case T_BIG_INTEGER: return(make_boolean(sc, (mpz_cmp_ui(big_integer(x), 0) < 0))); - case T_BIG_RATIO: return(make_boolean(sc, (mpq_cmp_ui(big_ratio(x), 0, 1) < 0))); - case T_BIG_REAL: return(make_boolean(sc, (mpfr_cmp_ui(big_real(x), 0) < 0))); + case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) < 0); + case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) < 0); + case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) < 0); #endif default: - return(method_or_bust_one_arg_p(sc, x, sc->is_negative_symbol, T_REAL)); + return(simple_wrong_type_argument(sc, sc->is_negative_symbol, x, T_REAL)); } } -static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args) +static bool is_negative_b_7p(s7_scheme *sc, s7_pointer p) { - #define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)" - #define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) - return(is_negative_p_p(sc, car(args))); + if (is_t_integer(p)) return(integer(p) < 0); + if (is_t_real(p)) return(real(p) < 0.0); + if (is_number(p)) return(is_negative(sc, p)); + return(method_or_bust_one_arg_p(sc, p, sc->is_negative_symbol, T_REAL) != sc->F); } -static bool is_negative_b_7p(s7_scheme *sc, s7_pointer p) +static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args) { -#if WITH_GMP - if (!s7_is_real(p)) - simple_wrong_type_argument(sc, sc->is_negative_symbol, p, T_REAL); - return(s7_is_negative(p)); -#else - if (is_t_integer(p)) - return(integer(p) < 0); - if (is_t_real(p)) - return(real(p) < 0.0); - if (!is_small_real(p)) - simple_wrong_type_argument(sc, sc->is_negative_symbol, p, T_REAL); - return(numerator(p) < 0); -#endif + #define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)" + #define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) + return(make_boolean(sc, is_negative_b_7p(sc, car(args)))); } +static s7_pointer is_negative_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_negative_b_7p(sc, p)));} static bool is_negative_i(s7_int p) {return(p < 0);} static bool is_negative_d(s7_double p) {return(p < 0.0);} @@ -24662,7 +24560,7 @@ static s7_pointer g_is_exact(s7_scheme *sc, s7_pointer args) static bool is_exact_b_7p(s7_scheme *sc, s7_pointer p) { if (!is_number(p)) - simple_wrong_type_argument_with_type(sc, sc->is_exact_symbol, p, a_number_string); + return(method_or_bust_with_type_one_arg(sc, p, sc->is_exact_symbol, set_plist_1(sc, p), a_number_string) != sc->F); return(is_rational(p)); } @@ -24689,7 +24587,7 @@ static s7_pointer g_is_inexact(s7_scheme *sc, s7_pointer args) static bool is_inexact_b_7p(s7_scheme *sc, s7_pointer p) { if (!is_number(p)) - simple_wrong_type_argument_with_type(sc, sc->is_inexact_symbol, p, a_number_string); + return(method_or_bust_with_type_one_arg(sc, p, sc->is_inexact_symbol, set_plist_1(sc, p), a_number_string) != sc->F); return(!is_rational(p)); } @@ -24722,7 +24620,7 @@ static s7_pointer g_integer_length(s7_scheme *sc, s7_pointer args) { s7_int x; x = integer(p); - return((x < 0) ? make_integer(sc, integer_length(-(x + 1))) : make_integer(sc, integer_length(x))); + return((x < 0) ? small_int(integer_length(-(x + 1))) : small_int(integer_length(x))); } #if WITH_GMP if (is_t_big_integer(p)) @@ -24758,7 +24656,7 @@ sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)" return(list_3(sc, make_integer(sc, (s7_int)((num.ix & 0xfffffffffffffLL) | 0x10000000000000LL)), make_integer(sc, (s7_int)(((num.ix & 0x7fffffffffffffffLL) >> 52) - 1023 - 52)), - make_integer(sc, ((num.ix & 0x8000000000000000LL) != 0) ? -1 : 1))); + ((num.ix & 0x8000000000000000LL) != 0) ? minus_one : int_one)); } #if WITH_GMP if (is_t_big_real(x)) @@ -24768,7 +24666,7 @@ sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)" exp_n = mpfr_get_z_exp(sc->mpz_1, big_real(x)); neg = (mpz_cmp_ui(sc->mpz_1, 0) < 0); if (neg) mpz_abs(sc->mpz_1, sc->mpz_1); - return(list_3(sc, mpz_to_integer(sc, sc->mpz_1), make_integer(sc, exp_n), make_integer(sc, neg ? -1 : 1))); + return(list_3(sc, mpz_to_integer(sc, sc->mpz_1), make_integer(sc, exp_n), (neg) ? minus_one : int_one)); /* not gmp: (integer-decode-float +nan.0): (6755399441055744 972 1), gmp: (integer-decode-float (bignum +nan.0)): (0 -1073741823 1) */ } #endif @@ -24791,12 +24689,10 @@ static s7_pointer big_logior(s7_scheme *sc, s7_int start, s7_pointer args) case T_BIG_INTEGER: mpz_ior(sc->mpz_1, sc->mpz_1, big_integer(i)); break; - case T_INTEGER: mpz_set_si(sc->mpz_2, integer(i)); mpz_ior(sc->mpz_1, sc->mpz_1, sc->mpz_2); break; - default: if (!is_integer_via_method(sc, i)) return(wrong_type_argument(sc, sc->logior_symbol, position_of(x, args), i, T_INTEGER)); @@ -25013,8 +24909,7 @@ static bool logbit_b_7ii(s7_scheme *sc, s7_int i1, s7_int i2) out_of_range(sc, sc->logbit_symbol, int_two, wrap_integer1(sc, i1), its_negative_string); return(false); } - if (i2 >= S7_INT_BITS) - return(i1 < 0); + if (i2 >= S7_INT_BITS) return(i1 < 0); return((((int64_t)(1LL << (int64_t)i2)) & (int64_t)i1) != 0); } @@ -25024,13 +24919,12 @@ static bool logbit_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) { if (is_t_integer(p2)) return(logbit_b_7ii(sc, integer(p1), integer(p2))); - simple_wrong_type_argument(sc, sc->logbit_symbol, p2, T_INTEGER); + return(method_or_bust(sc, p2, sc->logbit_symbol, set_plist_2(sc, p1, p2), T_INTEGER, 2) != sc->F); } #if WITH_GMP return(g_logbit(sc, set_plist_2(sc, p1, p2))); #else - simple_wrong_type_argument(sc, sc->logbit_symbol, p1, T_INTEGER); - return(false); + return(method_or_bust(sc, p1, sc->logbit_symbol, set_plist_2(sc, p1, p2), T_INTEGER, 1) != sc->F); #endif } @@ -25143,13 +25037,11 @@ static s7_int rsh_i_i2_direct(s7_int i1, s7_int i2) {return(i1 >> 1);} /* -------------------------------- random-state -------------------------------- */ -/* random numbers. The simple version used in clm.c is probably adequate, - * but here I'll use Marsaglia's MWC algorithm. +/* random numbers. The simple version used in clm.c is probably adequate, but here I'll use Marsaglia's MWC algorithm. * (random num) -> a number (0..num), if num == 0 return 0, use global default state * (random num state) -> same but use this state * (random-state seed) -> make a new state - * to save the current seed, use copy - * to save it across load, random-state->list and list->random-state. + * to save the current seed, use copy, to save it across load, random-state->list and list->random-state. * random-state? returns #t if its arg is one of these guys */ @@ -25366,15 +25258,15 @@ static s7_pointer g_random(s7_scheme *sc, s7_pointer args) numer = numerator(num); diff = S7_INT64_MAX - denominator(num); if (diff < 100) - return(s7_make_ratio(sc, numer, denominator(num))); + return(make_ratio(sc, numer, denominator(num))); denom = denominator(num) + (s7_int)floor(diff * next_random(r)); return(s7_make_ratio(sc, numer, denom)); } - return(s7_make_ratio(sc, numer, denominator(num))); + return(make_ratio(sc, numer, denominator(num))); } error = ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12; c_rationalize(x * next_random(r), error, &numer, &denom); - return(s7_make_ratio(sc, numer, denom)); + return(make_ratio(sc, numer, denom)); } case T_REAL: @@ -25455,7 +25347,7 @@ s7_double s7_random(s7_scheme *sc, s7_pointer state) static s7_double random_d_7d(s7_scheme *sc, s7_double x) { #if WITH_GMP - return(real(g_random(sc, set_plist_1(sc, wrap_real1(sc, x))))); + return(real(g_random(sc, set_plist_1(sc, wrap_real2(sc, x))))); #else return(x * next_random(sc->default_rng)); #endif @@ -25553,6 +25445,13 @@ static s7_int char_to_integer_i_7p(s7_scheme *sc, s7_pointer p) return(character(p)); } +static s7_pointer char_to_integer_p_p(s7_scheme *sc, s7_pointer p) +{ + if (!is_character(p)) + return(method_or_bust_one_arg_p(sc, p, sc->char_to_integer_symbol, T_CHARACTER)); + return(make_integer(sc, character(p))); +} + static s7_pointer integer_to_char_p_p(s7_scheme *sc, s7_pointer x) { s7_int ind; @@ -25560,7 +25459,7 @@ static s7_pointer integer_to_char_p_p(s7_scheme *sc, s7_pointer x) return(method_or_bust_one_arg_p(sc, x, sc->integer_to_char_symbol, T_INTEGER)); ind = s7_integer_checked(sc, x); if ((ind >= 0) && (ind < NUM_CHARS)) - return(s7_make_character(sc, (uint8_t)ind)); + return(chars[(uint8_t)ind]); return(s7_out_of_range_error(sc, "integer->char", 1, x, "it doen't fit in an unsigned byte")); } @@ -25574,7 +25473,7 @@ static s7_pointer g_integer_to_char(s7_scheme *sc, s7_pointer args) static s7_pointer integer_to_char_p_i(s7_scheme *sc, s7_int ind) { if ((ind >= 0) && (ind < NUM_CHARS)) - return(s7_make_character(sc, (uint8_t)ind)); + return(chars[(uint8_t)ind]); return(s7_out_of_range_error(sc, "integer->char", 1, wrap_integer2(sc, ind), "it doen't fit in an unsigned byte")); /* int2 s7_out... uses 1 */ } @@ -25652,10 +25551,10 @@ static s7_pointer char_upcase_p_p(s7_scheme *sc, s7_pointer c) { if (!is_character(c)) return(method_or_bust_one_arg_p(sc, c, sc->char_upcase_symbol, T_CHARACTER)); - return(s7_make_character(sc, upper_character(c))); + return(chars[upper_character(c)]); } -static s7_pointer char_upcase_p_p_unchecked(s7_scheme *sc, s7_pointer c) {return(s7_make_character(sc, upper_character(c)));} +static s7_pointer char_upcase_p_p_unchecked(s7_scheme *sc, s7_pointer c) {return(chars[upper_character(c)]);} static s7_pointer g_char_upcase(s7_scheme *sc, s7_pointer args) { @@ -25670,7 +25569,7 @@ static s7_pointer g_char_downcase(s7_scheme *sc, s7_pointer args) #define Q_char_downcase sc->pcl_c if (!is_character(car(args))) return(method_or_bust_one_arg(sc, car(args), sc->char_downcase_symbol, args, T_CHARACTER)); - return(s7_make_character(sc, lowers[character(car(args))])); + return(chars[lowers[character(car(args))]]); } @@ -25689,13 +25588,14 @@ static bool is_char_alphabetic_b_7p(s7_scheme *sc, s7_pointer c) { if (!is_character(c)) simple_wrong_type_argument(sc, sc->is_char_alphabetic_symbol, c, T_CHARACTER); + /* return(method_or_bust_one_arg(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), T_CHARACTER) != sc->F); */ /* slower? see tmisc */ return(is_char_alphabetic(c)); } static s7_pointer is_char_alphabetic_p_p(s7_scheme *sc, s7_pointer c) { if (!is_character(c)) - simple_wrong_type_argument(sc, sc->is_char_alphabetic_symbol, c, T_CHARACTER); + return(method_or_bust_one_arg(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), T_CHARACTER)); return(make_boolean(sc, is_char_alphabetic(c))); } @@ -25714,9 +25614,17 @@ static bool is_char_numeric_b_7p(s7_scheme *sc, s7_pointer c) { if (!is_character(c)) simple_wrong_type_argument(sc, sc->is_char_numeric_symbol, c, T_CHARACTER); + /* return(method_or_bust_one_arg(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), T_CHARACTER) != sc->F); */ /* as above */ return(is_char_numeric(c)); } +static s7_pointer is_char_numeric_p_p(s7_scheme *sc, s7_pointer c) +{ + if (!is_character(c)) + return(method_or_bust_one_arg(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), T_CHARACTER)); + return(make_boolean(sc, is_char_numeric(c))); +} + static s7_pointer g_is_char_whitespace(s7_scheme *sc, s7_pointer args) { @@ -25731,23 +25639,15 @@ static s7_pointer g_is_char_whitespace(s7_scheme *sc, s7_pointer args) static bool is_char_whitespace_b_7p(s7_scheme *sc, s7_pointer c) { - if (is_character(c)) - return(is_char_whitespace(c)); - if (has_active_methods(sc, c)) - { - s7_pointer f; - f = find_method_with_let(sc, c, sc->is_char_whitespace_symbol); - if (f != sc->undefined) - return(is_true(sc, call_method(sc, c, f, set_plist_1(sc, c)))); - } - simple_wrong_type_argument(sc, sc->is_char_whitespace_symbol, c, T_CHARACTER); - return(false); + if (!is_character(c)) + simple_wrong_type_argument(sc, sc->is_char_whitespace_symbol, c, T_CHARACTER); + return(is_char_whitespace(c)); } static s7_pointer is_char_whitespace_p_p(s7_scheme *sc, s7_pointer c) { if (!is_character(c)) - simple_wrong_type_argument(sc, sc->is_char_whitespace_symbol, c, T_CHARACTER); + return(method_or_bust_one_arg(sc, c, sc->is_char_whitespace_symbol, set_plist_1(sc, c), T_CHARACTER)); return(make_boolean(sc, is_char_whitespace(c))); } @@ -25769,7 +25669,7 @@ static s7_pointer g_is_char_upper_case(s7_scheme *sc, s7_pointer args) static bool is_char_upper_case_b_7p(s7_scheme *sc, s7_pointer c) { if (!is_character(c)) - simple_wrong_type_argument(sc, sc->is_char_upper_case_symbol, c, T_CHARACTER); + return(method_or_bust_one_arg(sc, c, sc->is_char_upper_case_symbol, set_plist_1(sc, c), T_CHARACTER) != sc->F); return(is_char_uppercase(c)); } @@ -25787,7 +25687,7 @@ static s7_pointer g_is_char_lower_case(s7_scheme *sc, s7_pointer args) static bool is_char_lower_case_b_7p(s7_scheme *sc, s7_pointer c) { if (!is_character(c)) - simple_wrong_type_argument(sc, sc->is_char_lower_case_symbol, c, T_CHARACTER); + return(method_or_bust_one_arg(sc, c, sc->is_char_lower_case_symbol, set_plist_1(sc, c), T_CHARACTER) != sc->F); return(is_char_lowercase(c)); } @@ -25921,14 +25821,11 @@ static s7_pointer g_chars_are_leq(s7_scheme *sc, s7_pointer args) static s7_pointer g_simple_char_eq(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, car(args) == cadr(args)));} /* chooser checks types */ - -static inline void check_char2_args(s7_scheme *sc, s7_pointer caller, s7_pointer p1, s7_pointer p2) -{ - if (!is_character(p1)) - simple_wrong_type_argument(sc, caller, p1, T_CHARACTER); - if (!is_character(p2)) - simple_wrong_type_argument(sc, caller, p2, T_CHARACTER); -} +#define check_char2_args(Sc, Caller, P1, P2) \ + do { \ + if (!is_character(P1)) return(method_or_bust(Sc, P1, Caller, set_plist_2(Sc, P1, P2), T_CHARACTER, 1) != sc->F); \ + if (!is_character(P2)) return(method_or_bust(Sc, P2, Caller, set_plist_2(Sc, P1, P2), T_CHARACTER, 2) != sc->F); \ + } while (0) static bool char_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 < p2);} static bool char_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) @@ -25962,46 +25859,40 @@ static bool char_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 == p2); static bool char_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) { - if (!is_character(p1)) simple_wrong_type_argument(sc, sc->char_eq_symbol, p1, T_CHARACTER); + if (!is_character(p1)) return(method_or_bust(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), T_CHARACTER, 1) != sc->F); if (p1 == p2) return(true); - if (!is_character(p2)) simple_wrong_type_argument(sc, sc->char_eq_symbol, p2, T_CHARACTER); + if (!is_character(p2)) return(method_or_bust(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), T_CHARACTER, 2) != sc->F); return(false); } static s7_pointer char_eq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) { - if (!is_character(p1)) simple_wrong_type_argument(sc, sc->char_eq_symbol, p1, T_CHARACTER); + if (!is_character(p1)) return(method_or_bust(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), T_CHARACTER, 1)); if (p1 == p2) return(sc->T); - if (!is_character(p2)) simple_wrong_type_argument(sc, sc->char_eq_symbol, p2, T_CHARACTER); + if (!is_character(p2)) return(method_or_bust(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), T_CHARACTER, 2)); return(sc->F); } static s7_pointer g_char_equal_2(s7_scheme *sc, s7_pointer args) { - if (!is_character(car(args))) - return(method_or_bust(sc, car(args), sc->char_eq_symbol, args, T_CHARACTER, 1)); + if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_eq_symbol, args, T_CHARACTER, 1)); if (car(args) == cadr(args)) return(sc->T); - if (!is_character(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->char_eq_symbol, args, T_CHARACTER, 2)); + if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_eq_symbol, args, T_CHARACTER, 2)); return(sc->F); } static s7_pointer g_char_less_2(s7_scheme *sc, s7_pointer args) { - if (!is_character(car(args))) - return(method_or_bust(sc, car(args), sc->char_lt_symbol, args, T_CHARACTER, 1)); - if (!is_character(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->char_lt_symbol, args, T_CHARACTER, 2)); + if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_lt_symbol, args, T_CHARACTER, 1)); + if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_lt_symbol, args, T_CHARACTER, 2)); return(make_boolean(sc, character(car(args)) < character(cadr(args)))); } static s7_pointer g_char_greater_2(s7_scheme *sc, s7_pointer args) { - if (!is_character(car(args))) - return(method_or_bust(sc, car(args), sc->char_gt_symbol, args, T_CHARACTER, 1)); - if (!is_character(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->char_gt_symbol, args, T_CHARACTER, 2)); + if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_gt_symbol, args, T_CHARACTER, 1)); + if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_gt_symbol, args, T_CHARACTER, 2)); return(make_boolean(sc, character(car(args)) > character(cadr(args)))); } @@ -26309,19 +26200,9 @@ s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len #define NUM_STRING_WRAPPERS 8 /* should be a power of 2 */ -#if S7_DEBUGGING -static s7_pointer wrap_string_1(s7_scheme *sc, const char *str, s7_int len, const char *func, int line) -#else static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len) -#endif { s7_pointer x; -#if S7_DEBUGGING - if ((strcmp(func, "g_substring_uncopied") != 0) && (strcmp(func, "read_sharp") != 0) && - (strcmp(func, "g_get_output_string_uncopied") != 0) && (strcmp(func, "substring_uncopied_p_pii") != 0) && - (len != safe_strlen(str))) - fprintf(stderr, "%s[%d]: %" print_s7_int " != %" print_s7_int ", %s\n", func, line, len, safe_strlen(str), str); -#endif x = sc->string_wrappers[sc->string_wrapper_pos]; sc->string_wrapper_pos = (sc->string_wrapper_pos + 1) & (NUM_STRING_WRAPPERS - 1); /* i.e. next is pos+1 modulo len */ string_value(x) = (char *)str; @@ -26620,7 +26501,7 @@ static s7_pointer string_ref_1(s7_scheme *sc, s7_pointer strng, s7_pointer index return(out_of_range(sc, sc->string_ref_symbol, int_two, index, its_too_large_string)); str = string_value(strng); - return(s7_make_character(sc, ((uint8_t *)str)[ind])); + return(chars[((uint8_t *)str)[ind]]); } static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args) @@ -26637,7 +26518,7 @@ static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args) static s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) { if (!is_string(p1)) - simple_wrong_type_argument(sc, sc->string_ref_symbol, p1, T_STRING); + return(method_or_bust(sc, p1, sc->string_ref_symbol, set_plist_2(sc, p1, make_integer(sc, i1)), T_STRING, 1)); if ((i1 >= 0) && (i1 < string_length(p1))) return(chars[((uint8_t *)string_value(p1))[i1]]); out_of_range(sc, sc->string_ref_symbol, int_two, wrap_integer1(sc, i1), (i1 < 0) ? its_negative_string : its_too_large_string); @@ -27218,13 +27099,11 @@ static s7_pointer g_string_greater_2(s7_scheme *sc, s7_pointer args) return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1)); } -static inline void check_string2_args(s7_scheme *sc, s7_pointer caller, s7_pointer p1, s7_pointer p2) -{ - if (!is_string(p1)) - simple_wrong_type_argument(sc, caller, p1, T_STRING); - if (!s7_is_string(p2)) - simple_wrong_type_argument(sc, caller, p2, T_STRING); -} +#define check_string2_args(Sc, Caller, P1, P2) \ + do { \ + if (!is_string(p1)) return(method_or_bust(sc, P1, Caller, set_plist_2(Sc, P1, P2), T_STRING, 1) != Sc->F); \ + if (!is_string(p2)) return(method_or_bust(sc, P2, Caller, set_plist_2(Sc, P1, P2), T_STRING, 2) != Sc->F); \ + } while (0) static bool string_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) == -1);} static bool string_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) @@ -27565,7 +27444,7 @@ static s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args) /* -------------------------------- string->list -------------------------------- */ -static s7_pointer s7_string_to_list(s7_scheme *sc, const char *str, s7_int len) +static s7_pointer string_to_list(s7_scheme *sc, const char *str, s7_int len) { s7_int i; s7_pointer result; @@ -27574,7 +27453,7 @@ static s7_pointer s7_string_to_list(s7_scheme *sc, const char *str, s7_int len) check_free_heap_size(sc, len); sc->v = sc->nil; for (i = len - 1; i >= 0; i--) - sc->v = cons_unchecked(sc, s7_make_character(sc, ((uint8_t)str[i])), sc->v); + sc->v = cons_unchecked(sc, chars[((uint8_t)str[i])], sc->v); result = sc->v; sc->v = sc->nil; return(result); @@ -27607,11 +27486,25 @@ static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args) sc->w = sc->nil; check_free_heap_size(sc, end - start); for (i = end - 1; i >= start; i--) - sc->w = cons_unchecked(sc, s7_make_character(sc, ((uint8_t)string_value(str)[i])), sc->w); + sc->w = cons_unchecked(sc, chars[((uint8_t)string_value(str)[i])], sc->w); p = sc->w; sc->w = sc->nil; return(p); } + +static s7_pointer string_to_list_p_p(s7_scheme *sc, s7_pointer str) +{ + s7_int i, len; + s7_pointer p; + const uint8_t *val; + if (!is_string(str)) return(method_or_bust_one_arg(sc, str, sc->string_to_list_symbol, set_plist_1(sc, str), T_STRING)); + len = string_length(str); + if (len == 0) return(sc->nil); + check_free_heap_size(sc, len); + val = (const uint8_t *)string_value(str); + for (p = sc->nil, i = len - 1; i >= 0; i--) p = cons_unchecked(sc, chars[val[i]], p); + return(p); +} #endif @@ -27635,8 +27528,7 @@ static bool is_port_closed_b_7p(s7_scheme *sc, s7_pointer x) return(port_is_closed(x)); if ((x == current_output_port(sc)) && (x == sc->F)) return(false); - simple_wrong_type_argument_with_type(sc, sc->is_port_closed_symbol, x, wrap_string(sc, "a port", 6)); - return(false); + return(method_or_bust_with_type_one_arg(sc, x, sc->is_port_closed_symbol, set_plist_1(sc, x), wrap_string(sc, "a port", 6)) != sc->F); } @@ -28059,23 +27951,22 @@ static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args) /* -------------------------------- flush-output-port -------------------------------- */ -void s7_flush_output_port(s7_scheme *sc, s7_pointer p) +bool s7_flush_output_port(s7_scheme *sc, s7_pointer p) { - if ((!is_output_port(p)) || - (!is_file_port(p)) || - (port_is_closed(p)) || - (p == sc->F)) - return; - if (port_file(p)) + bool result = true; + if ((is_output_port(p)) && /* type=T_OUTPUT_PORT, so this excludes #f */ + (is_file_port(p)) && + (!port_is_closed(p)) && + (port_file(p))) { if (port_position(p) > 0) { - if (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != (size_t)port_position(p)) - s7_warn(sc, 64, "fwrite trouble in flush-output-port\n"); + result = (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) == (size_t)port_position(p)); port_position(p) = 0; } fflush(port_file(p)); } + return(result); } static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args) @@ -28106,9 +27997,14 @@ static void close_output_file(s7_scheme *sc, s7_pointer p) } if (port_file(p)) { +#if (WITH_WARNINGS) if ((port_position(p) > 0) && (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != (size_t)port_position(p))) s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); +#else + if (port_position(p) > 0) + fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)); +#endif fflush(port_file(p)); fclose(port_file(p)); port_file(p) = NULL; @@ -28226,7 +28122,7 @@ static s7_pointer stdin_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) } if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin)) return(s7_make_string(sc, sc->read_line_buf)); /* fgets adds the trailing '\0' */ - return(make_string_with_length(sc, NULL, 0)); + return(nil_string); /* make_string_with_length(sc, NULL, 0)); */ } static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) @@ -28342,24 +28238,15 @@ static Inline void inline_file_write_char(s7_scheme *sc, uint8_t c, s7_pointer p { if (port_position(port) == sc->output_port_data_size) { - if (fwrite((void *)(port_data(port)), 1, sc->output_port_data_size, port_file(port)) != (size_t)sc->output_port_data_size) - s7_warn(sc, 64, "fwrite trouble during write-char\n"); + fwrite((void *)(port_data(port)), 1, sc->output_port_data_size, port_file(port)); port_position(port) = 0; } port_data(port)[port_position(port)++] = c; } -static void file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {return(inline_file_write_char(sc, c, port));} - -static void input_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, an_output_port_string); -} - -static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, an_open_port_string); -} +static void file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {return(inline_file_write_char(sc, c, port));} +static void input_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, an_output_port_string);} +static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, an_open_port_string);} /* -------- write string functions -------- */ @@ -28418,9 +28305,7 @@ static void string_write_string_resized(s7_scheme *sc, const char *str, s7_int l static void string_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) { -#if S7_DEBUGGING - if (len == 0) {fprintf(stderr, "string_write_string len == 0\n"); abort();} -#endif + if ((S7_DEBUGGING) && (len == 0)) {fprintf(stderr, "string_write_string len == 0\n"); abort();} if (port_position(pt) + len < port_data_size(pt)) { memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len); @@ -28437,12 +28322,15 @@ static void file_write_string(s7_scheme *sc, const char *str, s7_int len, s7_poi { if (port_position(pt) > 0) { +#if (WITH_WARNINGS) if (fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)) != (size_t)port_position(pt)) s7_warn(sc, 64, "fwrite trouble in write-string\n"); +#else + fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)); +#endif port_position(pt) = 0; } - if (fwrite((void *)str, 1, len, port_file(pt)) != (size_t)len) - s7_warn(sc, 64, "fwrite trouble in write-string\n"); + fwrite((void *)str, 1, len, port_file(pt)); } else { @@ -28463,12 +28351,20 @@ static void file_display(s7_scheme *sc, const char *s, s7_pointer port) { if (port_position(port) > 0) { +#if (WITH_WARNINGS) if (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port)) s7_warn(sc, 64, "fwrite trouble in display\n"); +#else + fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); +#endif port_position(port) = 0; } +#if (WITH_WARNINGS) if (fputs(s, port_file(port)) == EOF) s7_warn(sc, 64, "write to %s: %s\n", port_filename(port), strerror(errno)); +#else + fputs(s, port_file(port)); +#endif } } @@ -28600,8 +28496,7 @@ static int32_t terminated_string_read_white_space(s7_scheme *sc, s7_pointer pt) } -/* name (alphanumeric token) readers */ - +/* -------- name readers -------- */ #define BASE_10 10 static s7_pointer file_read_name_or_sharp(s7_scheme *sc, s7_pointer pt, bool atom_case) @@ -28698,7 +28593,6 @@ static s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer pt) */ char *str; str = (char *)(port_data(pt) + port_position(pt)); - if (char_ok_in_a_name[(uint8_t)*str]) { s7_int k; @@ -28813,7 +28707,7 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int ma block_t *b; new_cell(sc, port, T_INPUT_PORT); - port_loc = s7_gc_protect_1(sc, port); + port_loc = gc_protect_1(sc, port); b = mallocate_port(sc); port_block(port) = b; port_port(port) = (port_t *)block_data(b); @@ -28850,7 +28744,7 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int ma { char tmp[256]; int32_t len; - len = snprintf(tmp, 256, "(%s \"%s\") read %ld bytes of an expected %" print_s7_int "?", caller, name, (long)bytes, size); + len = snprintf(tmp, 256, "(%s \"%s\") read %ld bytes of an expected %" ld64 "?", caller, name, (long)bytes, size); port_write_string(current_output_port(sc))(sc, tmp, clamp_length(len, 256), current_output_port(sc)); } size = bytes; @@ -29203,7 +29097,7 @@ static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_ #if S7_DEBUGGING if (input_string[len] != '\0') { - fprintf(stderr, "%s[%d]: read_white_space string is not terminated: len: %" print_s7_int ", at end: %c%c, str: %s", __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string); + fprintf(stderr, "%s[%d]: read_white_space string is not terminated: len: %" ld64 ", at end: %c%c, str: %s", __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string); abort(); } #endif @@ -29248,7 +29142,7 @@ static s7_pointer g_open_input_string(s7_scheme *sc, s7_pointer args) static const port_functions_t output_string_functions = {output_read_char, string_write_char, string_write_string, NULL, NULL, NULL, NULL, output_read_line, string_display, close_output_string}; -static s7_pointer open_output_string(s7_scheme *sc, s7_int len) +s7_pointer s7_open_output_string(s7_scheme *sc) { s7_pointer x; block_t *block, *b; @@ -29258,8 +29152,8 @@ static s7_pointer open_output_string(s7_scheme *sc, s7_int len) port_port(x) = (port_t *)block_data(b); port_type(x) = STRING_PORT; port_set_closed(x, false); - port_data_size(x) = len; - block = mallocate(sc, len); + port_data_size(x) = sc->initial_string_port_length; + block = mallocate(sc, sc->initial_string_port_length); port_data_block(x) = block; port_data(x) = (uint8_t *)(block_data(block)); port_data(x)[0] = '\0'; /* in case s7_get_output_string before any output */ @@ -29273,10 +29167,6 @@ static s7_pointer open_output_string(s7_scheme *sc, s7_int len) return(x); } -s7_pointer s7_open_output_string(s7_scheme *sc) {return(open_output_string(sc, sc->initial_string_port_length));} - -static s7_pointer open_output_string_p(s7_scheme *sc) {return(s7_open_output_string(sc));} - static s7_pointer g_open_output_string(s7_scheme *sc, s7_pointer args) { #define H_open_output_string "(open-output-string) opens an output string port" @@ -29292,6 +29182,12 @@ const char *s7_get_output_string(s7_scheme *sc, s7_pointer p) return((const char *)port_data(p)); } +s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p) +{ + port_data(p)[port_position(p)] = '\0'; + return(make_string_with_length(sc, (const char *)port_data(p), port_position(p))); +} + static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer p) { if (port_is_closed(p)) @@ -29332,6 +29228,7 @@ If the optional 'clear-port' is #t, the current string is flushed." block_t *block; s7_pointer result; result = block_to_string(sc, port_data_block(p), port_position(p)); + /* this is slightly faster than make_string_with_length(sc, (char *)(port_data(p)), port_position(p)): we're trading a mallocate for a memcpy */ port_data_size(p) = sc->initial_string_port_length; block = mallocate(sc, port_data_size(p)); port_data_block(p) = block; @@ -29887,7 +29784,6 @@ s7_pointer s7_read(s7_scheme *sc, s7_pointer port) { push_stack_no_let_no_code(sc, OP_BARRIER, port); push_stack_direct(sc, OP_EVAL_DONE); - eval(sc, OP_READ_INTERNAL); if (sc->tok == TOKEN_EOF) sc->value = eof_object; @@ -30006,8 +29902,8 @@ static block_t *search_load_path(s7_scheme *sc, const char *name) const char *new_dir = string_value(car(dir_names)); if (new_dir) { - if (string_length(car(dir_names)) + name_len >= S7_FILENAME_MAX) - s7_warn(sc, 256, "load: file + directory name too long: %ld + %ld > %d\n", name_len, string_length(car(dir_names)), S7_FILENAME_MAX); + if ((WITH_WARNINGS) && (string_length(car(dir_names)) + name_len >= S7_FILENAME_MAX)) + s7_warn(sc, 256, "load: file + directory name too long: %" ld64 " + %" ld64 " > %d\n", name_len, string_length(car(dir_names)), S7_FILENAME_MAX); filename[0] = '\0'; if (new_dir[strlen(new_dir) - 1] == '/') catstrs(filename, S7_FILENAME_MAX, new_dir, name, (char *)NULL); @@ -30043,20 +29939,25 @@ static block_t *full_filename(s7_scheme *sc, const char *filename) } else { + size_t pwd_len, filename_len; char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */ - len = safe_strlen(pwd) + safe_strlen(filename) + 2; /* not 1! we need room for the '/' and the terminating 0 */ + pwd_len = safe_strlen(pwd); + filename_len = safe_strlen(filename); + len = pwd_len + filename_len + 2; /* not 1! we need room for the '/' and the terminating 0 */ block = mallocate(sc, len); rtn = (char *)block_data(block); if (pwd) { - rtn[0] = '\0'; - catstrs(rtn, len, pwd, "/", filename, (char *)NULL); + memcpy((void *)rtn, (void *)pwd, pwd_len); + rtn[pwd_len] = '/'; + memcpy((void *)(rtn + pwd_len + 1), (void *)filename, filename_len); + rtn[pwd_len + filename_len + 1] = '\0'; free(pwd); } else /* isn't this an error? -- perhaps warn about getcwd, strerror(errno) */ { - memcpy((void *)rtn, (void *)filename, len); - rtn[len] = '\0'; + memcpy((void *)rtn, (void *)filename, filename_len); + rtn[filename_len] = '\0'; }} return(block); } @@ -30100,9 +30001,7 @@ static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointe pwd_name = (char *)block_data(pname); }} /* else pname is NULL, so use fname -- can this happen? */ -#if S7_DEBUGGING - if (!pname) fprintf(stderr, "pname is null\n"); -#endif + if ((S7_DEBUGGING) && (!pname)) fprintf(stderr, "pname is null\n"); library = dlopen((pname) ? pwd_name : fname, RTLD_NOW); if (!library) s7_warn(sc, 512, "load %s failed: %s\n", (pname) ? pwd_name : fname, dlerror()); @@ -30156,9 +30055,7 @@ static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointe s7_warn(sc, 512, "loaded %s, but can't find init_func %s, dlerror: %s, let: %s\n", fname, init_name, dlerror(), display(let)); dlclose(library); } -#if S7_DEBUGGING - fprintf(stderr, "init_func trouble in %s, %s\n", fname, display(init)); -#endif + if (S7_DEBUGGING) fprintf(stderr, "init_func trouble in %s, %s\n", fname, display(init)); if (pname) liberate(sc, pname); return(sc->undefined); } @@ -30168,95 +30065,78 @@ static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointe } #endif -#if WITH_GCC -static FILE *expand_cwd(s7_scheme *sc, const char *fname) +static s7_pointer load_file_1(s7_scheme *sc, const char *filename) { - /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */ - if ((fname[0] == '~') && - (fname[1] == '/')) + FILE* fp; + if (is_directory(filename)) + return(NULL); + fp = fopen(filename, "r"); +#if WITH_GCC + if ((!fp) && /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */ + (filename[0] == '~') && (filename[1] == '/')) { char *home; home = getenv("HOME"); if (home) { block_t *b; - char *filename; - s7_int len; - FILE *fp; - - len = safe_strlen(fname) + safe_strlen(home) + 1; + char *fname; + s7_int len, file_len, home_len; + file_len = safe_strlen(filename); + home_len = safe_strlen(home); + len = file_len + home_len; b = mallocate(sc, len); - filename = (char *)block_data(b); - filename[0] = '\0'; - catstrs(filename, len, home, (char *)(fname + 1), (char *)NULL); - fp = fopen(filename, "r"); + fname = (char *)block_data(b); + memcpy((void *)fname, home, home_len); + memcpy((void *)(fname + home_len), (char *)(filename + 1), file_len - 1); + fname[len - 1] = '\0'; + fp = fopen(fname, "r"); + if (fp) filename = copy_string_with_length(fname, len - 1); liberate(sc, b); - - return(fp); }} - return(NULL); -} #endif - -static FILE *open_file_with_load_path(s7_scheme *sc, const char *fname) -{ - block_t *b; - FILE *fp; - b = search_load_path(sc, fname); - if (!b) return(NULL); - fp = fopen((const char *)block_data(b), "r"); - if ((fp) && (hook_has_functions(sc->load_hook))) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, sc->temp6 = s7_make_string(sc, (const char *)block_data(b)))); - liberate(sc, b); - return(fp); -} - -static s7_pointer read_scheme_file(s7_scheme *sc, FILE *fp, const char *fname) -{ - s7_pointer port; - port = read_file(sc, fp, fname, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */ - port_file_number(port) = remember_file_name(sc, fname); - set_loader_port(port); - sc->temp6 = port; - push_input_port(sc, port); - sc->temp6 = sc->nil; - return(port); + if (!fp) + { + block_t *b; + const char *fname; + b = search_load_path(sc, filename); + if (!b) return(NULL); + fname = (const char *)block_data(b); + fp = fopen(fname, "r"); + if (fp) filename = copy_string(fname); + liberate(sc, b); + } + if (fp) + { + s7_pointer port; + if (hook_has_functions(sc->load_hook)) + s7_apply_function(sc, sc->load_hook, set_plist_1(sc, sc->temp6 = s7_make_string(sc, filename))); + port = read_file(sc, fp, filename, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */ + port_file_number(port) = remember_file_name(sc, filename); + set_loader_port(port); + sc->temp6 = port; + push_input_port(sc, port); + sc->temp6 = sc->nil; + return(port); + } + return(NULL); } s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e) { /* returns either the value of the load or NULL if filename not found */ s7_pointer port; - FILE *fp; declare_jump_info(); TRACK(sc); if (e == sc->s7_let) return(NULL); #if WITH_C_LOADER - { - s7_pointer p; - p = load_shared_object(sc, filename, (is_null(e)) ? sc->rootlet : e); - if (p) return(p); - } + port = load_shared_object(sc, filename, (is_null(e)) ? sc->rootlet : e); + if (port) return(port); #endif - if (is_directory(filename)) - return(NULL); - fp = fopen(filename, "r"); -#if WITH_GCC - if (!fp) fp = expand_cwd(sc, filename); -#endif - if (fp) - { - if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, sc->temp6 = s7_make_string(sc, filename))); - } - else - { - fp = open_file_with_load_path(sc, filename); - if (!fp) return(NULL); - } - port = read_scheme_file(sc, fp, filename); + port = load_file_1(sc, filename); + if (!port) return(NULL); set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); @@ -30289,8 +30169,10 @@ s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, declare_jump_info(); TRACK(sc); + if (content[bytes] != 0) + s7_error(sc, make_symbol(sc, "bad-data"), set_elist_1(sc, wrap_string(sc, "s7_load_c_string content is not terminated", 42))); port = open_input_string(sc, content, bytes); - port_loc = s7_gc_protect_1(sc, port); + port_loc = gc_protect_1(sc, port); set_loader_port(port); push_input_port(sc, port); set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); @@ -30329,7 +30211,6 @@ static s7_pointer g_load(s7_scheme *sc, s7_pointer args) defaults to the rootlet. To load into the current environment instead, pass (curlet)." #define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol) - FILE *fp = NULL; s7_pointer name = car(args); const char *fname; @@ -30351,9 +30232,6 @@ defaults to the rootlet. To load into the current environment instead, pass (cu if ((!fname) || (!(*fname))) /* fopen("", "r") returns a file pointer?? */ return(s7_error(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "load's first argument, ~S, should be a filename", 47), name))); - if (is_directory(fname)) - return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "load argument, ~S, is a directory", 33), name))); - #if WITH_C_LOADER { s7_pointer p; @@ -30361,22 +30239,9 @@ defaults to the rootlet. To load into the current environment instead, pass (cu if (p) return(p); } #endif - - fp = fopen(fname, "r"); -#if WITH_GCC - if (!fp) fp = expand_cwd(sc, fname); -#endif - if (fp) - { - if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, sc->temp6 = s7_make_string(sc, fname))); - } - else - { - fp = open_file_with_load_path(sc, fname); - if (!fp) return(file_error(sc, "load", "can't open", fname)); - } - read_scheme_file(sc, fp, fname); + errno = 0; + if (!load_file_1(sc, fname)) + return(file_error(sc, "load", strerror(errno), fname)); push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was pushing args and code, but I don't think they're used later */ push_stack_op_let(sc, OP_READ_INTERNAL); @@ -30675,7 +30540,7 @@ bool s7_is_provided(s7_scheme *sc, const char *feature) static bool is_provided_b_7p(s7_scheme *sc, s7_pointer sym) { if (!is_symbol(sym)) - simple_wrong_type_argument(sc, sc->is_provided_symbol, sym, T_SYMBOL); + return(method_or_bust_one_arg_p(sc, sym, sc->is_provided_symbol, T_SYMBOL) != sc->F); return(is_memq(sym, s7_symbol_value(sc, sc->features_symbol))); } @@ -30690,9 +30555,7 @@ static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) if (!is_symbol(sym)) return(method_or_bust_one_arg_p(sc, sym, sc->provide_symbol, T_SYMBOL)); -#if S7_DEBUGGING - if (sc->curlet == sc->rootlet) fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, __LINE__); -#endif + if ((S7_DEBUGGING) && (sc->curlet == sc->rootlet)) fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, __LINE__); if ((sc->curlet == sc->nil) || (sc->curlet == sc->shadow_rootlet)) p = global_slot(sc->features_symbol); else p = symbol_to_local_slot(sc, sc->features_symbol, sc->curlet); /* if sc->curlet is nil, this returns the global slot, else local slot */ @@ -30997,7 +30860,7 @@ static s7_pointer call_file_out(s7_scheme *sc, s7_pointer args) return(opt2_pair(sc->code)); } -#define op_with_io_1(Sc) (((s7_function)((sc->code)->object.cons.opt1))(Sc, Sc->nil)) +#define op_with_io_1(Sc) (((s7_function)((Sc->code)->object.cons.opt1))(Sc, Sc->nil)) static s7_pointer op_lambda(s7_scheme *sc, s7_pointer code); @@ -31037,7 +30900,7 @@ static bool op_with_io_op(s7_scheme *sc) static void op_with_output_to_string(s7_scheme *sc) { s7_pointer old_port = current_output_port(sc); - set_current_output_port(sc, open_output_string(sc, sc->initial_string_port_length)); + set_current_output_port(sc, s7_open_output_string(sc)); push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc)); sc->curlet = make_let(sc, sc->curlet); push_stack(sc, OP_GET_OUTPUT_STRING, old_port, current_output_port(sc)); @@ -31047,7 +30910,7 @@ static void op_with_output_to_string(s7_scheme *sc) static void op_call_with_output_string(s7_scheme *sc) { s7_pointer port; - port = open_output_string(sc, sc->initial_string_port_length); + port = s7_open_output_string(sc); push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); sc->curlet = make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); @@ -31507,11 +31370,7 @@ in the sequence each time it is called. When it reaches the end, it returns " I { iterator_let_cons(iter) = carrier; set_mark_seq(iter); - } - else /* (let-temporarily (((*s7* 'safety) 1)) (make-iterator "asdf" (cons 1 2))) */ - if (sc->safety > MORE_SAFETY_WARNINGS) - s7_warn(sc, 256, "(make-iterator %s %s) does not need the second argument\n", display_80(seq), display_80(carrier)); - } + }} return(iter); } @@ -32155,14 +32014,14 @@ static void slashify_string_to_port(s7_scheme *sc, s7_pointer port, const char * case 'x': port_write_character(port)(sc, 'x', port); break; default: { - s7_int n; - port_write_character(port)(sc, 'x', port); - n = (s7_int)(*pcur); - if (n < 16) - port_write_character(port)(sc, '0', port); - else port_write_character(port)(sc, dignum[(n / 16) % 16], port); - port_write_character(port)(sc, dignum[n % 16], port); - port_write_character(port)(sc, ';', port); + char buf[5]; + s7_int n = (s7_int)(*pcur); + buf[0] = 'x'; + buf[1] = (n < 16) ? '0' : dignum[(n / 16) % 16]; + buf[2] = dignum[n % 16]; + buf[3] = ';'; + buf[4] = '\0'; + port_write_string(port)(sc, buf, 4, port); } break; }}} @@ -32303,7 +32162,7 @@ static bool symbol_needs_slashification(s7_scheme *sc, s7_pointer obj) if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ',')) return(true); - if (s7_is_number(make_atom(sc, (char *)str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR))) + if (is_number(make_atom(sc, (char *)str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR))) return(true); len = symbol_name_length(obj); @@ -32618,9 +32477,9 @@ static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_ port_write_character(port)(sc, ' ', port); object_to_port_with_circle_check(sc, vector_element(vect, i), port, P_READABLE, ci); } - port_write_character(port)(sc, ')', port); if (is_immutable_vector(vect)) - port_write_character(port)(sc, ')', port); + port_write_string(port)(sc, "))", 2, port); + else port_write_character(port)(sc, ')', port); if (vector_rank(vect) > 1) { @@ -32723,10 +32582,10 @@ static void int_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, make_vector_to_port(sc, vect, port); p = integer_to_string(sc, int_vector(vect, 0), &plen); port_write_string(port)(sc, p, plen, port); - port_write_character(port)(sc, ')', port); if ((use_write == P_READABLE) && (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); + port_write_string(port)(sc, "))", 2, port); + else port_write_character(port)(sc, ')', port); return; }} if (vector_rank(vect) == 1) @@ -32879,10 +32738,10 @@ static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, make_vector_to_port(sc, vect, port); p = integer_to_string(sc, byte_vector(vect, 0), &plen); port_write_string(port)(sc, p, plen, port); - port_write_character(port)(sc, ')', port); if ((use_write == P_READABLE) && (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); + port_write_string(port)(sc, "))", 2, port); + else port_write_character(port)(sc, ')', port); return; }} @@ -32938,9 +32797,9 @@ static void string_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_w nlen = catstrs_direct(buf, "(make-string ", pos_int_to_str_direct(sc, string_length(obj)), " ", (const char *)NULL); port_write_string(port)(sc, buf, nlen, port); port_write_string(port)(sc, character_name(c), character_name_length(c), port); - port_write_character(port)(sc, ')', port); if (immutable) - port_write_character(port)(sc, ')', port); + port_write_string(port)(sc, "))", 2, port); + else port_write_character(port)(sc, ')', port); return; }} if (use_write == P_DISPLAY) @@ -33040,9 +32899,9 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri return; } - port_write_character(port)(sc, '(', port); if (is_multiple_value(lst)) - port_write_string(port)(sc, "values ", 7, port); + port_write_string(port)(sc, "(values ", 8, port); + else port_write_character(port)(sc, '(', port); check_stack_size(sc); s7_gc_protect_via_stack(sc, lst); @@ -33301,7 +33160,7 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, }}} iterator = s7_make_iterator(sc, hash); - gc_iter = s7_gc_protect_1(sc, iterator); + gc_iter = gc_protect_1(sc, iterator); p = cons_unchecked(sc, sc->F, sc->F); iterator_current(iterator) = p; set_mark_seq(iterator); @@ -33895,11 +33754,11 @@ static s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b) s7_pointer p = cdr(a), tp, np; if (is_null(p)) return(cons(sc, car(a), b)); tp = list_1(sc, car(a)); - sc->y = tp; + gc_protect_via_stack(sc, tp); for (np = tp; is_pair(p); p = cdr(p), np = cdr(np)) set_cdr(np, list_1(sc, car(p))); set_cdr(np, b); - sc->y = sc->nil; + unstack(sc); return(tp); } @@ -33954,7 +33813,7 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); pe = closure_let(obj); - gc_loc = s7_gc_protect_1(sc, sc->nil); + gc_loc = gc_protect_1(sc, sc->nil); collect_locals(sc, body, pe, arglist, gc_loc); /* collect locals used only here (and below) */ collect_specials(sc, pe, arglist, gc_loc); @@ -34056,7 +33915,7 @@ static void iterator_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use if (ci->init_port == sc->F) { ci->init_port = s7_open_output_string(sc); - ci->init_loc = s7_gc_protect_1(sc, ci->init_port); + ci->init_loc = gc_protect_1(sc, ci->init_port); } port_write_string(port)(sc, "#f", 2, port); nlen = catstrs_direct(buf, " (set! <", pos_int_to_str_direct(sc, iter_ref), "> (make-iterator ", (const char *)NULL); @@ -34160,9 +34019,9 @@ static void c_pointer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, us if (ci->init_port == sc->F) { ci->init_port = s7_open_output_string(sc); - ci->init_loc = s7_gc_protect_1(sc, ci->init_port); + ci->init_loc = gc_protect_1(sc, ci->init_port); } - nlen = snprintf(buf, CP_BUFSIZE, " (set! <%d> (c-pointer %" print_pointer, -ref, (intptr_t)c_pointer(obj)); + nlen = snprintf(buf, CP_BUFSIZE, " (set! <%d> (c-pointer %" p64, -ref, (intptr_t)c_pointer(obj)); port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); if ((c_pointer_type(obj) != sc->F) || @@ -34186,7 +34045,7 @@ static void c_pointer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, us }} else { - nlen = snprintf(buf, CP_BUFSIZE, "(c-pointer %" print_pointer, (intptr_t)c_pointer(obj)); + nlen = snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64, (intptr_t)c_pointer(obj)); port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); if ((c_pointer_type(obj) != sc->F) || (c_pointer_info(obj) != sc->F)) @@ -34663,7 +34522,7 @@ static s7_pointer cyclic_out(s7_scheme *sc, s7_pointer obj, s7_pointer port, sha char buf[128]; ci->cycle_port = s7_open_output_string(sc); - ci->cycle_loc = s7_gc_protect_1(sc, ci->cycle_port); + ci->cycle_loc = gc_protect_1(sc, ci->cycle_port); port_write_string(port)(sc, "(let (", 6, port); for (i = 0; i < ci->top; i++) @@ -34794,7 +34653,7 @@ char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj) TRACK(sc); if ((sc->safety > NO_SAFETY) && (!s7_is_valid(sc, obj))) - s7_warn(sc, 256, "bad arg to %s: %p\n", __func__, obj); + s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj); strport = open_format_port(sc); object_out(sc, T_Pos(obj), strport, P_WRITE); @@ -34828,7 +34687,7 @@ s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer obj, bool use_write) /* if ((sc->safety > NO_SAFETY) && (!s7_is_valid(sc, obj))) - s7_warn(sc, 256, "bad arg to %s: %p\n", __func__, obj); + s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj); strport = open_format_port(sc); object_out(sc, obj, strport, (use_write) ? P_WRITE : P_DISPLAY); @@ -35441,15 +35300,15 @@ static format_data_t *open_format_data(s7_scheme *sc) } #if WITH_GMP -static bool s7_is_one_or_big_one(s7_scheme *sc, s7_pointer p) +static bool is_one_or_big_one(s7_scheme *sc, s7_pointer p) { - if (!is_big_number(p)) return(s7_is_one(p)); + if (!is_big_number(p)) return(is_one(p)); if (is_t_big_integer(p)) return(mpz_cmp_ui(big_integer(p), 1) == 0); if (is_t_big_real(p)) return(mpfr_cmp_d(big_real(p), 1.0) == 0); return(false); } #else -#define s7_is_one_or_big_one(Sc, Num) s7_is_one(Num) +#define is_one_or_big_one(Sc, Num) is_one(Num) #endif static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj); @@ -35562,7 +35421,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s if (!s7_is_real(car(fdat->args))) /* CL accepts non numbers here */ format_error(sc, "'@P' directive argument is not a real number", 44, str, args, fdat); - if (!s7_is_one_or_big_one(sc, car(fdat->args))) + if (!is_one_or_big_one(sc, car(fdat->args))) format_append_string(sc, fdat, "ies", 3, port); else format_append_char(sc, 'y', port); @@ -35574,7 +35433,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s format_error(sc, "'P' directive argument missing", 30, str, args, fdat); if (!s7_is_real(car(fdat->args))) format_error(sc, "'P' directive argument is not a real number", 43, str, args, fdat); - if (!s7_is_one_or_big_one(sc, car(fdat->args))) + if (!is_one_or_big_one(sc, car(fdat->args))) format_append_char(sc, 's', port); i++; fdat->args = cdr(fdat->args); @@ -35828,7 +35687,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s case 'F': case 'f': if (is_null(fdat->args)) format_error(sc, "~~F: missing argument", 21, str, args, fdat); - if (!(s7_is_number(car(fdat->args)))) + if (!(is_number(car(fdat->args)))) { if (!format_method(sc, (char *)(str + i), fdat, port)) format_error(sc, "~~F: numeric argument required", 30, str, args, fdat); @@ -35839,7 +35698,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s case 'G': case 'g': if (is_null(fdat->args)) format_error(sc, "~~G: missing argument", 21, str, args, fdat); - if (!(s7_is_number(car(fdat->args)))) + if (!(is_number(car(fdat->args)))) { if (!format_method(sc, (char *)(str + i), fdat, port)) format_error(sc, "~~G: numeric argument required", 30, str, args, fdat); @@ -35850,7 +35709,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s case 'E': case 'e': if (is_null(fdat->args)) format_error(sc, "~~E: missing argument", 21, str, args, fdat); - if (!(s7_is_number(car(fdat->args)))) + if (!(is_number(car(fdat->args)))) { if (!format_method(sc, (char *)(str + i), fdat, port)) format_error(sc, "~~E: numeric argument required", 30, str, args, fdat); @@ -35866,7 +35725,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s case 'D': case 'd': if (is_null(fdat->args)) format_error(sc, "~~D: missing argument", 21, str, args, fdat); - if (!(s7_is_number(car(fdat->args)))) + if (!(is_number(car(fdat->args)))) { /* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123))) * port here is a string-port, str has the width/precision data if the caller wants it, @@ -35884,7 +35743,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s case 'O': case 'o': if (is_null(fdat->args)) format_error(sc, "~~O: missing argument", 21, str, args, fdat); - if (!(s7_is_number(car(fdat->args)))) + if (!(is_number(car(fdat->args)))) { if (!format_method(sc, (char *)(str + i), fdat, port)) format_error(sc, "~~O: numeric argument required", 30, str, args, fdat); @@ -35895,7 +35754,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s case 'X': case 'x': if (is_null(fdat->args)) format_error(sc, "~~X: missing argument", 21, str, args, fdat); - if (!(s7_is_number(car(fdat->args)))) + if (!(is_number(car(fdat->args)))) { if (!format_method(sc, (char *)(str + i), fdat, port)) format_error(sc, "~~X: numeric argument required", 30, str, args, fdat); @@ -35906,7 +35765,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s case 'B': case 'b': if (is_null(fdat->args)) format_error(sc, "~~B: missing argument", 21, str, args, fdat); - if (!(s7_is_number(car(fdat->args)))) + if (!(is_number(car(fdat->args)))) { if (!format_method(sc, (char *)(str + i), fdat, port)) format_error(sc, "~~B: numeric argument required", 30, str, args, fdat); @@ -36429,7 +36288,7 @@ static void check_sig_entry(s7_scheme *sc, s7_pointer p, s7_int pos, bool circle (!s7_is_boolean(car(p))) && (!is_pair(car(p)))) { - s7_warn(sc, 512, "s7_make_%ssignature got an invalid entry at position %" print_s7_int ": (", (circle) ? "circular_" : "", pos); + s7_warn(sc, 512, "s7_make_%ssignature got an invalid entry at position %" ld64 ": (", (circle) ? "circular_" : "", pos); set_car(p, sc->nil); } } @@ -36944,14 +36803,7 @@ static s7_pointer g_tree_count(s7_scheme *sc, s7_pointer args) } -/* -------------------------------- null? pair? -------------------------------- */ -static s7_pointer g_is_null(s7_scheme *sc, s7_pointer args) -{ - #define H_is_null "(null? obj) returns #t if obj is the empty list" - #define Q_is_null sc->pl_bt - check_boolean_method(sc, is_null, sc->is_null_symbol, args); -} - +/* -------------------------------- pair? -------------------------------- */ static s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args) { #define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)" @@ -37122,26 +36974,28 @@ static s7_pointer protected_make_list(s7_scheme *sc, s7_int len, s7_pointer init return(sc->temp6); } -static s7_pointer g_make_list(s7_scheme *sc, s7_pointer args) +static s7_pointer make_list_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer init) { - #define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'." - #define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T) - - s7_pointer n = car(args); s7_int len; - if (!s7_is_integer(n)) - return(method_or_bust(sc, n, sc->make_list_symbol, args, T_INTEGER, 1)); + return(method_or_bust(sc, n, sc->make_list_symbol, set_plist_2(sc, n, init), T_INTEGER, 1)); len = s7_integer_checked(sc, n); #if WITH_GMP - if ((len == 0) && (!s7_is_zero(n))) + if ((len == 0) && (!is_zero(sc, n))) return(s7_out_of_range_error(sc, "make-list", 1, n, "big integer is too big for s7_int")); #endif + if (len == 0) return(sc->nil); /* what about (make-list 0 123)? */ if ((len < 0) || (len > sc->max_list_length)) return(out_of_range(sc, sc->make_list_symbol, int_one, n, (len < 0) ? its_negative_string : its_too_large_string)); - if (len == 0) return(sc->nil); /* what about (make-list 0 123)? */ - return(make_list(sc, len, (is_pair(cdr(args))) ? cadr(args) : sc->F)); + return(make_list(sc, len, init)); +} + +static s7_pointer g_make_list(s7_scheme *sc, s7_pointer args) +{ + #define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'." + #define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T) + return(make_list_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->F)); } @@ -37458,7 +37312,7 @@ static s7_pointer car_p_p(s7_scheme *sc, s7_pointer p) { if (is_pair(p)) return(car(p)); - return(simple_wrong_type_argument(sc, sc->car_symbol, p, T_PAIR)); + return(method_or_bust_one_arg(sc, p, sc->car_symbol, set_plist_1(sc, p), T_PAIR)); } static s7_pointer g_list_ref_at_0(s7_scheme *sc, s7_pointer args) @@ -37474,16 +37328,14 @@ static s7_pointer g_set_car(s7_scheme *sc, s7_pointer args) #define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) s7_pointer p = car(args); - if (!is_mutable_pair(p)) /* this is currently 2.5x slower than is_pair */ - return(mutable_method_or_bust(sc, p, sc->set_car_symbol, args, T_PAIR, 1)); + if (!is_mutable_pair(p)) return(mutable_method_or_bust(sc, p, sc->set_car_symbol, args, T_PAIR, 1)); set_car(p, cadr(args)); return(car(p)); } static Inline s7_pointer inline_set_car(s7_scheme *sc, s7_pointer p1, s7_pointer p2) { - if (!is_mutable_pair(p1)) - simple_wrong_type_argument(sc, sc->set_car_symbol, p1, T_PAIR); + if (!is_mutable_pair(p1)) return(mutable_method_or_bust(sc, p1, sc->set_car_symbol, set_plist_1(sc, p1), T_PAIR, 1)); set_car(p1, p2); return(p2); } @@ -37507,7 +37359,7 @@ static s7_pointer cdr_p_p(s7_scheme *sc, s7_pointer p) { if (is_pair(p)) return(cdr(p)); - return(simple_wrong_type_argument(sc, sc->cdr_symbol, p, T_PAIR)); + return(method_or_bust_one_arg(sc, p, sc->cdr_symbol, set_plist_1(sc, p), T_PAIR)); } @@ -37517,20 +37369,20 @@ static s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args) #define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) s7_pointer p = car(args); - if (!is_mutable_pair(p)) - return(mutable_method_or_bust(sc, p, sc->set_cdr_symbol, args, T_PAIR, 1)); + if (!is_mutable_pair(p)) return(mutable_method_or_bust(sc, p, sc->set_cdr_symbol, args, T_PAIR, 1)); set_cdr(p, cadr(args)); return(cdr(p)); } -static s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) +static Inline s7_pointer inline_set_cdr(s7_scheme *sc, s7_pointer p1, s7_pointer p2) { - if (!is_mutable_pair(p1)) - simple_wrong_type_argument(sc, sc->set_cdr_symbol, p1, T_PAIR); + if (!is_mutable_pair(p1)) return(mutable_method_or_bust(sc, p1, sc->set_cdr_symbol, set_plist_1(sc, p1), T_PAIR, 1)); set_cdr(p1, p2); return(p2); } +static s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(inline_set_cdr(sc, p1, p2));} + /* -------- caar --------*/ static s7_pointer g_caar(s7_scheme *sc, s7_pointer args) @@ -37547,7 +37399,7 @@ static s7_pointer g_caar(s7_scheme *sc, s7_pointer args) static s7_pointer caar_p_p(s7_scheme *sc, s7_pointer p) { if ((is_pair(p)) && (is_pair(car(p)))) return(caar(p)); - if (!is_pair(p)) return(simple_wrong_type_argument(sc, sc->caar_symbol, p, T_PAIR)); + if (!is_pair(p)) return(method_or_bust_one_arg(sc, p, sc->caar_symbol, set_plist_1(sc, p), T_PAIR)); return(simple_wrong_type_argument_with_type(sc, sc->caar_symbol, p, car_a_list_string)); } @@ -37566,15 +37418,14 @@ static s7_pointer g_cadr(s7_scheme *sc, s7_pointer args) static s7_pointer cadr_p_p(s7_scheme *sc, s7_pointer p) { if ((is_pair(p)) && (is_pair(cdr(p)))) return(cadr(p)); - if (!is_pair(p)) return(simple_wrong_type_argument(sc, sc->cadr_symbol, p, T_PAIR)); + if (!is_pair(p)) return(method_or_bust_one_arg(sc, p, sc->cadr_symbol, set_plist_1(sc, p), T_PAIR)); return(simple_wrong_type_argument_with_type(sc, sc->cadr_symbol, p, cdr_a_list_string)); } static s7_pointer g_list_ref_at_1(s7_scheme *sc, s7_pointer args) { s7_pointer lst = car(args); - if (!is_pair(lst)) - return(method_or_bust(sc, lst, sc->list_ref_symbol, args, T_PAIR, 1)); + if (!is_pair(lst)) return(method_or_bust(sc, lst, sc->list_ref_symbol, args, T_PAIR, 1)); if (is_pair(cdr(lst))) return(cadr(lst)); return(out_of_range(sc, sc->list_ref_symbol, int_two, cadr(args), its_too_large_string)); } @@ -37594,7 +37445,7 @@ static s7_pointer g_cdar(s7_scheme *sc, s7_pointer args) static s7_pointer cdar_p_p(s7_scheme *sc, s7_pointer p) { if ((is_pair(p)) && (is_pair(car(p)))) return(cdar(p)); - if (!is_pair(p)) return(simple_wrong_type_argument(sc, sc->cdar_symbol, p, T_PAIR)); + if (!is_pair(p)) return(method_or_bust_one_arg(sc, p, sc->cdar_symbol, set_plist_1(sc, p), T_PAIR)); return(simple_wrong_type_argument_with_type(sc, sc->cdar_symbol, p, car_a_list_string)); } @@ -37613,27 +37464,30 @@ static s7_pointer g_cddr(s7_scheme *sc, s7_pointer args) static s7_pointer cddr_p_p(s7_scheme *sc, s7_pointer p) { if ((is_pair(p)) && (is_pair(cdr(p)))) return(cddr(p)); - if (!is_pair(p)) return(simple_wrong_type_argument(sc, sc->cddr_symbol, p, T_PAIR)); + if (!is_pair(p)) return(method_or_bust_one_arg(sc, p, sc->cddr_symbol, set_plist_1(sc, p), T_PAIR)); return(simple_wrong_type_argument_with_type(sc, sc->cddr_symbol, p, cdr_a_list_string)); } /* -------- caaar -------- */ +static s7_pointer caaar_p_p(s7_scheme *sc, s7_pointer lst) +{ + if (!is_pair(lst)) return(method_or_bust_one_arg(sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), T_PAIR)); + if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, car_a_list_string)); + return((is_pair(caar(lst))) ? caaar(lst) : simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, caar_a_list_string)); +} + static s7_pointer g_caaar(s7_scheme *sc, s7_pointer args) { #define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1" #define Q_caaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(method_or_bust_one_arg(sc, lst, sc->caaar_symbol, args, T_PAIR)); - if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, car_a_list_string)); - return((is_pair(caar(lst))) ? caaar(lst) : simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, caar_a_list_string)); + return(caaar_p_p(sc, car(args))); } /* -------- caadr -------- */ static s7_pointer caadr_p_p(s7_scheme *sc, s7_pointer p) { if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cadr(p)))) return(caadr(p)); - if (!is_pair(p)) return(simple_wrong_type_argument(sc, sc->caadr_symbol, p, T_PAIR)); + if (!is_pair(p)) return(method_or_bust_one_arg(sc, p, sc->caadr_symbol, set_plist_1(sc, p), T_PAIR)); if (!is_pair(cdr(p))) return(simple_wrong_type_argument_with_type(sc, sc->caadr_symbol, p, cdr_a_list_string)); return(simple_wrong_type_argument_with_type(sc, sc->caadr_symbol, p, cadr_a_list_string)); } @@ -37663,21 +37517,24 @@ static s7_pointer g_cadar(s7_scheme *sc, s7_pointer args) static s7_pointer cadar_p_p(s7_scheme *sc, s7_pointer p) { if ((is_pair(p)) && (is_pair(car(p))) && (is_pair(cdar(p)))) return(cadar(p)); - if (!is_pair(p)) return(simple_wrong_type_argument(sc, sc->cadar_symbol, p, T_PAIR)); + if (!is_pair(p)) return(method_or_bust_one_arg(sc, p, sc->cadar_symbol, set_plist_1(sc, p), T_PAIR)); if (!is_pair(car(p))) return(simple_wrong_type_argument_with_type(sc, sc->cadar_symbol, p, car_a_list_string)); return(simple_wrong_type_argument_with_type(sc, sc->cadar_symbol, p, cdar_a_list_string)); } /* -------- cdaar -------- */ +static s7_pointer cdaar_p_p(s7_scheme *sc, s7_pointer lst) +{ + if (!is_pair(lst)) return(method_or_bust_one_arg(sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), T_PAIR)); + if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, car_a_list_string)); + return((is_pair(caar(lst))) ? cdaar(lst) : simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, caar_a_list_string)); +} + static s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args) { #define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)" #define Q_cdaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(method_or_bust_one_arg(sc, lst, sc->cdaar_symbol, args, T_PAIR)); - if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, car_a_list_string)); - return((is_pair(caar(lst))) ? cdaar(lst) : simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, caar_a_list_string)); + return(cdaar_p_p(sc, car(args))); } /* -------- caddr -------- */ @@ -37695,7 +37552,7 @@ static s7_pointer g_caddr(s7_scheme *sc, s7_pointer args) static s7_pointer caddr_p_p(s7_scheme *sc, s7_pointer p) { if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p)))) return(caddr(p)); - if (!is_pair(p)) return(simple_wrong_type_argument(sc, sc->caddr_symbol, p, T_PAIR)); + if (!is_pair(p)) return(method_or_bust_one_arg(sc, p, sc->caddr_symbol, set_plist_1(sc, p), T_PAIR)); if (!is_pair(cdr(p))) return(simple_wrong_type_argument_with_type(sc, sc->caddr_symbol, p, cdr_a_list_string)); return(simple_wrong_type_argument_with_type(sc, sc->caddr_symbol, p, cddr_a_list_string)); } @@ -37741,15 +37598,18 @@ static s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args) } /* -------- cddar -------- */ +static s7_pointer cddar_p_p(s7_scheme *sc, s7_pointer lst) +{ + if (!is_pair(lst)) return(method_or_bust_one_arg(sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), T_PAIR)); + if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, car_a_list_string)); + return((is_pair(cdar(lst))) ? cddar(lst) : simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, cdar_a_list_string)); +} + static s7_pointer g_cddar(s7_scheme *sc, s7_pointer args) { #define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)" #define Q_cddar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(method_or_bust_one_arg(sc, lst, sc->cddar_symbol, args, T_PAIR)); - if (!is_pair(car(lst))) return(simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, car_a_list_string)); - return((is_pair(cdar(lst))) ? cddar(lst) : simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, cdar_a_list_string)); + return(cddar_p_p(sc, car(args))); } /* -------- caaaar -------- */ @@ -38073,7 +37933,6 @@ s7_pointer s7_assoc(s7_scheme *sc, s7_pointer sym, s7_pointer lst) static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args); static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args); static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr); -static s7_pointer opt_bool_any(s7_scheme *sc); static s7_pointer g_assoc(s7_scheme *sc, s7_pointer args) { @@ -38082,84 +37941,87 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of #define Q_assoc s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol) s7_pointer x = cadr(args), y, obj, eq_func = NULL; + if (!is_null(x)) { if (!is_pair(x)) return(method_or_bust_with_type(sc, x, sc->assoc_symbol, args, an_association_list_string, 2)); - if ((is_pair(x)) && (!is_pair(car(x)))) return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, x, an_association_list_string)); /* we're assuming caar below so it better exist */ } - if (is_not_null(cddr(args))) + if (is_pair(cddr(args))) { - /* check third arg before second (trailing arg error check) */ eq_func = caddr(args); - - if (type(eq_func) < T_CONTINUATION) - return(method_or_bust_with_type_one_arg(sc, eq_func, sc->assoc_symbol, args, a_procedure_string)); - - if (!s7_is_aritable(sc, eq_func, 2)) - return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string)); - } - if (is_null(x)) return(sc->F); - - if (eq_func) - { /* here we know x is a pair, but need to protect against circular lists */ - if (s7_list_length(sc, x) != 0) + /* I wonder if the assoc equality function should get the cons, not just caar? */ + + if ((is_c_function(eq_func)) && (is_safe_procedure(eq_func))) { - /* now maybe there's a simple case */ - if ((is_c_function(eq_func)) && (is_safe_procedure(eq_func))) + s7_function func; + s7_pointer slow; + func = c_function_call(eq_func); + if (func == g_is_eq) return(is_null(x) ? sc->F : s7_assq(sc, car(args), x)); + if (func == g_is_eqv) return(assv_p_pp(sc, car(args), x)); + if (!s7_is_aritable(sc, eq_func, 2)) + return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string)); + set_car(sc->t2_1, car(args)); + for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) { - s7_function func; - func = c_function_call(eq_func); - if (func == g_is_eq) return(s7_assq(sc, car(args), x)); - if (func == g_is_eqv) return(assv_p_pp(sc, car(args), x)); - set_car(sc->t2_1, car(args)); - - for (; is_pair(x); x = cdr(x)) - { - if (!is_pair(car(x))) - return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string)); - set_car(sc->t2_2, caar(x)); - if (is_true(sc, func(sc, sc->t2_1))) - return(car(x)); - /* I wonder if the assoc equality function should get the cons, not just caar? */ - } - return(sc->F); + if (!is_pair(car(x))) return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string)); + set_car(sc->t2_2, caar(x)); + if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); + x = cdr(x); + if ((!is_pair(x)) || (x == slow)) return(sc->F); + if (!is_pair(car(x))) return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string)); + set_car(sc->t2_2, caar(x)); + if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); } - if ((is_closure(eq_func)) && - (is_pair(closure_args(eq_func))) && - (is_pair(cdr(closure_args(eq_func))))) /* not dotted arg list */ + return(sc->F); + } + if ((is_closure(eq_func)) && + (is_pair(closure_args(eq_func))) && + (is_pair(cdr(closure_args(eq_func)))) && /* not dotted arg list */ + (is_null(cddr(closure_args(eq_func))))) /* arity == 2 */ + { + s7_pointer body = closure_body(eq_func); + if (is_null(x)) return(sc->F); + if (is_null(cdr(body))) { - s7_pointer body; - body = closure_body(eq_func); - if (is_null(cdr(body))) + s7_pfunc func; + sc->curlet = make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F); + func = s7_bool_optimize(sc, body); + if (func) { - s7_pfunc func; - sc->curlet = make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F); - func = s7_bool_optimize(sc, body); - if (func) + s7_pointer slowx = x, b; + opt_info *o = sc->opts[0]; + b = next_slot(let_slots(sc->curlet)); + while (true) { - s7_pointer b; - b = next_slot(let_slots(sc->curlet)); - - if (func == opt_bool_any) - { - opt_info *o = sc->opts[0]; - for (; is_pair(x); x = cdr(x)) - { - slot_set_value(b, caar(x)); - if (o->v[0].fb(o)) - return(car(x)); - } - return(sc->F); - }}}}} + if (!is_pair(car(x))) return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string)); + slot_set_value(b, caar(x)); + if (o->v[0].fb(o)) return(car(x)); + x = cdr(x); + if (!is_pair(x)) return(sc->F); + if (!is_pair(car(x))) return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string)); + slot_set_value(b, caar(x)); + if (o->v[0].fb(o)) return(car(x)); + x = cdr(x); + if (!is_pair(x)) return(sc->F); + slowx = cdr(slowx); + if (x == slowx) return(sc->F); + } + return(sc->F); + }}} /* member_if is similar. Do not call eval here with op_eval_done to return! An error will longjmp past the * assoc point, leaving the op_eval_done on the stack, causing s7 to quit. */ + if (type(eq_func) < T_CONTINUATION) + return(method_or_bust_with_type_one_arg(sc, eq_func, sc->assoc_symbol, args, a_procedure_string)); + if (!s7_is_aritable(sc, eq_func, 2)) + return(wrong_type_argument_with_type(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string)); + if (is_null(x)) return(sc->F); y = list_1(sc, args); set_opt1_fast(y, x); set_opt2_slow(y, x); @@ -38175,11 +38037,10 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of return(sc->unspecified); } - x = cadr(args); + if (is_null(x)) return(sc->F); obj = car(args); if (is_simple(obj)) return(s7_assq(sc, obj, x)); - y = x; if (is_string(obj)) { @@ -38229,7 +38090,7 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of static s7_pointer assoc_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(g_assoc(sc, set_plist_2(sc, p1, p2)));} -static bool assoc_if(s7_scheme *sc) +static bool op_assoc_if(s7_scheme *sc) { s7_pointer orig_args = car(sc->args); /* code=func, args=(list (list args)) with f/opt1_fast=list, value=result of comparison @@ -38272,6 +38133,17 @@ static bool assoc_if(s7_scheme *sc) return(false); } +static s7_pointer assoc_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) +{ + if (!ops) return(f); + if ((args == 3) && (is_normal_symbol(cadddr(expr)))) + { + if (cadddr(expr) == sc->is_eq_symbol) return(global_value(sc->assq_symbol)); + if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->assv_symbol)); + } + return(f); +} + /* ---------------- member, memv, memq ---------------- */ s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x) @@ -38345,9 +38217,8 @@ static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args) return(sc->F); } -static s7_pointer g_memq_4(s7_scheme *sc, s7_pointer args) +static s7_pointer memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) { - s7_pointer x = cadr(args), obj = car(args); while (true) { LOOP_4(if (obj == car(x)) return(x); x = cdr(x)); @@ -38356,6 +38227,8 @@ static s7_pointer g_memq_4(s7_scheme *sc, s7_pointer args) return(sc->F); } +static s7_pointer g_memq_4(s7_scheme *sc, s7_pointer args) {return(memq_4_p_pp(sc, car(args), cadr(args)));} + static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args) { /* no circular list check needed in this case */ @@ -38409,7 +38282,7 @@ static s7_pointer memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer x) s7_pointer y = x; while (true) { - LOOP_4(if ((s7_is_number(car(x))) && (numbers_are_eqv(sc, obj, car(x)))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); + LOOP_4(if ((is_number(car(x))) && (numbers_are_eqv(sc, obj, car(x)))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); y = cdr(y); if (x == y) return(sc->F); } @@ -38426,7 +38299,7 @@ static s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) } if (is_simple(x)) return(s7_memq(sc, x, y)); - if (s7_is_number(x)) return(memv_number(sc, x, y)); + if (is_number(x)) return(memv_number(sc, x, y)); z = y; while (true) @@ -38519,61 +38392,50 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c if (is_not_null(cddr(args))) { - /* check third arg before second (trailing arg error check) */ - eq_func = caddr(args); - - if (type(eq_func) < T_CONTINUATION) - return(method_or_bust_with_type(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3)); - - if (!s7_is_aritable(sc, eq_func, 2)) - return(wrong_type_argument_with_type(sc, sc->member_symbol, 3, eq_func, an_eq_func_string)); - } - - if (is_null(x)) return(sc->F); - if (eq_func) - { s7_pointer y, slow; + eq_func = caddr(args); if ((is_c_function(eq_func)) && (is_safe_procedure(eq_func))) { s7_function func = c_function_call(eq_func); - if (func == g_is_eq) return(s7_memq(sc, car(args), x)); + if (func == g_is_eq) return(is_null(x) ? sc->F : s7_memq(sc, car(args), x)); if (func == g_is_eqv) return(g_memv(sc, args)); - if (func == g_less) func = g_less_2; - if (func == g_greater) func = g_greater_2; + if (func == g_less) + func = g_less_2; + else + if (func == g_greater) + func = g_greater_2; + else + if (!s7_is_aritable(sc, eq_func, 2)) + return(wrong_type_argument_with_type(sc, sc->member_symbol, 3, eq_func, an_eq_func_string)); set_car(sc->t2_1, car(args)); - for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) { set_car(sc->t2_2, car(x)); - if (is_true(sc, func(sc, sc->t2_1))) - return(x); - - if (!is_pair(cdr(x))) - return(sc->F); + if (is_true(sc, func(sc, sc->t2_1))) return(x); + if (!is_pair(cdr(x))) return(sc->F); x = cdr(x); - if (x == slow) - return(sc->F); - + if (x == slow) return(sc->F); set_car(sc->t2_2, car(x)); - if (is_true(sc, func(sc, sc->t2_1))) - return(x); + if (is_true(sc, func(sc, sc->t2_1))) return(x); } return(sc->F); } if ((is_closure(eq_func)) && (is_pair(closure_args(eq_func))) && - (is_pair(cdr(closure_args(eq_func))))) /* not dotted arg list */ + (is_pair(cdr(closure_args(eq_func)))) && /* not dotted arg list */ + (is_null(cddr(closure_args(eq_func))))) /* arity == 2 */ { s7_pointer body = closure_body(eq_func); + if (is_null(x)) return(sc->F); if ((!no_bool_opt(body)) && (is_null(cdr(body)))) { s7_pfunc func; sc->curlet = make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F); func = s7_bool_optimize(sc, body); - if (func == opt_bool_any) + if (func) { opt_info *o = sc->opts[0]; s7_pointer b; @@ -38608,6 +38470,11 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c set_no_bool_opt(body); }} + if (type(eq_func) < T_CONTINUATION) + return(method_or_bust_with_type(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3)); + if (!s7_is_aritable(sc, eq_func, 2)) + return(wrong_type_argument_with_type(sc, sc->member_symbol, 3, eq_func, an_eq_func_string)); + if (is_null(x)) return(sc->F); y = list_1(sc, args); /* this could probably be handled with a counter cell (cdr here is unused) */ set_opt1_fast(y, x); set_opt2_slow(y, x); @@ -38622,14 +38489,12 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c } return(sc->unspecified); } + if (is_null(x)) return(sc->F); obj = car(args); if (is_simple(obj)) return(s7_memq(sc, obj, x)); - - /* the only things that aren't simply == here are c_object, string, number, vector, hash-table, pair, and c_pointer - * but all the other cases are unlikely. - */ - if (s7_is_number(obj)) + /* the only things that aren't simply == here are c_object, string, number, vector, hash-table, pair, and c_pointer, but all the other cases are unlikely */ + if (is_number(obj)) return(memv_number(sc, obj, x)); return(member(sc, obj, x)); } @@ -38639,14 +38504,15 @@ static s7_pointer member_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {retu static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) { if (!ops) return(f); - if ((args == 3) && - (is_normal_symbol(cadddr(expr))) && - (cadddr(expr) == sc->is_eq_symbol)) - return(memq_chooser(sc, f, 2, expr, ops)); + if ((args == 3) && (is_normal_symbol(cadddr(expr)))) + { + if (cadddr(expr) == sc->is_eq_symbol) return(memq_chooser(sc, global_value(sc->memq_symbol), 2, expr, ops)); + if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->memv_symbol)); + } return(f); } -static bool member_if(s7_scheme *sc) +static bool op_member_if(s7_scheme *sc) { s7_pointer orig_args = car(sc->args); /* code=func, args = (list (list original args)) with opt1_fast->position in cadr (the list), @@ -38723,7 +38589,7 @@ static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer ls int32_t i; for (i = 1, p = lst; is_pair(p); p = cdr(p), i++) if (!s7_is_valid(sc, car(p))) - s7_warn(sc, 256, "bad arg (#%d) to %s: %p\n", i, caller, car(p)); + s7_warn(sc, 256, "bad argument (#%d) to %s: %p\n", i, caller, car(p)); } s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...) @@ -38943,10 +38809,10 @@ static s7_pointer append_in_place(s7_scheme *sc, s7_pointer a, s7_pointer b) /* -------------------------------- vectors -------------------------------- */ -bool s7_is_vector(s7_pointer p) {return(is_any_vector(p));} -bool s7_is_float_vector(s7_pointer p) {return(is_float_vector(p));} -bool s7_is_int_vector(s7_pointer p) {return(is_int_vector(p));} -static bool s7_is_byte_vector(s7_pointer b) {return(is_byte_vector(b));} +bool s7_is_vector(s7_pointer p) {return(is_any_vector(p));} +bool s7_is_float_vector(s7_pointer p) {return(is_float_vector(p));} +bool s7_is_int_vector(s7_pointer p) {return(is_int_vector(p));} +static bool is_byte_vector_b_p(s7_pointer b) {return(is_byte_vector(b));} s7_int s7_vector_length(s7_pointer vec) {return(vector_length(vec));} @@ -38982,6 +38848,9 @@ static inline s7_pointer typed_vector_setter(s7_scheme *sc, s7_pointer vec, s7_i } static s7_pointer default_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(vector_element(vec, loc));} +static s7_pointer int_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_integer(sc, int_vector(vec, loc)));} +static s7_pointer float_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_real(sc, float_vector(vec, loc)));} +static s7_pointer byte_vector_getter(s7_scheme *sc, s7_pointer bv, s7_int loc) {return(make_integer(sc, (uint8_t)(byte_vector(bv, loc))));} static s7_pointer int_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) { @@ -38991,18 +38860,12 @@ static s7_pointer int_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s return(val); } -static s7_pointer int_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_integer(sc, int_vector(vec, loc)));} - static s7_pointer float_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) { float_vector(vec, loc) = real_to_double(sc, val, "float-vector-set!"); return(val); } -static s7_pointer float_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_real(sc, float_vector(vec, loc)));} - -static s7_pointer byte_vector_getter(s7_scheme *sc, s7_pointer bv, s7_int loc) {return(make_integer(sc, (uint8_t)(byte_vector(bv, loc))));} - static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val) { s7_int byte; @@ -39622,7 +39485,7 @@ static s7_int flatten_multivector_indices(s7_scheme *sc, s7_pointer vector, s7_i if (rank != indices) { va_end(ap); - s7_wrong_number_of_args_error(sc, "s7_vector_ref_n: wrong number of indices: ~A", make_integer(sc, indices)); + s7_wrong_number_of_args_error(sc, "s7_vector_ref_n: wrong number of indices: ~A", wrap_integer1(sc, indices)); } if (rank == 1) index = va_arg(ap, s7_int); @@ -39638,7 +39501,7 @@ static s7_int flatten_multivector_indices(s7_scheme *sc, s7_pointer vector, s7_i (ind >= dimensions[i])) { va_end(ap); - out_of_range(sc, sc->vector_ref_symbol, make_integer(sc, i), wrap_integer1(sc, ind), (ind < 0) ? its_negative_string : its_too_large_string); + out_of_range(sc, sc->vector_ref_symbol, wrap_integer1(sc, i), wrap_integer1(sc, ind), (ind < 0) ? its_negative_string : its_too_large_string); return(-1); } index += (ind * offsets[i]); @@ -39919,7 +39782,7 @@ static s7_pointer g_is_byte_vector(s7_scheme *sc, s7_pointer args) { #define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector" #define Q_is_byte_vector sc->pl_bt - check_boolean_method(sc, s7_is_byte_vector, sc->is_byte_vector_symbol, args); + check_boolean_method(sc, is_byte_vector_b_p, sc->is_byte_vector_symbol, args); } @@ -40355,9 +40218,7 @@ static s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer v, s7_int i1 /* this is specific to T_VECTOR */ static s7_pointer vector_ref_unchecked(s7_scheme *sc, s7_pointer v, s7_int i) { -#if S7_DEBUGGING - if (!is_normal_vector(v)) fprintf(stderr, "%s[%d]: vector is not T_VECTOR\n", __func__, __LINE__); -#endif + if ((S7_DEBUGGING) && (!is_normal_vector(v))) fprintf(stderr, "%s[%d]: vector is not T_VECTOR\n", __func__, __LINE__); return(vector_element(v, i)); } @@ -40838,10 +40699,10 @@ static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args) return(method_or_bust(sc, init, sc->make_float_vector_symbol, args, T_REAL, 2)); #if WITH_GMP if (s7_is_bignum(init)) - return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real1(sc, s7_real(init))), sc->make_float_vector_symbol)); + return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real2(sc, s7_real(init))), sc->make_float_vector_symbol)); #endif if (is_rational(init)) - return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real1(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol)); + return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real2(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol)); } else init = real_zero; if (s7_is_integer(p)) @@ -41001,7 +40862,7 @@ static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) if ((len < 0) || (len > sc->max_vector_length)) return(out_of_range(sc, sc->make_byte_vector_symbol, int_one, wrap_integer1(sc, len), (len < 0) ? its_negative_string : its_too_large_string)); if ((init < 0) || (init > 255)) - return(simple_wrong_type_argument_with_type(sc, sc->make_byte_vector_symbol, make_integer(sc, init), an_unsigned_byte_string)); + return(simple_wrong_type_argument_with_type(sc, sc->make_byte_vector_symbol, wrap_integer1(sc, init), an_unsigned_byte_string)); p = make_simple_byte_vector(sc, len); if (len > 0) local_memset((void *)(byte_vector_bytes(p)), init, len); @@ -41047,7 +40908,7 @@ static s7_pointer g_vector_dimension(s7_scheme *sc, s7_pointer args) n = s7_integer(np); if ((n < 0) || (n >= vector_rank(v))) return(s7_out_of_range_error(sc, "vector-dimension", 2, np, "must be between 0 and the vector-rank - 1")); - if (vector_has_dimensional_info(v)) + if (vector_has_dimension_info(v)) return(make_integer(sc, vector_dimension(v, n))); return(make_integer(sc, vector_length(v))); } @@ -41120,7 +40981,7 @@ static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list) return(reverse_in_place_unchecked(sc, sc->nil, list)); } -static s7_pointer s7_multivector_error(s7_scheme *sc, const char *message, s7_pointer data) +static s7_pointer multivector_error(s7_scheme *sc, const char *message, s7_pointer data) { return(s7_error(sc, sc->read_error_symbol, set_elist_3(sc, wrap_string(sc, "reading constant vector, ~A: ~A", 31), @@ -41162,11 +41023,11 @@ static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) (!is_pair(x))) { free(sizes); - return(s7_multivector_error(sc, "we need a list that fully specifies the vector's elements", data)); + return(multivector_error(sc, "we need a list that fully specifies the vector's elements", data)); }} vec = g_make_vector(sc, set_plist_1(sc, sc->w = proper_list_reverse_in_place(sc, sc->w))); - vec_loc = s7_gc_protect_1(sc, vec); + vec_loc = gc_protect_1(sc, vec); sc->w = sc->nil; /* now fill the vector checking that all the lists match */ @@ -41175,7 +41036,7 @@ static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) free(sizes); s7_gc_unprotect_at(sc, vec_loc); if (err < 0) - return(s7_multivector_error(sc, (err == MULTIVECTOR_TOO_MANY_ELEMENTS) ? "found too many elements" : "not enough elements found", data)); + return(multivector_error(sc, (err == MULTIVECTOR_TOO_MANY_ELEMENTS) ? "found too many elements" : "not enough elements found", data)); return(vec); } @@ -41757,7 +41618,7 @@ static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer v, s7_pointer i if (!is_int_vector(v)) return(method_or_bust_ppp(sc, v, sc->int_vector_set_symbol, v, index, val, T_INT_VECTOR, 1)); if (vector_rank(v) != 1) - return(univect_set(sc, list_3(sc, v, index, val), sc->int_vector_set_symbol, T_INT_VECTOR)); + return(univect_set(sc, set_plist_3(sc, v, index, val), sc->int_vector_set_symbol, T_INT_VECTOR)); if (is_immutable_vector(v)) return(immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, v))); if (!s7_is_integer(index)) @@ -41772,9 +41633,7 @@ static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer v, s7_pointer i else int_vector(v, i) = s7_integer_checked(sc, val); } #else -#if S7_DEBUGGING - fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); -#endif + if (S7_DEBUGGING) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); #endif } return(val); @@ -42360,7 +42219,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) { s7_pfunc sf1; sf1 = s7_bool_optimize(sc, closure_body(lessp)); - if (sf1 == opt_bool_any) + if (sf1) { if (sc->opts[0]->v[0].fb == p_to_b) sort_func = opt_bool_sort_p; @@ -43348,7 +43207,7 @@ static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key) hash_entry_t *x; s7_int loc, hash_mask = hash_table_mask(table); loc = hash_loc(sc, table, key) & hash_mask; - if (s7_is_number(key)) + if (is_number(key)) { for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) if (numbers_are_eqv(sc, key, hash_entry_key(x))) @@ -43757,7 +43616,7 @@ s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size) hash_table_elements(table) = (hash_entry_t **)(block_data(els)); if (!hash_table_elements(table)) s7_error(sc, make_symbol(sc, "memory-error"), - set_elist_2(sc, wrap_string(sc, "hash-table not allocated! size: ~D bytes", 40), make_integer(sc, size * sizeof(hash_entry_t *)))); + set_elist_2(sc, wrap_string(sc, "hash-table not allocated! size: ~D bytes", 40), wrap_integer1(sc, size * sizeof(hash_entry_t *)))); hash_table_checker(table) = hash_empty; hash_table_mapper(table) = default_hash_map; hash_table_entries(table) = 0; @@ -44174,7 +44033,7 @@ static s7_pointer g_hash_table_ref_2(s7_scheme *sc, s7_pointer args) static s7_pointer hash_table_ref_p_pp(s7_scheme *sc, s7_pointer table, s7_pointer key) { if (!is_hash_table(table)) - simple_wrong_type_argument(sc, sc->hash_table_ref_symbol, table, T_HASH_TABLE); + return(method_or_bust(sc, table, sc->hash_table_ref_symbol, set_plist_2(sc, table, key), T_HASH_TABLE, 1)); return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); } @@ -44710,7 +44569,7 @@ static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_hash) s7_int gc_loc; new_hash = s7_make_hash_table(sc, len); - gc_loc = s7_gc_protect_1(sc, new_hash); + gc_loc = gc_protect_1(sc, new_hash); /* I don't think the original hash functions can make any sense in general, so ignore them */ for (i = 0; i < len; i++) @@ -44861,9 +44720,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); -#if S7_DEBUGGING - default: fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); -#endif + default: if (S7_DEBUGGING) fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); } return(sc->lambda_symbol); } @@ -45026,7 +44883,7 @@ static s7_pointer define_bool_function(s7_scheme *sc, const char *name, s7_funct void (*marker)(s7_pointer p, s7_int top), bool simple, s7_function bool_setter) { - s7_pointer func, sym; + s7_pointer func, sym, bfunc; func = s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, signature); sym = make_symbol(sc, name); s7_define(sc, sc->nil, sym, func); @@ -45035,8 +44892,10 @@ static s7_pointer define_bool_function(s7_scheme *sc, const char *name, s7_funct c_function_symbol(func) = sym; c_function_set_marker(func, marker); if (simple) c_function_set_has_simple_elements(func); - c_function_set_bool_setter(func, s7_make_function(sc, name, bool_setter, 2, 0, false, NULL)); + c_function_set_bool_setter(func, bfunc = s7_make_function(sc, name, bool_setter, 2, 0, false, NULL)); c_function_set_has_bool_setter(func); + c_function_set_setter(bfunc, func); + set_is_bool_function(bfunc); return(sym); } @@ -45075,17 +44934,22 @@ s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fn s7_pointer *names, *defaults; block_t *b; - len = safe_strlen(arglist) + 8; - b = mallocate(sc, len); + len = safe_strlen(arglist); + b = mallocate(sc, len + 4); internal_arglist = (char *)block_data(b); - catstrs_direct(internal_arglist, "'(", arglist, ")", (const char *)NULL); + internal_arglist[0] = '\''; + internal_arglist[1] = '('; + memcpy((void *)(internal_arglist + 2), (void *)arglist, len); + internal_arglist[len + 2] = ')'; + internal_arglist[len + 3] = '\0'; + /* catstrs_direct(internal_arglist, "'(", arglist, ")", (const char *)NULL); */ local_args = s7_eval_c_string(sc, internal_arglist); - gc_loc = s7_gc_protect_1(sc, local_args); + gc_loc = gc_protect_1(sc, local_args); liberate(sc, b); n_args = s7_list_length(sc, local_args); if (n_args < 0) { - s7_warn(sc, 256, "%s rest arg is not supported in C-side define*: %s\n", name, arglist); + s7_warn(sc, 256, "%s rest argument is not supported in C-side define*: %s\n", name, arglist); n_args = -n_args; } func = s7_make_function(sc, name, fnc, 0, n_args, false, doc); @@ -45703,17 +45567,13 @@ void s7_c_type_set_ref(s7_scheme *sc, s7_int tag, s7_pointer (*ref)(s7_scheme *s void s7_c_type_set_getter(s7_scheme *sc, s7_int tag, s7_pointer getter) { -#if S7_DEBUGGING - if (!is_c_function(getter)) fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, __LINE__, getter); -#endif + if ((S7_DEBUGGING) && (!is_c_function(getter))) fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, __LINE__, getter); sc->c_object_types[tag]->getter = getter; } void s7_c_type_set_setter(s7_scheme *sc, s7_int tag, s7_pointer setter) { -#if S7_DEBUGGING - if (!is_c_function(setter)) fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, __LINE__, setter); -#endif + if ((S7_DEBUGGING) && (!is_c_function(setter))) fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, __LINE__, setter); sc->c_object_types[tag]->setter = setter; } @@ -45950,14 +45810,13 @@ static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer int32_t len; if (is_symbol(x_args)) /* any number of args is ok */ - return(s7_cons(sc, int_zero, max_arity)); - + return(cons(sc, int_zero, max_arity)); 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 */ - return(s7_cons(sc, make_integer(sc, -len), max_arity)); - return(s7_cons(sc, make_integer(sc, len), make_integer(sc, len))); + return(cons(sc, make_integer(sc, -len), max_arity)); + return(cons(sc, make_integer(sc, len), make_integer(sc, len))); } static void closure_star_arity_1(s7_scheme *sc, s7_pointer x, s7_pointer args) @@ -45986,7 +45845,7 @@ static void closure_star_arity_1(s7_scheme *sc, s7_pointer x, s7_pointer args) static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args) { closure_star_arity_1(sc, x, x_args); - return((closure_arity(x) == -1) ? s7_cons(sc, int_zero, max_arity) : s7_cons(sc, int_zero, make_integer(sc, closure_arity(x)))); + return((closure_arity(x) == -1) ? cons(sc, int_zero, max_arity) : cons(sc, int_zero, make_integer(sc, closure_arity(x)))); } static int32_t closure_arity_to_int(s7_scheme *sc, s7_pointer x) @@ -46022,11 +45881,11 @@ s7_pointer s7_arity(s7_scheme *sc, s7_pointer x) case T_C_OPT_ARGS_FUNCTION: case T_C_RST_ARGS_FUNCTION: case T_C_FUNCTION: - return(s7_cons(sc, make_integer(sc, c_function_required_args(x)), make_integer(sc, c_function_all_args(x)))); + return(cons(sc, make_integer(sc, c_function_required_args(x)), make_integer(sc, c_function_all_args(x)))); case T_C_ANY_ARGS_FUNCTION: case T_C_FUNCTION_STAR: - return(s7_cons(sc, int_zero, make_integer(sc, c_function_all_args(x)))); + return(cons(sc, int_zero, make_integer(sc, c_function_all_args(x)))); case T_MACRO: case T_BACRO: case T_CLOSURE: return(closure_arity_to_cons(sc, x, closure_args(x))); @@ -46035,16 +45894,16 @@ s7_pointer s7_arity(s7_scheme *sc, s7_pointer x) return(closure_star_arity_to_cons(sc, x, closure_args(x))); case T_C_MACRO: - return(s7_cons(sc, make_integer(sc, c_macro_required_args(x)), make_integer(sc, c_macro_all_args(x)))); + return(cons(sc, make_integer(sc, c_macro_required_args(x)), make_integer(sc, c_macro_all_args(x)))); case T_GOTO: case T_CONTINUATION: - return(s7_cons(sc, int_zero, max_arity)); + return(cons(sc, int_zero, max_arity)); case T_STRING: return((string_length(x) == 0) ? sc->F : cons(sc, int_one, int_one)); case T_LET: - return(s7_cons(sc, int_one, int_one)); + return(cons(sc, int_one, int_one)); case T_C_OBJECT: check_method(sc, x, sc->arity_symbol, set_plist_1(sc, x)); @@ -46053,19 +45912,19 @@ s7_pointer s7_arity(s7_scheme *sc, s7_pointer x) case T_VECTOR: if (vector_length(x) == 0) return(sc->F); if (has_simple_elements(x)) return(cons(sc, int_one, make_integer(sc, vector_rank(x)))); - return(s7_cons(sc, int_one, max_arity)); + return(cons(sc, int_one, max_arity)); case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: return((vector_length(x) == 0) ? sc->F : cons(sc, int_one, make_integer(sc, vector_rank(x)))); case T_PAIR: case T_HASH_TABLE: - return(s7_cons(sc, int_one, max_arity)); + return(cons(sc, int_one, max_arity)); case T_ITERATOR: - return(s7_cons(sc, int_zero, int_zero)); + return(cons(sc, int_zero, int_zero)); case T_SYNTAX: - return(s7_cons(sc, small_int(syntax_min_args(x)), (syntax_max_args(x) == -1) ? max_arity : small_int(syntax_max_args(x)))); + return(cons(sc, small_int(syntax_min_args(x)), (syntax_max_args(x) == -1) ? max_arity : small_int(syntax_max_args(x)))); } return(sc->F); } @@ -46370,7 +46229,7 @@ static s7_pointer g_setter(s7_scheme *sc, s7_pointer args) case T_SYMBOL: /* (setter symbol let) */ { - s7_pointer sym = car(args), slot; + s7_pointer sym = car(args), slot, setter; if (is_keyword(sym)) return(sc->F); @@ -46383,9 +46242,10 @@ static s7_pointer g_setter(s7_scheme *sc, s7_pointer args) slot = lookup_slot_from(sym, sc->curlet); set_curlet(sc, old_e); } - if (!is_slot(slot)) - return(sc->F); - return((slot_has_setter(slot)) ? slot_setter(slot) : sc->F); + if ((!is_slot(slot)) || (!slot_has_setter(slot))) return(sc->F); + setter = slot_setter(slot); + if (is_bool_function(setter)) return(c_function_setter(setter)); + return(setter); }} return(s7_wrong_type_arg_error(sc, "setter", 0, p, "something that might have a setter")); } @@ -46439,7 +46299,7 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) if (is_pair(cddr(args))) { - s7_pointer e = cadr(args), old_e; /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */ + s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */ func = caddr(args); if ((e == sc->rootlet) || (e == sc->nil)) slot = global_slot(sym); @@ -46447,10 +46307,7 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) { if (!is_let(e)) return(s7_wrong_type_arg_error(sc, "set! setter", 2, e, "a let")); - old_e = sc->curlet; - set_curlet(sc, e); - slot = lookup_slot_from(sym, sc->curlet); - set_curlet(sc, old_e); + slot = lookup_slot_from(sym, e); }} else { @@ -46558,7 +46415,6 @@ s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) { slot_set_has_setter(global_slot(p)); symbol_set_has_setter(p); - slot_set_has_setter(global_slot(p)); protect_setter(sc, p, setter); slot_set_setter(global_slot(p), setter); if (s7_is_aritable(sc, setter, 3)) @@ -46600,7 +46456,7 @@ static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer new_val push_stack_direct(sc, OP_EVAL_DONE); sc->args = (has_let_arg(func)) ? list_3(sc, slot_symbol(slot), new_value, sc->curlet) : list_2(sc, slot_symbol(slot), new_value); - /* safe lists here are much slower -- the setters are called more often for some reason */ + /* safe lists here are much slower -- the setters are called more often for some reason (see tset.scm) */ sc->code = func; eval(sc, OP_APPLY); return(sc->value); @@ -46668,7 +46524,7 @@ bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) return(false); if ((a == b) && (!is_number(a))) /* if a is NaN, a == b doesn't mean (eqv? a b) */ return(true); /* a == b means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */ - if (s7_is_number(a)) + if (is_number(a)) return(numbers_are_eqv(sc, a, b)); if (is_unspecified(a)) /* types are the same so we know b is also unspecified */ return(true); @@ -46736,8 +46592,15 @@ static bool undefined_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_in return(safe_strcmp(undefined_name(x), undefined_name(y))); } -static bool s7_is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); -static bool s7_is_equivalent_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); +static bool is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + return((*(equals[type(x)]))(sc, x, y, ci)); +} + +static bool is_equivalent_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + return((*(equivalents[type(x)]))(sc, x, y, ci)); +} static bool c_pointer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) { @@ -46748,13 +46611,13 @@ static bool c_pointer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shar if (c_pointer_type(x) != c_pointer_type(y)) { if (!nci) nci = new_shared_info(sc); - if (!s7_is_equivalent_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) + if (!is_equivalent_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) return(false); } if (c_pointer_info(x) != c_pointer_info(y)) { if (!nci) nci = new_shared_info(sc); - if (!s7_is_equivalent_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) + if (!is_equivalent_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) return(false); } return(true); @@ -46769,13 +46632,13 @@ static bool c_pointer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_in if (c_pointer_type(x) != c_pointer_type(y)) { if (!nci) nci = new_shared_info(sc); - if (!s7_is_equal_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) + if (!is_equal_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) return(false); } if (c_pointer_info(x) != c_pointer_info(y)) { if (!nci) nci = new_shared_info(sc); - if (!s7_is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) + if (!is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) return(false); } return(true); @@ -46791,10 +46654,7 @@ static bool syntax_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_ return((is_syntax(y)) && (syntax_symbol(x) == syntax_symbol(y))); } -static bool port_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(x == y); -} +static bool port_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(x == y);} static bool port_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) { @@ -46891,7 +46751,7 @@ static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, share else nci = new_shared_info(sc); for (pa = to_list(sc, set_plist_1(sc, a)), pb = to_list(sc, set_plist_1(sc, b)); is_pair(pa) && (is_pair(pb)); pa = cdr(pa), pb = cdr(pb)) - if (!(s7_is_equal_1(sc, car(pa), car(pb), nci))) + if (!(is_equal_1(sc, car(pa), car(pb), nci))) return(false); return(pa == pb); /* presumably both are nil if successful */ } @@ -46948,7 +46808,7 @@ static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared len = hash_table_mask(x) + 1; lists = hash_table_elements(x); if (!nci) nci = new_shared_info(sc); - eqf = (equivalent) ? s7_is_equivalent_1 : s7_is_equal_1; + eqf = (equivalent) ? is_equivalent_1 : is_equal_1; hf = hash_table_checker(y); if ((hf != hash_equal) && (hf != hash_equivalent)) @@ -46999,15 +46859,8 @@ static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared return(true); } -static bool hash_table_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(hash_table_equal_1(sc, x, y, ci, false)); -} - -static bool hash_table_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(hash_table_equal_1(sc, x, y, ci, true)); -} +static bool hash_table_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(hash_table_equal_1(sc, x, y, ci, false));} +static bool hash_table_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(hash_table_equal_1(sc, x, y, ci, true));} static bool slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci) { @@ -47015,7 +46868,7 @@ static bool slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_ for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ - return(s7_is_equal_1(sc, slot_value(px), slot_value(py), nci)); + return(is_equal_1(sc, slot_value(px), slot_value(py), nci)); return(false); } @@ -47025,7 +46878,7 @@ static bool slots_equivalent_match(s7_scheme *sc, s7_pointer px, s7_pointer y, s for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ - return(s7_is_equivalent_1(sc, slot_value(px), slot_value(py), nci)); + return(is_equivalent_1(sc, slot_value(px), slot_value(py), nci)); return(false); } @@ -47128,8 +46981,8 @@ static bool closure_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared /* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y)) * because locally defined constant functions on the second pass find the outer let. */ - return((s7_is_equivalent_1(sc, closure_args(x), closure_args(y), ci)) && - (s7_is_equivalent_1(sc, closure_body(x), closure_body(y), ci))); + return((is_equivalent_1(sc, closure_args(x), closure_args(y), ci)) && + (is_equivalent_1(sc, closure_body(x), closure_body(y), ci))); } static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) @@ -47145,13 +46998,13 @@ static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t if (equal_ref(sc, x, y, ci)) return(true); - if (!s7_is_equal_1(sc, car(x), car(y), ci)) return(false); + if (!is_equal_1(sc, car(x), car(y), ci)) return(false); for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py)) { - if (!s7_is_equal_1(sc, car(px), car(py), ci)) return(false); + if (!is_equal_1(sc, car(px), car(py), ci)) return(false); if (equal_ref(sc, px, py, ci)) return(true); } - return((px == py) || (s7_is_equal_1(sc, px, py, ci))); + return((px == py) || (is_equal_1(sc, px, py, ci))); } static bool pair_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) @@ -47170,13 +47023,13 @@ static bool pair_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_in if (equal_ref(sc, x, y, ci)) return(true); - if (!s7_is_equivalent_1(sc, car(x), car(y), ci)) return(false); + if (!is_equivalent_1(sc, car(x), car(y), ci)) return(false); for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py)) { - if (!s7_is_equivalent_1(sc, car(px), car(py), ci)) return(false); + if (!is_equivalent_1(sc, car(px), car(py), ci)) return(false); if (equal_ref(sc, px, py, ci)) return(true); } - return((px == py) || ((s7_is_equivalent_1(sc, px, py, ci)))); + return((px == py) || ((is_equivalent_1(sc, px, py, ci)))); } static bool vector_rank_match(s7_scheme *sc, s7_pointer x, s7_pointer y) @@ -47184,13 +47037,13 @@ static bool vector_rank_match(s7_scheme *sc, s7_pointer x, s7_pointer y) s7_int x_dims; s7_int j; - if (vector_has_dimensional_info(x)) - x_dims = vector_ndims(x); - else return((!vector_has_dimensional_info(y)) || (vector_ndims(y) == 1)); + if (!vector_has_dimension_info(x)) + return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1)); + x_dims = vector_ndims(x); if (x_dims == 1) - return((!vector_has_dimensional_info(y)) || (vector_ndims(y) == 1)); + return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1)); - if ((!vector_has_dimensional_info(y)) || + if ((!vector_has_dimension_info(y)) || (x_dims != vector_ndims(y))) return(false); @@ -47258,7 +47111,7 @@ static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_ if ((is_byte_vector(x)) && (is_int_vector(y))) return(biv_meq(sc, x, y, NULL)); for (i = 0; i < len; i++) - if (!s7_is_equal_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ + if (!is_equal_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ return(false); return(true); } @@ -47271,7 +47124,7 @@ static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_ else nci = new_shared_info(sc); } for (i = 0; i < len; i++) - if (!(s7_is_equal_1(sc, vector_element(x, i), vector_element(y, i), nci))) + if (!(is_equal_1(sc, vector_element(x, i), vector_element(y, i), nci))) return(false); return(true); } @@ -47339,7 +47192,7 @@ static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ if ((is_byte_vector(x)) && (is_int_vector(y))) return(biv_meq(sc, x, y, NULL)); for (i = 0; i < len; i++) - if (!s7_is_equivalent_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ + if (!is_equivalent_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ return(false); return(true); } @@ -47375,7 +47228,7 @@ static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ else nci = new_shared_info(sc); } for (i = 0; i < len; i++) - if (!(s7_is_equivalent_1(sc, vector_element(x, i), vector_element(y, i), nci))) + if (!(is_equivalent_1(sc, vector_element(x, i), vector_element(y, i), nci))) return(false); return(true); } @@ -47476,15 +47329,8 @@ static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_i return(false); } -static bool iterator_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(iterator_equal_1(sc, x, y, ci, false)); -} - -static bool iterator_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(iterator_equal_1(sc, x, y, ci, true)); -} +static bool iterator_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, false));} +static bool iterator_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, true));} #if WITH_GMP static bool big_integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) @@ -47963,36 +47809,25 @@ static void init_equals(void) #endif } -static bool s7_is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((*(equals[type(x)]))(sc, x, y, ci)); -} - -bool s7_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(s7_is_equal_1(sc, x, y, NULL));} - -static bool s7_is_equivalent_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((*(equivalents[type(x)]))(sc, x, y, ci)); -} - -bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(s7_is_equivalent_1(sc, x, y, NULL));} +bool s7_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equals[type(x)]))(sc, x, y, NULL));} +bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equivalents[type(x)]))(sc, x, y, NULL));} static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args) { #define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2" #define Q_is_equal sc->pcl_bt - return(make_boolean(sc, s7_is_equal_1(sc, car(args), cadr(args), NULL))); + return(make_boolean(sc, is_equal_1(sc, car(args), cadr(args), NULL))); } static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args) { #define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2." #define Q_is_equivalent sc->pcl_bt - return(make_boolean(sc, s7_is_equivalent_1(sc, car(args), cadr(args), NULL))); + return(make_boolean(sc, is_equivalent_1(sc, car(args), cadr(args), NULL))); } -static s7_pointer is_equal_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((s7_is_equal_1(sc, a, b, NULL)) ? sc->T : sc->F);} -static s7_pointer is_equivalent_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((s7_is_equivalent_1(sc, a, b, NULL)) ? sc->T : sc->F);} +static s7_pointer is_equal_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equal_1(sc, a, b, NULL)) ? sc->T : sc->F);} +static s7_pointer is_equivalent_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equivalent_1(sc, a, b, NULL)) ? sc->T : sc->F);} /* ---------------------------------------- length, copy, fill ---------------------------------------- */ @@ -48116,7 +47951,7 @@ static s7_pointer string_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_po static s7_pointer string_getter(s7_scheme *sc, s7_pointer str, s7_int loc) { - return(s7_make_character(sc, (uint8_t)(string_value(str)[loc]))); /* cast needed else (copy (string (integer->char 255))...) is trouble */ + return(chars[(uint8_t)(string_value(str)[loc])]); /* cast needed else (copy (string (integer->char 255))...) is trouble */ } static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val) @@ -48134,8 +47969,7 @@ static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer obj, s7_int loc) static s7_pointer let_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val) { - /* loc is irrelevant here - * val has to be of the form (cons symbol value) + /* loc is irrelevant here, val has to be of the form (cons symbol value) * if symbol is already in e, its value is changed, otherwise a new slot is added to e */ if (is_pair(val)) @@ -48189,7 +48023,7 @@ static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer caller, s7_point s7_int gc_loc; s7_pointer new_hash; new_hash = s7_make_hash_table(sc, hash_table_mask(source) + 1); - gc_loc = s7_gc_protect_1(sc, new_hash); + gc_loc = gc_protect_1(sc, new_hash); hash_table_checker(new_hash) = hash_table_checker(source); if (hash_chosen(source)) hash_set_chosen(new_hash); hash_table_mapper(new_hash) = hash_table_mapper(source); @@ -48323,8 +48157,8 @@ static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer s mi = make_mutable_integer(sc, 0); mj = make_mutable_integer(sc, 0); - gc_loc1 = s7_gc_protect_1(sc, mi); - gc_loc2 = s7_gc_protect_1(sc, mj); + gc_loc1 = gc_protect_1(sc, mi); + gc_loc2 = gc_protect_1(sc, mj); cref = c_object_ref(sc, source); cset = c_object_set(sc, dest); @@ -48878,7 +48712,7 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) { s7_pointer *dst = vector_elements(dest); for (i = start, j = 0; i < end; i++, j++) - dst[j] = s7_make_character(sc, (uint8_t)string_value(source)[i]); + dst[j] = chars[(uint8_t)string_value(source)[i]]; return(dest); } if (is_int_vector(dest)) @@ -48934,16 +48768,14 @@ s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) {return(s7_copy_1(sc, sc->cop /* -------------------------------- reverse -------------------------------- */ -s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) +s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) /* just pairs */ { /* reverse list -- produce new list (other code assumes this function does not return the original!) */ s7_pointer x, p; if (is_null(a)) return(a); - if (!is_pair(cdr(a))) return((is_null(cdr(a))) ? list_1(sc, car(a)) : cons(sc, cdr(a), car(a))); /* don't return 'a' itself */ - sc->w = list_1(sc, car(a)); for (x = cdr(a), p = a; is_pair(x); x = cdr(x), p = cdr(p)) { @@ -48956,11 +48788,9 @@ s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) if (x == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */ break; } - if (is_not_null(x)) p = cons(sc, x, sc->w); /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */ else p = sc->w; - sc->w = sc->nil; return(p); } @@ -49066,7 +48896,7 @@ also accepts a string or vector argument." return(np); } -static s7_pointer reverse_in_place(s7_scheme *sc, s7_pointer term, s7_pointer list) +static s7_pointer any_list_reverse_in_place(s7_scheme *sc, s7_pointer term, s7_pointer list) { s7_pointer p, result; if (is_null(list)) return(term); @@ -49107,7 +48937,7 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) s7_pointer np; if (is_immutable_pair(p)) return(immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p))); - np = reverse_in_place(sc, sc->nil, p); + np = any_list_reverse_in_place(sc, sc->nil, p); if (is_null(np)) return(s7_wrong_type_arg_error(sc, "reverse!", 1, car(args), "a mutable, proper list")); return(np); @@ -49163,11 +48993,10 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) case T_INT_VECTOR: { - s7_int len; + s7_int len = vector_length(p); s7_int *s1, *s2; if (is_immutable_vector(p)) return(immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p))); - len = vector_length(p); if (len < 2) return(p); s1 = int_vector_ints(p); s2 = (s7_int *)(s1 + len - 1); @@ -49183,11 +49012,10 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) case T_FLOAT_VECTOR: { - s7_int len; + s7_int len = vector_length(p); s7_double *s1, *s2; if (is_immutable_vector(p)) return(immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p))); - len = vector_length(p); if (len < 2) return(p); s1 = float_vector_floats(p); s2 = (s7_double *)(s1 + len - 1); @@ -49203,11 +49031,10 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) case T_VECTOR: { - s7_int len; + s7_int len = vector_length(p); s7_pointer *s1, *s2; if (is_immutable_vector(p)) return(immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p))); - len = vector_length(p); if (len < 2) return(p); s1 = vector_elements(p); s2 = (s7_pointer *)(s1 + len - 1); @@ -49506,26 +49333,23 @@ static s7_pointer g_append(s7_scheme *sc, s7_pointer args) #define H_append "(append ...) returns its argument sequences appended into one sequence" #define Q_append s7_make_circular_signature(sc, 0, 1, sc->T) - s7_pointer a1; if (is_null(args)) return(sc->nil); /* (append) -> () */ - a1 = car(args); /* first arg determines result type unless all args but last are empty (sigh) */ - if (is_null(cdr(args))) return(a1); /* (append <anything>) -> <anything> */ - - sc->value = args; /* does this protect it? maybe gc_protect_via_stack */ - args = copy_proper_list(sc, args); /* copied to protect against possible method below which might change it? */ + if (is_null(cdr(args))) return(car(args)); /* (append <anything>) -> <anything> */ + sc->value = args; + args = copy_proper_list(sc, args); /* copied since other args might invoke methods */ sc->value = args; - switch (type(a1)) /* from old args -- more GC protection? */ + switch (type(car(args))) { case T_NIL: case T_PAIR: return(g_list_append(sc, args)); case T_STRING: return(g_string_append_1(sc, args, sc->append_symbol)); case T_HASH_TABLE: return(hash_table_append(sc, args)); case T_LET: return(let_append(sc, args)); case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return(vector_append(sc, args, type(a1), sc->append_symbol)); + return(vector_append(sc, args, type(car(args)), sc->append_symbol)); default: - check_method(sc, a1, sc->append_symbol, args); + check_method(sc, car(args), sc->append_symbol, args); } - return(wrong_type_argument_with_type(sc, sc->append_symbol, 1, a1, a_sequence_string)); /* (append 1 0) */ + return(wrong_type_argument_with_type(sc, sc->append_symbol, 1, car(args), a_sequence_string)); /* (append 1 0) */ } static s7_pointer append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(g_append(sc, set_plist_3(sc, p1, p2, p3)));} @@ -49673,7 +49497,7 @@ static s7_pointer c_obj_to_list(s7_scheme *sc, s7_pointer obj) /* "c_object_to_l result = make_list(sc, len, sc->nil); sc->temp8 = result; z = list_2_unchecked(sc, obj, zc = make_mutable_integer(sc, 0)); - gc_z = s7_gc_protect_1(sc, z); + gc_z = gc_protect_1(sc, z); set_car(sc->z2_1, sc->x); set_car(sc->z2_2, sc->z); for (i = 0, x = result; i < len; i++, x = cdr(x)) @@ -49693,7 +49517,7 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) /* used only in format_to_port_1 and (map values ...) */ switch (type(obj)) { - case T_STRING: return(s7_string_to_list(sc, string_value(obj), string_length(obj))); + case T_STRING: return(string_to_list(sc, string_value(obj), string_length(obj))); case T_BYTE_VECTOR: return(byte_vector_to_list(sc, byte_vector_bytes(obj), byte_vector_length(obj))); case T_HASH_TABLE: return(hash_table_to_list(sc, obj)); case T_ITERATOR: return(iterator_to_list(sc, obj)); @@ -49718,7 +49542,7 @@ static s7_pointer symbol_to_let(s7_scheme *sc, s7_pointer obj) { s7_pointer val; s7_int gc_loc; - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); if (!sc->current_value_symbol) sc->current_value_symbol = make_symbol(sc, "current-value"); val = s7_symbol_value(sc, obj); @@ -49766,7 +49590,7 @@ static s7_pointer vector_to_let(s7_scheme *sc, s7_pointer obj) sc->size_symbol, s7_length(sc, obj), sc->dimensions_symbol, g_vector_dimensions(sc, set_plist_1(sc, obj)), sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_vector(obj))); - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); if (is_subvector(obj)) { s7_int pos = 0; @@ -49802,7 +49626,7 @@ static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj) sc->entries_symbol, make_integer(sc, hash_table_entries(obj)), sc->locked_symbol, s7_make_boolean(sc, hash_table_checker_locked(obj)), sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); if (is_weak_hash_table(obj)) s7_varlet(sc, let, sc->weak_symbol, sc->T); if ((hash_table_checker(obj) == hash_eq) || @@ -49861,7 +49685,7 @@ static s7_pointer iterator_to_let(s7_scheme *sc, s7_pointer obj) sc->type_symbol, sc->is_iterator_symbol, sc->at_end_symbol, s7_make_boolean(sc, iterator_is_at_end(obj)), sc->sequence_symbol, iterator_sequence(obj)); - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); if (is_pair(seq)) s7_varlet(sc, let, sc->size_symbol, s7_length(sc, seq)); else @@ -49900,7 +49724,7 @@ static s7_pointer let_to_let(s7_scheme *sc, s7_pointer obj) sc->open_symbol, s7_make_boolean(sc, has_methods(obj)), sc->outlet_symbol, (obj == sc->rootlet) ? sc->nil : let_outlet(obj), sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); if (obj == sc->rootlet) s7_varlet(sc, let, sc->alias_symbol, sc->rootlet_symbol); else @@ -49968,7 +49792,7 @@ static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer obj) sc->c_object_type_symbol, make_integer(sc, c_object_type(obj)), sc->c_object_let_symbol, clet, sc->class_symbol, c_object_type_to_let(sc, obj)); - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); /* not sure these are useful */ if (c_object_len(sc, obj)) /* c_object_length is the object length, not the procedure */ s7_varlet(sc, let, sc->c_object_length_symbol, s7_lambda(sc, c_object_len(sc, obj), 1, 0, false)); @@ -50016,7 +49840,7 @@ static s7_pointer port_to_let(s7_scheme *sc, s7_pointer obj) /* note the underba sc->port_type_symbol, (is_string_port(obj)) ? sc->string_symbol : ((is_file_port(obj)) ? sc->file_symbol : sc->function_symbol), sc->closed_symbol, s7_make_boolean(sc, port_is_closed(obj)), sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_port(obj))); - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); if (is_file_port(obj)) { s7_varlet(sc, let, sc->file_symbol, g_port_filename(sc, set_plist_1(sc, obj))); @@ -50072,7 +49896,7 @@ static s7_pointer closure_to_let(s7_scheme *sc, s7_pointer obj) sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, sc->arity_symbol, s7_arity(sc, obj), sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); sig = s7_signature(sc, obj); if (is_pair(sig)) @@ -50129,7 +49953,7 @@ static s7_pointer c_function_to_let(s7_scheme *sc, s7_pointer obj) sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, sc->arity_symbol, s7_arity(sc, obj), sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - gc_loc = s7_gc_protect_1(sc, let); + gc_loc = gc_protect_1(sc, let); sig = c_function_signature(obj); if (is_pair(sig)) s7_varlet(sc, let, sc->local_signature_symbol, sig); @@ -50863,9 +50687,7 @@ static void swap_stack(s7_scheme *sc, opcode_t new_op, s7_pointer new_code, s7_p e = sc->stack_end[1]; args = sc->stack_end[2]; op = (opcode_t)(sc->stack_end[3]); /* this should be begin1 */ -#if S7_DEBUGGING - if ((op != OP_BEGIN_NO_HOOK) && (op != OP_BEGIN_HOOK)) fprintf(stderr, "swap %s\n", op_names[op]); -#endif + if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK) && (op != OP_BEGIN_HOOK)) fprintf(stderr, "swap %s\n", op_names[op]); push_stack(sc, new_op, new_args, new_code); sc->stack_end[0] = code; sc->stack_end[1] = e; @@ -51031,10 +50853,8 @@ static s7_pointer make_profile_info(s7_scheme *sc) /* -------------------------------- dynamic-unwind -------------------------------- */ static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer e) { -#if S7_DEBUGGING - if (is_multiple_value(sc->value)) + if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "%s[%d]: unexpected multiple-value! %s %s %s\n", __func__, __LINE__, display(func), display(e), display(sc->value)); -#endif return(s7_apply_function(sc, func, set_plist_2(sc, e, sc->value))); /* s7_apply_function returns sc->value */ } @@ -51106,7 +50926,7 @@ s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7 catch_goto_loc(p) = current_stack_top(sc); catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack); catch_set_handler(p, error_handler); - if (!sc->longjmp_ok) + if (!sc->longjmp_ok) { declare_jump_info(); TRACK(sc); @@ -51243,7 +51063,7 @@ It has the additional local variables: error-type, error-data, error-code, error #endif e = let_copy(sc, sc->owlet); - gc_loc = s7_gc_protect_1(sc, e); + gc_loc = gc_protect_1(sc, e); /* make sure the pairs/reals/strings/integers are copied: should be error-data, error-code, and error-history */ sc->gc_off = true; @@ -51617,20 +51437,23 @@ It looks for an existing catch with a matching tag, and jumps to it if found. O static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) /* len = max size of output string (for vsnprintf) */ { - if (sc->error_port != sc->F) + if ((sc->error_port != sc->F) && (!sc->muffle_warnings)) { + int bytes; va_list ap; - s7_pointer warning; + block_t *b; char *str; - warning = make_empty_string(sc, len, 0); - string_value(warning)[0] = '\0'; - str = (char *)string_value(warning); + b = mallocate(sc, len); + str = (char *)block_data(b); + str[0] = '\0'; va_start(ap, ctrl); - vsnprintf(str, len, ctrl, ap); + bytes = vsnprintf(str, len, ctrl, ap); va_end(ap); if (port_is_closed(sc->error_port)) sc->error_port = sc->standard_error; - s7_display(sc, warning, sc->error_port); + if ((bytes > 0) && (sc->error_port != sc->F)) + port_write_string(sc->error_port)(sc, str, bytes, sc->error_port); + liberate(sc, b); } } @@ -51750,9 +51573,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) if ((catcher) && (catcher(sc, i, type, info, &reset_error_hook))) { -#if S7_DEBUGGING - if (!sc->longjmp_ok) fprintf(stderr, "s7_error jump not available?\n"); -#endif + if ((S7_DEBUGGING) && (!sc->longjmp_ok)) fprintf(stderr, "s7_error jump not available?\n"); LongJmp(sc->goto_start, CATCH_JUMP); }}} /* error not caught */ @@ -51868,7 +51689,7 @@ s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) set_plist_3(sc, s7_make_string_wrapper(sc, call_name), s7_make_string_wrapper(sc, sc->s7_call_file), - make_integer(sc, sc->s7_call_line)), + wrap_integer1(sc, sc->s7_call_line)), false, 13); }} s7_newline(sc, sc->error_port); @@ -51978,7 +51799,7 @@ static s7_pointer read_error_1(s7_scheme *sc, const char *errmsg, bool string_er len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 64; p = make_empty_string(sc, len, '\0'); msg = string_value(p); - nlen = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" print_s7_int "]", + nlen = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]", errmsg, (recent_input) ? recent_input : "", port_filename(pt), port_line_number(pt), sc->current_file, sc->current_line); } @@ -51989,7 +51810,7 @@ static s7_pointer read_error_1(s7_scheme *sc, const char *errmsg, bool string_er msg = string_value(p); if ((sc->current_file) && (sc->current_line >= 0)) - nlen = snprintf(msg, len, "%s: %s, last top-level form at %s[%" print_s7_int "]", + nlen = snprintf(msg, len, "%s: %s, last top-level form at %s[%" ld64 "]", errmsg, (recent_input) ? recent_input : "", sc->current_file, sc->current_line); else nlen = snprintf(msg, len, "%s: %s", errmsg, (recent_input) ? recent_input : ""); @@ -52008,10 +51829,10 @@ static s7_pointer read_error_1(s7_scheme *sc, const char *errmsg, bool string_er p = make_empty_string(sc, len, '\0'); msg = string_value(p); if (string_error) - nlen = snprintf(msg, len, "%s %s[%u],\n; possible culprit: \"%s...\"\n; last top-level form at %s[%" print_s7_int "]", + nlen = snprintf(msg, len, "%s %s[%u],\n; possible culprit: \"%s...\"\n; last top-level form at %s[%" ld64 "]", errmsg, port_filename(pt), port_line_number(pt), sc->strbuf, sc->current_file, sc->current_line); - else nlen = snprintf(msg, len, "%s %s[%u], last top-level form at %s[%" print_s7_int "]", + else nlen = snprintf(msg, len, "%s %s[%u], last top-level form at %s[%" ld64 "]", errmsg, port_filename(pt), port_line_number(pt), sc->current_file, sc->current_line); string_length(p) = nlen; @@ -52170,12 +51991,12 @@ static s7_pointer missing_close_paren_error(s7_scheme *sc) msg = string_value(p); if (syntax_msg) { - nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" print_s7_int "]\n%s", + nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]\n%s", port_filename(pt), port_line_number(pt), sc->current_file, sc->current_line, syntax_msg); free(syntax_msg); } - else nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" print_s7_int "]", + else nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]", port_filename(pt), port_line_number(pt), sc->current_file, sc->current_line); string_length(p) = nlen; @@ -52393,7 +52214,6 @@ s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args) if (is_c_function(fnc)) return(c_function_call(fnc)(sc, args)); /* if [if (!is_applicable(fnc)) apply_error(sc, fnc, sc->args);] here, needs_copied_args can be T_App */ - push_stack_direct(sc, OP_EVAL_DONE); sc->code = fnc; sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; @@ -52656,9 +52476,9 @@ s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e) if (sc->safety > NO_SAFETY) { if (!s7_is_valid(sc, code)) - s7_warn(sc, 256, "bad code arg to %s: %p\n", __func__, code); + s7_warn(sc, 256, "bad code argument to %s: %p\n", __func__, code); if (!s7_is_valid(sc, e)) - s7_warn(sc, 256, "bad environment arg to %s: %p\n", __func__, e); + s7_warn(sc, 256, "bad environment argument to %s: %p\n", __func__, e); } store_jump_info(sc); @@ -52730,10 +52550,7 @@ s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args) declare_jump_info(); TRACK(sc); set_current_code(sc, history_cons(sc, func, args)); - -#if SHOW_EVAL_OPS - safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display(func), display_80(args))); -#endif + if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display(func), display_80(args))); if (is_c_function(func)) return(c_function_call(func)(sc, args)); /* no check for wrong-number-of-args -- is that reasonable? */ @@ -52902,7 +52719,7 @@ static s7_pointer g_exit(s7_scheme *sc, s7_pointer args) s7_quit(sc); if (show_gc_stats(sc)) - s7_warn(sc, 256, "gc calls %" print_s7_int " total time: %f\n", sc->gc_calls, (double)(sc->gc_total_time) / ticks_per_second()); + s7_warn(sc, 256, "gc calls %" ld64 " total time: %f\n", sc->gc_calls, (double)(sc->gc_total_time) / ticks_per_second()); return(g_emergency_exit(sc, args)); } @@ -53066,6 +52883,7 @@ static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_ static s7_pointer fx_c_o_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, o_lookup(sc, cadr(arg), arg)));} static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg)));} static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg)));} +static s7_pointer fx_c_v_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, v_lookup(sc, cadr(arg), arg)));} #define fx_car_any(Name, Lookup) \ @@ -53144,9 +52962,7 @@ fx_add_s1_any(fx_add_V1, V_lookup) static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, s7_int y) { -#if S7_DEBUGGING - if (is_t_integer(val)) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, display(val)); -#endif + if ((S7_DEBUGGING) && (is_t_integer(val))) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, display(val)); switch (type(val)) { case T_REAL: return(make_boolean(sc, real(val) == y)); @@ -53163,6 +52979,14 @@ static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, return(sc->T); } +static s7_pointer fx_num_eq_s0f(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val; + val = lookup(sc, cadr(arg)); + if (is_t_real(val)) return(make_boolean(sc, real(val) == 0.0)); + return(make_boolean(sc, num_eq_b_7pp(sc, val, real_zero))); +} + #define fx_num_eq_si_any(Name, Lookup) \ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ { \ @@ -53325,10 +53149,10 @@ static s7_pointer fx_subtract_fs(s7_scheme *sc, s7_pointer arg) case T_INTEGER: return(make_real(sc, n - integer(x))); case T_RATIO: return(make_real(sc, n - fraction(x))); case T_REAL: return(make_real(sc, n - real(x))); - case T_COMPLEX: return(s7_make_complex(sc, n - real_part(x), -imag_part(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); #if WITH_GMP case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, wrap_real1(sc, n), x)); + return(subtract_p_pp(sc, cadr(arg), x)); #endif default: return(method_or_bust_with_type_pp(sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string, 2)); @@ -53479,20 +53303,23 @@ static s7_pointer fx_is_symbol_car_t(s7_scheme *sc, s7_pointer arg) return(make_boolean(sc, (is_pair(val)) ? is_symbol(car(val)) : is_symbol(g_car(sc, set_plist_1(sc, val))))); } -#if WITH_GMP static s7_pointer fx_floor_sqrt_s(s7_scheme *sc, s7_pointer arg) { s7_pointer p; p = lookup(sc, opt2_sym(cdr(arg))); +#if WITH_GMP if ((is_t_big_integer(p)) && (mpz_cmp_ui(big_integer(p), 0) >= 0)) /* p >= 0 */ { mpz_sqrt(sc->mpz_1, big_integer(p)); return(mpz_to_integer(sc, sc->mpz_1)); } +#else + if (!is_negative_b_7p(sc, p)) + return(make_integer(sc, (s7_int)floor(sqrt(s7_number_to_real_with_caller(sc, p, "sqrt"))))); +#endif return(floor_p_p(sc, sqrt_p_p(sc, p))); } -#endif static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer arg) @@ -53500,15 +53327,10 @@ static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer arg) s7_pointer p1; p1 = u_lookup(sc, cadr(arg), arg); if (is_t_integer(p1)) return(make_boolean(sc, integer(p1) > 0)); - return((is_t_real(p1)) ? make_boolean(sc, real(p1) > 0.0) : is_positive_p_p(sc, p1)); + return(make_boolean(sc, is_positive_b_7p(sc, p1))); } -static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1; - p1 = u_lookup(sc, cadr(arg), arg); - return((is_t_integer(p1)) ? make_boolean(sc, integer(p1) == 0) : is_zero_p_p(sc, p1)); -} +static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_zero_b_7p(sc, u_lookup(sc, cadr(arg), arg))));} #define fx_real_part_s_any(Name, Lookup) \ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ @@ -53530,7 +53352,7 @@ fx_real_part_s_any(fx_real_part_t, t_lookup) } fx_imag_part_s_any(fx_imag_part_s, s_lookup) -fx_imag_part_s_any(fx_imag_part_t, t_lookup) +fx_imag_part_s_any(fx_imag_part_t, t_lookup) /* not used in current timing tests */ #define fx_iterate_s_any(Name, Lookup) \ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ @@ -53650,15 +53472,18 @@ static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer arg) {return((is_t_i static s7_pointer fx_is_string_s(s7_scheme *sc, s7_pointer arg) {return((is_string(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} static s7_pointer fx_is_string_t(s7_scheme *sc, s7_pointer arg) {return((is_string(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} static s7_pointer fx_is_procedure_s(s7_scheme *sc, s7_pointer arg) {return((is_procedure(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} +static s7_pointer fx_is_procedure_t(s7_scheme *sc, s7_pointer arg) {return((is_procedure(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} static s7_pointer fx_is_pair_s(s7_scheme *sc, s7_pointer arg) {return((is_pair(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} static s7_pointer fx_is_pair_t(s7_scheme *sc, s7_pointer arg) {return((is_pair(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} static s7_pointer fx_is_pair_u(s7_scheme *sc, s7_pointer arg) {return((is_pair(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} +static s7_pointer fx_is_pair_v(s7_scheme *sc, s7_pointer arg) {return((is_pair(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} static s7_pointer fx_is_keyword_s(s7_scheme *sc, s7_pointer arg) {return((is_keyword(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} static s7_pointer fx_is_vector_s(s7_scheme *sc, s7_pointer arg) {return((is_any_vector(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} static s7_pointer fx_is_vector_t(s7_scheme *sc, s7_pointer arg) {return((is_any_vector(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} static s7_pointer fx_is_proper_list_s(s7_scheme *sc, s7_pointer arg) {return((s7_is_proper_list(sc, lookup(sc, cadr(arg)))) ? sc->T : sc->F);} static s7_pointer fx_not_s(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, lookup(sc, cadr(arg)))));} static s7_pointer fx_not_t(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, t_lookup(sc, cadr(arg), arg))));} +static s7_pointer fx_not_o(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, o_lookup(sc, cadr(arg), arg))));} static s7_pointer fx_not_is_pair_s(s7_scheme *sc, s7_pointer arg) {return((is_pair(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);} static s7_pointer fx_not_is_pair_t(s7_scheme *sc, s7_pointer arg) {return((is_pair(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} static s7_pointer fx_not_is_pair_u(s7_scheme *sc, s7_pointer arg) {return((is_pair(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} @@ -53799,7 +53624,10 @@ static inline s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x) { s7_int val; if (multiply_overflow(integer(x), integer(x), &val)) - return(make_real(sc, (long_double)integer(x) * (long_double)integer(x))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer sqr overflow: (* %" ld64 " %" ld64 ")\n", integer(x), integer(x)); + return(make_real(sc, (long_double)integer(x) * (long_double)integer(x))); + } return(make_integer(sc, val)); } case T_RATIO: @@ -53812,7 +53640,7 @@ static inline s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x) } #else case T_INTEGER: return(make_integer(sc, integer(x) * integer(x))); - case T_RATIO: return(s7_make_ratio(sc, numerator(x) * numerator(x), denominator(x) * denominator(x))); + case T_RATIO: return(make_ratio(sc, numerator(x) * numerator(x), denominator(x) * denominator(x))); #endif case T_REAL: return(make_real(sc, real(x) * real(x))); case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x))); @@ -54305,7 +54133,7 @@ static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) return(wrong_type_argument(sc, sc->car_symbol, 1, val, T_PAIR)); } -static s7_pointer fx_c_weak1_type_s(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_eq_weak1_type_s(s7_scheme *sc, s7_pointer arg) { s7_pointer val; val = lookup(sc, opt2_sym(cdr(arg))); @@ -54382,7 +54210,7 @@ static s7_pointer fx_is_zero_remainder_car(s7_scheme *sc, s7_pointer arg) t = t_lookup(sc, opt1_sym(cdr(arg)), arg); if ((is_t_integer(u)) && (is_t_integer(t))) return(make_boolean(sc, remainder_i_7ii(sc, integer(u), integer(t)) == 0)); - return(is_zero_p_p(sc, remainder_p_pp(sc, u, t))); + return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, u, t)))); } static s7_pointer fx_is_zero_remainder_o(s7_scheme *sc, s7_pointer arg) @@ -54392,7 +54220,7 @@ static s7_pointer fx_is_zero_remainder_o(s7_scheme *sc, s7_pointer arg) t = t_lookup(sc, opt1_sym(cdr(arg)), arg); if ((is_t_integer(s)) && (is_t_integer(t))) return(make_boolean(sc, remainder_i_7ii(sc, integer(s), integer(t)) == 0)); - return(is_zero_p_p(sc, remainder_p_pp(sc, s, t))); + return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, s, t)))); } #define fx_c_opscq_any(Name, Lookup) \ @@ -54476,7 +54304,10 @@ static s7_pointer fx_add_mul_opssq_s(s7_scheme *sc, s7_pointer arg) s7_int val; if ((multiply_overflow(integer(a), integer(b), &val)) || (add_overflow(val, integer(c), &val))) - return(make_real(sc, ((long_double)integer(a) * (long_double)integer(b)) + (long_double)integer(c))); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply/add overflow: (+ (* %" ld64 " %" ld64 ") %" ld64 ")\n", integer(a), integer(b), integer(c)); + return(make_real(sc, ((long_double)integer(a) * (long_double)integer(b)) + (long_double)integer(c))); + } return(make_integer(sc, val)); } #else @@ -54923,6 +54754,7 @@ fx_c_s_opsq_direct_any(fx_c_u_opvq_direct, u_lookup, v_lookup) } fx_c_s_car_s_any(fx_c_s_car_s, s_lookup, s_lookup) +fx_c_s_car_s_any(fx_c_s_car_t, s_lookup, t_lookup) fx_c_s_car_s_any(fx_c_t_car_u, t_lookup, u_lookup) fx_c_s_car_s_any(fx_c_t_car_v, t_lookup, v_lookup) @@ -55341,6 +55173,8 @@ static s7_pointer fx_c_ac(s7_scheme *sc, s7_pointer arg) return(fn_proc(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_ac_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), opt3_con(arg)));} + static s7_pointer fx_is_eq_ac(s7_scheme *sc, s7_pointer arg) { s7_pointer x, y = opt3_con(arg); @@ -55641,6 +55475,27 @@ static s7_pointer fx_c_ns(s7_scheme *sc, s7_pointer arg) return(p); } +static s7_pointer fx_list_ns(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p, args, lst; + lst = make_list(sc, integer(opt3_arglen(cdr(arg))), sc->nil); + for (args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p)) + set_car(p, lookup(sc, car(args))); + return(lst); +} + +static s7_pointer fx_vector_ns(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer args, vec; + s7_int i; + s7_pointer *els; + vec = make_simple_vector(sc, integer(opt3_arglen(cdr(arg)))); + els = (s7_pointer *)vector_elements(vec); + for (args = cdr(arg), i = 0; is_pair(args); args = cdr(args), i++) + els[i] = lookup(sc, car(args)); + return(vec); +} + static s7_pointer fx_c_all_ca(s7_scheme *sc, s7_pointer code) { s7_pointer args, p, lst; @@ -56349,6 +56204,10 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf /* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */ return(fx_c_ss); + case HOP_SAFE_C_NS: + if (fn_proc(arg) == g_list) return(fx_list_ns); + return((fn_proc(arg) == g_vector) ? fx_vector_ns : fx_c_ns); + case HOP_SAFE_C_opSq_S: if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && (is_global_and_has_func(caadr(arg), s7_p_p_function))) @@ -56402,28 +56261,29 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf { s7_pointer s2 = caddr(arg); if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) return(fx_c_s_sqr); + + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(car(s2), s7_p_pp_function))) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(s2))))); + set_opt3_pair(arg, cdr(s2)); + if (car(s2) == sc->vector_ref_symbol) + { + if (car(arg) == sc->add_symbol) return(fx_add_s_vref); + if (car(arg) == sc->subtract_symbol) return(fx_subtract_s_vref); + if (car(arg) == sc->multiply_symbol) return(fx_multiply_s_vref); + if (car(arg) == sc->geq_symbol) return(fx_geq_s_vref); + if (car(arg) == sc->is_eq_symbol) return(fx_is_eq_s_vref); + if (car(arg) == sc->hash_table_ref_symbol) return(fx_href_s_vref); + if (car(arg) == sc->let_ref_symbol) return(fx_lref_s_vref); + if ((is_global(cadr(arg))) && (is_global(cadr(s2))) && (car(arg) == sc->vector_ref_symbol)) return(fx_vref_g_vref_gs); + } + if ((car(arg) == sc->vector_ref_symbol) && (car(s2) == sc->add_symbol)) return(fx_vref_s_add); + return(fx_c_s_opssq_direct); + } + return(fx_c_s_opssq); } - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caaddr(arg), s7_p_pp_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caaddr(arg))))); - set_opt3_pair(arg, cdaddr(arg)); - if (caaddr(arg) == sc->vector_ref_symbol) - { - if (car(arg) == sc->add_symbol) return(fx_add_s_vref); - if (car(arg) == sc->subtract_symbol) return(fx_subtract_s_vref); - if (car(arg) == sc->multiply_symbol) return(fx_multiply_s_vref); - if (car(arg) == sc->geq_symbol) return(fx_geq_s_vref); - if (car(arg) == sc->is_eq_symbol) return(fx_is_eq_s_vref); - if (car(arg) == sc->hash_table_ref_symbol) return(fx_href_s_vref); - if (car(arg) == sc->let_ref_symbol) return(fx_lref_s_vref); - if ((is_global(cadr(arg))) && (is_global(cadaddr(arg))) && (car(arg) == sc->vector_ref_symbol)) return(fx_vref_g_vref_gs); - } - if ((car(arg) == sc->vector_ref_symbol) && (caaddr(arg) == sc->add_symbol)) return(fx_vref_s_add); - return(fx_c_s_opssq_direct); - } - return(fx_c_s_opssq); case HOP_SAFE_C_opSSq_S: if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && @@ -56504,10 +56364,8 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if (caadr(arg) == sc->is_symbol_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_symbol_s);} return(fx_not_opsq); } -#if WITH_GMP if ((fx_matches(car(arg), sc->floor_symbol)) && (caadr(arg) == sc->sqrt_symbol)) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_floor_sqrt_s);} -#endif } if (is_unchanged_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ { /* other possibility: fx_c_a */ @@ -56517,7 +56375,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf set_opt2_sym(cdr(arg), cadadr(arg)); set_opt3_byte(cdr(arg), typ); if (fn_proc(cadr(arg)) == (s7_function)g_c_pointer_weak1) - return(fx_c_weak1_type_s); + return(fx_eq_weak1_type_s); return(fx_matches(caadr(arg), sc->car_symbol) ? fx_is_type_car_s : fx_is_type_opsq); }} /* this should follow the is_type* check above */ @@ -56551,12 +56409,12 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if (is_t_real(caddr(arg))) return(fx_multiply_sf); if (is_t_integer(caddr(arg))) return(fx_multiply_si); } - if ((car(arg) == sc->num_eq_symbol) && (is_t_integer(caddr(arg)))) return((integer(caddr(arg)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); if ((fn_proc(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2); if ((fn_proc(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc); if ((is_t_integer(caddr(arg))) && (s7_p_pi_function(global_value(car(arg))))) { + if (car(arg) == sc->num_eq_symbol) return((integer(caddr(arg)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); if (car(arg) == sc->lt_symbol) return(fx_lt_si); if (car(arg) == sc->leq_symbol) return(fx_leq_si); if (car(arg) == sc->gt_symbol) return(fx_gt_si); @@ -56564,6 +56422,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg))))); return(fx_c_si_direct); } + if ((is_t_real(caddr(arg))) && (real(caddr(arg)) == 0.0) && (car(arg) == sc->num_eq_symbol)) return(fx_num_eq_s0f); if ((s7_p_pp_function(global_value(car(arg)))) && (fn_proc(arg) != g_divide_by_2)) { if (car(arg) == sc->memq_symbol) @@ -56798,7 +56657,26 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf case HOP_SAFE_C_AC: if (fn_proc(arg) == g_cons) return(fx_cons_ac); - return((fx_matches(car(arg), sc->is_eq_symbol)) ? fx_is_eq_ac : fx_c_ac); + if (fx_matches(car(arg), sc->is_eq_symbol)) return(fx_is_eq_ac); + if (is_global_and_has_func(car(arg), s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + if ((opt3_direct(cdr(arg)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0)) + set_opt3_direct(cdr(arg), string_ref_p_p0); + if (opt3_direct(cdr(arg)) == (s7_pointer)memq_p_pp) + { + if (fn_proc(arg) == g_memq_2) + set_opt3_direct(cdr(arg), (s7_pointer)memq_2_p_pp); + else + if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) + set_opt3_direct(cdr(arg), memq_3_p_pp); + else + if (fn_proc(arg) == g_memq_4) + set_opt3_direct(cdr(arg), memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ + } + return(fx_c_ac_direct); + } + return(fx_c_ac); case HOP_SAFE_C_CA: return((fn_proc(arg) == g_cons) ? fx_cons_ca : fx_c_ca); @@ -56913,10 +56791,12 @@ static bool with_fx(s7_pointer p, s7_function f) return(true); } +static bool o_var_ok(s7_pointer p, s7_pointer var1, s7_pointer var2, s7_pointer var3) {return((p != var1) && (p != var2) && (p != var3));} + static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars) { s7_pointer p = car(tree); - /* fprintf(stderr, "[%d] %s %s %s %s\n", __LINE__, display(tree), display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : ""); */ + /* if (fx_proc(tree) == fx_iterate_o) fprintf(stderr, "[%d] %s %s %s %s\n", __LINE__, display(p), display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : ""); */ /* fprintf(stderr, "%s[%d] %s %s %d: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", has_fx(tree), display(tree)); */ if (is_symbol(p)) { @@ -56948,7 +56828,10 @@ static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_poin if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_U1)); } else - if ((cadr(p) == var3) && (fx_proc(tree) == fx_add_s1)) return(with_fx(tree, fx_add_V1)); + if (cadr(p) == var3) + { + if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_V1)); + } else if (is_pair(cddr(p))) { @@ -56976,15 +56859,13 @@ static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_poin } static s7_b_7p_t s7_b_7p_function(s7_pointer f); -static bool o_var_ok(s7_pointer p, s7_pointer var1, s7_pointer var2, s7_pointer var3) {return((p != var1) && (p != var2) && (p != var3));} static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars) { - /* extending this to a third variable did not get many hits */ s7_pointer p = car(tree); #if 0 /* if ((s7_tree_memq(sc, var1, car(tree))) || ((var2) && (s7_tree_memq(sc, var2, car(tree)))) || ((var3) && (s7_tree_memq(sc, var3, car(tree))))) */ - if (fx_proc(tree) == fx_c_opssq_s_direct) + if (fx_proc(tree) == fx_c_s_opssq_direct) fprintf(stderr, "fx_tree_in %s %s %s %s: %s\n", op_names[optimize_op(car(tree))], display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", display_80(car(tree))); #endif @@ -57000,9 +56881,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point } return(false); } -#if S7_DEBUGGING - if (!has_fx(tree)) fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display_80(p)); -#endif + if ((S7_DEBUGGING) && (!has_fx(tree))) fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, display_80(p)); if ((!is_pair(p)) || (is_fx_treed(tree))) return(false); set_fx_treed(tree); switch (optimize_op(p)) @@ -57024,6 +56903,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (fx_proc(tree) == fx_is_string_s) return(with_fx(tree, fx_is_string_t)); if (fx_proc(tree) == fx_is_vector_s) return(with_fx(tree, fx_is_vector_t)); if (fx_proc(tree) == fx_is_integer_s) return(with_fx(tree, fx_is_integer_t)); + if (fx_proc(tree) == fx_is_procedure_s) return(with_fx(tree, fx_is_procedure_t)); if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_t)); if (fx_proc(tree) == fx_length_s) return(with_fx(tree, fx_length_t)); if (fx_proc(tree) == fx_real_part_s) return(with_fx(tree, fx_real_part_t)); @@ -57061,21 +56941,24 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point } if (cadr(p) == var3) { - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_v)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_v)); - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_v)); + if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_v)); + if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_v)); + if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_v)); + if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_v)); + if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_v_direct)); return(false); } if (!more_vars) { - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_o)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_o)); - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_o)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_o)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_o)); - if (fx_proc(tree) == fx_iterate_s) return(with_fx(tree, fx_iterate_o)); + if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_o)); + if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_o)); + if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_o)); + if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_o)); + if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_o)); + if (fx_proc(tree) == fx_iterate_s) return(with_fx(tree, fx_iterate_o)); + if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_o)); if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_o_direct)); - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_o)); + if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_o)); } break; @@ -57136,7 +57019,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_u1)); return(false); } - if (cadr(p) == var3) + if (cadr(p) == var3) { if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_v0)); if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_vi)); @@ -57183,7 +57066,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (fx_proc(tree) == fx_memq_ss) return(with_fx(tree, fx_memq_tu)); } if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_ts)); - if (fx_proc(tree) == fx_num_eq_ss) + if (fx_proc(tree) == fx_num_eq_ss) { if (is_global(caddr(p))) return(with_fx(tree, fx_num_eq_tg)); if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_num_eq_to)); @@ -57197,7 +57080,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_ts)); if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_ts)); if (fx_proc(tree) == fx_lt_sg) return(with_fx(tree, fx_lt_tg)); - if (fx_proc(tree) == fx_gt_ss) + if (fx_proc(tree) == fx_gt_ss) { if (is_global(caddr(p))) return(with_fx(tree, fx_gt_tg)); if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_gt_to)); @@ -57210,7 +57093,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if ((!more_vars) && (caddr(p) != var3) && (caddr(p) != var1)) return(with_fx(tree, fx_is_eq_to)); return(with_fx(tree, fx_is_eq_ts)); } - if (fx_proc(tree) == fx_vref_ss) + if (fx_proc(tree) == fx_vref_ss) { if (caddr(p) == var2) return(with_fx(tree, fx_vref_tu)); return(with_fx(tree, fx_vref_ts)); @@ -57221,7 +57104,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (fx_proc(tree) == fx_c_ss_direct) {return(with_fx(tree, (is_global(cadr(p))) ? fx_c_gt_direct : fx_c_st_direct));} if (fx_proc(tree) == fx_hash_table_ref_ss) return(with_fx(tree, fx_hash_table_ref_st)); if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_st)); - if (fx_proc(tree) == fx_vref_ss) + if (fx_proc(tree) == fx_vref_ss) { if (is_global(cadr(p))) return(with_fx(tree, fx_vref_gt)); if ((!more_vars) && (cadr(p) != var2) && (cadr(p) != var3)) return(with_fx(tree, fx_vref_ot)); @@ -57229,7 +57112,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point } if ((fx_proc(tree) == fx_gt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_gt_ut)); if ((fx_proc(tree) == fx_lt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_lt_ut)); - if ((fx_proc(tree) == fx_geq_ss)) + if ((fx_proc(tree) == fx_geq_ss)) { if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_ot)); return(with_fx(tree, fx_geq_st)); @@ -57293,7 +57176,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point case HOP_SAFE_C_SSS: if ((cadr(p) == var1) && ((caddr(p) == var2) && ((fx_proc(tree) == fx_c_sss) || (fx_proc(tree) == fx_c_sss_direct)))) return(with_fx(tree, (cadddr(p) == var3) ? fx_c_tuv : fx_c_tus)); - if (caddr(p) == var1) + if (caddr(p) == var1) { if (car(p) == sc->vector_set_symbol) { @@ -57364,9 +57247,9 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point return(with_fx(tree, fx_c_optq_s)); } if (fx_proc(tree) == fx_c_opsq_s_direct) return(with_fx(tree, fx_c_optq_s_direct)); - if (fx_proc(tree) == fx_cons_car_s_s) + if (fx_proc(tree) == fx_cons_car_s_s) { - set_opt1_sym(cdr(p), var1); + set_opt1_sym(cdr(p), var1); return(with_fx(tree, (caddr(p) == var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); }} if (cadadr(p) == var2) @@ -57408,6 +57291,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if ((fx_proc(tree) == fx_add_s_car_s) && (cadaddr(p) == var1)) return(with_fx(tree, fx_add_u_car_t)); if ((fx_proc(tree) == fx_c_s_opsq_direct) && (cadaddr(p) == var3)) return(with_fx(tree, fx_c_u_opvq_direct)); } + if ((cadaddr(p) == var1) && (fx_proc(tree) == fx_c_s_car_s)) return(with_fx(tree, fx_c_s_car_t)); break; case HOP_SAFE_C_opSq_opSq: @@ -57567,7 +57451,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point break; case HOP_SAFE_C_AC: - if ((fx_proc(tree) == fx_c_ac) && (fn_proc(p) == g_num_eq_xi) && (caddr(p) == int_zero) && + if (((fx_proc(tree) == fx_c_ac) || (fx_proc(tree) == fx_c_ac_direct)) && (fn_proc(p) == g_num_eq_xi) && (caddr(p) == int_zero) && (fx_proc(cdr(p)) == fx_c_opuq_t_direct) && (caadr(p) == sc->remainder_symbol) && (fn_proc(cadadr(p)) == g_car)) { set_opt3_sym(p, cadr(cadadr(p))); @@ -57888,7 +57772,6 @@ static opt_info *alloc_opo(s7_scheme *sc) #define backup_pc(sc) sc->pc-- #define OPT_PRINT 0 - #if OPT_PRINT #define return_false(Sc, Expr) return(return_false_1(Sc, Expr, __func__, __LINE__)) static bool return_false_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line) @@ -58033,6 +57916,7 @@ static s7_int opt_i_i_c(opt_info *o) {return(o->v[2].i_i_f(o->v[1].i));} static s7_int opt_i_i_s(opt_info *o) {return(o->v[2].i_i_f(integer(slot_value(o->v[1].p))));} static s7_int opt_i_7i_c(opt_info *o) {return(o->v[2].i_7i_f(opt_sc(o), o->v[1].i));} static s7_int opt_i_7i_s(opt_info *o) {return(o->v[2].i_7i_f(opt_sc(o), integer(slot_value(o->v[1].p))));} +static s7_int opt_i_7i_s_rand(opt_info *o) {return(random_i_7i(opt_sc(o), integer(slot_value(o->v[1].p))));} static s7_int opt_i_d_c(opt_info *o) {return(o->v[2].i_7d_f(opt_sc(o), o->v[1].x));} static s7_int opt_i_d_s(opt_info *o) {return(o->v[2].i_7d_f(opt_sc(o), real(slot_value(o->v[1].p))));} @@ -58073,7 +57957,7 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (p) { opc->v[1].p = p; - opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_s_abs : opt_i_i_s) : opt_i_7i_s; + opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_s_abs : opt_i_i_s) : ((func7 == random_i_7i) ? opt_i_7i_s_rand : opt_i_7i_s); return(true); } if (int_optimize(sc, cdr(car_x))) @@ -58131,12 +58015,14 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer static s7_int opt_i_7pi_ss(opt_info *o) {return(o->v[3].i_7pi_f(opt_sc(o), slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} static s7_int opt_7pi_ss_ivref(opt_info *o) {return(int_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} +static s7_int opt_7pi_ss_bvref(opt_info *o) {return(byte_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} static s7_int opt_i_7pi_sf(opt_info *o) {return(o->v[3].i_7pi_f(opt_sc(o), slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { s7_pointer sig; s7_i_7pi_t pfunc; + pfunc = s7_i_7pi_function(s_func); if (!pfunc) return_false(sc, car_x); @@ -58152,23 +58038,34 @@ static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_pointer p; opc->v[1].p = slot; - if ((car(car_x) == sc->int_vector_ref_symbol) && + if ((s_func == slot_value(global_slot(sc->int_vector_ref_symbol))) && /* ivref etc */ ((!is_int_vector(slot_value(slot))) || (vector_rank(slot_value(slot)) > 1))) return_false(sc, car_x); - + if ((s_func == slot_value(global_slot(sc->byte_vector_ref_symbol))) && /* bvref etc */ + ((!is_byte_vector(slot_value(slot))) || + (vector_rank(slot_value(slot)) > 1))) + return_false(sc, car_x); + opc->v[3].i_7pi_f = pfunc; p = opt_integer_symbol(sc, arg2); if (p) { opc->v[2].p = p; opc->v[0].fi = opt_i_7pi_ss; - if ((car(car_x) == sc->int_vector_ref_symbol) && + if ((s_func == slot_value(global_slot(sc->int_vector_ref_symbol))) && (step_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) { opc->v[0].fi = opt_7pi_ss_ivref; opc->v[3].i_7pi_f = int_vector_ref_unchecked; } + else + if ((s_func == slot_value(global_slot(sc->byte_vector_ref_symbol))) && + (step_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) + { + opc->v[0].fi = opt_7pi_ss_bvref; + opc->v[3].i_7pi_f = byte_vector_ref_unchecked; + } return(true); } opc->v[4].o1 = sc->opts[sc->pc]; @@ -58265,7 +58162,7 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer p, sig; ifunc = s7_i_ii_function(s_func); - if (!ifunc) + if (!ifunc) { ifunc7 = s7_i_7ii_function(s_func); if (!ifunc7) @@ -58279,7 +58176,7 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (ifunc) opc->v[3].i_ii_f = ifunc; else opc->v[3].i_7ii_f = ifunc7; - + if (is_t_integer(arg1)) { opc->v[1].i = integer(arg1); @@ -58407,7 +58304,7 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (opc->v[3].i_ii_f == add_i_ii) {opc->v[0].fi = opt_i_ii_fc_add; return(true);} if (opc->v[3].i_ii_f == multiply_i_ii) {opc->v[0].fi = opt_i_ii_fc_mul; return(true);} opc->v[0].fi = opt_i_ii_fc; - + if ((opc->v[3].i_ii_f == subtract_i_ii) && (opc == sc->opts[sc->pc - 2]) && (sc->opts[start]->v[0].fi == opt_i_7i_c) && (sc->opts[start]->v[2].i_7i_f == random_i_7i)) @@ -58681,23 +58578,23 @@ static bool i_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe (is_symbol(cadr(car_x)))) { s7_pointer slot, fname = car(car_x); - + if ((is_target_or_its_alias(fname, s_func, sc->int_vector_set_symbol)) || (is_target_or_its_alias(fname, s_func, sc->byte_vector_set_symbol))) return(opt_int_vector_set(sc, (fname == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), NULL, cdddr(car_x))); - + slot = opt_types_match(sc, cadr(sig), cadr(car_x)); if (slot) { s7_pointer arg2, p; int32_t start = sc->pc; opc->v[1].p = slot; - + if (((is_target_or_its_alias(fname, s_func, sc->int_vector_ref_symbol)) || (is_target_or_its_alias(fname, s_func, sc->byte_vector_ref_symbol))) && (vector_rank(slot_value(slot)) != 2)) return_false(sc, car_x); - + arg2 = caddr(car_x); p = opt_integer_symbol(sc, arg2); if (p) @@ -59189,7 +59086,7 @@ static s7_double opt_d_p_f(opt_info *o) {return(o->v[3].d_p_f(o->v[5].fp(o->v[4] static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) { - s7_d_p_t dpf; + s7_d_p_t dpf; /* mostly clm gens */ int32_t start = sc->pc; dpf = s7_d_p_function(s_func); if (!dpf) @@ -59246,13 +59143,13 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); if (!is_slot(opc->v[1].p)) return_false(sc, car_x); - + obj = slot_value(opc->v[1].p); if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && ((!is_float_vector(obj)) || (vector_rank(obj) > 1))) return_false(sc, car_x); - + arg2 = caddr(car_x); if (!is_pair(arg2)) { @@ -59285,16 +59182,15 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer pc_fallback(sc, start); return_false(sc, car_x); } - + if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && ((!is_float_vector(cadr(car_x))) || (vector_rank(cadr(car_x)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */ return_false(sc, car_x); - + if (cell_optimize(sc, cdr(car_x))) { - opt_info *o2; - o2 = sc->opts[sc->pc]; + opt_info *o2 = sc->opts[sc->pc]; if (int_optimize(sc, cddr(car_x))) { opc->v[0].fd = opt_d_7pi_ff; @@ -60010,7 +59906,7 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_d_dd_t func; s7_d_7dd_t func7 = NULL; func = s7_d_dd_function(s_func); - if (!func) + if (!func) { func7 = s7_d_7dd_function(s_func); if (!func7) return_false(sc, car_x); @@ -60018,7 +59914,7 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (func) opc->v[3].d_dd_f = func; else opc->v[3].d_7dd_f = func7; - + /* arg1 = real constant */ if (is_small_real(arg1)) { @@ -60053,7 +59949,7 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer pc_fallback(sc, start); return_false(sc, car_x); } - + /* arg1 = float symbol */ slot = opt_float_symbol(sc, arg1); if (slot) @@ -60100,7 +59996,7 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer pc_fallback(sc, start); return_false(sc, car_x); } - + /* arg1 = float expr or non-float */ o1 = sc->opts[sc->pc]; if (float_optimize(sc, cdr(car_x))) @@ -60178,8 +60074,7 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } else { - opt_info *o2; - o2 = sc->opts[start2]; /* this is opc->v[10].o1 */ + opt_info *o2 = sc->opts[start2]; /* this is opc->v[10].o1 */ if (func == add_d_dd) { if (o2->v[0].fd == opt_d_dd_ff_mul) @@ -60407,8 +60302,7 @@ static s7_double opt_d_7pid_ss_ss(opt_info *o) static s7_double opt_d_7pid_ssfo(opt_info *o) { - s7_pointer fv; - fv = slot_value(o->v[1].p); + s7_pointer fv = slot_value(o->v[1].p); return(o->v[4].d_7pid_f(opt_sc(o), fv, integer(slot_value(o->v[2].p)), o->v[6].d_dd_f(o->v[5].d_7pi_f(opt_sc(o), fv, integer(slot_value(o->v[3].p))), real(slot_value(o->v[8].p))))); } @@ -60552,8 +60446,7 @@ static s7_double opt_d_7pii_sss(opt_info *o) static s7_double opt_d_7pii_sss_unchecked(opt_info *o) { - s7_pointer v; - v = slot_value(o->v[1].p); + s7_pointer v = slot_value(o->v[1].p); return(float_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p))))); } @@ -60712,8 +60605,7 @@ static bool d_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point slot = opt_integer_symbol(sc, caddr(car_x)); if (slot) { - s7_pointer vect; - vect = slot_value(opc->v[1].p); + s7_pointer vect = slot_value(opc->v[1].p); opc->v[2].p = slot; opc->v[0].fd = opt_d_7piii_ssss; if ((step_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && @@ -60852,7 +60744,7 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_ { opc->v[0].fd = opt_d_7piid_sssf; opc->v[9].fd = opc->v[8].o1->v[0].fd; - + if ((step_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && (step_end_fits(opc->v[3].p, vector_dimension(vect, 1)))) opc->v[0].fd = opt_d_7piid_sssf_unchecked; @@ -60960,8 +60852,7 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer o2 = sc->opts[start]; if (o2->v[0].fd == opt_d_dd_ff_mul1) { - opt_info *o3; - o3 = sc->opts[start + 2]; + opt_info *o3 = sc->opts[start + 2]; if (o3->v[0].fd == opt_d_vd_o1) { opt_info *o1 = sc->opts[start + 4]; @@ -61324,7 +61215,6 @@ static bool opt_b_p_s(opt_info *o) {return(o->v[2].b_p_f(slot_value(o->v[1].p)) static bool opt_b_p_f(opt_info *o) {return(o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));} static bool opt_b_7p_s(opt_info *o) {return(o->v[2].b_7p_f(opt_sc(o), slot_value(o->v[1].p)));} static bool opt_b_7p_f(opt_info *o) {return(o->v[2].b_7p_f(opt_sc(o), o->v[4].fp(o->v[3].o1)));} - static bool opt_b_d_s_is_positive(opt_info *o) {return(real(slot_value(o->v[1].p)) > 0.0);} static bool opt_b_p_s_is_integer(opt_info *o) {return(s7_is_integer(slot_value(o->v[1].p)));} static bool opt_b_p_s_is_pair(opt_info *o) {return(is_pair(slot_value(o->v[1].p)));} @@ -61333,8 +61223,7 @@ static bool opt_b_7p_s_iter_at_end(opt_info *o) {return(iterator_is_at_end(slot_ static bool opt_zero_mod(opt_info *o) { - s7_int x; - x = integer(slot_value(o->v[1].p)); + s7_int x = integer(slot_value(o->v[1].p)); return((x % o->v[2].i) == 0); } @@ -61530,28 +61419,25 @@ static bool opt_b_7pp_ss_char_lt(opt_info *o) {return(char_lt_b_7pp(opt_sc(o), s static bool opt_b_7pp_sc(opt_info *o) {return(o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].p));} static bool opt_b_7pp_sfo(opt_info *o) {return(o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), o->v[4].p_p_f(opt_sc(o), slot_value(o->v[2].p))));} static bool opt_is_equal_sfo(opt_info *o) {return(s7_is_equal(opt_sc(o), slot_value(o->v[1].p), o->v[4].p_p_f(opt_sc(o), slot_value(o->v[2].p))));} -static bool opt_is_equivalent_sfo(opt_info *o) {return(s7_is_equivalent_1(opt_sc(o), slot_value(o->v[1].p), o->v[4].p_p_f(opt_sc(o), slot_value(o->v[2].p)), NULL));} +static bool opt_is_equivalent_sfo(opt_info *o) {return(is_equivalent_1(opt_sc(o), slot_value(o->v[1].p), o->v[4].p_p_f(opt_sc(o), slot_value(o->v[2].p)), NULL));} static bool opt_b_pp_sf_char_eq(opt_info *o) {return(slot_value(o->v[1].p) == o->v[11].fp(o->v[10].o1));} /* lt above checks for char args */ static bool opt_b_pp_ff_char_eq(opt_info *o) {return(o->v[9].fp(o->v[8].o1) == o->v[11].fp(o->v[10].o1));} static bool opt_car_equal_sf(opt_info *o) { - s7_pointer p; - p = slot_value(o->v[2].p); + s7_pointer p = slot_value(o->v[2].p); return(s7_is_equal(opt_sc(o), slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(opt_sc(o), set_plist_1(opt_sc(o), p)))); } static bool opt_car_equivalent_sf(opt_info *o) { - s7_pointer p; - p = slot_value(o->v[2].p); - return(s7_is_equivalent_1(opt_sc(o), slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(opt_sc(o), set_plist_1(opt_sc(o), p)), NULL)); + s7_pointer p = slot_value(o->v[2].p); + return(is_equivalent_1(opt_sc(o), slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(opt_sc(o), set_plist_1(opt_sc(o), p)), NULL)); } static bool opt_b_7pp_car_sf(opt_info *o) { - s7_pointer p; - p = slot_value(o->v[2].p); + s7_pointer p = slot_value(o->v[2].p); return(o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(opt_sc(o), set_plist_1(opt_sc(o), p)))); } @@ -61614,10 +61500,8 @@ static bool opt_b_7pp_ffo(opt_info *o) static bool opt_b_cadr_cadr(opt_info *o) { - s7_pointer p1, p2; - p1 = slot_value(o->v[1].p); + s7_pointer p1 = slot_value(o->v[1].p), p2 = slot_value(o->v[2].p); p1 = ((is_pair(p1)) && (is_pair(cdr(p1)))) ? cadr(p1) : g_cadr(opt_sc(o), set_plist_1(opt_sc(o), p1)); - p2 = slot_value(o->v[2].p); p2 = ((is_pair(p2)) && (is_pair(cdr(p2)))) ? cadr(p2) : g_cadr(opt_sc(o), set_plist_1(opt_sc(o), p2)); return(o->v[3].b_7pp_f(opt_sc(o), p1, p2)); } @@ -61628,8 +61512,7 @@ static bool b_pp_ff_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case) (opc == sc->opts[sc->pc - 3])) { opt_info *o1 = sc->opts[sc->pc - 2], *o2 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fp == opt_p_p_s) && - (o2->v[0].fp == opt_p_p_s)) + if ((o1->v[0].fp == opt_p_p_s) && (o2->v[0].fp == opt_p_p_s)) { opc->v[1].p = o1->v[1].p; opc->v[4].p_p_f = o1->v[2].p_p_f; @@ -61656,6 +61539,13 @@ static void check_b_types(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po opc->v[0].fb = fb; opc->v[3].b_pp_f = s7_b_pp_unchecked_function(s_func); }} +#if 0 + if ((arg2_type == sc->is_integer_symbol) && s7_b_pi_function(s_func)) + { + /* opc->v[0].fb = opt_b_pi */ + fprintf(stderr, " pi: %s\n", display(car_x)); + } +#endif } static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2, bool bpf_case) @@ -61726,6 +61616,7 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } pc_fallback(sc, cur_index); } + /* fprintf(stderr, "%d %s %s\n", __LINE__, display(opt_arg_type(sc, cdr(car_x))), display(opt_arg_type(sc, cddr(car_x)))); */ o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) { @@ -61748,6 +61639,15 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer /* -------- b_pi -------- */ static bool opt_b_pi_fs(opt_info *o) {return(o->v[2].b_pi_f(opt_sc(o), o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));} static bool opt_b_pi_fs_num_eq(opt_info *o) {return(num_eq_b_pi(opt_sc(o), o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));} +static bool opt_b_pi_fi(opt_info *o) {return(o->v[2].b_pi_f(opt_sc(o), o->v[11].fp(o->v[10].o1), o->v[1].i));} +#if 0 +static bool opt_b_pi_ff(opt_info *o) +{ + s7_pointer p1; + p1 = o->v[9].fp(o->v[8].o1); + return(o->v[3].b_pi_f(opt_sc(o), p1, o->v[11].fi(o->v[10].o1))); +} +#endif static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg2) { @@ -61755,12 +61655,16 @@ static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer bpif = s7_b_pi_function(s_func); if (bpif) { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); /* slot checked in opt_arg_type */ + if (is_symbol(arg2)) + opc->v[1].p = lookup_slot_from(arg2, sc->curlet); /* slot checked in opt_arg_type */ + else opc->v[1].i = integer(arg2); opc->v[10].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) { opc->v[2].b_pi_f = bpif; - opc->v[0].fb = (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; + if (is_symbol(arg2)) /* not pair? arg2 in bool_optimize */ + opc->v[0].fb = (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; + else opc->v[0].fb = opt_b_pi_fi; opc->v[11].fp = opc->v[10].o1->v[0].fp; return(true); }} @@ -61895,7 +61799,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_b_ii_t bif; s7_b_7ii_t b7if = NULL; bif = s7_b_ii_function(s_func); - if (!bif) + if (!bif) { b7if = s7_b_7ii_function(s_func); if (!b7if) @@ -61908,7 +61812,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_symbol(arg2)) { opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - + opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt : ((bif == leq_b_ii) ? opt_b_ii_ss_leq : ((bif == gt_b_ii) ? opt_b_ii_ss_gt : @@ -61919,8 +61823,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } if (is_t_integer(arg2)) { - s7_int i2; - i2 = integer(arg2); + s7_int i2 = integer(arg2); opc->v[2].i = i2; opc->v[0].fb = (bif == num_eq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_eq_0 : ((i2 == 1) ? opt_b_ii_sc_eq_1 : opt_b_ii_sc_eq)) : ((bif == lt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_lt_0 : ((i2 == 1) ? opt_b_ii_sc_lt_1 : ((i2 == 2) ? opt_b_ii_sc_lt_2 : opt_b_ii_sc_lt))) : @@ -61941,7 +61844,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer return_false(sc, car_x); } if (!bif) return_false(sc, car_x); - + if (is_symbol(arg2)) { opc->v[10].o1 = sc->opts[sc->pc]; @@ -62015,8 +61918,7 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i opt_info *o1 = sc->opts[sc->pc]; if (bool_optimize_nw(sc, cdr(car_x))) { - opt_info *o2; - o2 = sc->opts[sc->pc]; + opt_info *o2 = sc->opts[sc->pc]; if (bool_optimize_nw(sc, cddr(car_x))) { opc->v[10].o1 = o2; @@ -62107,6 +62009,7 @@ static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(opt_sc(o), o->v[2].d static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(opt_sc(o), o->v[2].d_7d_f(opt_sc(o), o->v[1].x)));} static s7_pointer opt_p_p_s(opt_info *o) {return(o->v[2].p_p_f(opt_sc(o), slot_value(o->v[1].p)));} static s7_pointer opt_p_p_s_abs(opt_info *o) {return(abs_p_p(opt_sc(o), slot_value(o->v[1].p)));} +static s7_pointer opt_p_p_s_cdr(opt_info *o) {s7_pointer p = slot_value(o->v[1].p); return((is_pair(p)) ? cdr(p) : cdr_p_p(opt_sc(o), p));} static s7_pointer opt_p_p_s_iterate(opt_info *o) {return(iterate_p_p(opt_sc(o), slot_value(o->v[1].p)));} static s7_pointer opt_p_p_f(opt_info *o) {return(o->v[2].p_p_f(opt_sc(o), o->v[4].fp(o->v[3].o1)));} static s7_pointer opt_p_p_f1(opt_info *o) {return(o->v[2].p_p_f(opt_sc(o), o->v[3].p_p_f(opt_sc(o), slot_value(o->v[1].p))));} @@ -62191,7 +62094,7 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c opc->v[1].p = opt_simple_symbol(sc, cadr(car_x)); if (!opc->v[1].p) return_false(sc, car_x); - opc->v[0].fp = (ppf == abs_p_p) ? opt_p_p_s_abs : ((ppf == iterate_p_p) ? opt_p_p_s_iterate : opt_p_p_s); + opc->v[0].fp = (ppf == abs_p_p) ? opt_p_p_s_abs : ((ppf == cdr_p_p) ? opt_p_p_s_cdr : ((ppf == iterate_p_p) ? opt_p_p_s_iterate : opt_p_p_s)); return(true); } if (!is_pair(cadr(car_x))) @@ -62489,13 +62392,13 @@ static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if ((is_any_vector(slot_value(slot1))) && (vector_rank(slot_value(slot1)) > 1)) return_false(sc, car_x); - + opc->v[3].p_pi_f = func; opc->v[1].p = slot1; - + if (is_symbol(cadr(sig))) checker = cadr(sig); - + if ((s7_p_pi_unchecked_function(s_func)) && (checker)) { @@ -62567,6 +62470,10 @@ static s7_pointer opt_p_pp_fs(opt_info *o) {return(o->v[3].p_pp_f(opt_sc(o), o-> static s7_pointer opt_p_pp_fc(opt_info *o) {return(o->v[3].p_pp_f(opt_sc(o), o->v[5].fp(o->v[4].o1), o->v[2].p));} static s7_pointer opt_p_pp_cc(opt_info *o) {return(o->v[3].p_pp_f(opt_sc(o), o->v[1].p, o->v[2].p));} static s7_pointer opt_set_car_pp_ss(opt_info *o) {return(inline_set_car(opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p)));} +static s7_pointer opt_p_pp_sf_add(opt_info *o) {return(add_p_pp(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} +static s7_pointer opt_p_pp_sf_sub(opt_info *o) {return(subtract_p_pp(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} +static s7_pointer opt_p_pp_sf_set_car(opt_info *o) {return(inline_set_car(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} +static s7_pointer opt_p_pp_sf_set_cdr(opt_info *o) {return(inline_set_cdr(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} static s7_pointer opt_p_pp_sf_href(opt_info *o) {return(s7_hash_table_ref(opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} static s7_pointer opt_p_pp_fs_vref(opt_info *o) {return(vector_ref_p_pp(opt_sc(o), o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} static s7_pointer opt_p_pp_fs_cons(opt_info *o) {return(cons(opt_sc(o), o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} @@ -62603,10 +62510,10 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer return_false(sc, car_x); } opc->v[1].p = slot; - + if ((func == hash_table_ref_p_pp) && (is_hash_table(slot_value(slot)))) opc->v[3].p_pp_f = s7_hash_table_ref; - + if (is_symbol(caddr(car_x))) { opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); @@ -62627,7 +62534,8 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } if (cell_optimize(sc, cddr(car_x))) { - opc->v[0].fp = (opc->v[3].p_pp_f == s7_hash_table_ref) ? opt_p_pp_sf_href : opt_p_pp_sf; /* subtract here makes almost no difference */ + opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_sf_add : ((func == subtract_p_pp) ? opt_p_pp_sf_sub : ((func == set_car_p_pp) ? opt_p_pp_sf_set_car : + ((func == set_cdr_p_pp) ? opt_p_pp_sf_set_cdr : ((opc->v[3].p_pp_f == s7_hash_table_ref) ? opt_p_pp_sf_href : opt_p_pp_sf)))); opc->v[4].o1 = sc->opts[pstart]; opc->v[5].fp = sc->opts[pstart]->v[0].fp; return(true); @@ -63016,8 +62924,7 @@ static s7_pointer opt_p_piip_sssf(opt_info *o) static s7_pointer vector_set_piip_sssf_unchecked(opt_info *o) { - s7_pointer v, val; - v = slot_value(o->v[1].p); + s7_pointer val, v = slot_value(o->v[1].p); val = o->v[11].fp(o->v[10].o1); vector_element(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))) = val; return(val); @@ -63124,8 +63031,7 @@ static s7_pointer opt_p_pii_sff(opt_info *o) static s7_pointer vector_ref_pii_sss_unchecked(opt_info *o) { - s7_pointer v; - v = slot_value(o->v[1].p); + s7_pointer v = slot_value(o->v[1].p); return(vector_element(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p))))); } @@ -63146,9 +63052,7 @@ static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if ((is_normal_vector(obj)) && (vector_rank(obj) == 2)) { - s7_pointer indexp1, indexp2, slot; - indexp1 = cddr(car_x); - indexp2 = cdddr(car_x); + s7_pointer slot, indexp1 = cddr(car_x), indexp2 = cdddr(car_x); opc->v[1].p = slot1; opc->v[4].p_pii_f = vector_ref_p_pii; slot = opt_integer_symbol(sc, car(indexp2)); @@ -63252,17 +63156,17 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_pointer slot, obj; opt_info *o1; - + slot = lookup_slot_from(arg1, sc->curlet); if ((!is_slot(slot)) || (has_methods(slot_value(slot)))) return_false(sc, car_x); - + obj = slot_value(slot); if ((is_any_vector(obj)) && (vector_rank(obj) > 1)) return_false(sc, car_x); - + if (is_target_or_its_alias(car(car_x), s_func, sc->hash_table_set_symbol)) { if ((!is_hash_table(obj)) || (is_immutable(obj))) @@ -63272,12 +63176,12 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if ((is_target_or_its_alias(car(car_x), s_func, sc->let_set_symbol)) && ((!is_let(obj)) || (is_immutable(obj)))) return_false(sc, car_x); - + opc->v[1].p = slot; - + if ((func == hash_table_set_p_ppp) && (is_hash_table(obj))) opc->v[3].p_ppp_f = s7_hash_table_set; - + if (is_symbol(arg2)) { slot = opt_simple_symbol(sc, arg2); @@ -63340,8 +63244,7 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cddr(car_x))) { - opt_info *o2; - o2 = sc->opts[sc->pc]; + opt_info *o2 = sc->opts[sc->pc]; if (is_symbol(arg3)) { s7_pointer val_slot; @@ -63349,7 +63252,7 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (val_slot) { opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_sfs; + opc->v[0].fp = opt_p_ppp_sfs; /* hset case goes through the case below */ opc->v[4].o1 = o1; opc->v[5].fp = o1->v[0].fp; return(true); @@ -63497,14 +63400,10 @@ static s7_pointer opt_p_call_any(opt_info *o) opt_info *o1 = o->v[i + P_CALL_O1].o1; set_car(arg, o1->v[0].fp(o1)); } + arg = o->v[2].call(sc, val); if (in_heap(val)) unstack(sc); - else - { - clear_type_bit(T_Pair(val), T_LIST_IN_USE); - sc->current_safe_list = 0; - } - arg = o->v[2].call(sc, val); + else clear_list_in_use(val); return(arg); } @@ -63574,13 +63473,13 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in case T_LET: opc->v[3].p_pp_f = s7_let_ref; break; case T_STRING: opc->v[3].p_pi_f = string_ref_p_pi_unchecked; break; case T_C_OBJECT: return_false(sc, car_x); /* no pi_ref because ref assumes pp */ - + case T_VECTOR: if (vector_rank(obj) != 1) return_false(sc, car_x); opc->v[3].p_pi_f = normal_vector_ref_p_pi_unchecked; break; - + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: @@ -63588,7 +63487,7 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in return_false(sc, car_x); opc->v[3].p_pi_f = vector_ref_p_pi_unchecked; break; - + default: return_false(sc, car_x); } @@ -63675,7 +63574,7 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in }} pc_fallback(sc, start); } - + if (len < (NUM_VUNIONS - 4)) /* mimic p_call_any_ok */ { int32_t pctr; @@ -63732,8 +63631,7 @@ static s7_pointer opt_set_p_p_f(opt_info *o) static s7_pointer opt_set_p_i_s(opt_info *o) { - s7_pointer val; - val = slot_value(o->v[2].p); + s7_pointer val = slot_value(o->v[2].p); if (is_mutable_integer(val)) val = make_integer(opt_sc(o), integer(val)); slot_set_value(o->v[1].p, val); @@ -63750,8 +63648,7 @@ static s7_pointer opt_set_p_i_f(opt_info *o) static s7_pointer opt_set_p_d_s(opt_info *o) { - s7_pointer val; - val = slot_value(o->v[2].p); + s7_pointer val = slot_value(o->v[2].p); if (is_mutable_number(val)) val = make_real(opt_sc(o), real(val)); slot_set_value(o->v[1].p, val); @@ -63843,8 +63740,7 @@ static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc) if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { - opt_info *o1; - o1 = sc->opts[sc->pc - 1]; + opt_info *o1 = sc->opts[sc->pc - 1]; if ((o1->v[0].fi == opt_i_ii_ss) || (o1->v[0].fi == opt_i_ii_ss_add)) { @@ -63924,8 +63820,7 @@ static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer tree_count(sc, target, cddr(code), 0); for (p = car(code); is_pair(p); p = cdr(p)) { - s7_pointer var; - var = car(p); + s7_pointer var = car(p); if ((is_proper_list_2(sc, var)) && (car(var) == target)) counts--; @@ -63951,9 +63846,8 @@ static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_syntax) */ { opt_info *opc; - s7_pointer target; + s7_pointer target = cadr(car_x); opc = alloc_opo(sc); - target = cadr(car_x); if (is_symbol(target)) { s7_pointer settee; @@ -64490,8 +64384,7 @@ static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len) return_false(sc, car_x); for (k = 5, p = cddr(car_x); is_pair(p); k++, p = cdr(p)) { - opt_info *start; - start = sc->opts[sc->pc]; + opt_info *start = sc->opts[sc->pc]; if (!cell_optimize(sc, p)) return_false(sc, car_x); if (is_pair(cdr(p))) @@ -64541,8 +64434,7 @@ static s7_pointer opt_cond(opt_info *top) int32_t clause, len = top->v[2].i; for (clause = 0; clause < len; clause++) { - opt_info *o1, *o2; - o1 = top->v[clause + COND_O1].o1; + opt_info *o2, *o1 = top->v[clause + COND_O1].o1; o2 = o1->v[4].o1; if (o2->v[0].fb(o2)) { @@ -64645,8 +64537,7 @@ static s7_pointer opt_and_any_p(opt_info *o) s7_pointer val = opt_sc(o)->T; /* (and) -> #t */ for (i = 0; i < o->v[1].i; i++) { - opt_info *o1; - o1 = o->v[i + 3].o1; + opt_info *o1 = o->v[i + 3].o1; val = o1->v[0].fp(o1); if (val == opt_sc(o)->F) return(opt_sc(o)->F); @@ -65462,7 +65353,7 @@ static s7_pointer opt_do_list_simple(opt_info *o) o1 = do_any_body(o); fp = o1->v[0].fp; - if (fp == opt_if_bp) + if (fp == opt_if_bp) { while (is_pair(slot_value(vp))) { @@ -65510,8 +65401,7 @@ static s7_pointer opt_do_very_simple(opt_info *o) o1 = o2->v[4].o1; if (o2->v[3].p_pip_f == vector_set_unchecked) { - s7_pointer v; - v = slot_value(o2->v[1].p); + s7_pointer v = slot_value(o2->v[1].p); while (integer(vp) < end) { vector_set_unchecked(o2->sc, v, integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); @@ -66553,7 +66443,6 @@ static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer expr) opc = alloc_opo(sc); sig1 = opt_arg_type(sc, cdr(car_x)); sig2 = opt_arg_type(sc, cddr(car_x)); - if (sig2 == sc->is_integer_symbol) { int32_t cur_index = sc->pc; @@ -66563,7 +66452,7 @@ static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer expr) return(true); pc_fallback(sc, cur_index); - if ((is_symbol(arg2)) && + if ((!is_pair(arg2)) && (b_pi_ok(sc, opc, s_func, car_x, arg2))) return(true); pc_fallback(sc, cur_index); @@ -66681,6 +66570,87 @@ static s7_pfunc s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nr) } +/* ---------------- bool funcs (an experiment) ---------------- */ +typedef bool (*s7_bfunc)(s7_scheme *sc, s7_pointer expr); + +static bool fb_lt_ss(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x, y; + x = lookup(sc, cadr(expr)); + y = lookup(sc, opt2_sym(cdr(expr))); + return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) < integer(y)) : lt_b_7pp(sc, x, y)); +} + +static bool fb_num_eq_ss(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x, y; + x = lookup(sc, cadr(expr)); + y = lookup(sc, opt2_sym(cdr(expr))); + return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y)); +} + +static bool fb_num_eq_s0(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x; + x = lookup(sc, cadr(expr)); + return((is_t_integer(x)) ? (integer(x) == 0) : num_eq_b_7pp(sc, x, int_zero)); +} + +static bool fb_num_eq_s0f(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x; + x = lookup(sc, cadr(expr)); + return((is_t_real(x)) ? (real(x) == 0.0) : num_eq_b_7pp(sc, x, real_zero)); +} + +static bool fb_gt_tu(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x, y; + x = t_lookup(sc, cadr(expr), expr); + y = u_lookup(sc, opt2_sym(cdr(expr)), expr); + return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) > integer(y)) : gt_b_7pp(sc, x, y)); +} + +static bool fb_gt_ss(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x, y; + x = s_lookup(sc, cadr(expr), expr); + y = s_lookup(sc, opt2_sym(cdr(expr)), expr); + return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) > integer(y)) : gt_b_7pp(sc, x, y)); +} + +static bool fb_geq_ss(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x, y; + x = s_lookup(sc, cadr(expr), expr); + y = s_lookup(sc, opt2_sym(cdr(expr)), expr); + return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) >= integer(y)) : geq_b_7pp(sc, x, y)); +} + +static bool fb_leq_ss(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer x, y; + x = s_lookup(sc, cadr(expr), expr); + y = s_lookup(sc, opt2_sym(cdr(expr)), expr); + return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) <= integer(y)) : leq_b_7pp(sc, x, y)); +} + +static s7_pointer fx_to_fb(s7_scheme *sc, s7_function fx) /* eventually parallel arrays? */ +{ + if (fx == fx_num_eq_ss) return((s7_pointer)fb_num_eq_ss); + if (fx == fx_lt_ss) return((s7_pointer)fb_lt_ss); + if (fx == fx_gt_ss) return((s7_pointer)fb_gt_ss); + if (fx == fx_leq_ss) return((s7_pointer)fb_leq_ss); + if (fx == fx_geq_ss) return((s7_pointer)fb_geq_ss); + if (fx == fx_gt_tu) return((s7_pointer)fb_gt_tu); + if (fx == fx_num_eq_s0) return((s7_pointer)fb_num_eq_s0); + if (fx == fx_num_eq_s0f) return((s7_pointer)fb_num_eq_s0f); + return(NULL); +} + +/* when_b cond? do end-test? num_eq_vs|us */ + + /* ---------------------------------------- for-each ---------------------------------------- */ static Inline s7_pointer make_counter(s7_scheme *sc, s7_pointer iter) @@ -66737,7 +66707,7 @@ static s7_pointer seq_init(s7_scheme *sc, s7_pointer seq) if (x == y) break; \ }}} while (0) -static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) +static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* one sequence arg */ { s7_pointer body = closure_body(f); if (!no_cell_opt(body)) /* if at top level we often get an unoptimized (not safe) function here that can be cell_optimized below */ @@ -66752,10 +66722,12 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq if (is_null(cdr(body))) func = s7_optimize_nr(sc, body); else - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); /* was list_1 via cons 8-Apr-21, true=nr */ - } + if (is_null(cddr(body))) /* 3 sometimes works */ + { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); /* was list_1 via cons 8-Apr-21, true=nr */ + } + else func = NULL; if (func) { s7_int (*fi)(opt_info *o); @@ -66911,6 +66883,103 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq return(sc->unspecified); } +static s7_pointer g_for_each_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq_1, s7_pointer seq_2) +{ + s7_pointer body = closure_body(f); + /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(sc->code), display(seq1), display(seq2)); */ + if (!no_cell_opt(body)) + { + s7_pfunc fnc; + s7_pointer olde = sc->curlet, pars = closure_args(f), val_1, val_2, slot_1, slot_2; + + val_1 = seq_init(sc, seq_1); + val_2 = seq_init(sc, seq_2); + sc->curlet = make_let_with_two_slots(sc, closure_let(f), + (is_pair(car(pars))) ? caar(pars) : car(pars), val_1, + (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val_2); + slot_1 = let_slots(sc->curlet); + slot_2 = next_slot(slot_1); + + if (is_null(cdr(body))) + fnc = s7_optimize_nr(sc, body); + else + if (is_null(cddr(body))) + { + set_ulist_1(sc, sc->begin_symbol, body); + fnc = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); + } + else fnc = NULL; + if (fnc) + { + if ((is_pair(seq_1)) && (is_pair(seq_2))) + { + s7_pointer fast_1, slow_1, fast_2, slow_2; + for (fast_1 = seq_1, slow_1 = seq_1, fast_2 = seq_2, slow_2 = seq_2; (is_pair(fast_1)) && (is_pair(fast_2)); + fast_1 = cdr(fast_1), slow_1 = cdr(slow_1), fast_2 = cdr(fast_2), slow_2 = cdr(slow_2)) + { + slot_set_value(slot_1, car(fast_1)); + slot_set_value(slot_2, car(fast_2)); + fnc(sc); + if ((is_pair(cdr(fast_1))) && (is_pair(cdr(fast_2)))) + { + fast_1 = cdr(fast_1); + if (fast_1 == slow_1) break; + fast_2 = cdr(fast_2); + if (fast_2 == slow_2) break; + slot_set_value(slot_1, car(fast_1)); + slot_set_value(slot_2, car(fast_2)); + fnc(sc); + }} + set_curlet(sc, olde); + return(sc->unspecified); + } + else + if ((is_any_vector(seq_1)) && (is_any_vector(seq_2))) + { + s7_int i, len = vector_length(seq_1); + if (len > vector_length(seq_2)) len = vector_length(seq_2); + for (i = 0; i < len; i++) + { + slot_set_value(slot_1, vector_getter(seq_1)(sc, seq_1, i)); + slot_set_value(slot_2, vector_getter(seq_2)(sc, seq_2, i)); + fnc(sc); + } + set_curlet(sc, olde); + return(sc->unspecified); + } + else + if ((is_string(seq_1)) && (is_string(seq_2))) + { + s7_int i, len = string_length(seq_1); + const char *s_1 = string_value(seq_1), *s_2 = string_value(seq_2); + if (len > string_length(seq_2)) len = string_length(seq_2); + for (i = 0; i < len; i++) + { + slot_set_value(slot_1, chars[(uint8_t)(s_1[i])]); + slot_set_value(slot_2, chars[(uint8_t)(s_2[i])]); + fnc(sc); + } + set_curlet(sc, olde); + return(sc->unspecified); + } + else + { + set_no_cell_opt(body); + set_curlet(sc, olde); + }} + else /* not fnc */ + { + set_no_cell_opt(body); + set_curlet(sc, olde); + }} + + sc->z = list_1(sc, (is_iterator(seq_2)) ? seq_2 : s7_make_iterator(sc, seq_2)); + sc->z = cons(sc, (is_iterator(seq_1)) ? seq_1 : s7_make_iterator(sc, seq_1), sc->z); + push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, sc->z, make_list(sc, 2, sc->nil)), f); + sc->z = sc->nil; + return(sc->unspecified); +} + static inline bool for_each_arg_is_null(s7_scheme *sc, s7_pointer args) { s7_pointer p; @@ -66964,6 +67033,45 @@ Each object can be a list, string, vector, hash-table, or any other sequence." { s7_function func; s7_pointer iters; + + s7_p_p_t fp = s7_p_p_function(f); + if ((fp) && (len == 1)) + { + if (is_pair(cadr(args))) + { + s7_pointer fast, slow; + for (fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + { + fp(sc, car(fast)); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + fp(sc, car(fast)); + } + return(sc->unspecified); + }} + else + if (is_any_vector(cadr(args))) + { + s7_int i, vlen; + s7_pointer v = cadr(args); + vlen = vector_length(v); + for (i = 0; i < vlen; i++) fp(sc, vector_getter(v)(sc, v, i)); + return(sc->unspecified); + } + else + if (is_string(cadr(args))) + { + s7_int i, slen; + s7_pointer str = cadr(args); + const char *s; + s = string_value(str); + slen = string_length(str); + for (i = 0; i < slen; i++) fp(sc, chars[(uint8_t)(s[i])]); + return(sc->unspecified); + }} + func = c_function_call(f); /* presumably this is either display/write, or method call? */ sc->z = make_iterators(sc, args); sc->z = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); @@ -67117,7 +67225,7 @@ static Inline bool op_for_each_2(s7_scheme *sc) /* ---------------------------------------- map ---------------------------------------- */ -static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) +static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* one sequence argument */ { s7_pointer body = closure_body(f); sc->value = f; @@ -67134,10 +67242,12 @@ static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) if (is_null(cdr(body))) func = s7_cell_optimize(sc, body, false); else - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */ - } + if (is_null(cddr(body))) + { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */ + } + else func = NULL; if (func) { s7_pointer z; @@ -67154,8 +67264,7 @@ static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) if (is_pair(cdr(fast))) { fast = cdr(fast); - if (fast == slow) - break; + if (fast == slow) break; slot_set_value(slot, car(fast)); z = func(sc); if (z != sc->no_value) sc->v = cons(sc, z, sc->v); @@ -67239,6 +67348,111 @@ static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) return(sc->nil); } +static s7_pointer g_map_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer seq2) +{ + s7_pointer body = closure_body(f); + /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(sc->code), display(seq1), display(seq2)); */ + if (!no_cell_opt(body)) + { + s7_pfunc func; + s7_pointer old_e = sc->curlet, pars = closure_args(f), val1, val2, slot1, slot2; + + val1 = seq_init(sc, seq1); + val2 = seq_init(sc, seq2); + sc->curlet = make_let_with_two_slots(sc, closure_let(f), + (is_pair(car(pars))) ? caar(pars) : car(pars), val1, + (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2); + slot1 = let_slots(sc->curlet); + slot2 = next_slot(slot1); + + if (is_null(cdr(body))) + func = s7_cell_optimize(sc, body, false); + else + if (is_null(cddr(body))) + { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); + } + else func = NULL; + if (func) + { + s7_pointer val; + if ((is_pair(seq1)) && (is_pair(seq2))) + { + s7_pointer fast1, slow1, fast2, slow2; + sc->v = sc->nil; + for (fast1 = seq1, slow1 = seq1, fast2 = seq2, slow2 = seq2; (is_pair(fast1)) && (is_pair(fast2)); + fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) + { + slot_set_value(slot1, car(fast1)); + slot_set_value(slot2, car(fast2)); + val = func(sc); + if (val != sc->no_value) sc->v = cons(sc, val, sc->v); + if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) + { + fast1 = cdr(fast1); + if (fast1 == slow1) break; + fast2 = cdr(fast2); + if (fast2 == slow2) break; + slot_set_value(slot1, car(fast1)); + slot_set_value(slot2, car(fast2)); + val = func(sc); + if (val != sc->no_value) sc->v = cons(sc, val, sc->v); + }} + set_curlet(sc, old_e); + return(proper_list_reverse_in_place(sc, sc->v)); + } + else + if ((is_any_vector(seq1)) && (is_any_vector(seq2))) + { + s7_int i, len = vector_length(seq1); + if (len > vector_length(seq2)) len = vector_length(seq2); + sc->v = sc->nil; + for (i = 0; i < len; i++) + { + slot_set_value(slot1, vector_getter(seq1)(sc, seq1, i)); + slot_set_value(slot2, vector_getter(seq2)(sc, seq2, i)); + val = func(sc); + if (val != sc->no_value) sc->v = cons(sc, val, sc->v); + } + set_curlet(sc, old_e); + return(proper_list_reverse_in_place(sc, sc->v)); + } + else + if ((is_string(seq1)) && (is_string(seq2))) + { + s7_int i, len = string_length(seq1); + const char *s1 = string_value(seq1), *s2 = string_value(seq2); + if (len > string_length(seq2)) len = string_length(seq2); + sc->v = sc->nil; + for (i = 0; i < len; i++) + { + slot_set_value(slot1, chars[(uint8_t)(s1[i])]); + slot_set_value(slot2, chars[(uint8_t)(s2[i])]); + val = func(sc); + if (val != sc->no_value) sc->v = cons(sc, val, sc->v); + } + set_curlet(sc, old_e); + return(proper_list_reverse_in_place(sc, sc->v)); + } + else + { + set_no_cell_opt(body); + set_curlet(sc, old_e); + }} + else /* not func */ + { + set_no_cell_opt(body); + set_curlet(sc, old_e); + }} + + sc->z = list_1(sc, (is_iterator(seq2)) ? seq2 : s7_make_iterator(sc, seq2)); + sc->z = cons(sc, (is_iterator(seq1)) ? seq1 : s7_make_iterator(sc, seq1), sc->z); + push_stack(sc, OP_MAP, make_counter(sc, sc->z), f); + sc->z = sc->nil; + return(sc->unspecified); +} + static s7_pointer g_map(s7_scheme *sc, s7_pointer args) { #define H_map "(map proc object . objects) applies proc to a list made up of the next element of each of its arguments, returning \ @@ -67264,7 +67478,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table if ((c_function_required_args(f) > len) || (c_function_all_args(f) < len)) return(s7_error(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, make_integer(sc, len), make_integer(sc, len)))); + set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer1(sc, len), wrap_integer2(sc, len)))); case T_C_OPT_ARGS_FUNCTION: case T_C_ANY_ARGS_FUNCTION: @@ -67272,67 +67486,127 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table if (got_nil) return(sc->nil); if (is_safe_procedure(f)) { - s7_function func; - func = c_function_call(f); - if ((is_pair(cadr(args))) && - (len == 1)) - { - s7_pointer f_args, val, fast, slow; - f_args = list_1(sc, sc->F); - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let(sc, OP_GC_PROTECT, f_args, val); - for (fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + s7_pointer val, val1, old_args, iter_list; + s7_function func = c_function_call(f); + if (is_pair(cadr(args))) + { + if (len == 1) { - s7_pointer z; - set_car(f_args, car(fast)); - z = func(sc, f_args); - if (z != sc->no_value) - set_car(val, cons(sc, z, car(val))); - if (is_pair(cdr(fast))) + s7_p_p_t fp = s7_p_p_function(f); + if (fp) { - fast = cdr(fast); - if (fast == slow) - break; - set_car(f_args, car(fast)); - z = func(sc, f_args); - if (z != sc->no_value) - set_car(val, cons(sc, z, car(val))); + s7_pointer fast, slow; + val = list_1_unchecked(sc, sc->nil); + push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + for (fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + { + s7_pointer z; + z = fp(sc, car(fast)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + z = fp(sc, car(fast)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + }} + unstack(sc); + return(proper_list_reverse_in_place(sc, car(val))); }} - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - } - else - { - s7_pointer val, val1, old_args, iter_list; - sc->z = make_iterators(sc, args); - val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); - iter_list = sc->z; - old_args = sc->args; - func = c_function_call(f); - push_stack_no_let(sc, OP_GC_PROTECT, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */ - sc->z = sc->nil; - while (true) + if ((len == 2) && (is_pair(caddr(args)))) { - s7_pointer x, y, z; - for (x = iter_list, y = cdr(val1); is_pair(x); x = cdr(x), y = cdr(y)) + s7_p_pp_t fp = s7_p_pp_function(f); + if (fp) { - set_car(y, s7_iterate(sc, car(x))); - if (iterator_is_at_end(car(x))) + s7_pointer fast1, slow1, fast2, slow2; + val = list_1_unchecked(sc, sc->nil); + push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + for (fast1 = cadr(args), slow1 = cadr(args), fast2 = caddr(args), slow2 = caddr(args); + (is_pair(fast1)) && (is_pair(fast2)); + fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) { - unstack(sc); - /* free_cell(sc, car(x)); */ /* 16-Jan-19 iterator in circular list -- see s7test */ - sc->args = T_Pos(old_args); - return(proper_list_reverse_in_place(sc, car(val))); - }} - z = func(sc, cdr(val1)); /* can this contain multiple-values? */ - if (z != sc->no_value) - set_car(val, cons(sc, z, car(val))); - }}} + s7_pointer z; + z = fp(sc, car(fast1), car(fast2)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) + { + fast1 = cdr(fast1); + if (fast1 == slow1) break; + fast2 = cdr(fast2); + if (fast2 == slow2) break; + z = fp(sc, car(fast1), car(fast2)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + }} + unstack(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }}} + if ((is_string(cadr(args))) && (len == 1)) + { + s7_p_p_t fp = s7_p_p_function(f); + if (fp) + { + s7_int i, len; + s7_pointer val, str = cadr(args); + const char *s; + val = list_1_unchecked(sc, sc->nil); + push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + s = string_value(str); + len = string_length(str); + for (i = 0; i < len; i++) + { + s7_pointer z; + z = fp(sc, chars[(uint8_t)(s[i])]); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + } + unstack(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + if ((is_any_vector(cadr(args))) && (len == 1)) + { + s7_p_p_t fp = s7_p_p_function(f); + if (fp) + { + s7_int i, len; + s7_pointer val, vec = cadr(args); + val = list_1_unchecked(sc, sc->nil); + push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + len = vector_length(vec); + for (i = 0; i < len; i++) + { + s7_pointer z; + z = fp(sc, vector_getter(vec)(sc, vec, i)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + } + unstack(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + + sc->z = make_iterators(sc, args); + val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); + iter_list = sc->z; + old_args = sc->args; + /* func = c_function_call(f); */ + push_stack_no_let(sc, OP_GC_PROTECT, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */ + sc->z = sc->nil; + while (true) + { + s7_pointer x, y, z; + for (x = iter_list, y = cdr(val1); is_pair(x); x = cdr(x), y = cdr(y)) + { + set_car(y, s7_iterate(sc, car(x))); + if (iterator_is_at_end(car(x))) + { + unstack(sc); + /* free_cell(sc, car(x)); */ /* 16-Jan-19 iterator in circular list -- see s7test */ + sc->args = T_Pos(old_args); + return(proper_list_reverse_in_place(sc, car(val))); + }} + z = func(sc, cdr(val1)); /* can this contain multiple-values? */ + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + }} + else /* not safe procedure */ - /* to mimic map values handling elsewhere: - * ((lambda args (format *stderr* "~A~%" (map values args))) (values)): () - * ((lambda args (format *stderr* "~A~%" (map values args))) (values #<unspecified>)): #<unspecified> etc - */ if ((f == global_value(sc->values_symbol)) && (len == 1) && (!has_methods(cadr(args)))) /* iterator should be ok here -- object_to_list can handle it */ @@ -67366,7 +67640,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table if (((fargs >= 0) && (fargs < len)) || ((is_closure(f)) && (abs(fargs) > len))) return(s7_error(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, make_integer(sc, len), make_integer(sc, len)))); + set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer1(sc, len), wrap_integer2(sc, len)))); if (got_nil) return(sc->nil); } break; @@ -67377,7 +67651,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table if ((!is_pair(f)) && (!s7_is_aritable(sc, f, len))) return(s7_error(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, make_integer(sc, len), make_integer(sc, len)))); + set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer1(sc, len), wrap_integer2(sc, len)))); if (got_nil) return(sc->nil); break; } @@ -67390,8 +67664,7 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table static bool op_map(s7_scheme *sc) { - s7_pointer y, iterators; - iterators = counter_list(sc->args); + s7_pointer y, iterators = counter_list(sc->args); sc->x = sc->nil; /* can't use preset args list here (as in for-each): (map list '(a b c)) */ for (y = iterators; is_pair(y); y = cdr(y)) { @@ -67513,20 +67786,14 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) int64_t top; s7_pointer x; top = current_stack_top(sc) - 1; /* stack_end - stack_start if negative, we're in big trouble */ -#if SHOW_EVAL_OPS - safe_print(fprintf(stderr, "%s[%d]: splice %s %s\n", __func__, __LINE__, op_names[stack_op(sc->stack, top)], display_80(args))); -#endif + if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s[%d]: splice %s %s\n", __func__, __LINE__, op_names[stack_op(sc->stack, top)], display_80(args))); switch (stack_op(sc->stack, top)) { /* the normal case -- splice values into caller's args */ - case OP_EVAL_ARGS1: - case OP_EVAL_ARGS2: - case OP_EVAL_ARGS3: - case OP_EVAL_ARGS4: - /* code = args yet to eval in order, args = evalled args reversed - * - * it's not safe to simply reverse args and tack the current stacked args onto its (new) end, + case OP_EVAL_ARGS1: case OP_EVAL_ARGS2: case OP_EVAL_ARGS3: case OP_EVAL_ARGS4: + /* code = args yet to eval in order, args = evalled args reversed. + * it is not safe to simply reverse args and tack the current stacked args onto its (new) end, * setting stacked args to cdr of reversed-args and returning car because the list (args) * can be some variable's value in a macro expansion via ,@ and reversing it in place * (all this to avoid consing), clobbers the variable's value. @@ -67546,12 +67813,10 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) stack_element(sc->stack, top) = (s7_pointer)OP_ANY_C_NP_MV_1; goto FP_MV; - case OP_ANY_C_NP_1: - case OP_ANY_CLOSURE_NP_1: + case OP_ANY_C_NP_1: case OP_ANY_CLOSURE_NP_1: stack_element(sc->stack, top) = (s7_pointer)(stack_op(sc->stack, top) + 1); /* replace with mv version */ - case OP_ANY_C_NP_MV_1: - case OP_ANY_CLOSURE_NP_MV_1: + case OP_ANY_C_NP_MV_1: case OP_ANY_CLOSURE_NP_MV_1: FP_MV: if ((is_immutable(args)) || /* (let () (define (func) (with-output-to-string (lambda () (apply-values (write '(1 2)))))) (func) (func)) */ (needs_copied_args(args))) @@ -67566,7 +67831,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SSP_MV_1; return(args); - case OP_SAFE_C_SP_1: case OP_SAFE_CONS_SP_1: case OP_SAFE_LIST_SP_1: case OP_SAFE_ADD_SP_1: case OP_SAFE_MULTIPLY_SP_1: + case OP_SAFE_C_SP_1: case OP_SAFE_CONS_SP_1: case OP_SAFE_LIST_SP_1: case OP_SAFE_ADD_SP_1: case OP_SAFE_MULTIPLY_SP_1: stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SP_MV; return(args); @@ -67582,8 +67847,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PA_MV; return(args); - case OP_C_P_1: - case OP_SAFE_C_P_1: + case OP_C_P_1: case OP_SAFE_C_P_1: stack_element(sc->stack, top) = (s7_pointer)OP_C_P_MV; return(args); @@ -67633,8 +67897,10 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) return(cadr(x)); /* look for errors here rather than glomming up the set! and let code. */ - case OP_SET_SAFE: /* symbol is sc->code after pop */ - case OP_SET1: /* (set! var (values 1 2 3)) */ + case OP_SET_SAFE: /* symbol is sc->code after pop */ + case OP_SET1: + case OP_SET_FROM_LET_TEMP: /* (set! var (values 1 2 3)) */ + case OP_SET_FROM_SETTER: eval_error_with_caller2(sc, "~A: can't set ~A to ~S", 22, sc->set_symbol, stack_code(sc->stack, top), set_ulist_1(sc, sc->values_symbol, args)); case OP_SET_PAIR_P_1: @@ -67657,11 +67923,14 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) */ } - case OP_LET_ONE_NEW_1: /* op_let_one_[p]_old_1 can't happen here, I think */ - case OP_LET_ONE_P_NEW_1: + case OP_LET_ONE_NEW_1: case OP_LET_ONE_P_NEW_1: eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, opt2_sym(stack_code(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); + case OP_LET_ONE_OLD_1: case OP_LET_ONE_P_OLD_1: + eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, + slot_symbol(let_slots(opt3_let(stack_code(sc->stack, top)))), set_ulist_1(sc, sc->values_symbol, args)); + case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */ eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->let_star_symbol, caar(stack_code(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); @@ -67674,7 +67943,6 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_star_symbol, slot_symbol(stack_args(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - /* handle 'and' and 'or' specially */ case OP_AND_P1: case OP_AND_SAFE_P_REST: /* from OP_AND_SAFE_P1 or P2 */ for (x = args; is_not_null(cdr(x)); x = cdr(x)) @@ -67695,8 +67963,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_COND1: case OP_COND1_SIMPLE: return(car(args)); - case OP_DYNAMIC_UNWIND: - case OP_DYNAMIC_UNWIND_PROFILE: + case OP_DYNAMIC_UNWIND: case OP_DYNAMIC_UNWIND_PROFILE: { s7_pointer old_value = sc->value; bool mv = is_multiple_value(args); @@ -67823,7 +68090,13 @@ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) if (is_null(x)) { if (!checked) /* (!tree_has_definers(sc, args)) seems to work, reduces copy_tree calls slightly, but costs more than it saves in tgen */ - return((is_immutable(args)) ? copy_proper_list(sc, args) : args); + { + s7_pointer p; + for (p = args; is_pair(p); p = cdr(p)) + if (is_immutable(p)) + return(copy_proper_list(sc, args)); + return(args); + } sc->u = args; check_free_heap_size(sc, 8192); if (sc->safety > NO_SAFETY) @@ -68043,9 +68316,7 @@ static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const int32_t required_args, int32_t optional_args, bool rest_arg) { s7_pointer uf; -#if S7_DEBUGGING - if (!is_safe_procedure(global_value(s7_make_symbol(sc, name)))) fprintf(stderr, "%s unsafe: %s\n", __func__, name); -#endif + if ((S7_DEBUGGING) && (!is_safe_procedure(global_value(s7_make_symbol(sc, name))))) fprintf(stderr, "%s unsafe: %s\n", __func__, name); uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); s7_function_set_class(sc, uf, cls); c_function_signature(uf) = c_function_signature(cls); @@ -68065,9 +68336,6 @@ static s7_pointer make_unsafe_function_with_class(s7_scheme *sc, s7_pointer cls, static s7_pointer set_function_chooser(s7_scheme *sc, s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops)) { s7_pointer f = global_value(sym); -#if S7_DEBUGGING - if (c_function_chooser(f) != fallback_chooser) fprintf(stderr, "%s[%d]: reset %s chooser\n", __func__, __LINE__, display(sym)); -#endif c_function_chooser(f) = chooser; return(f); } @@ -68130,6 +68398,16 @@ static void init_choosers(s7_scheme *sc) sc->num_eq_xi = make_function_with_class(sc, f, "=", g_num_eq_xi, 2, 0, false); sc->num_eq_ix = make_function_with_class(sc, f, "=", g_num_eq_ix, 2, 0, false); + /* min */ + f = set_function_chooser(sc, sc->min_symbol, min_chooser); + sc->min_2 = make_function_with_class(sc, f, "min", g_min_2, 2, 0, false); + sc->min_3 = make_function_with_class(sc, f, "min", g_min_3, 3, 0, false); + + /* max */ + f = set_function_chooser(sc, sc->max_symbol, max_chooser); + sc->max_2 = make_function_with_class(sc, f, "max", g_max_2, 2, 0, false); + sc->max_3 = make_function_with_class(sc, f, "max", g_max_3, 3, 0, false); + /* < */ f = set_function_chooser(sc, sc->lt_symbol, less_chooser); sc->less_xi = make_function_with_class(sc, f, "<", g_less_xi, 2, 0, false); @@ -68317,6 +68595,9 @@ static void init_choosers(s7_scheme *sc) sc->list_ref_at_1 = make_function_with_class(sc, f, "list", g_list_ref_at_1, 2, 0, false); sc->list_ref_at_2 = make_function_with_class(sc, f, "list", g_list_ref_at_2, 2, 0, false); + /* assoc */ + set_function_chooser(sc, sc->assoc_symbol, assoc_chooser); + /* member */ set_function_chooser(sc, sc->member_symbol, member_chooser); @@ -68719,7 +69000,7 @@ static s7_pointer unknown_string_constant(s7_scheme *sc, int32_t c) if (hook_has_functions(sc->read_error_hook)) { s7_pointer result; - result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->F, s7_make_character(sc, (uint8_t)c))); + result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->F, chars[(uint8_t)c])); if (is_character(result)) return(result); } @@ -69304,8 +69585,7 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int return(OPT_F); if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1; - if ((is_safe_procedure(func)) || - (c_function_call(func) == g_list)) /* (list) is safe, (values) is not (in this context -- possibly used as list-values arg) */ + if (is_safe_procedure(func)) { set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); choose_c_function(sc, expr, func, 0); @@ -69327,9 +69607,7 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int static opt_t optimize_closure_dotted_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e) { -#if S7_DEBUGGING - if (!is_symbol(closure_args(func))) fprintf(stderr, "%s[%d]: %s but %s\n", __func__, __LINE__, display_80(expr), display(func)); -#endif + if ((S7_DEBUGGING) && (!is_symbol(closure_args(func)))) fprintf(stderr, "%s[%d]: %s but %s\n", __func__, __LINE__, display_80(expr), display(func)); if (fx_count(sc, expr) != args) /* fx_count starts at cdr, args here is the number of exprs in cdr(expr) -- so this means "are all args fxable" */ return(OPT_F); fx_annotate_args(sc, cdr(expr), e); @@ -69760,10 +70038,7 @@ static bool is_safe_fxable(s7_scheme *sc, s7_pointer p) return(true); } if (is_proper_quote(sc, p)) return(true); -#if S7_DEBUGGING - if ((is_optimized(p)) && (fx_function[optimize_op(p)])) - fprintf(stderr, "omit %s: %s\n", op_names[optimize_op(p)], display(p)); -#endif + if ((S7_DEBUGGING) && (is_optimized(p)) && (fx_function[optimize_op(p)])) fprintf(stderr, "omit %s: %s\n", op_names[optimize_op(p)], display(p)); return(false); } @@ -70147,7 +70422,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar { s7_int len; len = proper_list_length(orx); - if ((len == 3) || ((vars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1))) + if ((len == 3) || ((vars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1) && (is_fxable(sc, caddr(orx))))) { s7_pointer tc; tc = (len == 3) ? caddr(orx) : cadddr(orx); @@ -70446,9 +70721,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar fx_annotate_args(sc, cdr(letb), args); for (v = letv; is_pair(v); v = cdr(v)) fx_annotate_arg(sc, cdar(v), args); - fx_tree(sc, cdar(letv), car(args), cadr(args), NULL, true); /* first var of let* */ - if ((is_pair(cdr(letv))) && (!s7_tree_memq(sc, caar(letv), cdadr(letv)))) - fx_tree(sc, cdadr(letv), car(args), cadr(args), NULL, true); /* second var of let* */ + fx_tree(sc, cdar(letv), car(args), cadr(args), NULL, true); /* first var of let*, second var of let* can't be fx_treed */ fx_tree(sc, cdr(body), car(args), cadr(args), NULL, true); /* these are references to the outer let */ fx_tree(sc, cdr(laa), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); fx_tree(sc, cdr(letb), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); @@ -71717,16 +71990,16 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if (is_normal_symbol(car(p))) add_symbol_to_list(sc, car(p)); + /* two seq args can't happen here (func_2_args = map + lambda + seq, arg1 is the lambda form, arg2 is fxable (see above) */ choose_c_function(sc, expr, func, 2); if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && - (is_proper_list_1(sc, cadr(arg1))) && - (is_proper_list_1(sc, cddr(arg1))) && - (!is_possibly_constant(caadr(arg1)))) + ((is_proper_list_1(sc, cadr(arg1))) && /* one parameter */ + (!is_possibly_constant(caadr(arg1))))) /* parameter name not trouble */ { /* built-in permanent closure here was not much faster */ set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure : NULL); set_opt3_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, OP_MAP_OR_FOR_EACH_FA); + set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FA); } return(OPT_F); }} @@ -72212,6 +72485,36 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer } return(OPT_F); }}} + + if ((is_semisafe(func)) && + (is_symbol(car(expr))) && + (car(expr) != sc->values_symbol) && + (is_fxable(sc, arg2)) && + (is_fxable(sc, arg3)) && + (is_pair(arg1)) && + (car(arg1) == sc->lambda_symbol)) + { + choose_c_function(sc, expr, func, 3); + if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && + (is_proper_list_2(sc, cadr(arg1))) && /* two parameters */ + (!is_possibly_constant(caadr(arg1))) && /* parameter name not trouble */ + (!is_possibly_constant(cadadr(arg1)))) + { + s7_pointer p; + fx_annotate_args(sc, cddr(expr), e); + check_lambda(sc, arg1, true); /* this changes symbol_list */ + + clear_symbol_list(sc); /* so restore it */ + for (p = e; is_pair(p); p = cdr(p)) + if (is_normal_symbol(car(p))) + add_symbol_to_list(sc, car(p)); + + set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure_2 : NULL); + set_opt3_pair(expr, cdr(arg1)); + set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FAA); + return(OPT_F); + }} + if ((is_safe_procedure(func)) || ((is_semisafe(func)) && (((car(expr) != sc->assoc_symbol) && (car(expr) != sc->member_symbol)) || @@ -72842,13 +73145,10 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in } return(OPT_T); - case OP_IF: - case OP_WHEN: - case OP_UNLESS: + case OP_IF: case OP_WHEN: case OP_UNLESS: if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) return(OPT_OOPS); - case OP_OR: - case OP_AND: + case OP_OR: case OP_AND: e = cons(sc, sc->key_if_symbol, e); break; @@ -73228,10 +73528,9 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 else /* pairs != 0 */ { s7_pointer arg1 = cadr(expr); - if ((pairs == 1) && - (len == 1)) + if ((pairs == 1) && (len == 1)) { - if ((car(expr) == sc->quote_symbol) && + if ((car_expr == sc->quote_symbol) && (direct_memq(sc->quote_symbol, e))) return(OPT_OOPS); @@ -73242,27 +73541,11 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 set_unsafe_optimize_op(expr, OP_UNKNOWN_A); return(OPT_F); }} - - if ((len == 2) && - (is_fxable(sc, arg1)) && - (is_fxable(sc, caddr(expr)))) - { - set_opt3_arglen(cdr(expr), int_two); - set_unsafe_optimize_op(expr, OP_UNKNOWN_AA); - return(OPT_F); - } - if (fx_count(sc, expr) == len) { - if ((len == 1) && - (car(expr) == sc->quote_symbol) && - (direct_memq(sc->quote_symbol, e))) - return(OPT_OOPS); - - set_unsafe_optimize_op(expr, (len == 1) ? OP_UNKNOWN_A : OP_UNKNOWN_NA); + set_unsafe_optimize_op(expr, (len == 1) ? OP_UNKNOWN_A : ((len == 2) ? OP_UNKNOWN_AA : OP_UNKNOWN_NA)); set_opt3_arglen(cdr(expr), make_permanent_integer(len)); - if (len == 1) - fx_annotate_arg(sc, cdr(expr), e); + if (len <= 2) fx_annotate_args(sc, cdr(expr), e); return(OPT_F); } set_unsafe_optimize_op(expr, OP_UNKNOWN_NP); @@ -74769,6 +75052,7 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ if ((opt == OP_LET_FX_OLD) && (is_null(cddr(code)))) /* 1 form in body */ { + /* if (is_fxable(sc, cadr(code))) fprintf(stderr, "%s\n", display(code)); */ if (vars == 2) { pair_set_syntax_op(sc->code, OP_LET_2A_OLD); @@ -74967,46 +75251,44 @@ static bool op_named_let(s7_scheme *sc) static void op_named_let_no_vars(s7_scheme *sc) { - s7_pointer body = opt1_pair(sc->code); /* cdddr(sc->code) */ + s7_pointer arg = cadr(sc->code); + sc->code = opt1_pair(sc->code); /* cdddr(sc->code) */ sc->curlet = make_let(sc, sc->curlet); - sc->args = make_closure_unchecked(sc, sc->nil, body, T_CLOSURE, 0); /* sc->args is a temp here */ - add_slot_checked(sc, sc->curlet, cadr(sc->code), sc->args); - sc->code = body; + sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); /* sc->args is a temp here */ + add_slot_checked(sc, sc->curlet, arg, sc->args); } static void op_named_let_a(s7_scheme *sc) { - s7_pointer body; - sc->code = cdr(sc->code); - body = cddr(sc->code); - sc->args = fx_call(sc, cdr(opt1_pair(sc->code))); /* cdaadr(sc->code) */ + s7_pointer args; + args = cdr(sc->code); + sc->code = cddr(args); + sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) */ sc->curlet = make_let_slowly(sc, sc->curlet); - sc->w = list_1_unchecked(sc, car(opt1_pair(sc->code))); /* caaadr(sc->code), subsequent calls will need a normal list of pars in closure_args */ - sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, 1); /* picks up curlet (this is the funclet?) */ - add_slot(sc, sc->curlet, car(sc->code), sc->x); /* the function */ + sc->w = list_1_unchecked(sc, car(opt1_pair(args))); /* caaadr(args), subsequent calls will need a normal list of pars in closure_args */ + sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 1); /* picks up curlet (this is the funclet?) */ + add_slot(sc, sc->curlet, car(args), sc->x); /* the function */ sc->curlet = make_let_with_slot(sc, sc->curlet, car(sc->w), sc->args); /* why the second let? */ closure_set_let(sc->x, sc->curlet); sc->x = sc->nil; sc->w = sc->nil; - sc->code = T_Pair(body); } static void op_named_let_aa(s7_scheme *sc) { - s7_pointer body; - sc->code = cdr(sc->code); - body = cddr(sc->code); - sc->args = fx_call(sc, cdr(opt1_pair(sc->code))); /* cdaadr(sc->code) == init val of first par */ - sc->value = fx_call(sc, cdr(opt3_pair(sc->code))); /* cdadadr = init val of second */ + s7_pointer args; + args = cdr(sc->code); + sc->code = cddr(args); + sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) == init val of first par */ + sc->value = fx_call(sc, cdr(opt3_pair(args))); /* cdadadr = init val of second */ sc->curlet = make_let_slowly(sc, sc->curlet); - sc->w = list_2_unchecked(sc, car(opt1_pair(sc->code)), car(opt3_pair(sc->code))); /* subsequent calls will need a normal list of pars in closure_args */ - sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, 2); /* picks up curlet (this is the funclet?) */ - add_slot(sc, sc->curlet, car(sc->code), sc->x); /* the function */ + sc->w = list_2_unchecked(sc, car(opt1_pair(args)), car(opt3_pair(args))); /* subsequent calls will need a normal list of pars in closure_args */ + sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 2); /* picks up curlet (this is the funclet?) */ + add_slot(sc, sc->curlet, car(args), sc->x); /* the function */ sc->curlet = make_let_with_two_slots(sc, sc->curlet, car(sc->w), sc->args, cadr(sc->w), sc->value); closure_set_let(sc->x, sc->curlet); sc->x = sc->nil; sc->w = sc->nil; - sc->code = T_Pair(body); } static bool op_named_let_fx(s7_scheme *sc) @@ -75037,13 +75319,6 @@ static void op_let_one_new(s7_scheme *sc) sc->code = opt2_pair(sc->code); } -static void op_let_one_old(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args_direct(sc, OP_LET_ONE_OLD_1); - sc->code = opt2_pair(sc->code); -} - static void op_let_one_p_new(s7_scheme *sc) { sc->code = cdr(sc->code); @@ -75051,11 +75326,11 @@ static void op_let_one_p_new(s7_scheme *sc) sc->code = T_Pair(opt2_pair(sc->code)); } -static void op_let_one_p_old(s7_scheme *sc) +static void op_let_one_old(s7_scheme *sc) { sc->code = cdr(sc->code); - push_stack_no_args_direct(sc, OP_LET_ONE_P_OLD_1); - sc->code = T_Pair(opt2_pair(sc->code)); + push_stack_no_args_direct(sc, OP_LET_ONE_OLD_1); + sc->code = opt2_pair(sc->code); } static void op_let_one_old_1(s7_scheme *sc) @@ -75067,6 +75342,13 @@ static void op_let_one_old_1(s7_scheme *sc) sc->code = cdr(sc->code); } +static void op_let_one_p_old(s7_scheme *sc) +{ + sc->code = cdr(sc->code); + push_stack_no_args_direct(sc, OP_LET_ONE_P_OLD_1); + sc->code = T_Pair(opt2_pair(sc->code)); +} + static void op_let_one_p_old_1(s7_scheme *sc) { s7_pointer let; @@ -75084,11 +75366,11 @@ static Inline void op_let_a_new(s7_scheme *sc) static Inline void op_let_a_old(s7_scheme *sc) { - s7_pointer let, f = cdr(sc->code); - let = update_let_with_slot(sc, opt3_let(f), fx_call(sc, cdr(opt2_pair(f)))); + s7_pointer let; + sc->code = cdr(sc->code); + let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); let_set_outlet(let, sc->curlet); set_curlet(sc, let); - sc->code = f; } static void op_let_a_a_new(s7_scheme *sc) @@ -75418,11 +75700,10 @@ static bool check_let_star(s7_scheme *sc) (is_fxable(sc, cadr(code)))) { fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_LET_STAR_FX_A); /* does this ever happen? */ + pair_set_syntax_op(form, OP_LET_STAR_FX_A); }} else pair_set_syntax_op(form, OP_LET_STAR2); set_opt2_con(code, cadaar(code)); - for (last_var = caaar(code), vars = cdar(code); is_pair(vars); last_var = caar(vars), vars = cdr(vars)) if (has_fx(cdar(vars))) fx_tree(sc, cdar(vars), last_var, NULL, NULL, true); /* actually there's isn't a new let unless it's needed */ @@ -75885,26 +76166,31 @@ static goto_t op_let_temp_init2(s7_scheme *sc) new_value = caar(p); set_car(p, cdar(p)); car(sc->args) = cdar(sc->args); - if ((!is_symbol(settee)) || /* (let-temporarily (((*s7* 'print-length) 32)) ...) */ - (symbol_has_setter(settee)) || /* ((*features* #f))... */ - (is_pair(new_value))) /* ((line-number (if (eq? caller top-level:) -1 line-number)))... */ + if ((!is_symbol(settee)) || (is_pair(new_value))) { - push_stack_direct(sc, OP_LET_TEMP_INIT2); - sc->code = list_3(sc, sc->set_symbol, settee, new_value); - return(goto_top_no_pop); + if (is_symbol(settee)) + { + push_stack_direct(sc, OP_LET_TEMP_INIT2); /* (let-temporarily (((*s7* 'print-length) 32)) ...) */ + push_stack_no_args(sc, OP_SET_FROM_LET_TEMP, settee); + sc->code = new_value; + return(goto_eval); + } + sc->code = set_plist_3(sc, sc->set_symbol, settee, new_value); + push_stack_direct(sc, OP_EVAL_DONE); + eval(sc, OP_SET_UNCHECKED); + continue; } slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) - unbound_variable_error(sc, settee); - if (is_immutable_slot(slot)) - immutable_object_error(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); - slot_set_value(slot, new_value); + if (!is_slot(slot)) unbound_variable_error(sc, settee); + if (is_immutable_slot(slot)) immutable_object_error(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); + /* if ((symbol_has_setter(settee)) && (!slot_has_setter(slot))) settee is local with no setter, but its global binding does have a setter */ + if (slot_has_setter(slot)) + slot_set_value(slot, call_setter(sc, slot, new_value)); + else slot_set_value(slot, new_value); } car(sc->args) = cadr(sc->args); pop_stack(sc); - /* push_stack_direct(sc, OP_LET_TEMP_DONE); */ /* we fall into LET_TEMP_DONE below so this seems redundant */ sc->code = cdr(sc->code); if (is_pair(sc->code)) { @@ -75935,19 +76221,21 @@ static bool op_let_temp_done1(s7_scheme *sc) else { s7_pointer slot; - if ((!is_symbol(settee)) || - (symbol_has_setter(settee))) /* (let-temporarily ((x 1))...) -> (set! x 0) if x has a setter */ - { - push_stack_direct(sc, OP_LET_TEMP_DONE1); - if ((is_pair(sc->value)) || (is_symbol(sc->value))) /* (let-temporarily ((*load-path* ())) 32) here: (set! *load-path* '(".")) */ - sc->code = list_3(sc, sc->set_symbol, settee, list_2(sc, sc->quote_symbol, sc->value)); - else sc->code = list_3(sc, sc->set_symbol, settee, sc->value); - return(false); /* goto eval */ + if (!is_symbol(settee)) + { + if ((is_pair(sc->value)) || (is_symbol(sc->value))) + sc->code = set_plist_3(sc, sc->set_symbol, settee, set_plist_2(sc, sc->quote_symbol, sc->value)); + else sc->code = set_plist_3(sc, sc->set_symbol, settee, sc->value); + push_stack_direct(sc, OP_EVAL_DONE); + eval(sc, OP_SET_UNCHECKED); + continue; } slot = lookup_slot_from(settee, sc->curlet); if (is_immutable_slot(slot)) immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - slot_set_value(slot, sc->value); + if (slot_has_setter(slot)) /* maybe setter changed in let-temp body? else setter has already checked the init value */ + slot_set_value(slot, call_setter(sc, slot, sc->value)); + else slot_set_value(slot, sc->value); }} pop_stack(sc); /* remove the gc_protect */ sc->value = sc->code; @@ -75989,7 +76277,7 @@ static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value if (slot_has_setter(slot)) /* setter has to be called because it might affect other vars (*clm-srate* -> mus-srate etc), but it should not change sc->value */ { s7_pointer old_value = sc->value; - slot_set_value(slot, s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); + slot_set_value(slot, call_setter(sc, slot, new_value)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); */ sc->value = old_value; } else slot_set_value(slot, new_value); @@ -76019,7 +76307,7 @@ static bool op_let_temp_fx(s7_scheme *sc) /* all entries are of the form (symbol new_val = fx_call(sc, cdr(var)); slot = end[0]; if (slot_has_setter(slot)) - slot_set_value(slot, s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); + slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ else slot_set_value(slot, new_val); } sc->code = cdr(sc->code); @@ -76040,7 +76328,7 @@ static bool op_let_temp_fx_1(s7_scheme *sc) /* one entry */ push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); new_val = fx_call(sc, cdr(var)); if (slot_has_setter(slot)) - slot_set_value(slot, s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); + slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ else slot_set_value(slot, new_val); sc->code = cdr(sc->code); return(is_pair(sc->code)); /* sc->code can be null if no body */ @@ -76275,6 +76563,20 @@ static void fx_safe_closure_tree(s7_scheme *sc) }} } +static void fb_annotate(s7_scheme *sc, s7_pointer form, s7_function fx, opcode_t op) +{ + s7_pointer bfunc; + bfunc = fx_to_fb(sc, fx); + if (bfunc) + { + set_opt3_any(cdr(form), bfunc); + pair_set_syntax_op(form, op); + } +#if 0 + else fprintf(stderr, "%s %s: %s\n", op_names[op], op_names[optimize_op((op == OP_IF_B_N_N) ? cadadr(form) : cadr(form))], display_80(form)); +#endif +} + #define choose_if_optc(Opc, One, Reversed, Not) ((One) ? ((Reversed) ? OP_ ## Opc ## _R : ((Not) ? OP_ ## Opc ## _N : OP_ ## Opc ## _P)) : ((Not) ? OP_ ## Opc ## _N_N : OP_ ## Opc ## _P_P)) static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool reversed) /* cdr(form) == sc->code */ @@ -76378,15 +76680,22 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re } else set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((optimize_op(form) == OP_IF_A_P) && - (is_fxable(sc, cadr(code)))) + if (optimize_op(form) == OP_IF_A_P) { - pair_set_syntax_op(form, OP_IF_A_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_opt1_pair(form, cdr(code)); - fx_safe_closure_tree(sc); - if (fx_proc(code) == fx_gt_tu) {set_opt2_pair(form, cdr(test)); pair_set_syntax_op(form, OP_IF_GT_A);} + if (is_fxable(sc, cadr(code))) + { + pair_set_syntax_op(form, OP_IF_A_A); + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_opt1_pair(form, cdr(code)); + fx_safe_closure_tree(sc); + fb_annotate(sc, form, fx_proc(code), OP_IF_B_A); + } + else fb_annotate(sc, form, fx_proc(code), OP_IF_B_P); } + if (optimize_op(form) == OP_IF_A_R) + fb_annotate(sc, form, fx_proc(code), OP_IF_B_R); + if (optimize_op(form) == OP_IF_A_N_N) + fb_annotate(sc, form, fx_proc(cdar(code)), OP_IF_B_N_N); if (optimize_op(form) == OP_IF_A_P_P) { if (is_fxable(sc, cadr(code))) @@ -76394,10 +76703,14 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re set_opt1_pair(form, cdr(code)); if (is_fxable(sc, caddr(code))) { - pair_set_syntax_op(form, OP_IF_A_A_A); + pair_set_syntax_op(form, OP_IF_A_A_A); /* b_a_a never happens? */ set_opt2_pair(form, cddr(code)); } - else pair_set_syntax_op(form, OP_IF_A_A_P); + else + { + pair_set_syntax_op(form, OP_IF_A_A_P); + fb_annotate(sc, form, fx_proc(code), OP_IF_B_A_P); + } fx_annotate_args(sc, cdr(code), sc->curlet); fx_safe_closure_tree(sc); } @@ -76408,7 +76721,10 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re fx_annotate_args(sc, cdr(code), sc->curlet); set_opt2_pair(form, cddr(code)); fx_safe_closure_tree(sc); - }}} + fb_annotate(sc, form, fx_proc(code), OP_IF_B_P_A); + } + else fb_annotate(sc, form, fx_proc(code), OP_IF_B_P_P); + }} else { pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); @@ -76466,7 +76782,6 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re static s7_pointer check_if(s7_scheme *sc, s7_pointer form) { s7_pointer cdr_code, code = cdr(form); - if (!is_pair(code)) /* (if) or (if . 1) */ eval_error(sc, "(if): if needs at least 2 expressions: ~A", 41, form); @@ -76651,8 +76966,7 @@ static bool op_when_pp(s7_scheme *sc) /* -------------------------------- unless -------------------------------- */ static void check_unless(s7_scheme *sc) { - s7_pointer form = sc->code, code; - code = cdr(sc->code); + s7_pointer form = sc->code, code = cdr(sc->code); if (!is_pair(code)) /* (unless) or (unless . 1) */ eval_error(sc, "unless has no expression or body: ~A", 37, form); @@ -77317,6 +77631,7 @@ static goto_t op_macroexpand(s7_scheme *sc) if ((!is_pair(sc->code)) || (!is_pair(car(sc->code)))) eval_error(sc, "macroexpand argument is not a macro call: ~A", 44, form); + if (!is_null(cdr(sc->code))) eval_error(sc, "macroexpand: too many arguments: ~A", 35, form); @@ -77327,8 +77642,10 @@ static goto_t op_macroexpand(s7_scheme *sc) return(goto_eval); } - /* sc->args = copy_proper_list(sc, cdar(sc->code)); */ sc->args = cdar(sc->code); + if (!is_list(sc->args)) /* (macroexpand (mac . 7)) */ + eval_error(sc, "can't macroexpand ~S: the macro's argument list is not a list", 61, car(sc->code)); + if (!is_symbol(caar(sc->code))) { if (!is_any_macro(caar(sc->code))) @@ -77342,7 +77659,6 @@ static goto_t op_macroexpand(s7_scheme *sc) static goto_t op_macroexpand_1(s7_scheme *sc) { - /* sc->args = copy_proper_list(sc, cdar(sc->code)); */ sc->args = cdar(sc->code); sc->code = sc->value; return(macroexpand(sc)); @@ -77488,8 +77804,7 @@ static void activate_with_let(s7_scheme *sc, s7_pointer e) static void check_cond(s7_scheme *sc) { bool has_feed_to = false, result_fx = true, result_single = true; - s7_pointer x, code, form = sc->code; - code = cdr(form); + s7_pointer x, code = cdr(sc->code), form = sc->code; if (!is_pair(code)) /* (cond) or (cond . 1) */ eval_error(sc, "cond, but no body: ~A", 21, form); @@ -77667,7 +77982,7 @@ static bool op_cond1(s7_scheme *sc) pop_stack(sc); return(true); } - sc->code = cdr(sc->code); + sc->code = cdr(sc->code); /* go to next clause */ if (is_null(sc->code)) { sc->value = sc->unspecified; /* changed 31-Dec-15 */ @@ -77831,15 +78146,13 @@ static inline bool fx_cond_value(s7_scheme *sc, s7_pointer p) static bool op_cond_fx_2e(s7_scheme *sc) { - s7_pointer p; - p = cdr(sc->code); + s7_pointer p = cdr(sc->code); return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p))); } static bool op_cond_fx_3e(s7_scheme *sc) { - s7_pointer p; - p = cdr(sc->code); + s7_pointer p = cdr(sc->code); if (is_true(sc, fx_call(sc, car(p)))) return(fx_cond_value(sc, cdar(p))); p = cdr(p); @@ -77914,8 +78227,7 @@ static void set_dilambda_opt(s7_scheme *sc, s7_pointer form, opcode_t opt, s7_po (is_closure(closure_setter(func))) && (is_safe_closure(closure_setter(func)))) { - s7_pointer setter; - setter = closure_setter(func); + s7_pointer setter = closure_setter(func); pair_set_syntax_op(form, opt); if ((!(is_let(closure_let(setter)))) || (!(is_funclet(closure_let(setter))))) @@ -77923,11 +78235,9 @@ static void set_dilambda_opt(s7_scheme *sc, s7_pointer form, opcode_t opt, s7_po } } -static inline void check_set(s7_scheme *sc) +static void check_set(s7_scheme *sc) { - s7_pointer form = sc->code, code; - code = cdr(form); - + s7_pointer form = sc->code, code = cdr(sc->code); if (!is_pair(code)) { if (is_null(code)) /* (set!) */ @@ -77964,7 +78274,7 @@ static inline void check_set(s7_scheme *sc) /* here we have (set! (...) ...) */ s7_pointer inner = car(code), value = cadr(code); - pair_set_syntax_op(form, OP_SET_UNCHECKED); + pair_set_syntax_op(form, OP_SET_UNCHECKED); /* if not pair car, op_set_normal below */ if (is_symbol(car(inner))) { if ((is_null(cdr(inner))) && @@ -78215,6 +78525,17 @@ static void op_set_symbol_a(s7_scheme *sc) slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code))); } +static void op_set_from_let_temp(s7_scheme *sc) +{ + s7_pointer settee = sc->code, slot; + slot = lookup_slot_from(settee, sc->curlet); + if (!is_slot(slot)) unbound_variable_error(sc, settee); + if (is_immutable_slot(slot)) immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); + if (slot_has_setter(slot)) + slot_set_value(slot, call_setter(sc, slot, sc->value)); + else slot_set_value(slot, sc->value); +} + static inline void op_set_cons(s7_scheme *sc) { s7_pointer slot; @@ -78485,7 +78806,7 @@ static s7_pointer op_set1(s7_scheme *sc) if (is_slot(lx)) { if (is_immutable(lx)) - immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, lx)); + immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, slot_symbol(lx))); if (slot_has_setter(lx)) { s7_pointer func = slot_setter(lx); @@ -78557,14 +78878,17 @@ static goto_t op_set2(s7_scheme *sc) */ if (sc->args == sc->nil) eval_error(sc, "vector set!: not enough arguments: ~S", 37, sc->code); - push_op_stack(sc, sc->vector_set_function); if (!is_null(cdr(sc->args))) sc->code = pair_append(sc, cdr(sc->args), sc->code); push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), T_Pair(sc->code)); sc->code = car(sc->args); return(goto_eval); } +#if 0 sc->code = cons_unchecked(sc, sc->set_symbol, cons_unchecked(sc, cons(sc, sc->value, sc->args), sc->code)); /* (let ((x 32)) (set! ((curlet) 'x) 3) x) */ +#else + sc->code = set_ulist_2(sc, sc->set_symbol, set_ulist_1(sc, sc->value, sc->args), sc->code); +#endif return(set_implicit(sc)); } @@ -78594,12 +78918,12 @@ static bool op_set_with_let_1(s7_scheme *sc) return(true); } sc->value = lookup_checked(sc, e); - sc->code = list_3(sc, sc->set_symbol, b, ((is_symbol(x)) || (is_pair(x))) ? set_plist_2(sc, sc->quote_symbol, x) : x); + sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x)) || (is_pair(x))) ? set_plist_2(sc, sc->quote_symbol, x) : x); /* (let* ((x (vector 1 2)) (lt (curlet))) (set! (with-let lt (x 0)) 32) x) here: (set! (x 0) 32) */ return(false); /* goto SET_WITH_LET */ } - sc->code = e; /* 'e above, an expression we need to evaluate */ - sc->args = list_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */ + sc->code = e; /* 'e above, an expression we need to evaluate */ + sc->args = set_plist_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */ push_stack_direct(sc, OP_SET_WITH_LET_2); sc->cur_op = optimize_op(sc->code); return(true); /* goto top_no_pop */ @@ -78619,8 +78943,8 @@ static bool op_set_with_let_2(s7_scheme *sc) return(true); /* goto START */ } if ((is_symbol(x)) || (is_pair(x))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */ - sc->code = list_3(sc, sc->set_symbol, b, ((is_symbol(x)) || (is_pair(x))) ? set_plist_2(sc, sc->quote_symbol, x) : x); - else sc->code = cons(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), x=16 b=(*s7* 'print-length) */ + sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x)) || (is_pair(x))) ? set_plist_2(sc, sc->quote_symbol, x) : x); + else sc->code = set_ulist_1(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), x=16 b=(*s7* 'print-length) */ return(false); /* fall into SET_WITH_LET */ } @@ -78716,7 +79040,7 @@ static goto_t op_implicit_string_ref_a(s7_scheme *sc) index = s7_integer_checked(sc, x); if ((index < string_length(s)) && (index >= 0)) { - sc->value = s7_make_character(sc, ((uint8_t *)string_value(s))[index]); + sc->value = chars[((uint8_t *)string_value(s))[index]]; return(goto_start); } sc->value = string_ref_1(sc, s, x); @@ -78787,11 +79111,12 @@ static inline bool op_implicit_vector_set_3(s7_scheme *sc) pair_set_syntax_op(sc->code, OP_SET_UNCHECKED); return(true); } - i1 = fx_call(sc, cdar(code)); + i1 = fx_call(sc, cdar(code)); /* gc protect? */ set_car(sc->t3_3, fx_call(sc, cdr(code))); set_car(sc->t3_1, v); set_car(sc->t3_2, i1); - sc->value = g_vector_set_3(sc, sc->t3_1); + sc->value = g_vector_set_3(sc, sc->t3_1); /* calls vector_setter handling any vector type whereas vector_set_p_ppp wants a normal vector */ + /* sc->value = vector_set_p_ppp(sc, v, i1, fx_call(sc, cdr(code))); */ return(false); } @@ -78819,11 +79144,14 @@ static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer cx, s7_pointer for { s7_pointer settee, index, val; - if (!is_pair(cdr(sc->code))) - s7_wrong_number_of_args_error(sc, "no value for object-set!: ~S", form); - if (!is_null(cddr(sc->code))) - s7_wrong_number_of_args_error(sc, "too many values for object-set!: ~S", form); - + if (!implicit_set_ok(sc->code)) + { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, "no value for object-set!: ~S", form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, "too many values for object-set!: ~S", form); + set_implicit_set_ok(sc->code); + } settee = car(sc->code); if ((!is_pair(cdr(settee))) || (!is_null(cddr(settee)))) @@ -78875,17 +79203,19 @@ static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer cx, s7_pointer for static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form) { /* cx is the vector, sc->code is expr without the set!, form is the full expr, args have not been evaluated! */ - s7_pointer settee, index; + s7_pointer settee = car(sc->code), index; s7_int argnum; - if (!is_pair(cdr(sc->code))) /* (set! (v 0)) */ - s7_wrong_number_of_args_error(sc, "no value for vector-set!: ~S", form); - if (!is_null(cddr(sc->code))) /* (set! (v 0) 1 2) */ - s7_wrong_number_of_args_error(sc, "too many values for vector-set!: ~S", form); - - settee = car(sc->code); - if (!is_pair(cdr(settee))) - s7_wrong_number_of_args_error(sc, "no index for vector-set!: ~S", form); + if (!implicit_set_ok(sc->code)) + { + if (!is_pair(cdr(sc->code))) /* (set! (v 0)) */ + s7_wrong_number_of_args_error(sc, "no value for vector-set!: ~S", form); + if (!is_null(cddr(sc->code))) /* (set! (v 0) 1 2) */ + s7_wrong_number_of_args_error(sc, "too many values for vector-set!: ~S", form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, "no index for vector-set!: ~S", form); + set_implicit_set_ok(sc->code); + } if (is_immutable(cx)) immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, cx)); @@ -79002,15 +79332,16 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form) static goto_t set_implicit_string(s7_scheme *sc, s7_pointer cx, s7_pointer form) { /* here only one index makes sense, and it is required, so (set! ("str") #\a), (set! ("str" . 1) #\a) and (set! ("str" 1 2) #\a) are all errors (but see below!) */ - s7_pointer settee, index, val; - - if (!is_pair(cdr(sc->code))) s7_wrong_number_of_args_error(sc, "no value for string-set!: ~S", form); - if (!is_null(cddr(sc->code))) s7_wrong_number_of_args_error(sc, "too many values for string-set!: ~S", form); - - settee = car(sc->code); - if (!is_pair(cdr(settee))) s7_wrong_number_of_args_error(sc, "no index for string-set!: ~S", form); - if (!is_null(cddr(settee))) s7_wrong_number_of_args_error(sc, "too many indices for string-set!: ~S", form); + s7_pointer settee = car(sc->code), index, val; + if (!implicit_set_ok(sc->code)) + { + if (!is_pair(cdr(sc->code))) s7_wrong_number_of_args_error(sc, "no value for string-set!: ~S", form); + if (!is_null(cddr(sc->code))) s7_wrong_number_of_args_error(sc, "too many values for string-set!: ~S", form); + if (!is_pair(cdr(settee))) s7_wrong_number_of_args_error(sc, "no index for string-set!: ~S", form); + if (!is_null(cddr(settee))) s7_wrong_number_of_args_error(sc, "too many indices for string-set!: ~S", form); + set_implicit_set_ok(sc->code); + } /* if there's one index (the standard case), and it is not a pair, and there's one value (also standard) * and it is not a pair, let's optimize this thing! * cx is what we're setting, cadar is the index, cadr is the new value @@ -79058,17 +79389,18 @@ static goto_t set_implicit_string(s7_scheme *sc, s7_pointer cx, s7_pointer form) static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer cx, s7_pointer form) /* code: ((lst 1) 32) from (let ((lst (list 1 2 3))) (set! (lst 1) 32)) */ { - s7_pointer settee, index, val; - - if (!is_pair(cdr(sc->code))) - s7_wrong_number_of_args_error(sc, "no value for list-set!: ~S", form); - if (!is_null(cddr(sc->code))) - s7_wrong_number_of_args_error(sc, "too many values for list-set!: ~S", form); - - settee = car(sc->code); - if (!is_pair(cdr(settee))) - s7_wrong_number_of_args_error(sc, "no index for list-set!: ~S", form); + s7_pointer settee = car(sc->code), index, val; + if (!implicit_set_ok(sc->code)) + { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, "no value for list-set!: ~S", form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, "too many values for list-set!: ~S", form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, "no index for list-set!: ~S", form); + set_implicit_set_ok(sc->code); + } if (!is_null(cddr(settee))) { /* split (set! (a b c...) v) into (set! ((a b) c ...) v), eval (a b), return @@ -79107,16 +79439,18 @@ static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer cx, s7_pointer form) static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer cx, s7_pointer form) { - s7_pointer settee, key; - - if (!is_pair(cdr(sc->code))) - s7_wrong_number_of_args_error(sc, "no value for hash-table-set!: ~S", form); - if (!is_null(cddr(sc->code))) - s7_wrong_number_of_args_error(sc, "too many values for hash-table-set!: ~S", form); + s7_pointer settee = car(sc->code), key; - settee = car(sc->code); - if (!is_pair(cdr(settee))) - s7_wrong_number_of_args_error(sc, "no key for hash-table-set!: ~S", form); + if (!implicit_set_ok(sc->code)) + { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, "no value for hash-table-set!: ~S", form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, "too many values for hash-table-set!: ~S", form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, "no key for hash-table-set!: ~S", form); + set_implicit_set_ok(sc->code); + } if (is_immutable(cx)) immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, cx)); @@ -79156,17 +79490,19 @@ static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer cx, s7_pointer f static goto_t set_implicit_let(s7_scheme *sc, s7_pointer cx, s7_pointer form) { - s7_pointer settee, key; + s7_pointer settee = car(sc->code), key; /* code: ((gen 'input) input) from (set! (gen 'input) input) */ - if (!is_pair(cdr(sc->code))) - s7_wrong_number_of_args_error(sc, "no value for let-set!: ~S", form); - if (!is_null(cddr(sc->code))) - s7_wrong_number_of_args_error(sc, "too many values for let-set!: ~S", form); - - settee = car(sc->code); - if (!is_pair(cdr(settee))) - s7_wrong_number_of_args_error(sc, "no symbol (variable name) for let-set!: ~S", form); + if (!implicit_set_ok(sc->code)) + { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, "no value for let-set!: ~S", form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, "too many values for let-set!: ~S", form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, "no symbol (variable name) for let-set!: ~S", form); + set_implicit_set_ok(sc->code); + } if (!is_null(cddr(settee))) { push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); @@ -79177,9 +79513,8 @@ static goto_t set_implicit_let(s7_scheme *sc, s7_pointer cx, s7_pointer form) key = cadr(settee); if (is_proper_quote(sc, key)) { - s7_pointer val; + s7_pointer val = cadr(sc->code); key = cadr(key); - val = cadr(sc->code); if (!is_pair(val)) { if (is_symbol(val)) @@ -79327,8 +79662,7 @@ static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer cx) static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer cx) { - s7_pointer setter; - setter = iterator_sequence(cx); + s7_pointer setter = iterator_sequence(cx); if ((is_any_closure(setter)) || (is_any_macro(setter))) setter = closure_setter(iterator_sequence(cx)); else setter = sc->F; @@ -79371,14 +79705,6 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) .. s7_pointer caar_code, cx, form = sc->code; sc->code = cdr(sc->code); caar_code = caar(sc->code); - if (is_pair(caar_code)) - { - push_stack(sc, OP_SET2, cdar(sc->code), T_Pair(cdr(sc->code))); - sc->code = caar_code; - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - if (is_symbol(caar_code)) { /* this was cx = s7_symbol_value(sc, caar_code) but the function call overhead is noticeable */ @@ -79387,7 +79713,15 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) .. cx = slot_value(cx); else s7_error(sc, sc->syntax_error_symbol, set_elist_3(sc, no_setter_string, caar_code, sc->prepackaged_type_names[type(cx)])); } - else cx = caar_code; + else + if (is_pair(caar_code)) + { + push_stack(sc, OP_SET2, cdar(sc->code), T_Pair(cdr(sc->code))); + sc->code = caar_code; + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); + } + else cx = caar_code; /* code here is the setter and the value without the "set!": ((window-width) 800) */ /* (set! (hi 0) (* 2 3)) -> ((hi 0) (* 2 3)) */ @@ -79493,19 +79827,15 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) { s7_pointer var; - if (!is_pair(car(vars))) - return(false); + if (!is_pair(car(vars))) return(false); var = caar(vars); - if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? cp : var_list)) - return(false); - if ((!is_symbol(var)) || (is_keyword(var))) - return(false); + if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? cp : var_list)) return(false); + if ((!is_symbol(var)) || (is_keyword(var))) return(false); cp = cons(sc, var, cp); sc->x = cp; } sc->x = sc->nil; - if (!do_is_safe(sc, cddr(expr), stepper, cp, has_set)) - return(false); + if (!do_is_safe(sc, cddr(expr), stepper, cp, has_set)) return(false); break; case OP_DO: @@ -79515,12 +79845,9 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) { s7_pointer var; - if (!is_pair(car(vars))) - return(false); + if (!is_pair(car(vars))) return(false); var = caar(vars); - if ((direct_memq(var, cp)) || (var == stepper)) - return(false); - + if ((direct_memq(var, cp)) || (var == stepper)) return(false); cp = cons(sc, var, cp); sc->x = cp; if ((is_pair(cdar(vars))) && @@ -79530,8 +79857,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po return(false); }} sc->x = sc->nil; - if (!do_is_safe(sc, caddr(expr), stepper, cp, has_set)) - return(false); + if (!do_is_safe(sc, caddr(expr), stepper, cp, has_set)) return(false); if ((is_pair(cdddr(expr))) && (!do_is_safe(sc, cdddr(expr), stepper, cp, has_set))) return(false); @@ -79566,14 +79892,12 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po set_match_symbol(settee); res = tree_match(caaddr(sc->code)); /* (set! end ...) in some fashion */ clear_match_symbol(settee); - if (res) - return(false); + if (res) return(false); } if ((has_set) && (!direct_memq(cadr(expr), var_list))) /* is some non-local variable being set? */ (*has_set) = true; } - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) - return(false); + if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) return(false); if (!safe_stepper_expr(expr, stepper)) /* is step var's value used as the stored value by set!? */ return(false); } @@ -79589,8 +79913,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po (!is_pair(cdar(cp))) || (!do_is_safe(sc, cdar(cp), stepper, var_list, has_set))) return(false); - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) - return(false); + if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) return(false); break; case OP_COND: @@ -80586,7 +80909,6 @@ static goto_t op_dox(s7_scheme *sc) bodyf(sc); slot_set_value(stepper, make_integer(sc, ++i)); } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); return(goto_do_end_clauses); } @@ -80865,7 +81187,8 @@ static void op_dox_no_body(s7_scheme *sc) test = caadr(sc->code); result = cdadr(sc->code); - if (!in_heap(sc->code)) + if ((!in_heap(sc->code)) && + (is_let(opt3_any(sc->code)))) /* (*repl* 'keymap) anything -> segfault because opt3_any here is #f. (see line 80517) */ { s7_pointer let; let = update_let_with_slot(sc, opt3_any(sc->code), fx_call(sc, cdr(var))); @@ -81658,19 +81981,19 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf { if (fp == opt_if_bp) { - for (; integer(stepper) < end; integer(stepper)++) + for (; integer(stepper) < end; integer(stepper)++) if (o->v[3].fb(o->v[2].o1)) o->v[5].fp(o->v[4].o1); } else if (fp == opt_if_nbp_fs) { - for (; integer(stepper) < end; integer(stepper)++) + for (; integer(stepper) < end; integer(stepper)++) if (!(o->v[2].b_pi_f(sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) o->v[11].fp(o->v[10].o1); } else if (fp == opt_unless_p_1) { - for (; integer(stepper) < end; integer(stepper)++) + for (; integer(stepper) < end; integer(stepper)++) if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1); } else for (; integer(stepper) < end; integer(stepper)++) fp(o); @@ -81765,9 +82088,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf func(sc); step = integer(slot_value(step_slot)) + 1; } -#if S7_DEBUGGING - if (stop != integer(slot_value(end_slot))) fprintf(stderr, "end: %ld %ld\n", stop, integer(slot_value(end_slot))); -#endif + if ((S7_DEBUGGING) && (stop != integer(slot_value(end_slot)))) fprintf(stderr, "end: %" ld64 " %" ld64 "\n", stop, integer(slot_value(end_slot))); } sc->value = sc->T; sc->code = cdadr(scc); @@ -82515,7 +82836,7 @@ static goto_t op_read_s(s7_scheme *sc) port = lookup(sc, cadr(sc->code)); if (!is_input_port(port)) /* was also not stdin */ { - sc->value = g_read(sc, list_1(sc, port)); + sc->value = g_read(sc, set_plist_1(sc, port)); return(goto_start); } if (port_is_closed(port)) /* I guess the port_is_closed check is needed because we're going down a level below */ @@ -82645,7 +82966,7 @@ static void op_set_pws(s7_scheme *sc) /* -------------------------------- apply functions -------------------------------- */ -static void apply_c_function(s7_scheme *sc) /* -------- C-based function -------- */ +static void apply_c_function(s7_scheme *sc) /* -------- C-based function -------- */ { s7_int len; len = proper_list_length(sc->args); @@ -82660,7 +82981,7 @@ static void apply_c_function(s7_scheme *sc) /* -------- C-b */ } -static void apply_c_opt_args_function(s7_scheme *sc) /* -------- C-based function that has n optional arguments -------- */ +static void apply_c_opt_args_function(s7_scheme *sc) /* -------- C-based function that has n optional arguments -------- */ { s7_int len; len = proper_list_length(sc->args); @@ -82669,7 +82990,7 @@ static void apply_c_opt_args_function(s7_scheme *sc) /* -------- sc->value = c_function_call(sc->code)(sc, sc->args); } -static void apply_c_rst_args_function(s7_scheme *sc) /* -------- C-based function that has n required args, then any others -------- */ +static void apply_c_rst_args_function(s7_scheme *sc) /* -------- C-based function that has n required args, then any others -------- */ { s7_int len; len = proper_list_length(sc->args); @@ -82679,12 +83000,12 @@ static void apply_c_rst_args_function(s7_scheme *sc) /* -------- /* sc->code here need not match sc->code before the function call (map for example) */ } -static void apply_c_any_args_function(s7_scheme *sc) /* -------- C-based function that can take any number of arguments -------- */ +static void apply_c_any_args_function(s7_scheme *sc) /* -------- C-based function that can take any number of arguments -------- */ { sc->value = c_function_call(sc->code)(sc, sc->args); } -static void apply_c_macro(s7_scheme *sc) /* -------- C-based macro -------- */ +static void apply_c_macro(s7_scheme *sc) /* -------- C-based macro -------- */ { s7_int len; len = proper_list_length(sc->args); @@ -82695,10 +83016,10 @@ static void apply_c_macro(s7_scheme *sc) /* -------- C-bas sc->code = c_macro_call(sc->code)(sc, sc->args); } -static void apply_syntax(s7_scheme *sc) /* -------- syntactic keyword as applicable object -------- */ -{ /* current reader-cond macro uses this via (map quote ...) */ - s7_int len; /* ((apply lambda '((x) (+ x 1))) 4) */ - if (is_pair(sc->args)) /* this is ((pars) . body) */ +static void apply_syntax(s7_scheme *sc) /* -------- syntactic keyword as applicable object -------- */ +{ /* current reader-cond macro uses this via (map quote ...) */ + s7_int len; /* ((apply lambda '((x) (+ x 1))) 4) */ + if (is_pair(sc->args)) /* this is ((pars) . body) */ { len = s7_list_length(sc, sc->args); if (len == 0) @@ -82717,13 +83038,13 @@ static void apply_syntax(s7_scheme *sc) /* -------- s (syntax_max_args(sc->code) != -1)) s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); - sc->cur_op = (opcode_t)syntax_opcode(sc->code); /* (apply begin '((define x 3) (+ x 2))) */ + sc->cur_op = (opcode_t)syntax_opcode(sc->code); /* (apply begin '((define x 3) (+ x 2))) */ /* I had elaborate checks here for embedded circular lists, but now I think that is the caller's problem */ sc->code = cons(sc, sc->code, sc->args); pair_set_syntax_op(sc->code, sc->cur_op); } -static void apply_vector(s7_scheme *sc) /* -------- vector as applicable object -------- */ +static void apply_vector(s7_scheme *sc) /* -------- vector as applicable object -------- */ { /* sc->code is the vector, sc->args is the list of indices */ if (is_null(sc->args)) /* (#2d((1 2) (3 4))) */ @@ -82742,7 +83063,7 @@ static void apply_vector(s7_scheme *sc) /* -------- v else sc->value = vector_ref_1(sc, sc->code, sc->args); } -static void apply_string(s7_scheme *sc) /* -------- string as applicable object -------- */ +static void apply_string(s7_scheme *sc) /* -------- string as applicable object -------- */ { if ((is_pair(sc->args)) && (is_null(cdr(sc->args)))) @@ -82753,7 +83074,7 @@ static void apply_string(s7_scheme *sc) /* -------- s if ((index >= 0) && (index < string_length(sc->code))) { - sc->value = s7_make_character(sc, ((uint8_t *)string_value(sc->code))[index]); + sc->value = chars[((uint8_t *)string_value(sc->code))[index]]; return; }} sc->value = string_ref_1(sc, sc->code, car(sc->args)); @@ -82763,12 +83084,12 @@ static void apply_string(s7_scheme *sc) /* -------- s set_elist_3(sc, (is_null(sc->args)) ? not_enough_arguments_string : too_many_arguments_string, sc->code, sc->args)); } -static bool apply_pair(s7_scheme *sc) /* -------- list as applicable object -------- */ +static bool apply_pair(s7_scheme *sc) /* -------- list as applicable object -------- */ { - if (is_multiple_value(sc->code)) /* ((values 1 2 3) 0) */ + if (is_multiple_value(sc->code)) /* ((values 1 2 3) 0) */ { /* car of values can be anything, so conjure up a new expression, and apply again */ - sc->x = multiple_value(sc->code); /* ((values + 1 2) 3) */ + sc->x = multiple_value(sc->code); /* ((values + 1 2) 3) */ sc->code = car(sc->x); sc->args = pair_append(sc, cdr(sc->x), sc->args); sc->x = sc->nil; @@ -82776,13 +83097,13 @@ static bool apply_pair(s7_scheme *sc) /* -------- } if (is_null(sc->args)) s7_wrong_number_of_args_error(sc, "not enough arguments for list-ref (via list as applicable object): ~A", sc->args); - sc->value = list_ref_1(sc, sc->code, car(sc->args)); /* (L 1) */ + sc->value = list_ref_1(sc, sc->code, car(sc->args)); /* (L 1) */ if (!is_null(cdr(sc->args))) sc->value = implicit_index(sc, sc->value, cdr(sc->args)); /* (L 1 2) */ return(true); } -static void apply_hash_table(s7_scheme *sc) /* -------- hash-table as applicable object -------- */ +static void apply_hash_table(s7_scheme *sc) /* -------- hash-table as applicable object -------- */ { if (is_null(sc->args)) s7_wrong_number_of_args_error(sc, "not enough arguments for hash-table-ref (via hash table as applicable object): ~A", sc->args); @@ -82791,7 +83112,7 @@ static void apply_hash_table(s7_scheme *sc) /* -------- h sc->value = implicit_index(sc, sc->value, cdr(sc->args)); } -static void apply_let(s7_scheme *sc) /* -------- environment as applicable object -------- */ +static void apply_let(s7_scheme *sc) /* -------- environment as applicable object -------- */ { if (is_null(sc->args)) wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, sc->args, a_symbol_string); @@ -82803,14 +83124,14 @@ static void apply_let(s7_scheme *sc) /* -------- e */ } -static void apply_iterator(s7_scheme *sc) /* -------- iterator as applicable object -------- */ +static void apply_iterator(s7_scheme *sc) /* -------- iterator as applicable object -------- */ { if (!is_null(sc->args)) s7_wrong_number_of_args_error(sc, "too many arguments for iterator: ~A", sc->args); sc->value = s7_iterate(sc, sc->code); } -static Inline void apply_lambda(s7_scheme *sc) /* -------- normal function (lambda), or macro -------- */ +static Inline void apply_lambda(s7_scheme *sc) /* -------- normal function (lambda), or macro -------- */ { /* load up the current args into the ((args) (lambda)) layout [via the current environment] */ s7_pointer x, z, e = sc->curlet, sym, slot, last_slot; uint64_t id; @@ -82877,8 +83198,7 @@ static s7_pointer star_set(s7_scheme *sc, s7_pointer slot, s7_pointer val, bool return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args))); if ((check_rest) && (is_rest_slot(slot))) return(s7_error(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest arg ~S to ~S via keyword", 39), - slot_symbol(slot), val))); + set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), slot_symbol(slot), val))); set_checked_slot(slot); slot_set_value(slot, val); return(val); @@ -82896,7 +83216,7 @@ static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, s7_pointer sym, return(sc->no_value); } -static inline s7_pointer lambda_star_set_args(s7_scheme *sc) +static s7_pointer lambda_star_set_args(s7_scheme *sc) { bool allow_other_keys; s7_pointer lx = sc->args, cx, zx = sc->nil, code = sc->code, args = sc->args, slot = let_slots(sc->curlet); @@ -82916,7 +83236,7 @@ static inline s7_pointer lambda_star_set_args(s7_scheme *sc) (is_pair(cdr(lx))) && (keyword_symbol(car(lx)) == car(cx))) return(s7_error(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest arg ~S to ~S via keyword", 39), car(cx), cadr(lx)))); + set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), car(cx), cadr(lx)))); lambda_star_argument_set_value(sc, car(cx), lx, slot, false); lx = cdr(lx); cx = cdr(cx); @@ -82995,7 +83315,7 @@ static inline s7_pointer lambda_star_set_args(s7_scheme *sc) (is_pair(cdr(lx))) && (keyword_symbol(car(lx)) == cx)) return(s7_error(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest arg ~S to ~S via keyword", 39), cx, cadr(lx)))); + set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), cx, cadr(lx)))); slot_set_value(slot, lx); }} else @@ -83323,8 +83643,7 @@ static void op_safe_closure_star_aa(s7_scheme *sc, s7_pointer code) if ((is_keyword(arg2)) && (!sc->accept_all_keyword_arguments)) s7_error(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: keyword argument's value is missing: ~S in ~S", 49), - closure_name(sc, func), arg2, code)); + set_elist_4(sc, wrap_string(sc, "~A: keyword argument's value is missing: ~S in ~S", 49), closure_name(sc, func), arg2, code)); sc->curlet = update_let_with_two_slots(sc, closure_let(func), arg1, arg2); sc->code = T_Pair(closure_body(func)); } @@ -83419,8 +83738,7 @@ static void op_closure_star_a(s7_scheme *sc, s7_pointer code) if ((is_keyword(val)) && (!sc->accept_all_keyword_arguments)) s7_error(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: keyword argument's value is missing: ~S in ~S", 49), - closure_name(sc, opt1_lambda(code)), val, code)); + set_elist_4(sc, wrap_string(sc, "~A: keyword argument's value is missing: ~S in ~S", 49), closure_name(sc, opt1_lambda(code)), val, code)); func = opt1_lambda(code); p = car(closure_args(func)); sc->curlet = make_let_with_slot(sc, closure_let(func), (is_pair(p)) ? car(p) : p, val); @@ -83486,8 +83804,7 @@ static goto_t op_define1(s7_scheme *sc) { s7_pointer x; x = lookup_slot_from(sc->code, sc->curlet); - if ((is_slot(x)) && - (slot_has_setter(x))) + if ((is_slot(x)) && (slot_has_setter(x))) { sc->value = bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER, sc->code, sc->value); if (sc->value == sc->no_value) @@ -84428,9 +84745,10 @@ static void op_any_closure_na(s7_scheme *sc) /* for (lambda a ...) ? */ else if (num_args == 2) { - sc->value = fx_call(sc, old_args); + gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ sc->args = fx_call(sc, cdr(old_args)); - sc->args = ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? set_plist_2(sc, sc->value, sc->args) : list_2(sc, sc->value, sc->args); + sc->args = ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? set_plist_2(sc, stack_protected1(sc), sc->args) : list_2(sc, stack_protected1(sc), sc->args); + unstack(sc); } else { @@ -85845,10 +86163,9 @@ typedef enum {OPT_PTR, OPT_INT, OPT_DBL, OPT_INT_0} opt_pid_t; static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op, s7_pointer code) { - s7_pointer caller; + s7_pointer caller = opt3_pair(code); /* false_p in check_recur */ #if (!WITH_GMP) s7_pointer c_op; - caller = opt3_pair(code); c_op = car(caller); if ((is_symbol(c_op)) && ((is_global(c_op)) || @@ -85883,7 +86200,6 @@ static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op, s7_ #endif rec_set_test(sc, cdr(code)); rec_set_res(sc, (a_op) ? cddr(code) : cdddr(code)); - caller = opt3_pair(code); /* false_p in check_recur */ rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); rec_set_f2(sc, cdr(opt3_pair(caller))); sc->rec_slot1 = let_slots(sc->curlet); @@ -86154,13 +86470,9 @@ static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme *sc) /* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) { -#if WITH_GMP - s7_pointer caller; - caller = opt3_pair(sc->code); -#else - s7_pointer caller, c_op; - caller = opt3_pair(sc->code); - + s7_pointer caller = opt3_pair(sc->code); +#if (!WITH_GMP) + s7_pointer c_op; c_op = car(caller); if ((is_symbol(c_op)) && ((is_global(c_op)) || @@ -86464,8 +86776,7 @@ static s7_pointer rec_y(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->r static s7_pointer rec_z(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot3));} static s7_pointer rec_sub_z1(s7_scheme *sc, s7_pointer code) { - s7_pointer x; - x = slot_value(sc->rec_slot3); + s7_pointer x = slot_value(sc->rec_slot3); return((is_t_integer(x)) ? make_integer(sc, integer(x) - 1) : minus_c1(sc, x)); } @@ -87267,7 +87578,7 @@ static void op_safe_c_sp_1(s7_scheme *sc) static void op_safe_c_sp_mv(s7_scheme *sc) { - sc->args = cons(sc, sc->args, sc->value); /* not ulist here */ + sc->args = cons(sc, sc->args, sc->value); /* not ulist */ sc->code = c_function_base(opt1_cfunc(sc->code)); } @@ -87363,10 +87674,9 @@ static void op_cl_fa(s7_scheme *sc) sc->value = fn_proc(sc->code)(sc, sc->t2_1); } -static void op_map_or_for_each_fa(s7_scheme *sc) +static void op_map_for_each_fa(s7_scheme *sc) { - s7_pointer f, code = sc->code; - f = cddr(code); + s7_pointer f = cddr(sc->code), code = sc->code; sc->value = fx_call(sc, f); if (is_null(sc->value)) sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; @@ -87378,6 +87688,21 @@ static void op_map_or_for_each_fa(s7_scheme *sc) } } +static void op_map_for_each_faa(s7_scheme *sc) +{ + s7_pointer f = cddr(sc->code), code = sc->code; + sc->value = fx_call(sc, f); + sc->args = fx_call(sc, cdr(f)); + if ((is_null(sc->value)) || (is_null(sc->args))) + sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; + else + { + sc->code = opt3_pair(code); /* cdadr(code); */ + f = inline_make_closure(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 2); /* arity=2 checked in optimizer */ + sc->value = (fn_proc_unchecked(code)) ? g_for_each_closure_2(sc, f, sc->value, sc->args) : g_map_closure_2(sc, f, sc->value, sc->args); + } +} + static void op_cl_na(s7_scheme *sc) { s7_pointer args, p, val; @@ -87386,18 +87711,14 @@ static void op_cl_na(s7_scheme *sc) gc_protect_via_stack(sc, val); for (args = cdr(sc->code), p = val; is_pair(args); args = cdr(args), p = cdr(p)) set_car(p, fx_call(sc, args)); - if (in_heap(val)) + sc->value = fn_proc(sc->code)(sc, val); + if (in_heap(val)) { - /* the fn_proc call -- the latter might push its own op (e.g. for-each/map) so we have to check for that */ - /* perhaps just unstack here without the opcode check? why is there something left over? - * or if it isn't op_gc_protect don't unstack anything - */ - sc->stack_end -= 4; - if (((opcode_t)sc->stack_end[3]) != OP_GC_PROTECT) + /* the fn_proc call might push its own op (e.g. for-each/map) so we have to check for that */ + if (main_stack_op(sc) == OP_GC_PROTECT) unstack(sc); } else clear_list_in_use(val); - sc->value = fn_proc(sc->code)(sc, val); } static void op_cl_sas(s7_scheme *sc) @@ -87468,6 +87789,7 @@ static void op_safe_c_pp_6_mv(s7_scheme *sc) static void op_safe_c_3p(s7_scheme *sc) { + /* check_stack_size(sc); */ push_stack_no_args_direct(sc, OP_SAFE_C_3P_1); sc->code = cadr(sc->code); } @@ -87516,7 +87838,6 @@ static void op_safe_c_3p_3_mv(s7_scheme *sc) ps1 = stack_protected1(sc); if ((is_pair(ps1)) && (car(ps1) == sc->unused)) p2 = cdr(ps1); else p2 = list_1(sc, ps1); if ((is_pair(sc->value)) && (car(sc->value) == sc->unused)) p3 = cdr(sc->value); else p3 = list_1(sc, sc->value); - /* fprintf(stderr, "p1: %s, p2: %s, p3: %s\n", display(p1), display(p2), display(p3)); */ unstack(sc); for (p = p1; is_pair(cdr(p)); p = cdr(p)); set_cdr(p, p2); @@ -87591,7 +87912,7 @@ static void op_any_c_np_2(s7_scheme *sc) static s7_pointer revappend(s7_scheme *sc, s7_pointer a, s7_pointer b) { - /* (map (lambda (x) (if (odd? x) (apply values '(1 2 3)) (values))) (list 1 2 3 4)) is a bad case -- we have to copy the incoming list */ + /* (map (lambda (x) (if (odd? x) (apply values '(1 2 3)) (values))) (list 1 2 3 4)) is a bad case -- we have to copy the incoming list (in op_map_gather) */ s7_pointer p = b, q; if (is_not_null(a)) { @@ -87608,7 +87929,7 @@ static s7_pointer revappend(s7_scheme *sc, s7_pointer a, s7_pointer b) return(p); } -static Inline bool op_any_c_np_mv_1(s7_scheme *sc) +static bool op_any_c_np_mv_1(s7_scheme *sc) { /* we're looping through fp cases here, so sc->value can be non-mv after the first */ if (collect_np_args(sc, OP_ANY_C_NP_MV_1, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args))) @@ -87709,17 +88030,16 @@ static bool op_safe_c_ap(s7_scheme *sc) if ((has_gx(val)) && (symbol_ctr(caar(val)) == 1)) { val = fx_proc_unchecked(val)(sc, car(val)); - sc->value = val; - sc->temp10 = val; + gc_protect_via_stack(sc, val); set_car(sc->t2_1, fx_call(sc, code)); set_car(sc->t2_2, val); - sc->temp10 = sc->nil; + unstack(sc); sc->value = fn_proc(sc->code)(sc, sc->t2_1); return(false); } check_stack_size(sc); sc->args = fx_call(sc, code); - push_stack_direct(sc, (opcode_t)opt1_any(code)); + push_stack_direct(sc, (opcode_t)opt1_any(code)); /* safe_c_sp cases, mv->safe_c_sp_mv */ sc->code = car(val); return(true); } @@ -87731,11 +88051,10 @@ static bool op_safe_c_pa(s7_scheme *sc) { s7_pointer val; val = fx_proc_unchecked(args)(sc, car(args)); - sc->value = val; - sc->temp10 = val; + gc_protect_via_stack(sc, val); set_car(sc->t2_2, fx_call(sc, cdr(args))); set_car(sc->t2_1, val); - sc->temp10 = sc->nil; + unstack(sc); sc->value = fn_proc(sc->code)(sc, sc->t2_1); return(false); } @@ -87748,20 +88067,23 @@ static bool op_safe_c_pa(s7_scheme *sc) static void op_safe_c_pa_1(s7_scheme *sc) { s7_pointer val = sc->value; - sc->temp10 = val; + gc_protect_via_stack(sc, val); /* not a temp */ set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); set_car(sc->t2_1, val); - sc->temp10 = sc->nil; + unstack(sc); sc->value = fn_proc(sc->code)(sc, sc->t2_1); } static void op_safe_c_pa_mv(s7_scheme *sc) { - s7_pointer val = sc->value; /* this is necessary since the fx_proc below can clobber sc->value */ - sc->temp10 = val; + s7_pointer p, val; + val = copy_proper_list(sc, sc->value); /* this is necessary since the fx_proc below can clobber sc->value */ + gc_protect_via_stack(sc, val); + for (p = val; is_pair(cdr(p)); p = cdr(p)); /* must be more than 1 member of list or it's not mv */ sc->args = fx_call(sc, cddr(sc->code)); - sc->args = pair_append(sc, val, list_1(sc, sc->args)); /* not plist here! pair_append does not copy it */ - sc->temp10 = sc->nil; + cdr(p) = set_plist_1(sc, sc->args); /* do we need to copy sc->args if it is immutable (i.e. plist)? */ + sc->args = val; + unstack(sc); sc->code = c_function_base(opt1_cfunc(sc->code)); } @@ -87826,11 +88148,11 @@ static void op_c_ap_mv(s7_scheme *sc) static void op_c_aa(s7_scheme *sc) { - s7_pointer code = sc->code; - sc->code = fx_call(sc, cdr(code)); - sc->value = fx_call(sc, cddr(code)); - sc->value = list_2(sc, sc->code, sc->value); - sc->value = fn_proc(code)(sc, sc->value); + gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); + stack_protected2(sc) = fx_call(sc, cddr(sc->code)); + sc->value = list_2(sc, stack_protected1(sc), stack_protected2(sc)); + unstack(sc); /* fn_proc here is unsafe so clear stack first */ + sc->value = fn_proc(sc->code)(sc, sc->value); } static inline void op_c_s(s7_scheme *sc) @@ -88007,11 +88329,8 @@ static bool op_load_close_and_pop_if_eof(s7_scheme *sc) sc->code = sc->value; return(true); /* we read an expression, now evaluate it, and return to read the next */ } -#if S7_DEBUGGING - if (!is_loader_port(current_input_port(sc))) - fprintf(stderr, "%s not loading?\n", display(current_input_port(sc))); + if ((S7_DEBUGGING) && (!is_loader_port(current_input_port(sc)))) fprintf(stderr, "%s not loading?\n", display(current_input_port(sc))); /* if *#readers* func hits error, clear_loader_port might not be undone? */ -#endif s7_close_input_port(sc, current_input_port(sc)); pop_input_port(sc); sc->current_file = NULL; @@ -88047,7 +88366,7 @@ static goto_t op_read_dot(s7_scheme *sc) * (list 1 2 . 3) -> value: 3, args: (2 1 list), '(1 . 2) -> value: 2, args: (1) * but we also get here in a lambda arg list: (lambda (a b . c) #f) -> value: c, args: (b a) */ - sc->value = reverse_in_place(sc, sc->value, sc->args); + sc->value = any_list_reverse_in_place(sc, sc->value, sc->args); return((main_stack_op(sc) == OP_READ_LIST) ? goto_pop_read_list : goto_start); } @@ -88118,11 +88437,9 @@ static inline void eval_last_arg(s7_scheme *sc, s7_pointer car_code) static inline void eval_args_pair_car(s7_scheme *sc) { - s7_pointer code; + s7_pointer code = cdr(sc->code); if (sc->stack_end >= sc->stack_resize_trigger) check_for_cyclic_code(sc, sc->code); - - code = cdr(sc->code); /* all 3 of these push_stacks can result in stack overflow, see above 64065 */ if (is_null(code)) push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args); @@ -88141,7 +88458,6 @@ static inline void eval_args_pair_car(s7_scheme *sc) static bool eval_car_pair(s7_scheme *sc) { s7_pointer code = sc->code, carc = car(code); - /* evaluate the inner list but that list can be circular: carc: #1=(#1# #1#)! * and the cycle can be well-hidden -- #1=((#1 2) . 2) and other such stuff */ @@ -88156,6 +88472,21 @@ static bool eval_car_pair(s7_scheme *sc) ((!is_pair(cdr(carc))) || /* ((quote . #\h) (2 . #\i)) ! */ (is_symbol_and_syntactic(cadr(carc))))) /* ('or #f) but not ('#_or #f) */ apply_error(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc, cdr(code)); +#if 0 + /* if ((lambda ...)), check for ((lambda () ...)) and unwrap it to ...: need an operator here to skip these checks (and need optimization of lambda body etc) */ + /* this is slower than going to op_lambda via eval_car_pair below, both much slower than code without the idiotic lambda */ + if (car(carc) == sc->lambda_symbol) + { + if ((is_null(cadr(carc))) && + (is_pair(cddr(carc))) && + (is_null(cdddr(carc))) && /* else wrap in (let ()...) */ + (!((is_pair(caddr(carc))) && (is_syntax(caaddr(carc))) && (is_syntax_definer(caaddr(carc)))))) + { + sc->stack_end -= 4; /* avoid debugger complaint */ + sc->code = caddr(carc); + return(true); + }} +#endif sc->code = carc; if (!no_cell_opt(carc)) { @@ -88430,15 +88761,9 @@ static bool op_unknown_g(s7_scheme *sc) bool sym_case; if (!f) unbound_variable_error(sc, car(sc->code)); - -#if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, display(f)); -#endif + if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); code = sc->code; -#if S7_DEBUGGING - if (is_pair(cadr(code))) fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code)); -#endif sym_case = is_normal_symbol(cadr(code)); if ((sym_case) && @@ -88608,9 +88933,7 @@ static bool op_unknown_a(s7_scheme *sc) { s7_pointer code, f = sc->last_function; if (!f) unbound_variable_error(sc, car(sc->code)); -#if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, display(f)); -#endif + if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); code = sc->code; switch (type(f)) @@ -88703,15 +89026,9 @@ static bool op_unknown_gg(s7_scheme *sc) bool s1, s2; s7_pointer code, f = sc->last_function; if (!f) unbound_variable_error(sc, car(sc->code)); - -#if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, display(f)); -#endif + if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); code = sc->code; -#if S7_DEBUGGING - if ((is_pair(cadr(code))) || (is_pair(caddr(code)))) fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code)); -#endif s1 = is_normal_symbol(cadr(code)); s2 = is_normal_symbol(caddr(code)); @@ -88796,6 +89113,7 @@ static bool op_unknown_gg(s7_scheme *sc) } else { + set_opt3_arglen(cdr(code), int_two); fx_annotate_args(sc, cdr(code), sc->curlet); if (safe_case) set_safe_optimize_op(code, hop + ((one_form) ? OP_SAFE_CLOSURE_AA_O : OP_SAFE_CLOSURE_AA)); @@ -88822,6 +89140,7 @@ static bool op_unknown_gg(s7_scheme *sc) break; case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_PAIR: + set_opt3_arglen(cdr(code), int_two); fx_annotate_args(sc, cdr(code), sc->curlet); return(fixup_unknown_op(code, f, (is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA)); @@ -88845,10 +89164,7 @@ static bool op_unknown_ns(s7_scheme *sc) int32_t num_args; if (!f) unbound_variable_error(sc, car(sc->code)); - -#if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, display(f)); -#endif + if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); code = sc->code; num_args = integer(opt3_arglen(cdr(code))); @@ -88922,18 +89238,24 @@ static bool op_unknown_ns(s7_scheme *sc) return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); } +/* #define op_unknown_aa(Sc) ({fprintf(stderr, "aa: %s[%d]\n", __func__, __LINE__); op_unknown_aa_1(Sc);}) */ static bool op_unknown_aa(s7_scheme *sc) { s7_pointer code, f = sc->last_function; if (!f) unbound_variable_error(sc, car(sc->code)); -#if SHOW_EVAL_OPS - fprintf(stderr, "%s %s\n", __func__, display(f)); -#endif + if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); code = sc->code; +#if S7_DEBUGGING + if (!is_t_integer(opt3_arglen(cdr(code)))) {fprintf(stderr, "not int\n"); abort();} + if (!has_fx(cdr(code))) {fprintf(stderr, "not fx cdr\n"); abort();} + if (!has_fx(cddr(code))) {fprintf(stderr, "not fx cddr\n"); abort();} +#endif +#if 0 set_opt3_arglen(cdr(code), int_two); fx_annotate_args(sc, cdr(code), sc->curlet); +#endif switch (type(f)) { @@ -89023,10 +89345,7 @@ static bool op_unknown_na(s7_scheme *sc) int32_t num_args; if (!f) unbound_variable_error(sc, car(sc->code)); - -#if SHOW_EVAL_OPS - fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(f), display(sc->code)); -#endif + if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(f), display(sc->code)); code = sc->code; num_args = (is_pair(cdr(code))) ? integer(opt3_arglen(cdr(code))) : 0; @@ -89158,10 +89477,7 @@ static bool op_unknown_np(s7_scheme *sc) int32_t num_args; if (!f) unbound_variable_error(sc, car(sc->code)); - -#if SHOW_EVAL_OPS - fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(f), type_name(sc, f, NO_ARTICLE), display(sc->code)); -#endif + if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(f), type_name(sc, f, NO_ARTICLE), display(sc->code)); code = sc->code; num_args = (is_pair(cdr(code))) ? integer(opt3_arglen(cdr(code))) : 0; @@ -89284,9 +89600,7 @@ static bool unknown_any(s7_scheme *sc, s7_pointer f, s7_pointer code) static inline bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) { s7_pointer f; -#if S7_DEBUGGING - if (symbol_ctr(car(code)) == 1) fprintf(stderr, "%s ctr is 1, %p != %p\n", display(car(code)), unchecked_local_value(car(code)), opt1_lambda_unchecked(code)); -#endif + if ((S7_DEBUGGING) && (symbol_ctr(car(code)) == 1)) fprintf(stderr, "%s ctr is 1, %p != %p\n", display(car(code)), unchecked_local_value(car(code)), opt1_lambda_unchecked(code)); f = lookup_unexamined(sc, car(code)); if ((f == opt1_lambda_unchecked(code)) || ((f) && @@ -89377,9 +89691,7 @@ static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type /* ---------------- eval ---------------- */ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) { -#if SHOW_EVAL_OPS - safe_print(fprintf(stderr, "eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], display_80(sc->code), display_80(sc->args))); -#endif + if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], display_80(sc->code), display_80(sc->args))); sc->cur_op = first_op; goto TOP_NO_POP; @@ -89398,9 +89710,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_choice) */ TOP_NO_POP: -#if SHOW_EVAL_OPS - safe_print(fprintf(stderr, "%s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_80(sc->code))); -#endif + if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_80(sc->code))); + /* it is only slightly faster to use labels as values (computed gotos) here. In my timing tests (June-2018), the best case speedup was in titer.scm * callgrind numbers 4808 to 4669; another good case was tread.scm: 2410 to 2386. Most timings were a draw. computed-gotos-s7.c has the code, * macroized so it will work if such gotos aren't available. I think I'll stick with a switch statement. @@ -89408,6 +89719,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) * then the switch below is not needed, and we free up 16 type bits. C does not guarantee tail calls (I think) * so we'd have each function return the next, and eval would be (while (true) f = f(sc) but would the function * call overhead be less expensive than the switch? (We get most functions inlined in the current code). + * with some fake fx_calls for the P cases, many of these could be + * sc->value = fx_function[sc->cur_op](sc, sc->code); continue; + * so the switch statement is unnecessary -- maybe a table eval_functions[cur_op] eventually */ switch (sc->cur_op) @@ -89476,19 +89790,19 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_S_opAAAq: if (!c_function_is_ok(sc, sc->code)) break; case HOP_SAFE_C_S_opAAAq: sc->value = fx_c_s_opaaaq(sc, sc->code); continue; - case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) break; + case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue; - case OP_SAFE_C_SA: if (!c_function_is_ok(sc, sc->code)) break; + case OP_SAFE_C_SA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} case HOP_SAFE_C_SA: sc->value = fx_c_sa(sc, sc->code); continue; case OP_SAFE_C_AS: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} case HOP_SAFE_C_AS: sc->value = fx_c_as(sc, sc->code); continue; - case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) break; + case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} case HOP_SAFE_C_CA: sc->value = fx_c_ca(sc, sc->code); continue; - case OP_SAFE_C_AC: if (!c_function_is_ok(sc, sc->code)) break; + case OP_SAFE_C_AC: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} case HOP_SAFE_C_AC: sc->value = fx_c_ac(sc, sc->code); continue; case OP_SAFE_C_AAA: if (!c_function_is_ok(sc, sc->code)) break; @@ -89708,8 +90022,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case HOP_CL_NA: op_cl_na(sc); continue; case OP_CL_FA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_FA: op_cl_fa(sc); continue; /* op_c_fs was not faster if fx_s below */ - case OP_MAP_OR_FOR_EACH_FA: op_map_or_for_each_fa(sc); continue; /* here only if for-each or map */ + case HOP_CL_FA: op_cl_fa(sc); continue; /* op_c_fs was not faster if fx_s below */ + case OP_MAP_FOR_EACH_FA: op_map_for_each_fa(sc); continue; /* here only if for-each or map + one seq */ + case OP_MAP_FOR_EACH_FAA: op_map_for_each_faa(sc); continue; /* here only if for-each or map + twp seqs */ /* unsafe c_functions */ @@ -90303,7 +90618,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_MACROEXPAND_1: switch (op_macroexpand_1(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} - case OP_MACROEXPAND: switch (op_macroexpand(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} @@ -90335,10 +90649,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_FOR_EACH_3: if (op_for_each_2(sc)) continue; goto EVAL; case OP_MEMBER_IF: - case OP_MEMBER_IF1: if (member_if(sc)) continue; goto APPLY; + case OP_MEMBER_IF1: if (op_member_if(sc)) continue; goto APPLY; case OP_ASSOC_IF: - case OP_ASSOC_IF1: if (assoc_if(sc)) continue; goto APPLY; + case OP_ASSOC_IF1: if (op_assoc_if(sc)) continue; goto APPLY; case OP_SAFE_DOTIMES: @@ -90559,7 +90873,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SET_SYMBOL_P: op_set_symbol_p(sc); goto EVAL; case OP_SET_CONS: op_set_cons(sc); continue; case OP_SET_SAFE: op_set_safe(sc); continue; - case OP_SET_FROM_SETTER: slot_set_value(sc->code, sc->value); continue; + case OP_SET_FROM_SETTER: slot_set_value(sc->code, sc->value); continue; /* mv caught in splice_in_values */ + case OP_SET_FROM_LET_TEMP: op_set_from_let_temp(sc); continue; case OP_SET2: switch (op_set2(sc)) @@ -90571,7 +90886,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) default: goto EVAL_ARGS; } - case OP_SET: check_set(sc); + case OP_SET: check_set(sc); case OP_SET_UNCHECKED: if (is_pair(cadr(sc->code))) /* has setter */ switch (set_implicit(sc)) @@ -90618,10 +90933,11 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_IF_NOT_A_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : fx_call(sc, opt3_pair(sc->code)); continue; case OP_IF_AND2_S_A: sc->value = fx_if_and2_s_a(sc, sc->code); continue; - case OP_IF_GT_A: /* tclo -- an experiment, test expr = (> t u) */ - sc->value = (gt_b_7pp(sc, t_lookup(sc, car(opt2_pair(sc->code)), sc->code), u_lookup(sc, cadr(opt2_pair(sc->code)), sc->code))) ? - fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; - continue; + #define call_bfunc(Sc, Expr) ((s7_bfunc)opt3_any(cdr(Sc->code)))(Sc, Expr) + case OP_IF_B_A: sc->value = (call_bfunc(sc, cadr(sc->code))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; + case OP_IF_B_A_P: if (call_bfunc(sc, cadr(sc->code))) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_B_P_A: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; + case OP_IF_B_P_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; #define if_s_p(sc) if (is_true(sc, lookup(sc, cadr(sc->code)))) #define if_not_s_p(sc) if (is_false(sc, lookup(sc, opt1_sym(cdr(sc->code))))) /* cadadr(sc->code) */ @@ -90640,6 +90956,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_IF_A_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; case OP_IF_A_N_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_B_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_B_R: if (call_bfunc(sc, cadr(sc->code))) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_B_N_N: if (call_bfunc(sc, car(opt3_pair(sc->code)))) {sc->code = opt2_any(sc->code); goto EVAL;} sc->code = opt1_any(sc->code); goto EVAL; + #define if_is_type_s_p(sc) if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) #define if_is_not_type_s_p(sc) if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) @@ -90809,7 +91129,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) switch (op_let_temp_init2(sc)) { case goto_begin: goto BEGIN; - case goto_top_no_pop: sc->cur_op = OP_SET_UNCHECKED; goto TOP_NO_POP; + case goto_eval: goto EVAL; default: break; } @@ -91199,7 +91519,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) break; default: - fprintf(stderr, "unknown operator: %" print_pointer " in %s\n", sc->cur_op, display(current_code(sc))); + fprintf(stderr, "unknown operator: %" p64 " in %s\n", sc->cur_op, display(current_code(sc))); return(sc->F); } @@ -91229,7 +91549,7 @@ typedef enum {SL_NO_FIELD=0, SL_STACK_TOP, SL_STACK_SIZE, SL_STACKTRACE_DEFAULTS SL_DEFAULT_HASH_TABLE_LENGTH, SL_INITIAL_STRING_PORT_LENGTH, SL_DEFAULT_RATIONALIZE_ERROR, SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON, SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH, SL_BIGNUM_PRECISION, SL_MEMORY_USAGE, SL_FLOAT_FORMAT_PRECISION, SL_HISTORY, SL_HISTORY_ENABLED, - SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_AUTOLOADING, SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, + SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_AUTOLOADING, SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, SL_MUFFLE_WARNINGS, SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM, SL_OUTPUT_PORT_DATA_SIZE, SL_DEBUG, SL_VERSION, SL_GC_TEMPS_SIZE, SL_GC_RESIZE_HEAP_FRACTION, SL_GC_RESIZE_HEAP_BY_4_FRACTION, SL_OPENLETS, SL_EXPANSIONS, SL_NUM_FIELDS} s7_let_field_t; @@ -91243,7 +91563,7 @@ static const char *s7_let_field_names[SL_NUM_FIELDS] = "default-hash-table-length", "initial-string-port-length", "default-rationalize-error", "default-random-state", "equivalent-float-epsilon", "hash-table-float-epsilon", "print-length", "bignum-precision", "memory-usage", "float-format-precision", "history", "history-enabled", - "history-size", "profile", "profile-info", "autoloading?", "accept-all-keyword-arguments", + "history-size", "profile", "profile-info", "autoloading?", "accept-all-keyword-arguments", "muffle-warnings?", "most-positive-fixnum", "most-negative-fixnum", "output-port-data-size", "debug", "version", "gc-temps-size", "gc-resize-heap-fraction", "gc-resize-heap-by-4-fraction", "openlets", "expansions?"}; @@ -91279,7 +91599,7 @@ static s7_pointer kmg(s7_scheme *sc, s7_int bytes) int len = 0; b = mallocate(sc, 128); if (bytes < 1000) - len = snprintf((char *)block_data(b), 128, "%" print_s7_int, bytes); + len = snprintf((char *)block_data(b), 128, "%" ld64, bytes); else if (bytes < 1000000) len = snprintf((char *)block_data(b), 128, "%.1fk", bytes / 1000.0); @@ -91303,7 +91623,7 @@ static s7_pointer memory_usage(s7_scheme *sc) #endif mu_let = s7_inlet(sc, sc->nil); - gc_loc = s7_gc_protect_1(sc, mu_let); + gc_loc = gc_protect_1(sc, mu_let); #if (!_WIN32) /* (!MS_WINDOWS) */ getrusage(RUSAGE_SELF, &info); @@ -91346,7 +91666,7 @@ static s7_pointer memory_usage(s7_scheme *sc) { if (i > 0) in_use += ts[i]; if (ts[i] > 50) - sc->w = cons(sc, cons(sc, make_symbol(sc, (i == 0) ? "free" : type_name_from_type(i, NO_ARTICLE)), make_integer(sc, ts[i])), sc->w); + sc->w = cons_unchecked(sc, cons(sc, make_symbol(sc, (i == 0) ? "free" : type_name_from_type(i, NO_ARTICLE)), make_integer(sc, ts[i])), sc->w); } add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cells-in-use/free"), cons(sc, make_integer(sc, in_use), make_integer(sc, sc->free_heap_top - sc->free_heap))); if (is_pair(sc->w)) @@ -91400,7 +91720,8 @@ static s7_pointer memory_usage(s7_scheme *sc) loc = sc->strings->loc + sc->vectors->loc + sc->input_ports->loc + sc->output_ports->loc + sc->input_string_ports->loc + sc->continuations->loc + sc->c_objects->loc + sc->hash_tables->loc + sc->gensyms->loc + sc->undefineds->loc + sc->lambdas->loc + sc->multivectors->loc + sc->weak_refs->loc + sc->weak_hash_iterators->loc + sc->opt1_funcs->loc; - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-lists"), cons(sc, make_integer(sc, loc), cons(sc, make_integer(sc, len), make_integer(sc, len * sizeof(s7_pointer))))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-lists"), + cons_unchecked(sc, make_integer(sc, loc), cons(sc, make_integer(sc, len), make_integer(sc, len * sizeof(s7_pointer))))); } /* strings */ gp = sc->strings; @@ -91412,8 +91733,7 @@ static s7_pointer memory_usage(s7_scheme *sc) for (k = 0, gp = sc->vectors; k < 2; k++, gp = sc->multivectors) for (i = 0; i < gp->loc; i++) { - s7_pointer v; - v = gp->list[i]; + s7_pointer v = gp->list[i]; if (is_float_vector(v)) flen += vector_length(v); else @@ -91435,8 +91755,7 @@ static s7_pointer memory_usage(s7_scheme *sc) /* hash-tables */ for (i = 0, gp = sc->hash_tables; i < gp->loc; i++) { - s7_pointer v; - v = gp->list[i]; + s7_pointer v = gp->list[i]; hlen += ((hash_table_mask(v) + 1) * sizeof(hash_entry_t *)); hlen += (hash_table_entries(v) * sizeof(hash_entry_t)); } @@ -91446,15 +91765,13 @@ static s7_pointer memory_usage(s7_scheme *sc) gp = sc->input_ports; for (i = 0, len = 0; i < gp->loc; i++) { - s7_pointer v; - v = gp->list[i]; + s7_pointer v = gp->list[i]; if (port_data(v)) len += port_data_size(v); } gp = sc->input_string_ports; for (i = 0, len = 0; i < gp->loc; i++) { - s7_pointer v; - v = gp->list[i]; + s7_pointer v = gp->list[i]; if (port_data(v)) len += port_data_size(v); } add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-ports"), @@ -91462,8 +91779,7 @@ static s7_pointer memory_usage(s7_scheme *sc) gp = sc->output_ports; for (i = 0, len = 0; i < gp->loc; i++) { - s7_pointer v; - v = gp->list[i]; + s7_pointer v = gp->list[i]; if (port_data(v)) len += port_data_size(v); } add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "output-ports"), @@ -91646,6 +91962,7 @@ static s7_pointer s7_let_field(s7_scheme *sc, s7_pointer sym) case SL_MEMORY_USAGE: return(memory_usage(sc)); case SL_MOST_NEGATIVE_FIXNUM: return(sl_int_fixup(sc, leastfix)); case SL_MOST_POSITIVE_FIXNUM: return(sl_int_fixup(sc, mostfix)); + case SL_MUFFLE_WARNINGS: return(s7_make_boolean(sc, sc->muffle_warnings)); case SL_OPENLETS: return(s7_make_boolean(sc, sc->has_openlets)); case SL_EXPANSIONS: return(s7_make_boolean(sc, sc->is_expanding)); case SL_OUTPUT_PORT_DATA_SIZE: return(make_integer(sc, sc->output_port_data_size)); @@ -91957,6 +92274,10 @@ static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args) case SL_MOST_NEGATIVE_FIXNUM: case SL_MOST_POSITIVE_FIXNUM: return(sl_unsettable_error(sc, sym)); + case SL_MUFFLE_WARNINGS: + if (s7_is_boolean(val)) {sc->muffle_warnings = s7_boolean(sc, val); return(val);} + return(simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + case SL_OPENLETS: if (s7_is_boolean(val)) {sc->has_openlets = s7_boolean(sc, val); return(val);} return(simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); @@ -92188,9 +92509,7 @@ char *s7_decode_bt(s7_scheme *sc) if ((is_pair(p)) && (has_location(p))) { - uint32_t line, file; - line = pair_line_number(p); - file = pair_file_number(p); + uint32_t line = pair_line_number(p), file = pair_file_number(p); if (line > 0) fprintf(stdout, " %s(%s[%u])%s", BOLD_TEXT, string_value(sc->file_names[file]), line, UNBOLD_TEXT); }}}}}}}} @@ -92392,6 +92711,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_i_7p_function(sc, global_value(sc->string_length_symbol), string_length_i_7p); s7_set_i_7p_function(sc, global_value(sc->vector_length_symbol), vector_length_i_7p); s7_set_p_p_function(sc, global_value(sc->vector_to_list_symbol), vector_to_list_p_p); + s7_set_p_p_function(sc, global_value(sc->string_to_list_symbol), string_to_list_p_p); s7_set_p_p_function(sc, global_value(sc->vector_length_symbol), vector_length_p_p); s7_set_b_7p_function(sc, global_value(sc->is_exact_symbol), is_exact_b_7p); s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol), is_inexact_b_7p); @@ -92463,6 +92783,9 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_p_function(sc, global_value(sc->cadar_symbol), cadar_p_p); s7_set_p_p_function(sc, global_value(sc->cdddr_symbol), cdddr_p_p); s7_set_p_p_function(sc, global_value(sc->cdadr_symbol), cdadr_p_p); + s7_set_p_p_function(sc, global_value(sc->cddar_symbol), cddar_p_p); + s7_set_p_p_function(sc, global_value(sc->cdaar_symbol), cdaar_p_p); + s7_set_p_p_function(sc, global_value(sc->caaar_symbol), caaar_p_p); s7_set_p_p_function(sc, global_value(sc->caddar_symbol), caddar_p_p); s7_set_p_p_function(sc, global_value(sc->caaddr_symbol), caaddr_p_p); s7_set_p_p_function(sc, global_value(sc->cadddr_symbol), cadddr_p_p); @@ -92487,7 +92810,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_pp_function(sc, global_value(sc->inlet_symbol), inlet_p_pp); s7_set_i_7p_function(sc, global_value(sc->port_line_number_symbol), s7_port_line_number); s7_set_p_pp_function(sc, global_value(sc->cons_symbol), cons_p_pp); - s7_set_p_function(sc, global_value(sc->open_output_string_symbol), open_output_string_p); + s7_set_p_function(sc, global_value(sc->open_output_string_symbol), s7_open_output_string); s7_set_p_ppi_function(sc, global_value(sc->char_position_symbol), char_position_p_ppi); s7_set_p_pp_function(sc, global_value(sc->append_symbol), s7_append); s7_set_p_pp_function(sc, global_value(sc->string_append_symbol), string_append_p_pp); @@ -92514,6 +92837,9 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_i_function(sc, global_value(sc->rationalize_symbol), rationalize_p_i); s7_set_i_i_function(sc, global_value(sc->rationalize_symbol), rationalize_i_i); s7_set_p_p_function(sc, global_value(sc->truncate_symbol), truncate_p_p); + s7_set_p_p_function(sc, global_value(sc->round_symbol), round_p_p); + s7_set_p_p_function(sc, global_value(sc->ceiling_symbol), ceiling_p_p); + s7_set_p_p_function(sc, global_value(sc->floor_symbol), floor_p_p); s7_set_p_pp_function(sc, global_value(sc->max_symbol), max_p_pp); s7_set_p_pp_function(sc, global_value(sc->min_symbol), min_p_pp); s7_set_p_p_function(sc, global_value(sc->sqrt_symbol), sqrt_p_p); @@ -92548,7 +92874,6 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_i_function(sc, global_value(sc->int_vector_symbol), int_vector_p_i); s7_set_i_i_function(sc, global_value(sc->round_symbol), round_i_i); s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i); - s7_set_p_p_function(sc, global_value(sc->floor_symbol), floor_p_p); s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i); s7_set_i_i_function(sc, global_value(sc->truncate_symbol), truncate_i_i); @@ -92620,21 +92945,22 @@ static void init_opt_functions(s7_scheme *sc) s7_set_i_7p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_i_7p); s7_set_i_7p_function(sc, global_value(sc->hash_table_entries_symbol), hash_table_entries_i_7p); s7_set_i_7p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_i_7p); + s7_set_p_p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_p_p); s7_set_b_p_function(sc, global_value(sc->is_boolean_symbol), s7_is_boolean); - s7_set_b_p_function(sc, global_value(sc->is_byte_vector_symbol), s7_is_byte_vector); + s7_set_b_p_function(sc, global_value(sc->is_byte_vector_symbol), is_byte_vector_b_p); s7_set_b_p_function(sc, global_value(sc->is_c_object_symbol), s7_is_c_object); s7_set_b_p_function(sc, global_value(sc->is_char_symbol), s7_is_character); s7_set_b_p_function(sc, global_value(sc->is_complex_symbol), s7_is_complex); - s7_set_b_p_function(sc, global_value(sc->is_continuation_symbol), s7_is_continuation); + s7_set_b_p_function(sc, global_value(sc->is_continuation_symbol), is_continuation_b_p); s7_set_b_p_function(sc, global_value(sc->is_c_pointer_symbol), s7_is_c_pointer); s7_set_b_p_function(sc, global_value(sc->is_dilambda_symbol), s7_is_dilambda); - s7_set_b_p_function(sc, global_value(sc->is_eof_object_symbol), s7_is_eof_object); + s7_set_b_p_function(sc, global_value(sc->is_eof_object_symbol), is_eof_object_b_p); s7_set_b_7p_function(sc, global_value(sc->is_even_symbol), is_even_b_7p); s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), is_odd_b_7p); s7_set_b_p_function(sc, global_value(sc->is_float_symbol), is_float_b); s7_set_b_p_function(sc, global_value(sc->is_float_vector_symbol), s7_is_float_vector); - s7_set_b_p_function(sc, global_value(sc->is_gensym_symbol), s7_is_gensym); + s7_set_b_p_function(sc, global_value(sc->is_gensym_symbol), is_gensym_b_p); s7_set_b_p_function(sc, global_value(sc->is_hash_table_symbol), s7_is_hash_table); s7_set_b_7p_function(sc, global_value(sc->is_infinite_symbol), is_infinite_b_7p); s7_set_b_7p_function(sc, global_value(sc->is_nan_symbol), is_nan_b_7p); @@ -92645,10 +92971,10 @@ static void init_opt_functions(s7_scheme *sc) s7_set_b_p_function(sc, global_value(sc->is_let_symbol), s7_is_let); s7_set_b_p_function(sc, global_value(sc->is_list_symbol), is_list_b); s7_set_b_p_function(sc, global_value(sc->is_macro_symbol), is_macro_b); - s7_set_b_p_function(sc, global_value(sc->is_null_symbol), is_null_b); s7_set_b_p_function(sc, global_value(sc->is_number_symbol), s7_is_number); s7_set_b_p_function(sc, global_value(sc->is_output_port_symbol), is_output_port_b); s7_set_b_p_function(sc, global_value(sc->is_pair_symbol), s7_is_pair); + s7_set_b_p_function(sc, global_value(sc->is_null_symbol), is_null_b_p); s7_set_b_7p_function(sc, global_value(sc->is_port_closed_symbol), is_port_closed_b_7p); s7_set_b_p_function(sc, global_value(sc->is_procedure_symbol), s7_is_procedure); s7_set_b_7p_function(sc, global_value(sc->is_proper_list_symbol), s7_is_proper_list); @@ -92678,6 +93004,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_b_7p_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7p); s7_set_b_7pp_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7pp); s7_set_b_7pp_function(sc, global_value(sc->tree_memq_symbol), s7_tree_memq); + s7_set_b_7p_function(sc, global_value(sc->tree_is_cyclic_symbol), tree_is_cyclic); s7_set_b_7pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_b_7pp); s7_set_p_pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_p_pp); s7_set_b_p_function(sc, global_value(sc->is_immutable_symbol), s7_is_immutable); @@ -92686,8 +93013,8 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_p_function(sc, global_value(sc->is_pair_symbol), is_pair_p_p); s7_set_p_p_function(sc, global_value(sc->is_char_symbol), is_char_p_p); s7_set_p_p_function(sc, global_value(sc->is_constant_symbol), is_constant_p_p); + s7_set_b_7p_function(sc, global_value(sc->is_constant_symbol), is_constant_b_7p); s7_set_p_p_function(sc, global_value(sc->type_of_symbol), s7_type_of); - /* s7_set_p_p_function(sc, global_value(sc->openlet_symbol), s7_openlet); -- needs error check */ s7_set_p_i_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_i); s7_set_p_p_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_p); s7_set_p_p_function(sc, global_value(sc->iterate_symbol), iterate_p_p); @@ -92695,6 +93022,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_pp_function(sc, global_value(sc->list_symbol), list_p_pp); s7_set_p_ppp_function(sc, global_value(sc->list_symbol), list_p_ppp); s7_set_p_pp_function(sc, global_value(sc->list_tail_symbol), list_tail_p_pp); + s7_set_p_pp_function(sc, global_value(sc->make_list_symbol), make_list_p_pp); s7_set_p_pp_function(sc, global_value(sc->assq_symbol), assq_p_pp); s7_set_p_pp_function(sc, global_value(sc->assv_symbol), assv_p_pp); s7_set_p_pp_function(sc, global_value(sc->memq_symbol), memq_p_pp); @@ -92710,6 +93038,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_p_function(sc, global_value(sc->c_pointer_weak2_symbol), c_pointer_weak2_p_p); s7_set_p_p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_p_p); s7_set_p_p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_p_p); + s7_set_p_p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_p_p); s7_set_p_p_function(sc, global_value(sc->char_upcase_symbol), char_upcase_p_p); s7_set_p_p_function(sc, global_value(sc->read_char_symbol), read_char_p_p); s7_set_p_i_function(sc, global_value(sc->make_string_symbol), make_string_p_i); @@ -92719,6 +93048,7 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_p_function(sc, global_value(sc->signature_symbol), s7_signature); s7_set_p_p_function(sc, global_value(sc->copy_symbol), copy_p_p); s7_set_p_p_function(sc, global_value(sc->object_to_let_symbol), object_to_let_p_p); + s7_set_p_p_function(sc, global_value(sc->outlet_symbol), outlet_p_p); #if WITH_SYSTEM_EXTRAS s7_set_b_7p_function(sc, global_value(sc->is_directory_symbol), is_directory_b_7p); @@ -92744,8 +93074,8 @@ static void init_opt_functions(s7_scheme *sc) s7_set_p_pi_function(sc, global_value(sc->leq_symbol), leq_p_pi); s7_set_b_pi_function(sc, global_value(sc->leq_symbol), leq_b_pi); s7_set_p_pi_function(sc, global_value(sc->gt_symbol), gt_p_pi); - s7_set_p_pi_function(sc, global_value(sc->geq_symbol), geq_p_pi); s7_set_b_pi_function(sc, global_value(sc->gt_symbol), gt_b_pi); + s7_set_p_pi_function(sc, global_value(sc->geq_symbol), geq_p_pi); s7_set_b_pi_function(sc, global_value(sc->geq_symbol), geq_b_pi); /* no ip pd dp! */ s7_set_b_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_b_pi); @@ -93058,7 +93388,6 @@ static void init_setters(s7_scheme *sc) set_is_setter(sc->byte_vector_set_symbol); set_is_setter(sc->set_car_symbol); set_is_setter(sc->set_cdr_symbol); - set_is_safe_setter(sc->byte_vector_set_symbol); set_is_safe_setter(sc->int_vector_set_symbol); set_is_safe_setter(sc->float_vector_set_symbol); @@ -93952,6 +94281,7 @@ s7_scheme *s7_init(void) sc->has_openlets = true; sc->is_expanding = true; sc->accept_all_keyword_arguments = false; + sc->muffle_warnings = false; sc->initial_string_port_length = 128; sc->format_depth = -1; sc->singletons = (s7_pointer *)calloc(256, sizeof(s7_pointer)); @@ -93989,6 +94319,8 @@ s7_scheme *s7_init(void) sc->t3_1 = permanent_cons(sc, sc->nil, sc->t3_2, T_PAIR | T_IMMUTABLE); sc->t4_1 = permanent_cons(sc, sc->nil, sc->t3_1, T_PAIR | T_IMMUTABLE); sc->u1_1 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + sc->u2_2 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + sc->u2_1 = permanent_cons(sc, sc->nil, sc->u2_2, T_PAIR | T_IMMUTABLE); sc->safe_lists[0] = sc->nil; for (i = 1; i < NUM_SAFE_PRELISTS; i++) @@ -94040,7 +94372,6 @@ s7_scheme *s7_init(void) sc->temp7 = sc->nil; sc->temp8 = sc->nil; sc->temp9 = sc->nil; - sc->temp10 = sc->nil; sc->rec_p1 = sc->F; sc->rec_p2 = sc->F; @@ -94132,14 +94463,14 @@ s7_scheme *s7_init(void) vector_getter(sc->symbol_table) = default_vector_getter; vector_setter(sc->symbol_table) = default_vector_setter; s7_vector_fill(sc, sc->symbol_table, sc->nil); - { + + { /* sc->opts */ opt_info *os; os = (opt_info *)calloc(OPTS_SIZE, sizeof(opt_info)); add_saved_pointer(sc, os); for (i = 0; i < OPTS_SIZE; i++) { - opt_info *o; - o = &os[i]; + opt_info *o = &os[i]; sc->opts[i] = o; opt_set_sc(o, sc); }} @@ -94169,6 +94500,7 @@ s7_scheme *s7_init(void) sc->default_hash_table_length = 8; sc->gensym_counter = 0; sc->capture_let_counter = 0; + sc->continuation_counter = 0; sc->f_class = 0; sc->add_class = 0; sc->num_eq_class = 0; @@ -94425,7 +94757,7 @@ s7_scheme *s7_init(void) 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 != 932) 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 (NUM_OPS != 940) 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 @@ -94692,7 +95024,7 @@ void s7_repl(s7_scheme *sc) /* try to get lib_s7.so from the repl's directory, and set *libc*. * otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h */ - e = s7_inlet(sc, list_2(sc, s7_make_symbol(sc, "init_func"), s7_make_symbol(sc, "libc_s7_init"))); + e = s7_inlet(sc, set_plist_2(sc, s7_make_symbol(sc, "init_func"), s7_make_symbol(sc, "libc_s7_init"))); gc_loc = s7_gc_protect(sc, e); old_e = s7_set_curlet(sc, e); /* e is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */ @@ -94811,57 +95143,74 @@ int main(int argc, char **argv) #endif #endif -/* ------------------------------------------------------- - * gmp (7-19) 20.9 21.0 21.5 21.6 - * ------------------------------------------------------- - * tpeak 123 115 114 112 110 - * tref 527 691 687 480 477 - * tauto 786 648 642 503 496 - * tshoot 1484 883 872 837 810 - * index 1051 1026 1016 989 983 - * tmock 7748 1177 1165 1111 1098 - * tvect 1951 2456 2413 1867 1756 - * s7test 4522 1873 1831 1817 1815 1812 - * lt 2127 2123 2110 2119 2123 - * tform 3263 2281 2273 2274 2267 - * tmac 2413 3317 3277 2436 2389 - * tread 2594 2440 2421 2409 2411 - * trclo 4070 2715 2561 2459 2455 - * tmat 2677 3065 3042 2524 2523 2534 - * fbench 2868 2688 2583 2542 2544 - * tcopy 2623 8035 5546 2557 2555 - * dup 2927 3805 3788 2962 2639 - * tb 3321 2735 2681 2565 2560 2576 [op_dox? subtract_u1??] - * titer 2727 2865 2842 2710 2679 - * tsort 3656 3105 3104 2925 2924 - * tset 3230 3253 3104 3244 3090 - * teq 3594 4068 4045 3701 3576 - * tio 3715 3816 3752 3703 3702 - * tstr 6591 5281 4863 4329 4197 - * tclo 4690 4787 4735 4512 4409 - * tcase 4537 4960 4793 4480 4474 - * tlet 5471 7775 5640 4488 4490 - * tmap 5715 8270 8188 4730 4694 - * tfft 114.8 7820 7729 4816 4798 - * tnum 56.6 6348 6013 5449 5445 - * tmisc 6068 7389 6210 5477 5463 - * tgsl 25.2 8485 7802 6394 6389 - * trec 8338 6936 6563 6553 - * tlist 7140 7896 7216 7087 - * tgc 10.2 11.9 11.1 9070 8726 - * thash 35.3 11.8 11.7 10.3 9838 - * tgen 12.3 11.2 11.4 11.4 11.5 - * tall 26.8 15.6 15.6 15.6 15.6 - * calls 60.7 36.7 37.5 37.1 37.1 - * sg 56.1 - * lg 104.9 106.6 105.0 104.5 104.5 - * tbig 596.1 177.4 175.8 169.6 167.6 - * ------------------------------------------------------- +/* -------------------------------------------------------- + * gmp (8-23) 20.9 21.0 21.6 21.7 + * -------------------------------------------------------- + * tpeak 123 115 114 110 110 + * tari 376 + * tref 552 691 687 477 476 + * tauto 785 648 642 496 496 + * tshoot 1471 883 872 810 808 + * index 1031 1026 1016 983 981 + * tmock 7756 1177 1165 1098 1090 + * tvect 1915 2456 2413 1756 1735 + * s7test 4514 1873 1831 1812 1792 + * lt 2129 2123 2110 2123 2120 + * tform 3245 2281 2273 2267 2255 + * tmac 2429 3317 3277 2389 2409 + * tread 2591 2440 2421 2411 2415 + * trclo 4093 2715 2561 2455 2458 + * fbench 2852 2688 2583 2544 2475 + * tmat 2648 3065 3042 2523 2530 + * tcopy 2745 8035 5546 2557 2550 + * dup 2760 3805 3788 2639 2565 + * tb 3375 2735 2681 2560 2627 + * titer 2678 2865 2842 2679 2679 + * tsort 3590 3105 3104 2924 2860 + * tset 3100 3253 3104 3090 3089 + * tload 3849 3234 3142 + * teq 3542 4068 4045 3576 3570 + * tio 3684 3816 3752 3702 3693 + * tstr 6230 5281 4863 4197 4175 + * tclo 4636 4787 4735 4409 4402 + * tlet 5283 7775 5640 4490 4431 + * tcase 4550 4960 4793 4474 4444 + * tmap 5984 8869 8774 5209 4493 + * tfft 115.1 7820 7729 4798 4787 + * tnum 56.7 6348 6013 5445 5443 + * tgsl 25.2 8485 7802 6389 6397 + * trec 8338 6936 6922 6553 6553 [half fx_num_eq_t0 -> fb_num_eq_s0] + * tmisc 7217 8960 7699 6972 6597 + * tlist 6834 7896 7546 7087 6865 + * tgc 10.1 11.9 11.1 8726 8668 + * thash 35.4 11.8 11.7 9838 9775 + * cb 18.8 12.2 12.2 11.6 11.1 + * tgen 12.1 11.2 11.4 11.5 11.5 + * tall 24.4 15.6 15.6 15.6 15.6 + * calls 58.0 36.7 37.5 37.1 37.1 + * sg 80.0 56.1 56.1 + * lg 104.5 106.6 105.0 104.5 104.4 + * tbig 635.1 177.4 175.8 167.7 166.4 166.1 + * -------------------------------------------------------- * - * terminal app doc? - * dilambda/setter timings * (n)repl.scm should have some autoload function for libm and libgsl (libc also for nrepl): cload.scm has checks at end - * random -> 0? try new form? - * more rest arg tests - * extend gmp to fx/opt? + * fb_annotate: bool_opt cases? and/or with bool ops (lt gt etc), cond/do tests if result + * in the vs case, can we see the bfunc and update it? In fx_tree OP_IF_B* call fx_tree directly and catch fixup + * for and/or: all branches fx->fb -> new op?? + * fx_tree fb cases? + * much repetition now from p_p + * op_local_lambda _fx? [and unwrap the pointless case ((lambda () (f a b)))] + * need fx_annotate (but not tree) for lambda body, OP_F|F_A|F_AA? + * timing top-down, in-place lambda, tangled lets, r7rs (stuff?, write?), dw/call-with-exit, unknowns, p_call etc + * tari/texit/tsupid + * test/timing 20.0|6 + * b_pi_ff and check_b_types -> b_pi etc + * some opt cases check methods/errors, but others don't -- these should have the methods + * new nrepl bug in row 0 (2.3.13 is ok, 2.3.17 is broken) [probably some option] + * __has_include_ (c++ now?, c23) for mus-config.h, possibly: + #if defined __has_include + # if __has_include ("mus-config.h") + # include "mus-config.h" + # endif + #endif */ @@ -1,10 +1,10 @@ #ifndef S7_H #define S7_H -#define S7_VERSION "9.15" -#define S7_DATE "3-Aug-2021" +#define S7_VERSION "9.17" +#define S7_DATE "6-Sep-2021" #define S7_MAJOR_VERSION 9 -#define S7_MINOR_VERSION 15 +#define S7_MINOR_VERSION 17 #include <stdint.h> /* for int64_t */ @@ -366,7 +366,8 @@ s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string); s7_pointer s7_open_output_string(s7_scheme *sc); /* (open-output-string) */ const char *s7_get_output_string(s7_scheme *sc, s7_pointer out_port); /* (get-output-string port) -- current contents of output string */ /* don't free the string */ -void s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* (flush-output-port port) */ +s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p); /* same but returns an s7 string */ +bool s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* (flush-output-port port) */ typedef enum {S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, S7_IS_CHAR_READY, S7_NUM_READ_CHOICES} s7_read_t; s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)); @@ -911,6 +912,7 @@ typedef s7_double s7_Double; * * s7 changes * + * 25-Aug: s7_output_string (like s7_get_output_string, but returns an s7 string). * 19-Jul: s7_is_random_state, s7_make_normal_vector. s7_array_to_list. * 12-Apr: s7_optimize now returns an s7_pfunc, not an s7_function. * 7-Apr: removed the "args" parameter from s7_float_function. added s7_make_c_object_without_gc. @@ -5526,7 +5526,8 @@ undefined-constant-warnings #f accept-all-keyword-arguments #f autoloading? #t openlets #t, whether any let can be open globally (this overrides all openlets) -expansions? #t, whether expansions are handled at read-time +expansions? #t, whether expansions are handled at read-time +muffle-warnings? #f, if #t s7_warn does not output anything cpu-time run time so far file-names currently loaded files (a list) @@ -5560,6 +5561,20 @@ Use the standard environment syntax to access these fields: <code>(*s7* 'stack-top)</code>. stuff.scm has the function *s7*->list that returns most of these fields in a list. </p> +<p>The compile-time defaults for some of these fields can be set: +</p> +<pre class="indented"> +heap-size: INITIAL_HEAP_SIZE (64000) +stack-size: INITIAL_STACK_SIZE (4096) +gc-temps-size: GC_TEMPS_SIZE (256) +bignum-precision: DEFAULT_BIGNUM_PRECISION (128) +history-size: DEFAULT_HISTORY_SIZE (8) +print-length: DEFAULT_PRINT_LENGTH (12) +gc-resize-heap-fraction: GC_RESIZE_HEAP_FRACTION (0.8) +output-port-data-size: OUTPUT_PORT_DATA_SIZE (2048) + +See also WITH_WARNINGS, S7_ALIGNED, and GC_TRIGGER_SIZE. +</pre> <p><code>(set! (*s7* 'autoloading) #f)</code> turns off the autoloader. </p> @@ -8967,7 +8982,8 @@ and treats it as if it were the contents of a file of scheme code. So, unlike s multiple statements, and things like double-quote don't need to be quoted. nrepl.c for example embeds the contents of nrepl.scm at compile time, then calls s7_load_c_string at program startup. It also includes notcurses_s7.c. The end result is a stand-alone program that doesn't need to load either nrepl.scm -or notcurses_s7.so. +or notcurses_s7.so. The "content" argument should be a null-terminated C string. The "bytes" argument +is the contents length, not including the trailing null, as in strlen. There are simple examples in ffitest.c. </p> <blockquote> @@ -9402,7 +9418,7 @@ bool s7_is_input_port(s7_scheme *sc, s7_pointer p); bool s7_is_output_port(s7_scheme *sc, s7_pointer p); void s7_close_input_port(s7_scheme *sc, s7_pointer p); void s7_close_output_port(s7_scheme *sc, s7_pointer p); -void s7_flush_output_port(s7_scheme *sc, s7_pointer p); +bool s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* false=flush lost data */ const char *s7_port_filename(s7_scheme *sc, s7_pointer x); s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p); @@ -9412,6 +9428,7 @@ s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string); s7_pointer s7_open_output_string(s7_scheme *sc); const char *s7_get_output_string(s7_scheme *sc, s7_pointer out_port); +s7_pointer s7_output_string(s7_scheme *sc, s7_pointer out_port); typedef enum {S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, S7_IS_CHAR_READY, S7_NUM_READ_CHOICES} s7_read_t; s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)); @@ -9441,6 +9458,8 @@ returns the file associated with a file port. s7_port_line_number returns posit reader in an input file port. The "use_write" parameter to s7_object_to_string refers to the write/display choice in scheme. The string returned by s7_object_to_c_string should be freed by the caller. +s7_output_string is the same as s7_get_output_string except that it returns an s7 string, +not a C string. </p> <p>s7_open_input_function and s7_open_output_function call their "function" argument when input or output is requested. The "read_choice" @@ -253,24 +253,27 @@ end (if (not (equal? result oexp)) (format #t "~A: ~A got ~S but expected ~S~%~%" (port-line-number) otst result oexp)))) -(if (not (defined? 'test)) - (define-macro (test tst expected) ;(display tst *stderr*) (newline *stderr*) - ;; `(ok? ',tst (lambda () (eval-string (format #f "~S" ',tst))) ,expected)) - ;; `(ok? ',tst (lambda () (eval ',tst)) ,expected)) - ;; `(ok? ',tst (lambda () ,tst) ,expected)) - ;; `(ok? ',tst (lambda () (eval-string (object->string ,tst :readable))) ,expected)) - ;; `(ok? ',tst (let () (define (_s7_) ,tst)) ,expected)) - ;; `(ok? ',tst (lambda () (let ((_s7_ #f)) (set! _s7_ ,tst))) ,expected)) - ;; `(ok? ',tst (lambda () (let ((_s7_ ,tst)) _s7_)) ,expected)) - ;; `(ok? ',tst (catch #t (lambda () (lambda* ((_a_ ,tst)) _a_)) (lambda any (lambda () 'error))) ,expected)) - ;; `(ok? ',tst (lambda () (do ((_a_ ,tst)) (#t _a_))) ,expected)) - ;; `(ok? ',tst (lambda () (call-with-exit (lambda (_a_) (_a_ ,tst)))) ,expected)) - ;; `(ok? ',tst (lambda () (values ,tst)) ,expected)) - ;; `(ok? ',tst (lambda () (define (_s7_ _a_) _a_) (_s7_ ,tst)) ,expected)) - ;; `(ok? ',tst (lambda () (define* (_s7_ (_a_ #f)) (or _a_)) (_s7_ ,tst)) ,expected)) - ;; `(ok? ',tst (lambda () (caadr (catch 'receive (lambda () (throw 'receive ,tst)) (lambda any any)))) ,expected)) - ;; `(ok? ',tst (lambda () (stacktrace (- (random 100) 50) (- (random 100) 50) (- (random 100) 50) (- (random 100) 50) (> (random 100) 50)) ,tst) ,expected)) - (list 'ok? (list quote tst) (list-values lambda () tst) expected)) +(define original-test-macro #f) + +(unless (defined? 'test) + (set! original-test-macro #t) + (define-macro (test tst expected) ;(display tst *stderr*) (newline *stderr*) + ;; `(ok? ',tst (lambda () (eval-string (format #f "~S" ',tst))) ,expected)) + ;; `(ok? ',tst (lambda () (eval ',tst)) ,expected)) + ;; `(ok? ',tst (lambda () ,tst) ,expected)) + ;; `(ok? ',tst (lambda () (eval-string (object->string ,tst :readable))) ,expected)) + ;; `(ok? ',tst (let () (define (_s7_) ,tst)) ,expected)) + ;; `(ok? ',tst (lambda () (let ((_s7_ #f)) (set! _s7_ ,tst))) ,expected)) + ;; `(ok? ',tst (lambda () (let ((_s7_ ,tst)) _s7_)) ,expected)) + ;; `(ok? ',tst (catch #t (lambda () (lambda* ((_a_ ,tst)) _a_)) (lambda any (lambda () 'error))) ,expected)) + ;; `(ok? ',tst (lambda () (do ((_a_ ,tst)) (#t _a_))) ,expected)) + ;; `(ok? ',tst (lambda () (call-with-exit (lambda (_a_) (_a_ ,tst)))) ,expected)) + ;; `(ok? ',tst (lambda () (values ,tst)) ,expected)) + ;; `(ok? ',tst (lambda () (define (_s7_ _a_) _a_) (_s7_ ,tst)) ,expected)) + ;; `(ok? ',tst (lambda () (define* (_s7_ (_a_ #f)) (or _a_)) (_s7_ ,tst)) ,expected)) + ;; `(ok? ',tst (lambda () (caadr (catch 'receive (lambda () (throw 'receive ,tst)) (lambda any any)))) ,expected)) + ;; `(ok? ',tst (lambda () (stacktrace (- (random 100) 50) (- (random 100) 50) (- (random 100) 50) (- (random 100) 50) (> (random 100) 50)) ,tst) ,expected)) + (list 'ok? (list quote tst) (list-values lambda () tst) expected)) #| `(let ((_result_ #f)) (define (stest) (set! _result_ ,tst)) @@ -430,7 +433,8 @@ end ;;; -------------------------------------------------------------------------------- ;;; before starting, make a test c-object -(define with-block (not (provided? 'windows))) +(unless (defined? 'with-block) + (define with-block (not (provided? 'windows)))) (if with-block (begin @@ -451,7 +455,7 @@ typedef struct { double *data; } g_block; -static s7_int g_block_type = 0, g_simple_block_type = 0, g_c_tag_type = 0, g_cycle_type = 0; +static s7_int g_block_type = 0, g_simple_block_type = 0, g_c_tag_type = 0, g_cycle_type = 0, block_gc_loc = 0; static s7_pointer g_block_methods; static s7_pointer g_block_let(s7_scheme *sc, s7_pointer args) @@ -986,6 +990,16 @@ static s7_pointer g_block_append(s7_scheme *sc, s7_pointer args) return(new_g); } +#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__))) + #define Vectorized +#else +#if (defined(__GNUC__) && __GNUC__ >= 5) + #define Vectorized __attribute__((optimize(\"tree-vectorize\"))) +#else + #define Vectorized +#endif +#endif + static s7_pointer g_block_reverse(s7_scheme *sc, s7_pointer args) { size_t i, j; @@ -1001,7 +1015,7 @@ static s7_pointer g_block_reverse(s7_scheme *sc, s7_pointer args) return(new_g); } -static s7_pointer g_block_reverse_in_place(s7_scheme *sc, s7_pointer args) +static s7_pointer g_block_reverse_in_place(s7_scheme *sc, s7_pointer args) /* Vectorized is slower */ { #define g_block_reverse_in_place_help \"(block-reverse! block) returns block with its data reversed.\" size_t i, j; @@ -1039,15 +1053,6 @@ static s7_pointer g_block_reverse_in_place(s7_scheme *sc, s7_pointer args) return(obj); } -#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__))) - #define Vectorized -#else -#if (defined(__GNUC__) && __GNUC__ >= 5) - #define Vectorized __attribute__((optimize(\"tree-vectorize\"))) -#else - #define Vectorized -#endif -#endif static Vectorized void block_memclr64(double *data, size_t bytes) { size_t i; @@ -1116,6 +1121,13 @@ static s7_pointer g_subblock(s7_scheme *sc, s7_pointer args) return(new_g); } +static s7_pointer g_block_release_methods(s7_scheme *sc, s7_pointer args) +{ + s7_gc_unprotect_at(sc, block_gc_loc); + return(s7_f(sc)); +} + + /* function port tests */ static unsigned char *fout = NULL; static unsigned int fout_size = 0, fout_loc = 0; @@ -1308,7 +1320,7 @@ void block_init(s7_scheme *sc) s7_define_function_star(sc, \"unsafe-blocks4\", g_blocks, \"(frequency 4) (scaler 1) (asdf 32) etc\", \"test for function*\"); s7_define_safe_function_star(sc, \"blocks5\", g_blocks, \"(frequency 4) :allow-other-keys\", \"test for function*\"); g_block_methods = s7_eval_c_string(sc, \"(openlet (immutable! (inlet 'float-vector? (lambda (p) #t) \ - 'signature (lambda (p) (list '#t 'block? 'integer?)) \ + 'signature (lambda (p) (list #t 'block? 'integer?)) \ 'type block? \ 'arity (lambda (p) (cons 1 1)) \ 'aritable? (lambda (p args) (= args 1)) \ @@ -1319,7 +1331,8 @@ void block_init(s7_scheme *sc) 'subsequence subblock \ 'append block-append \ 'reverse! block-reverse!)))\"); - s7_gc_protect(sc, g_block_methods); + block_gc_loc = s7_gc_protect(sc, g_block_methods); + s7_define_safe_function(sc, \"block-release-methods\", g_block_release_methods, 0, 0, false, NULL); g_simple_block_type = s7_make_c_type(sc, \"<simple-block>\"); s7_define_safe_function(sc, \"make-simple-block\", g_make_simple_block, 1, 0, false, g_make_simple_block_help); @@ -1413,8 +1426,8 @@ void block_init(s7_scheme *sc) (define _c_obj_ (make-block 16)) (unless (immutable? (block-let _c_obj_)) (format *stderr* "~S's let is mutable~%" _c_obj_))) ; with-block - -(define _c_obj_ (c-pointer 0))) ; not with-block + ;; else... + (define _c_obj_ (c-pointer 0))) ; not with-block (define _null_ (c-pointer 0)) (when (provided? 'linux) @@ -11548,6 +11561,10 @@ i" (lambda (p) (eval (read p)))) pi) (set! v (make-byte-vector 3)) (fill! v (bignum "1")))) +(test ((lambda () (make-vector (call-with-exit (lambda (return) (let ((x 1) (y 2)) (return x y)))) (vector? (make-float-vector '(2 3) 1))))) #(2)) +(when with-block + (test ((lambda () (list (call-with-exit (lambda (return) (let ((x 1) (y 2)) (return x y)))) (append (block) (block))))) (list 1 2 (block)))) + (test (equal? (make-int-vector 3 1) (int-vector 1 1 1)) #t) (test ((make-int-vector '(2 3) 2) 1 2) 2) @@ -11971,6 +11988,16 @@ i" (lambda (p) (eval (read p)))) pi) (test (f1) 3) (test (f2) 3)) +(let () + (define fvref float-vector-ref) + (define ivref int-vector-ref) + (define bvref byte-vector-ref) + (define vref vector-ref) + (test (let ((a7 (subvector #i2d((1 2) (3 4)) 1 3 '(2 1)))) (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (ivref a7 0)))) (func)) #i(2)) + (test (let ((a7 (subvector #u2d((1 2) (3 4)) 1 3 '(2 1)))) (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (bvref a7 0)))) (func)) #u(2)) + (test (let ((a7 (subvector #r2d((1 2) (3 4)) 1 3 '(2 1)))) (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (fvref a7 0)))) (func)) #r(2)) + (test (let ((a7 (subvector #2d((1 2) (3 4)) 1 3 '(2 1)))) (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (vref a7 0)))) (func)) #(2))) + ;;; -------------------------------------------------------------------------------- ;;; vector @@ -12227,6 +12254,7 @@ i" (lambda (p) (eval (read p)))) pi) (test (vector-dimensions (vector-ref #3d(((1 2 3) (3 4 5)) ((5 6 1) (7 8 2))) 0 1)) '(3)) (test (set! (vector-dimensions #(1 2)) 1) 'error) (test (let ((v #(1 2 3))) (set! (car (vector-dimensions v)) 0) v) #(1 2 3)) +(test (hash-table 1 (vector-dimensions (block))) (hash-table 1 '(0))) ;;; -------------------------------------------------------------------------------- @@ -13863,8 +13891,8 @@ i" (lambda (p) (eval (read p)))) pi) (test (list-tail lst1 9223372036854775807) 'error) (test (make-vector lst1 9223372036854775807) 'error) (let-temporarily (((*s7* 'safety) 1)) - (test (not (member (map (lambda (x) x) lst1) (list () '(1)))) #f) ; geez -- just want to allow two possible ok results - (test (not (member (map (lambda (x y) x) lst1 lst1) (list () '(1)))) #f) + (test (not (member (map (lambda (x) x) lst1) '(() (1)))) #f) (newline) ; geez -- just want to allow two possible ok results, so "not" makes it boolean + (test (not (member (map (lambda (x y) x) lst1 lst1) '(() (1)))) #f) (test (for-each (lambda (x) x) lst1) #<unspecified>) ; was 'error (test (for-each (lambda (x y) x) lst1 lst1) #<unspecified>) ; was 'error (test (not (member (map (lambda (x y) (+ x y)) lst1 '(1 2 3)) (list () '(2)))) #f))) @@ -13877,12 +13905,12 @@ i" (lambda (p) (eval (read p)))) pi) (let ((lst1 (list 1 -1))) (set-cdr! (cdr lst1) lst1) (let ((vals (map * '(1 2 3 4) lst1))) - (test vals '(1 -2)))) ; was '(1 -2 3 -4), then later (1) -- as in other cases above, map/for-each stop when a cycle is encountered + (test vals '(1 -2 3)))) ; was '(1 -2 3 -4), then later (1 -2) -- as in other cases above, map/for-each stop when a cycle is encountered (test (let ((lst '(a b c))) (set! (cdr (cddr lst)) lst) (map cons lst '(0 1 2 3 4 5))) - '((a . 0) (b . 1) (c . 2) (a . 3))) + '((a . 0) (b . 1) (c . 2) (a . 3) (b . 4))) ; as above (test (object->string (let ((l1 (list 0 1))) (set! (l1 1) l1) (copy l1))) "(0 #1=(0 #1#))") @@ -21791,7 +21819,6 @@ a2" 3) "132") (with-output-to-file (append "/home/" username "/test/load-path-test.scm") (lambda () (format #t "(define (load-path-test) *load-path*)~%"))) - (load "load-path-test.scm") (if (or (not (defined? 'load-path-test)) (not (equal? *load-path* (load-path-test)))) @@ -25180,7 +25207,7 @@ c" (define L2 (let ((lst (list 1 2 3))) (set-cdr! (cddr lst) lst) lst)) (define V1 (make-vector 5 0)) (test (map cons L1 V1) '((1 . 0) (2 . 0))) ; perhaps it should be out to 5 (needs to be consistent with iterate) - (test (map cons L1 L2) '((1 . 1) (2 . 2))) + (test (map cons L1 L2) '((1 . 1) (2 . 2) (1 . 3))) (let ((L ())) (for-each (lambda (p q) (set! L (cons (cons p q) L))) @@ -25190,7 +25217,7 @@ c" (for-each (lambda (p q) (set! L (cons (cons p q) L))) L1 L2) - (test L '((2 . 2) (1 . 1)))) + (test L '((2 . 2) (1 . 1)))) ; depends on cycle detection point (test (map (let ((L1 (let ((lst (list 1 2 3))) (set-cdr! (cddr lst) lst) lst))) (lambda (p) (let ((result (cons (car L1) p))) @@ -25630,7 +25657,8 @@ c" (test (let ((L (list 1 2 3))) (map (lambda (x) (set-car! (cddr L) 32) x) L)) '(1 2 32)) ;;; should these notice the increased length?: (test (let ((L1 (list 1 2)) (L2 (list 6 7 8 9))) (map (lambda (x y) (set-cdr! (cdr L1) (list 10 11 12 13 14)) (cons x y)) L1 L2)) '((1 . 6) (2 . 7) (10 . 8) (11 . 9))) -(test (let ((L1 (list 1)) (L2 (list 6 7 8))) (map (lambda (x y) (set-cdr! L1 (list 10 11 12)) (cons x y)) L1 L2)) '((1 . 6))) +(test (let ((L1 (list 1)) (L2 (list 6 7 8))) (not (member (map (lambda (x y) (set-cdr! L1 (list 10 11 12)) (cons x y)) L1 L2) '(((1 . 6)) ((1 . 6) (10 . 7) (11 . 8)))))) #f) +;;; op_map checks iterator_at_end before calling the function, whereas op_map_closure_2 checks afterwards so we get inconsistent results (test (let ((L1 (list 1 2))) (map (lambda (x) (set-cdr! (cdr L1) (list 10 11 12)) x) L1)) '(1 2 10 11 12)) ;;; a similar case could be made from hash-tables (test (let ((H (hash-table 'a 3 'b 4))) (pair? (map (lambda (x) (set! (H 'c) 32) (cdr x)) H))) #t) @@ -25849,6 +25877,18 @@ c" ;;; (test (map symbol->value (let ((lst (list 'integer? 'boolean?))) (set-cdr! (cdr lst) lst) lst)) (list integer?)) ;;; I think this depends on when the list iterator notices the cycle +(let () (define (f0) (for-each (lambda (x y) (display x)) (list 1 2 3) (list 4 5 6))) (test (with-output-to-string f0) "123")) +(let () (define (f1) (for-each (lambda (x y) (display x)) (vector 1 2 3) (vector 4 5 6))) (test (with-output-to-string f1) "123")) +(let () (define (f2) (for-each (lambda (x y) (display x)) "123" "456")) (test (with-output-to-string f2) "123")) +(let () (define (f01) (for-each (lambda (x y) (display y)) (list 1 2 3) (list 4 5 6))) (test (with-output-to-string f01) "456")) +(let () (define (f11) (for-each (lambda (x y) (display y)) (vector 1 2 3) (vector 4 5 6))) (test (with-output-to-string f11) "456")) +(let () (define (f21) (for-each (lambda (x y) (display y)) "123" "456")) (test (with-output-to-string f21) "456")) +(let () (define (f02) (map (lambda (x y) (+ x y)) (list 1 2 3) (list 4 5 6))) (test (f02) (list 5 7 9))) +(let () (define (f12) (map (lambda (x y) (+ x y)) (vector 1 2 3) (vector 4 5 6))) (test (f12) (list 5 7 9))) +(let () (define (f22) (map (lambda (x y) (cons x y)) "123" "456")) (test (f22) '((#\1 . #\4) (#\2 . #\5) (#\3 . #\6)))) +(let () (define (f03) (map (lambda (x y) (+ x y)) (list 1 2 3) (vector 4 5 6))) (test (f03) '(5 7 9))) +(let () (define (f13) (map (lambda (x y) (+ x y)) (vector 1 2 3) (list 4 5 6))) (test (f13) '(5 7 9))) +(let () (define (f23) (map (lambda (x y) (cons x y)) "123" (list 4 5 6))) (test (f23) '((#\1 . 4) (#\2 . 5) (#\3 . 6)))) #| ;;; this is from the r6rs comment site @@ -26096,6 +26136,13 @@ in s7: (test (iterator-at-end? s1) #t) (test (iterator? s1) #t))) +(let ((lst ()) + (iter (make-iterator '(1 2 3 #<eof> 4 5 6)))) + (do ((val (iterate iter) (iterate iter))) + ((iterator-at-end? iter) + (test (reverse lst) '(1 2 3 #<eof> 4 5 6))) + (set! lst (cons val lst)))) + (let ((str #2d((1 2) (3 4)))) (let ((s1 (make-iterator str))) (test (iterator-at-end? s1) #f) @@ -32531,11 +32578,18 @@ in s7: (test (+ (dynamic-wind (lambda () #f) (lambda () (values 1 2 3)) (lambda () #f)) 4) 10) (when with-block -;; safe_c_pa_mv plist bug + ;; op_safe_c_pa_mv plist bug (test (format #f "~S~%" (list (list-values (values 1 2 3 4 5 6 7 8 9 10) (block 1.0 2.0 3.0)) (make-vector 3 :rest keyword?))) (let () (define (func) (format #f "~S~%" (list (list-values (values 1 2 3 4 5 6 7 8 9 10) (block 1.0 2.0 3.0)) (make-vector 3 :rest keyword?)))) - (define (hi) (func)) (hi)))) + (define (hi) (func)) (hi))) + ;; list-values bug when args contains an immutable list + (test (list-values (vector (block 0.0)) (call-with-exit (lambda (return) (let ((x 1) (y 2)) (return x y))))) + (list (vector (block 0)) 1 2)) + (test (let () (define (func) (list (vector (block 0.0)) (call-with-exit (lambda (return) (let ((x 1) (y 2)) (return x y)))))) (func)) + (list (vector (block 0)) 1 2)) + (test (let () (define (func) (list-values (vector (block 0.0)) (call-with-exit (lambda (return) (let ((x 1) (y 2)) (return x y)))))) (func)) + (list (vector (block 0)) 1 2))) (let ((x 'y) (y 32)) @@ -35788,6 +35842,14 @@ who says the continuation has to restart the map from the top? (test (call-with-exit (lambda (quit) ((lambda* ((a (quit 32))) a)))) 32) (test ((call-with-exit (lambda (go) (go quasiquote))) go) 'go) +(if original-test-macro + (let ((res #f)) + (catch #t (lambda () + (test (let ((y 2)) ((lambda () (let ((z 1)) (values y z))))) 'error)) ; binding result in test to the (values 2 1) + (lambda args (set! res 'error))) + (unless (eq? res 'error) + (format *stderr* "bind test result to (values 1 2) not an error?~%")))) + (test (let ((x #f)) ((lambda () (let-temporarily ((x 1234)) @@ -40070,6 +40132,9 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta ;; that is the rest arg is not settable via a keyword and it's an error to try to ;; do so, even if :allow-other-keys -- ?? +(test (let ((mac (macro (a) `(+ ,a `1)))) (macroexpand (mac . 3))) 'error) +(test (for-each macroexpand (hash-table (macro (a) `(+ ,a 1)) #i(1 2))) 'error) + (test (let ((x 1)) (define* (hi (a x)) a) (let ((x 32)) (hi))) 1) (test (let ((x 1)) (define* (hi (a (+ x 0))) a) (let ((x 32)) (hi))) 1) (test (let ((x 1)) (define* (hi (a (+ x "hi"))) a) (let ((x 32)) (hi))) 'error) @@ -41523,6 +41588,9 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (define x 3) (test x 6)) +(test (eq? (let ((x 0)) (set! (setter 'x) integer?) (setter 'x)) integer?) #t) ; tricky... +(test (let ((x 0)) (set! (setter 'x) integer?) (make-vector (values 1 2) (setter 'x))) #i(2)) + (test (let ((v #(1 2 3))) ((setter vector-ref) v 0 32) v) @@ -41710,6 +41778,12 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (set! (setter '_x1_) (lambda (x y) 'error)) (test (set! _x1_ 32) 'error)) +(let ((x 0)) + (set! (setter 'x) + (lambda (_A _B) + (let ((y 2)) ((lambda () (let ((z 1)) (values y z))))))) + (test (set! x 1) 'error)) ; mv from setter + (let ((x 1)) (set! (setter 'x) (lambda (s v) x)) (let ((x 2)) @@ -41914,6 +41988,11 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (set! x 0) (test x 'error)) +(test (let ((x 3)) (set! (setter 'x) integer?) (set! (setter 'x) #f) (set! x 4.0)) 4.0) +(test (let ((x 3)) (set! (setter 'x) integer?) (set! (setter 'x) #f) (let-temporarily ((x 4.0)) x) x) 3) +(test (let ((x 3)) (set! (setter 'x) integer?) (let-temporarily (((setter 'x) #f)) (set! x 4.0)) x) 4.0) +(test (let ((x 3)) (set! (setter 'x) integer?) (let-temporarily (((setter 'x) #f)) (set! x 4.0)) (set! x 8.0)) 'error) + ;;; -------------------------------------------------------------------------------- ;;; documentation @@ -45166,8 +45245,8 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (im-test (immutable? L5) #f) (im-test (immutable? (L1 'a1)) #f) ; this is the value - (im-test (with-let L1 (immutable? 'a1)) #t) - (im-test (let ((a8 (list 8))) (immutable! 'a8) (immutable? 'a8)) #t) +; (im-test (with-let L1 (immutable? 'a1)) #t) + (im-test (let ((a8 (list 8))) (immutable! a8) (immutable? a8)) #t) (im-test (with-let L1 (set! a1 32)) 'immutable-error) (im-test (with-let L2 (set! a2 32)) 'immutable-error) @@ -46232,6 +46311,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (let ((a 1)) ((inlet (curlet)) 'a)) 1) (test (let ((a 1)) ((inlet '(b . 2)) 'a)) #<undefined>) (test (let ((a (inlet 'b 2))) (set! (let-ref a 'b) 3) (a 'b)) 3) ; let-ref setter is let-set! +(let ((let1 (inlet 'a 1))) (varlet let1 'let1 let1) (with-let let1 (with-let let1 (define b 2))) (test (let1 'b) 2)) (for-each (lambda (arg) @@ -63479,6 +63559,7 @@ hi6: (string-app... (num-test (modulo 5.551115123125783999999999999999999999984E-17 1.110223024625156799999999999999999999997E-16) 5.551115123125783999999999999999999999984E-17) (num-test (modulo 9223372036854775807 -9223372036854775808) -1) (num-test (modulo 9223372036854775807 9223372036854775807) 0) +(num-test (modulo (+ (ash 1 54) 1) (ash 1 54)) 1) (num-test (modulo 8/3 3/2) 7/6) (num-test (modulo 37/8 17/12) 3/8) @@ -93892,7 +93973,7 @@ etc ;;; *s7* -------- -(define-constant *s7*-length 54) +(define-constant *s7*-length 55) (test (let? *s7*) #t) (test (outlet *s7*) (rootlet)) @@ -93943,7 +94024,7 @@ etc (test (eq? (car val) 'stack-top) #t) (test (integer? (cdr val)) #t))) -(test (length (object->let *s7*)) 60) +(test (length (object->let *s7*)) 61) (test (with-let *s7* (define asdf 321)) 'error) (test ((object->let (make-iterator *s7*)) 'sequence) *s7*) (when full-s7test @@ -93998,6 +94079,7 @@ etc (test (boolean? (*s7* 'undefined-identifier-warnings)) #t) (test (boolean? (*s7* 'undefined-constant-warnings)) #t) (test (boolean? (*s7* 'accept-all-keyword-arguments)) #t) +(test (boolean? (*s7* 'muffle-warnings?)) #t) (test (integer? (*s7* ':print-length)) #t) (test (integer? (*s7* :print-length)) #t) (test (eqv? (*s7* 'print-length) (*s7* :print-length)) #t) @@ -94170,7 +94252,7 @@ etc (test (set! (*s7* field) arg) 'error)) (list "hi" (integer->char 65) (list 1 2) (make-vector 3) abs _ht_ _undef_ _null_ _c_obj_ quasiquote macroexpand 3/4 3.14 1.0+1.0i #\f (lambda (a) (+ a 1)) #<eof> #<undefined>))) - '(undefined-identifier-warnings undefined-constant-warnings gc-stats accept-all-keyword-arguments)) + '(undefined-identifier-warnings undefined-constant-warnings gc-stats accept-all-keyword-arguments muffle-warnings?)) (test (set! #_abs 32) 'error) (test (define (#_abs a) (= a 1)) 'error) @@ -97884,6 +97966,7 @@ etc (lint-test "(if old (cons form old) (list form))" " if: perhaps (if old (cons form old) (list form)) -> (cons form (or old ()))") (lint-test "(if (not x) (list y) (cons y x))" " if: perhaps (if (not x) (list y) (cons y x)) -> (cons y (or x ()))") (lint-test "(if (not x) (cons y x) (list y))" " if: perhaps (if (not x) (cons y x) (list y)) -> (cons y (if (not x) x ()))") + (lint-test "(if (float-vector-ref fv 0) 0 1)" " if: if test is never false: (if (float-vector-ref fv 0) 0 1)") (lint-test "(if x (set! y #f) (set! y #t))" " if: perhaps (if x (set! y #f) (set! y #t)) -> (set! y (not x))") (lint-test "(if x (set! y x) (set! y 21))" " if: perhaps (if x (set! y x) (set! y 21)) -> (set! y (or x 21))") @@ -103855,7 +103938,8 @@ etc with-input-from-file's argument 1 should be a string, but 0 is an integer? func: let is messed up: (let (make-dilambda (lambda () 1) (lambda (a) a)) (set! i01+))") (lint-test "(define (func x) (cond ((byte-vector-ref) (iterator? 12.)) (else (unless .+2 '((x 1) y . 2) 1 - or case quote . __asdf__))))" - " func: byte-vector-ref needs at least 2 arguments: (byte-vector-ref) + " func: cond test (byte-vector-ref) is never false: (cond ((byte-vector-ref) (iterator? 12.0)) (else (unless .+2 '((x 1) y .... + func: byte-vector-ref needs at least 2 arguments: (byte-vector-ref) func: unless is messed up: (unless .+2 '((x 1) y . 2) 1 - or case quote . __asdf__)") (lint-test "(define (func x) (lambda* .(lcm . do)))" " func: lambda* is messed up in (lambda* lcm . do)") (lint-test "(define (func x) (let . `(((x 1))) ))" @@ -1554,6 +1554,7 @@ void stop_applying(snd_info *sp) { /* called if C-g during the apply process */ sp->apply_ok = false; + sp->applying = false; } typedef struct { @@ -1607,7 +1608,7 @@ static bool apply_controls(apply_state *ap) if (!ap) return(false); sp = ap->sp; - if ((!(sp->active)) || (sp->inuse != SOUND_NORMAL)) return(false); + if ((!(sp->active)) || (sp->inuse != SOUND_NORMAL)) {sp->applying = false; return(false);} if (sp->filter_control_on) added_dur = sp->filter_control_order; @@ -1644,6 +1645,7 @@ static bool apply_controls(apply_state *ap) if (!si) { sp->sync = old_sync; + sp->applying = false; return(false); } @@ -1700,7 +1702,7 @@ static bool apply_controls(apply_state *ap) case APPLY_TO_SELECTION: ap->hdr->chans = selection_chans(); - if (ap->hdr->chans <= 0) return(false); + if (ap->hdr->chans <= 0) {sp->applying = false; return(false);} if (apply_dur == 0) apply_dur = selection_len(); break; @@ -1778,11 +1780,11 @@ static bool apply_controls(apply_state *ap) if (ap->ofd == -1) { + sp->applying = false; snd_error("%s apply temp file %s: %s\n", (io_err != IO_NO_ERROR) ? io_error_name(io_err) : "can't open", ap->ofile, snd_open_strerror()); - sp->applying = false; free_apply_state(ap); return(false); } @@ -4166,8 +4168,6 @@ static s7_pointer g_save_sound_as(s7_scheme *sc, s7_pointer args) bool free_outcom = false; int edit_position = AT_CURRENT_EDIT_POSITION; - /* fprintf(stderr, "args: %s\n", s7_object_to_c_string(sc, args)); */ - fp = s7_car(args); filep = fp; if (fp != Xen_false) @@ -47,11 +47,11 @@ #include "snd-strings.h" -#define SND_DATE "3-Aug-21" +#define SND_DATE "6-Sep-21" #ifndef SND_VERSION -#define SND_VERSION "21.6" +#define SND_VERSION "21.7" #endif #define SND_MAJOR_VERSION "21" -#define SND_MINOR_VERSION "6" +#define SND_MINOR_VERSION "7" #endif @@ -150,9 +150,10 @@ (if (and (procedure? bp) (signature bp) (eq? 'boolean? (car (signature bp)))) - (if (type e) - e - (error 'bad-type "~S is ~S but should be ~S" e (type-of e) bp)) + (let ((result (if (= (car (arity bp)) 1) + (type e) + (bp 'the e)))) + (if result e (error 'bad-type "~S is ~S but should be ~S" e (type-of e) bp))) (error 'bad-type "~S is not a boolean procedure" bp)))) (define iota diff --git a/tools/fbench.scm b/tools/fbench.scm index 1b77ff4..d8fa5b3 100644 --- a/tools/fbench.scm +++ b/tools/fbench.scm @@ -71,8 +71,8 @@ (define max-lspher 0) (define max-osc 0) (define max-lchrom 0) -(define radius-of-curvature 0) -(define object-distance 0) +(define radius-of-curvature 0.0) +(define object-distance 0.0) (define ray-height 0) (define axis-slope-angle 0) (define from-index 0) @@ -117,30 +117,30 @@ (define (transit-surface) (let ((iang-sin 0)) (if (= paraxial 1) - (if (zero? radius-of-curvature) + (if (= radius-of-curvature 0.0) (begin (set! object-distance (* object-distance (/ to-index from-index))) (set! axis-slope-angle (* axis-slope-angle (/ from-index to-index)))) (begin - (if (zero? object-distance) + (if (= object-distance 0.0) (begin - (set! axis-slope-angle 0) + (set! axis-slope-angle 0.0) (set! iang-sin (/ ray-height radius-of-curvature))) (set! iang-sin (* (/ (- object-distance radius-of-curvature) radius-of-curvature) axis-slope-angle))) (let ((rang-sin (* (/ from-index to-index) iang-sin)) (old-axis-slope-angle axis-slope-angle)) (set! axis-slope-angle (- (+ axis-slope-angle iang-sin) rang-sin)) - (if (not (zero? object-distance)) + (if (not (= object-distance 0.0)) (set! ray-height (* object-distance old-axis-slope-angle))) (set! object-distance (/ ray-height axis-slope-angle))))) - (if (zero? radius-of-curvature) + (if (= radius-of-curvature 0.0) (let ((rang (- (asin (* (/ from-index to-index) (sin axis-slope-angle)))))) (set! object-distance (/ (* object-distance to-index (cos rang)) (* from-index (cos axis-slope-angle)))) (set! axis-slope-angle (- rang))) (begin - (if (zero? object-distance) + (if (= object-distance 0.0) (begin - (set! axis-slope-angle 0) + (set! axis-slope-angle 0.0) (set! iang-sin (/ ray-height radius-of-curvature))) (set! iang-sin (* (/ (- object-distance radius-of-curvature) radius-of-curvature) (sin axis-slope-angle)))) (let ((iang (asin iang-sin)) @@ -148,12 +148,12 @@ (old-axis-slope-angle axis-slope-angle)) (set! axis-slope-angle (+ axis-slope-angle (- iang (asin rang-sin)))) (let ((sagitta (sin (/ (+ old-axis-slope-angle iang) 2.0)))) - (set! sagitta (* 2 radius-of-curvature sagitta sagitta)) + (set! sagitta (* (* 2 radius-of-curvature) (* sagitta sagitta))) (set! object-distance (+ (/ (* radius-of-curvature (sin (+ old-axis-slope-angle iang))) (tan axis-slope-angle)) sagitta))))))))) ;; Perform ray trace in specific spectral line (define (trace-line line ray-h) - (set! object-distance 0) + (set! object-distance 0.0) (set! ray-height ray-h) (set! from-index 1) (for-each (lambda (surface) diff --git a/tools/ffitest.c b/tools/ffitest.c index 86b1fe2..0472ab9 100644 --- a/tools/ffitest.c +++ b/tools/ffitest.c @@ -18,7 +18,7 @@ #include "s7.h" -#define print_s7_int PRId64 +#define ld64 PRId64 #define TO_STR(x) s7_object_to_c_string(sc, x) #define TO_S7_INT(x) s7_make_integer(sc, x) @@ -789,7 +789,7 @@ int main(int argc, char **argv) i = (*((int *)s7_c_pointer(p))); if (i != 32) - fprintf(stderr, "%d: 32 -> %" print_s7_int " via raw c pointer?\n", __LINE__, i); + fprintf(stderr, "%d: 32 -> %" ld64 " via raw c pointer?\n", __LINE__, i); s7_provide(sc, "ffitest"); if (!s7_is_provided(sc, "ffitest")) @@ -798,7 +798,7 @@ int main(int argc, char **argv) p = s7_cons(sc, s7_f(sc), s7_t(sc)); gc_loc = s7_gc_protect(sc, p); if (p != s7_gc_protected_at(sc, gc_loc)) - {fprintf(stderr, "%d: %s is not gc protected at %" print_s7_int ": %s?\n", __LINE__, s1 = TO_STR(p), gc_loc, s2 = TO_STR(s7_gc_protected_at(sc, gc_loc))); free(s1); free(s2);} + {fprintf(stderr, "%d: %s is not gc protected at %" ld64 ": %s?\n", __LINE__, s1 = TO_STR(p), gc_loc, s2 = TO_STR(s7_gc_protected_at(sc, gc_loc))); free(s1); free(s2);} if (s7_car(p) != s7_f(sc)) {fprintf(stderr, "%d: (car %s) is not #f?\n", __LINE__, s1 = TO_STR(p)); free(s1);} @@ -1612,7 +1612,7 @@ int main(int argc, char **argv) s7_make_integer(sc, 5), s7_make_integer(sc, 6)))); if (val != 21) - fprintf(stderr, "plus1: %" print_s7_int "\n", val); + fprintf(stderr, "plus1: %" ld64 "\n", val); p = s7_make_c_object_without_gc(sc, dax_type_tag, (void *)malloc(sizeof(dax))); { @@ -1784,11 +1784,11 @@ int main(int argc, char **argv) s7_vector_offsets(p1, offs, ndims); els = s7_vector_elements(p1); - if (dims[0] != 2) fprintf(stderr, "%d: dims[0]: %" print_s7_int "?\n", __LINE__, dims[0]); - if (dims[1] != 3) fprintf(stderr, "%d: dims[1]: %" print_s7_int "?\n", __LINE__, dims[1]); - if (dims[2] != 4) fprintf(stderr, "%d: dims[2]: %" print_s7_int "?\n", __LINE__, dims[2]); - if (offs[0] != 12) fprintf(stderr, "%d: offs[0]: %" print_s7_int "?\n", __LINE__, offs[0]); - if (offs[1] != 4) fprintf(stderr, "%d: offs[1]: %" print_s7_int "?\n", __LINE__, offs[1]); + if (dims[0] != 2) fprintf(stderr, "%d: dims[0]: %" ld64 "?\n", __LINE__, dims[0]); + if (dims[1] != 3) fprintf(stderr, "%d: dims[1]: %" ld64 "?\n", __LINE__, dims[1]); + if (dims[2] != 4) fprintf(stderr, "%d: dims[2]: %" ld64 "?\n", __LINE__, dims[2]); + if (offs[0] != 12) fprintf(stderr, "%d: offs[0]: %" ld64 "?\n", __LINE__, offs[0]); + if (offs[1] != 4) fprintf(stderr, "%d: offs[1]: %" ld64 "?\n", __LINE__, offs[1]); if (s7_integer(p = els[12 + 4 + 1]) != 32) {fprintf(stderr, "%d: %s is not 32?\n", __LINE__, s1 = TO_STR(p)); free(s1);} @@ -1836,7 +1836,7 @@ int main(int argc, char **argv) if (p != s7_f(sc)) {fprintf(stderr, "%d: set slot-value %s is not #f?\n", __LINE__, s1 = TO_STR(p)); free(s1);} - if (s7_outlet(sc, new_env) != old_env) + if ((s7_outlet(sc, new_env) != old_env) && (old_env != s7_nil(sc))) {fprintf(stderr, "%d: outer-env %s?\n", __LINE__, s1 = TO_STR(old_env)); free(s1);} s7_make_slot(sc, new_env, s7_make_symbol(sc, "var2"), TO_S7_INT(-1)); @@ -2089,9 +2089,14 @@ int main(int argc, char **argv) s7_display(sc, s7_make_string(sc, "(+ 2 3)"), port); { const char *s2; + s7_pointer s3; s2 = s7_get_output_string(sc, port); if (strcmp(s2, "(+ 2 3)") != 0) - {fprintf(stderr, "%d: read output string sees %s?\n", __LINE__, s2);} + {fprintf(stderr, "%d: s7_get_output_string returns %s?\n", __LINE__, s2);} + s3 = s7_output_string(sc, port); + if ((!s7_is_string(s3)) || + (strcmp(s7_string(s3), "(+ 2 3)") != 0)) + {fprintf(stderr, "%d: s7_output_string returns %s?\n", __LINE__, s2);} } s7_close_output_port(sc, port); s7_gc_unprotect_at(sc, gc_loc); @@ -2328,9 +2333,9 @@ int main(int argc, char **argv) {fprintf(stderr, "%d: g_block %s is not a c_object?\n", __LINE__, s1 = TO_STR(gp)); free(s1);} g = (g_block *)s7_c_object_value(gp); if (s7_c_object_type(gp) != g_block_type) - {fprintf(stderr, "%d: g_block types: %" print_s7_int " %" print_s7_int "\n", __LINE__, g_block_type, s7_c_object_type(gp));} + {fprintf(stderr, "%d: g_block types: %" ld64 " %" ld64 "\n", __LINE__, g_block_type, s7_c_object_type(gp));} if (s7_c_object_value_checked(gp, g_block_type) != g) - {fprintf(stderr, "%d: checked g_block types: %" print_s7_int " %" print_s7_int "\n", __LINE__, g_block_type, s7_c_object_type(gp));} + {fprintf(stderr, "%d: checked g_block types: %" ld64 " %" ld64 "\n", __LINE__, g_block_type, s7_c_object_type(gp));} if (s7_c_object_let(gp) != g_block_methods) fprintf(stderr, "%d: s7_c_object_let trouble\n", __LINE__); s7_gc_unprotect_at(sc, gc_loc); diff --git a/tools/t101.scm b/tools/t101.scm index 89b2c5d..50a6b75 100644 --- a/tools/t101.scm +++ b/tools/t101.scm @@ -257,6 +257,9 @@ (format *stderr* "~NC tlist ~NC~%" 20 #\- 20 #\-) (system "./repl tlist.scm") +(format *stderr* "~NC tload ~NC~%" 20 #\- 20 #\-) +(system "./repl tload.scm") + (format *stderr* "~NC tgc ~NC~%" 20 #\- 20 #\-) (system "./repl tgc.scm") @@ -290,4 +293,8 @@ (format *stderr* "~NC full s7test ~NC~%" 20 #\- 20 #\-) (system "./repl full-s7test.scm") +(define with-block #f) +(format *stderr* "~NC s7test no blocks~NC~%" 20 #\- 20 #\-) +(system "./repl s7test.scm") + (exit) diff --git a/tools/tari.scm b/tools/tari.scm new file mode 100644 index 0000000..94c11e6 --- /dev/null +++ b/tools/tari.scm @@ -0,0 +1,240 @@ +(define size 100000) +(define int-limit 1000000) +(define float-limit 1000.0) + + +(define (make-ivals) + (let ((v (make-int-vector size)) + (lim (* 2 int-limit))) + (do ((i 0 (+ i 1))) + ((= i size) v) + (int-vector-set! v i (- (random lim) int-limit))))) +(define ivals (make-ivals)) + +(define (make-ivals1) + (let ((v (make-vector size)) + (lim (* 2 int-limit))) + (do ((i 0 (+ i 1))) + ((= i size) v) + (vector-set! v i (- (random lim) int-limit))))) +(define ivals1 (make-ivals1)) + + +(define (make-fvals) + (let ((v (make-float-vector size)) + (lim (* 2.0 float-limit))) + (do ((i 0 (+ i 1))) + ((= i size) v) + (float-vector-set! v i (- (random lim) float-limit))))) +(define fvals (make-fvals)) + +(define (make-fvals1) + (let ((v (make-vector size)) + (lim (* 2.0 float-limit))) + (do ((i 0 (+ i 1))) + ((= i size) v) + (vector-set! v i (- (random lim) float-limit))))) +(define fvals1 (make-fvals1)) + + +(define (make-ratvals) + (let ((v (make-vector size)) + (lim (* 2 int-limit))) + (do ((i 0 (+ i 1))) + ((= i size) v) + (vector-set! v i (/ (- (random lim) int-limit) (+ 1 (random int-limit))))))) +(define ratvals (make-ratvals)) + + +(define (make-cvals) + (let ((v (make-vector size)) + (lim (* 2 float-limit))) + (do ((i 0 (+ i 1))) + ((= i size) v) + (vector-set! v i (complex (- (random lim) float-limit) (- (random lim) float-limit)))))) +(define cvals (make-cvals)) + + +#| +;;; -------- min max -------- +(define (minmax v) + (let ((lo (v 0)) + (hi (v 0))) + (do ((i 0 (+ i 1))) + ((= i size) (list lo hi)) + (set! lo (min lo (v i))) + (set! hi (max hi (v i)))))) + +(define (minmax1 v) + (let ((lo (v 0)) + (hi (v 0))) + (do ((i 0 (+ i 1))) + ((= i size) (list lo hi)) + (set! lo (min lo (v i) hi)) + (set! hi (max hi lo (v i)))))) + +(format *stderr* "int-minmax ~S~%" (minmax ivals)) ; min/max_i_ii +(format *stderr* "int-minmax ~S~%" (minmax ivals1)) ; min/max_p_pp +(format *stderr* "int-minmax1 ~S~%" (minmax1 ivals)) ; min/max_i_iii +(format *stderr* "int-minmax1 ~S~%" (minmax1 ivals1)) ; g_min/max -> min/max_p_pp [perhaps min/max_3?] +(format *stderr* "float-minmax ~S~%" (minmax fvals)) +(format *stderr* "float-minmax ~S~%" (minmax fvals1)) +(format *stderr* "float-minmax1 ~S~%" (minmax1 fvals)) +(format *stderr* "float-minmax1 ~S~%" (minmax1 fvals1)) +(format *stderr* "ratio-minmax ~S~%" (minmax ratvals)) + + +;;; -------- real-part imag-part -------- + +(define (complex-minmax v) + (let ((rlo (real-part (v 0))) + (rhi (real-part (v 0))) + (ilo (imag-part (v 0))) + (ihi (imag-part (v 0)))) + (do ((i 0 (+ i 1))) + ((= i size) (list rlo ilo rhi ihi)) + (set! rlo (min rlo (real-part (v i)))) + (set! rhi (max rhi (real-part (v i)))) + (set! ilo (min ilo (imag-part (v i)))) + (set! ihi (max ihi (imag-part (v i))))))) + +(format *stderr* "complex-minmax ~S~%" (complex-minmax cvals)) + + +;;; -------- numerator denominator -------- + +(define (numden-minmax v) + (let ((numlo (numerator (v 0))) + (numhi (numerator (v 0))) + (denlo (denominator (v 0))) + (denhi (denominator (v 0)))) + (do ((i 0 (+ i 1))) + ((= i size) (list numlo denlo numhi denhi)) + (set! numlo (min numlo (numerator (v i)))) + (set! numhi (max numhi (numerator (v i)))) + (set! denlo (min denlo (denominator (v i)))) + (set! denhi (max denhi (denominator (v i))))))) + +(format *stderr* "numden-minmax ~S~%" (numden-minmax ratvals)) + + +;;; -------- even? odd? -------- + +(define (count-evens v) + (let ((even 0) + (odd 0)) + (do ((i 0 (+ i 1))) + ((= i size) (list even odd size (+ even odd))) + (if (even? (v i)) (set! even (+ even 1))) + (if (odd? (v i)) (set! odd (+ odd 1)))))) + +(format *stderr* "evens: ~S~%" (count-evens ivals)) +(format *stderr* "evens1: ~S~%" (count-evens ivals1)) + + +;;; -------- zero? positive? negative? -------- + +(define (count-zeros v) + (let ((zero 0) + (pos 0) + (neg 0)) + (do ((i 0 (+ i 1))) + ((= i size) (list zero pos neg size (+ zero pos neg))) + (if (zero? (v i)) (set! zero (+ zero 1))) + (if (positive? (v i)) (set! pos (+ pos 1))) + (if (negative? (v i)) (set! neg (+ neg 1)))))) + +(format *stderr* "zeros: ~S~%" (count-zeros ivals)) +(format *stderr* "zeros1: ~S~%" (count-zeros ivals1)) +(format *stderr* "zerosf: ~S~%" (count-zeros fvals)) +(format *stderr* "zerosrat: ~S~%" (count-zeros ratvals)) + + +;;; -------- exact->inexact inexact->exact rationalize -------- + +(define (inex v1 v2) + (do ((i 0 (+ i 1))) + ((= i size)) + (exact->inexact (v1 i)) + (inexact->exact (v2 i)) + (rationalize (v2 i)))) + +(inex ivals fvals) + +(define (inex? v1 v2) + (do ((i 0 (+ i 1))) + ((= i size)) + (if (inexact? (v1 i)) (display "oops: inexact?")) + (if (exact? (v2 i)) (display "oops: exact")))) + +(inex? ivals fvals) + + +;;; -------- integer? byte? number? real? float? complex? rational? infinite? nan? -------- + +(define (bools) + (do ((i 0 (+ i 1))) + ((= i size)) + (if (infinite? (fvals i)) (display "oops inf")) + (if (nan? (fvals i)) (display "oops nan")) + (if (integer? (fvals i)) (display "oops int")) + (if (byte? (cvals i)) (display "oops byte")) + (if (and (real? (cvals i)) (not (zero? (imag-part (cvals i))))) (display "oops real")) + (if (or (not (complex? (cvals i))) (not (number? (cvals i)))) (display "oops complex")) + (if (rational? (cvals i)) (display "oops rational")) + (if (float? (ivals1 i)) (display "oops float")))) + +(bools) + + +;;; -------- ceiling truncate round floor -------- + +(define (ceil/floor) + (let ((ints (make-int-vector 1))) + (do ((i 0 (+ i 1))) + ((= i size)) + (unless (integer? (ceiling (fvals i))) (display "oops: ceiling")) + (unless (integer? (floor (fvals i))) (display "oops: floor")) + (unless (integer? (truncate (fvals i))) (display "oops: truncate")) + (unless (integer? (round (fvals i))) (display "oops: round")) + (int-vector-set! ints 0 (ceiling (ratvals i))) + (int-vector-set! ints 0 (ceiling (fvals i))) + (int-vector-set! ints 0 (floor (fvals i))) + (int-vector-set! ints 0 (floor (ratvals i))) + (int-vector-set! ints 0 (round (fvals i))) + (int-vector-set! ints 0 (truncate (fvals i)))))) + +(ceil/floor) + + +;;; -------- abs magnitude -------- + +(define (absmag) + (let ((fv (make-float-vector 1)) + (iv (make-int-vector 1))) + (do ((i 0 (+ i 1))) + ((= i size)) + (if (not (= (abs (fvals i)) (magnitude (fvals i)))) (display "oops: abs")) + (if (not (real? (magnitude (cvals i)))) (display "oops: magnitude")) + (if (negative? (abs (ivals1 i))) (display "oops: abs neg")) + (if (negative? (abs (ratvals i))) (display "oops: abs neg rat")) + (int-vector-set! iv 0 (abs (ivals i))) + (float-vector-set! fv 0 (abs (fvals i)))))) + +(absmag) +|# + + + +;;; quotient remainder modulo +;;; + - * / +;;; = < > <= >= +;;; gcd lcm +;;; expt log exp sqrt +;;; ash logand logior logxor lognot logbit? +;;; sin cos tan sinh cosh tanh asin acos atan asinh acosh atanh angle + + + +(newline) +(exit) diff --git a/tools/tgsl.scm b/tools/tgsl.scm index 5189bec..650f4f2 100644 --- a/tools/tgsl.scm +++ b/tools/tgsl.scm @@ -79,11 +79,12 @@ (format *stderr* "~S #(4.0 2.0)~%" (eigenvalues (float-vector 3 1 1 3))) - (define (testla) - (do ((i 0 (+ i 1))) - ((= i 30000)) - (eigenvalues (float-vector 1 2 4 3)))) - + (define testla + (let ((fv (float-vector 1 2 4 3))) + (lambda () + (do ((i 0 (+ i 1))) + ((= i 30000)) + (eigenvalues fv))))) (testla) (define (num-test expr result) diff --git a/tools/titer.scm b/tools/titer.scm index 66dae5e..f227644 100644 --- a/tools/titer.scm +++ b/tools/titer.scm @@ -33,7 +33,7 @@ (do () ((or (string? (iterate iter)) (iterator-at-end? iter)))))) - (define (test) + (define (itest) (for-each (lambda (size) (format *stderr* "~D: " size) @@ -95,7 +95,7 @@ )) (list 1 10 100 1000 10000 100000 1000000))) - (test) + (itest) (when (> (*s7* 'profile) 0) (show-profile 200)) diff --git a/tools/tload.scm b/tools/tload.scm new file mode 100644 index 0000000..d1b7eca --- /dev/null +++ b/tools/tload.scm @@ -0,0 +1,247 @@ +;; shared library loader timing test + +(call-with-output-file "add1.c" + (lambda (oport) + (format oport " +#include <stdlib.h> +#include \"s7.h\" +static s7_pointer add1(s7_scheme *sc, s7_pointer args) +{ + if (s7_is_integer(s7_car(args))) + return(s7_make_integer(sc, 1 + s7_integer(s7_car(args)))); + return(s7_wrong_type_arg_error(sc, \"add1\", 1, s7_car(args), \"an integer\")); +} +void add1_init(s7_scheme *sc); +void add1_init(s7_scheme *sc) +{ + s7_define_function(sc, \"add1\", add1, 1, 0, false, \"(add1 int) adds 1 to int\"); +} +"))) + +(system "gcc -fpic -c add1.c") +(system "gcc -shared -Wl,-soname,libadd1.so -o libadd1.so add1.o -lm -lc") +(load "libadd1.so" (inlet 'init_func 'add1_init)) + +(display (add1 2)) (newline) + +;;; -------------------------------------------------------------------------------- + +(call-with-output-file "tlib.c" + (lambda (oport) + (format oport " +#include <stdio.h> +#include <stdlib.h> +#include \"s7.h\" +static s7_pointer a_function(s7_scheme *sc, s7_pointer args) +{ + return(s7_car(args)); +} +s7_pointer tlib_init(s7_scheme *sc, s7_pointer args); +s7_pointer tlib_init(s7_scheme *sc, s7_pointer args) +{ + s7_define_function(sc, \"a-function\", a_function, 1, 0, true, NULL); + return(s7_cons(sc, s7_car(args), s7_nil(sc))); +} +"))) + +(system "gcc -fPIC -c tlib.c") +(system "gcc tlib.o -shared -o tlib.so -ldl -lm -Wl,-export-dynamic") + +(define tinit (load "tlib.so" (inlet 'init_func 'tlib_init 'init_args (list 1 2 3)))) +(display (apply a-function tinit)) (newline) + +;;; -------------------------------------------------------------------------------- + +(unless (file-exists? "s7test-block.so") + (system (string-append "gcc -fPIC -c s7test-block.c -I. -g -O2")) + (system "gcc s7test-block.o -shared -o s7test-block.so -ldl -lm -Wl,-export-dynamic")) + +(load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init))) + + +(define (f) + (do ((i 0 (+ i 1))) + ((= i 20000)) + (let () + (load "libadd1.so" (inlet 'init_func 'add1_init)) + (load "tlib.so" (inlet 'init_func 'tlib_init 'init_args (list 1 2 3))) + (load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init))) + (block-release-methods)))) +(f) + +;;; -------------------------------------------------------------------------------- + +(require libc.scm) +(require libm.scm) +(require libgsl.scm) +(require libgdbm.scm) +(require libdl.scm) +(require libutf8proc.scm) + +(define username (getenv "USER")) + +(define (g) + (do ((i 0 (+ i 1))) + ((= i 3)) + (load (append "/home/" username "/cl/libc_s7.so") (inlet 'init_func 'libc_s7_init)) + (load (append "/home/" username "/cl/libm_s7.so") (inlet 'init_func 'libm_s7_init)) + (load (append "/home/" username "/cl/libgsl_s7.so") (inlet 'init_func 'libgsl_s7_init)) + (load (append "/home/" username "/cl/libgdbm_s7.so") (inlet 'init_func 'libgdbm_s7_init)) + (load (append "/home/" username "/cl/libdl_s7.so") (inlet 'init_func 'libdl_s7_init)))) +(g) + +;;; -------------------------------------------------------------------------------- + +(call-with-output-file "dax1.c" + (lambda (oport) + (format oport " + +#include <stdlib.h> +#include <stdio.h> +#include <string.h> + +#include \"s7.h\" +typedef struct { + s7_double x; + s7_pointer data; +} dax; + +static int dax_type_tag = 0; + +static s7_pointer dax_to_string(s7_scheme *sc, s7_pointer args) +{ + char *data_str, *str; + s7_pointer result; + int data_str_len; + dax *o = (dax *)s7_c_object_value(s7_car(args)); + data_str = s7_object_to_c_string(sc, o->data); + data_str_len = strlen(data_str); + str = (char *)calloc(data_str_len + 32, sizeof(char)); + snprintf(str, data_str_len + 32, \"<dax %.3f %s>\", o->x, data_str); + free(data_str); + result = s7_make_string(sc, str); + free(str); + return(result); +} + +static s7_pointer free_dax(s7_scheme *sc, s7_pointer obj) +{ + free(s7_c_object_value(obj)); + return(NULL); +} + +static s7_pointer mark_dax(s7_scheme *sc, s7_pointer obj) +{ + dax *o; + o = (dax *)s7_c_object_value(obj); + s7_mark(o->data); + return(NULL); +} + +static s7_pointer make_dax(s7_scheme *sc, s7_pointer args) +{ + dax *o; + o = (dax *)malloc(sizeof(dax)); + o->x = s7_real(s7_car(args)); + if (s7_cdr(args) != s7_nil(sc)) + o->data = s7_cadr(args); + else o->data = s7_nil(sc); + return(s7_make_c_object(sc, dax_type_tag, (void *)o)); +} + +static s7_pointer is_dax(s7_scheme *sc, s7_pointer args) +{ + return(s7_make_boolean(sc, + s7_is_c_object(s7_car(args)) && + s7_c_object_type(s7_car(args)) == dax_type_tag)); +} + +static s7_pointer dax_x(s7_scheme *sc, s7_pointer args) +{ + dax *o; + o = (dax *)s7_c_object_value(s7_car(args)); + return(s7_make_real(sc, o->x)); +} + +static s7_pointer set_dax_x(s7_scheme *sc, s7_pointer args) +{ + dax *o; + o = (dax *)s7_c_object_value(s7_car(args)); + o->x = s7_real(s7_cadr(args)); + return(s7_cadr(args)); +} + +static s7_pointer dax_data(s7_scheme *sc, s7_pointer args) +{ + dax *o; + o = (dax *)s7_c_object_value(s7_car(args)); + return(o->data); +} + +static s7_pointer set_dax_data(s7_scheme *sc, s7_pointer args) +{ + dax *o; + o = (dax *)s7_c_object_value(s7_car(args)); + o->data = s7_cadr(args); + return(o->data); +} + +static s7_pointer dax_is_equal(s7_scheme *sc, s7_pointer args) +{ + s7_pointer p1, p2; + dax *d1, *d2; + p1 = s7_car(args); + p2 = s7_cadr(args); + if (p1 == p2) + return(s7_t(sc)); + if ((!s7_is_c_object(p2)) || + (s7_c_object_type(p2) != dax_type_tag)) + return(s7_f(sc)); + d1 = (dax *)s7_c_object_value(p1); + d2 = (dax *)s7_c_object_value(p2); + return(s7_make_boolean(sc, + (d1->x == d2->x) && + (s7_is_equal(sc, d1->data, d2->data)))); +} + +static s7_pointer make_and_free(s7_scheme *sc, s7_pointer args) +{ + s7_scheme *s7; + s7 = s7_init(); + + dax_type_tag = s7_make_c_type(s7, \"dax\"); + s7_c_type_set_gc_free(s7, dax_type_tag, free_dax); + s7_c_type_set_gc_mark(s7, dax_type_tag, mark_dax); + s7_c_type_set_is_equal(s7, dax_type_tag, dax_is_equal); + s7_c_type_set_to_string(s7, dax_type_tag, dax_to_string); + + s7_define_function(s7, \"make-dax\", make_dax, 2, 0, false, \"(make-dax x data) makes a new dax\"); + s7_define_function(s7, \"dax?\", is_dax, 1, 0, false, \"(dax? anything) returns #t if its argument is a dax object\"); + + s7_define_variable(s7, \"dax-x\", + s7_dilambda(s7, \"dax-x\", dax_x, 1, 0, set_dax_x, 2, 0, \"dax x field\")); + + s7_define_variable(s7, \"dax-data\", + s7_dilambda(s7, \"dax-data\", dax_data, 1, 0, set_dax_data, 2, 0, \"dax data field\")); + + s7_free(s7); + return(s7_f(sc)); +} + +void dax_init(s7_scheme *sc); +void dax_init(s7_scheme *sc) +{ + s7_define_function(sc, \"dax\", make_and_free, 0, 0, false, NULL); +} +"))) + +(system "gcc -fpic dax1.c -c dax1.c") +(system "gcc dax1.o -shared -o dax1.so -ldl -lm -Wl,-export-dynamic") + +(load "dax1.so" (inlet 'init_func 'dax_init)) +(do ((i 0 (+ i 1))) + ((= i 200)) + (dax)) + + +(exit) diff --git a/tools/tmap.scm b/tools/tmap.scm index 2c8ab99..d16101c 100644 --- a/tools/tmap.scm +++ b/tools/tmap.scm @@ -652,7 +652,29 @@ lst v)) (f27 lst nv) +(define (f28) + (do ((p lst (cdr p)) + (i 0 (+ i 1))) + ((null? p)) + (set-car! p i)) + (map + lst lst)) +(f28) + +(define (f29) + (let ((str (make-string 100 #\a))) + (set! (str 50) #\b) + (do ((i 0 (+ i 1))) + ((= i 30000)) + (map char->integer str)))) +(f29) + +(define (f30) + (do ((i 0 (+ i 1))) + ((= i 30)) + (map pair? lst))) +(f30) + +(newline) (when (> (*s7* 'profile) 0) (show-profile 200)) (exit) - diff --git a/tools/tmat.scm b/tools/tmat.scm index bd937e4..6a65912 100755 --- a/tools/tmat.scm +++ b/tools/tmat.scm @@ -266,4 +266,4 @@ (when (> (*s7* 'profile) 0) (show-profile 200)) -(#_exit) +(exit) diff --git a/tools/tmisc.scm b/tools/tmisc.scm index 46c33e3..0f11e70 100644 --- a/tools/tmisc.scm +++ b/tools/tmisc.scm @@ -107,6 +107,77 @@ (w3))) +;;; -------- implicit/generalized set! -------- + +(define (fs1) + (let-temporarily (((*s7* 'print-length) 8)) + 123)) + +(define (fs2) + (let ((x 32)) + (set! ((curlet) 'x) 3) + x)) + +(define (fs3) + (set! (with-let (curlet) (*s7* 'print-length)) 16) + (*s7* 'print-length)) + +(define (fs4) + (let ((e (inlet :v (vector 1 2)))) + (set! (with-let e (v 0)) 'a) + (e 'v))) + +(define (fs5) + (let ((v (vector (inlet 'a 0)))) + (set! (v 0 'a) 32) + ((v 0) 'a))) + +(define (fs6) + (let ((e (inlet 'x (inlet 'b 2)))) + (set! (e 'x 'b) 32) + ((e 'x) 'b))) + +(define (fs7) + (let ((L (list (list 1 2)))) + (set! (L 0 0) 3) + L)) + +(define (fs8) + (let ((H (hash-table 'a (hash-table 'b 2)))) + (set! (H 'a 'b) 32) + ((H 'a) 'b))) + +(define (fs9) + (let ((v (vector 1 2))) + (let-temporarily (((v 1) 32)) + (v 1)))) + +(define fs10 + (let ((val 0)) + (let ((fs (dilambda (lambda () val) (lambda (v) (set! val v))))) + (lambda () + (set! (fs) 32) + (fs))))) + + +(define (tf) + (do ((i 0 (+ i 1))) + ((= i 150000)) + (fs1) + (fs2) + (fs3) + (fs4) + (fs5) + (fs6) + (fs7) + (fs8) + (fs9) + (fs10) + )) + +(tf) + + ;;; -------- => -------- (define-constant (f1) (cond (-2 => abs))) diff --git a/tools/valcall.scm b/tools/valcall.scm index 4462431..b536752 100644 --- a/tools/valcall.scm +++ b/tools/valcall.scm @@ -40,6 +40,9 @@ ("concordance.scm" . "v-str") ("tgsl.scm" . "v-gsl") ("tlist.scm" . "v-list") + ("tload.scm" . "v-load") + ("cookbook.scm" . "v-cook") + ("tari.scm" . "v-ari") )) (define (last-callg) @@ -73,6 +76,7 @@ (system (format #f "./snd compare-calls.scm -e '(compare-calls \"~A~D\" \"~A~D\")'" outfile (- next 1) outfile next))))) (list (list "repl" "tpeak.scm") + (list "repl" "tari.scm") (list "repl" "tref.scm") (list "repl" "tauto.scm") (list "repl" "tshoot.scm") @@ -85,28 +89,30 @@ (list "repl" "tmac.scm") (list "repl" "tread.scm") (list "repl" "trclo.scm") - (list "repl" "tmat.scm") (list "repl" "fbench.scm") + (list "repl" "tmat.scm") (list "repl" "tcopy.scm") (list "repl" "dup.scm") (list "repl" "titer.scm") (list "repl" "tsort.scm") (list "repl" "tset.scm") + (list "repl" "tload.scm") (list "repl" "teq.scm") (list "repl" "tio.scm") (list "repl" "concordance.scm") (list "repl" "tclo.scm") - (list "repl" "tcase.scm") (list "repl" "tlet.scm") + (list "repl" "tcase.scm") (list "repl" "tmap.scm") (list "repl" "tfft.scm") (list "repl" "tnum.scm") - (list "repl" "tmisc.scm") (list "repl" "tgsl.scm") (list "repl" "trec.scm") + (list "repl" "tmisc.scm") (list "repl" "tlist.scm") (list "repl" "tgc.scm") (list "repl" "thash.scm") + (list "repl" "cookbook.scm") (list "snd -noinit" "tgen.scm") ; repl here + cload sndlib was slower (list "snd -noinit" "tall.scm") (list "snd -l" "snd-test.scm") |