diff options
| author | IOhannes m zmölnig <zmoelnig@umlautS.umlaeute.mur.at> | 2019-09-10 19:16:42 +0200 |
|---|---|---|
| committer | IOhannes m zmölnig <zmoelnig@umlautS.umlaeute.mur.at> | 2019-09-10 19:16:42 +0200 |
| commit | f006cecce8a17e228aab1ca78242b81a5acb8090 (patch) | |
| tree | 24b8dc5ba79d2e448f7b7f961714af7b734cfbb1 | |
| parent | 3daa05c5a6f63979cb9d756027166027deb04b1d (diff) | |
New upstream version 19.7
| -rw-r--r-- | HISTORY.Snd | 1 | ||||
| -rw-r--r-- | NEWS | 11 | ||||
| -rw-r--r-- | README.Snd | 8 | ||||
| -rwxr-xr-x | configure | 20 | ||||
| -rw-r--r-- | configure.ac | 4 | ||||
| -rw-r--r-- | libgtk_s7.c | 186 | ||||
| -rw-r--r-- | lint.scm | 28 | ||||
| -rw-r--r-- | mockery.scm | 31 | ||||
| -rw-r--r-- | reactive.scm | 77 | ||||
| -rw-r--r-- | repl.scm | 5 | ||||
| -rw-r--r-- | s7.c | 9585 | ||||
| -rw-r--r-- | s7.html | 28 | ||||
| -rw-r--r-- | s7test.scm | 313 | ||||
| -rw-r--r-- | snd.h | 6 | ||||
| -rw-r--r-- | stuff.scm | 6 | ||||
| -rw-r--r-- | tools/auto-tester.scm | 107 | ||||
| -rw-r--r-- | tools/dup.scm | 8 | ||||
| -rw-r--r-- | tools/fbench.scm | 10 | ||||
| -rwxr-xr-x | tools/makexg.scm | 6 | ||||
| -rw-r--r-- | tools/tauto.scm | 3 | ||||
| -rw-r--r-- | tools/tbig.scm | 4 | ||||
| -rw-r--r-- | tools/tcopy.scm | 2 | ||||
| -rw-r--r-- | tools/teq.scm | 2 | ||||
| -rw-r--r-- | tools/tfft.scm | 60 | ||||
| -rw-r--r-- | tools/tform.scm | 62 | ||||
| -rw-r--r-- | tools/tgen.scm | 2 | ||||
| -rw-r--r-- | tools/tmac.scm | 80 | ||||
| -rw-r--r-- | tools/tmap.scm | 9 | ||||
| -rw-r--r-- | tools/tmisc.scm | 163 | ||||
| -rw-r--r-- | tools/valcall.scm | 20 | ||||
| -rw-r--r-- | xen.c | 2 | ||||
| -rw-r--r-- | xg.c | 189 |
32 files changed, 6238 insertions, 4800 deletions
diff --git a/HISTORY.Snd b/HISTORY.Snd index bd828ce..ff94743 100644 --- a/HISTORY.Snd +++ b/HISTORY.Snd @@ -1,5 +1,6 @@ Snd change log + 2-Sep: Snd 19.7. 1-Aug: Snd 19.6. 26-Jun: Snd 19.5. 19-May: Snd 19.4. @@ -1,10 +1,7 @@ -Snd 19.6: +Snd 19.7: -s7: added tools directory (timing tests etc) - moved most-positive|negative-fixnum to *s7* - s7_load now parallels scheme load; it returns NULL if file not found (or a directory). - added s7_call_with_catch and define-expansion*. +in clm, Anders fixed a bug in mus.lisp. -checked: sbcl 1.5.4|5 +checked: sbcl 1.5.6 -Thanks!: Kjetil Matheussen, Woody Douglas +Thanks!: Anders Vinjar, Kenneth Flak, David O'Toole
\ No newline at end of file @@ -232,6 +232,14 @@ where TROUBLES: +---- wayland ---- + +Currently in wayland you need to run snd: + +GDK_BACKEND=x11 snd + +Thanks to Kenneth Flak for this tip! + ---- audio (a can of worms) ---- @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for snd 19.6. +# Generated by GNU Autoconf 2.69 for snd 19.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-19.tar.gz' -PACKAGE_VERSION='19.6' -PACKAGE_STRING='snd 19.6' +PACKAGE_VERSION='19.7' +PACKAGE_STRING='snd 19.7' PACKAGE_BUGREPORT='bil@ccrma.stanford.edu' PACKAGE_URL='' @@ -1324,7 +1324,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 19.6 to adapt to many kinds of systems. +\`configure' configures snd 19.7 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1395,7 +1395,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of snd 19.6:";; + short | recursive ) echo "Configuration of snd 19.7:";; esac cat <<\_ACEOF @@ -1514,7 +1514,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -snd configure 19.6 +snd configure 19.7 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1975,7 +1975,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 19.6, which was +It was created by snd $as_me 19.7, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -3322,7 +3322,7 @@ LOCAL_LANGUAGE="None" GRAPHICS_TOOLKIT="None" PACKAGE=Snd -VERSION=19.6 +VERSION=19.7 #-------------------------------------------------------------------------------- # configuration options @@ -6897,7 +6897,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 19.6, which was +This file was extended by snd $as_me 19.7, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -6959,7 +6959,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 19.6 +snd config.status 19.7 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac index 9d8f023..7d32c0b 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ # gmp, mpfr, and mpc deliberately have none! -AC_INIT(snd, 19.6, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz) +AC_INIT(snd, 19.7, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.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=19.6 +VERSION=19.7 #-------------------------------------------------------------------------------- # configuration options diff --git a/libgtk_s7.c b/libgtk_s7.c index 7259c98..7f34f32 100644 --- a/libgtk_s7.c +++ b/libgtk_s7.c @@ -47423,13 +47423,13 @@ static void define_structs(s7_scheme *sc) static void define_functions(s7_scheme *sc) { s7_pointer s_boolean, s_integer, s_real, s_string, s_any, s_pair, s_float, s_gtk_enum_t, s_pair_false; - s7_pointer pl_bsu, pl_bsigb, pl_buuusuug, pl_i, pl_bu, pl_pb, pl_bur, pl_bug, pl_bus, pl_bui, pl_bub, pl_buui, pl_buus, pl_busu, pl_buub, pl_buig, pl_busib, pl_buuub, pl_buttu, pl_busgu, pl_buuui, pl_buuig, pl_buiuig, pl_buusib, pl_buuuub, pl_buurbr, pl_t, pl_iit, pl_iiit, pl_ti, pl_it, pl_tiu, pl_itsub, pl_itiiub, pl_itstttg, pl_itgiiut, pl_tts, pl_tti, pl_g, pl_s, pl_gi, pl_igi, pl_tg, pl_p, pl_si, pl_is, pl_isi, pl_sig, pl_isgt, pl_isigutttiiu, pl_ts, pl_tsi, pl_tsig, pl_tsiu, pl_tsiuui, pl_tsiiuui, pl_iu, pl_pi, pl_iur, pl_iug, pl_iui, pl_ius, pl_piu, pl_pit, pl_iuis, pl_iusi, pl_iuui, pl_iuuui, pl_iuisi, pl_iuuuui, pl_iuisut, pl_tusiuiui, pl_tuiiiiui, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_pt, pl_tu, pl_tut, pl_tus, pl_tug, pl_tur, pl_tui, pl_tub, pl_tusg, pl_tugb, pl_tugs, pl_tuui, pl_tuib, pl_tusi, pl_tuug, pl_tuig, pl_tuur, pl_turi, pl_tusr, pl_tusb, pl_tuub, pl_tuus, pl_tugu, pl_tugr, pl_tugi, pl_tusu, pl_tuut, pl_tugt, pl_tuis, pl_tust, pl_tuiu, pl_tuit, pl_tuuiu, pl_tuurb, pl_tuuri, pl_tuugi, pl_turgs, pl_tuisi, pl_tusri, pl_tuuut, pl_tuubr, pl_tuuub, pl_tuuir, pl_tuuui, pl_tuusi, pl_tuiiu, pl_tuiggu, pl_turrrb, pl_tuusit, pl_tuurbr, pl_tusiis, pl_tusuig, pl_tuuubr, pl_tuuiuui, pl_tubiiiu, pl_du, pl_pr, pl_dui, pl_dus, pl_dusi, pl_dusr, pl_sg, pl_gs, pl_b, pl_gu, pl_pg, pl_gus, pl_pgi, pl_pgu, pl_gui, pl_guut, pl_pgbi, pl_guuut, pl_gurrsiu, pl_gussitu, pl_ssi, pl_ssig, pl_bi, pl_big, pl_su, pl_ps, pl_bt, pl_tb, pl_bti, pl_sui, pl_sug, pl_psi, pl_psb, pl_psu, pl_sus, pl_psg, pl_psgi, pl_psiu, pl_psut, pl_btiib, pl_suuub, pl_psugt, pl_psiuub, pl_psrrrb, pl_psgbiiiit, pl_psiiuusu, pl_pu, pl_pur, pl_pub, pl_pui, pl_pug, pl_pus, pl_put, pl_pugi, pl_pubi, pl_puri, pl_pust, pl_pusi, pl_pusu, pl_pugu, pl_puiu, pl_puiig, pl_puigu, pl_pusiu, pl_pusub, pl_puuiu, pl_puiiu, pl_pussu, pl_puibu, pl_pusig, pl_puiigi, pl_pugiiu, pl_puuubu, pl_pusigu, pl_pusiiu, pl_puuiiu, pl_pusiuiu, pl_puuusuug, pl_pusiuibu, pl_bpt; + s7_pointer pl_si, pl_is, pl_isi, pl_sig, pl_isgt, pl_isigutttiiu, pl_tg, pl_sg, pl_gs, pl_iu, pl_pi, pl_iur, pl_iug, pl_iui, pl_ius, pl_piu, pl_pit, pl_iuis, pl_iusi, pl_iuui, pl_iuuui, pl_iuisi, pl_iuuuui, pl_iuisut, pl_gu, pl_pg, pl_gus, pl_pgi, pl_pgu, pl_gui, pl_guut, pl_pgbi, pl_guuut, pl_gurrsiu, pl_gussitu, pl_t, pl_s, pl_du, pl_pr, pl_dui, pl_dus, pl_dusi, pl_dusr, pl_p, pl_tts, pl_tti, pl_ts, pl_tsi, pl_tsig, pl_tsiu, pl_tsiuui, pl_tsiiuui, pl_ssi, pl_ssig, pl_bi, pl_big, pl_tusiuiui, pl_tuiiiiui, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_pt, pl_tu, pl_tut, pl_tus, pl_tug, pl_tur, pl_tui, pl_tub, pl_tusg, pl_tugb, pl_tugs, pl_tuui, pl_tuib, pl_tusi, pl_tuug, pl_tuig, pl_tuur, pl_turi, pl_tusr, pl_tusb, pl_tuub, pl_tuus, pl_tugu, pl_tugr, pl_tugi, pl_tusu, pl_tuut, pl_tugt, pl_tuis, pl_tust, pl_tuiu, pl_tuit, pl_tuuiu, pl_tuurb, pl_tuuri, pl_tuugi, pl_turgs, pl_tuisi, pl_tusri, pl_tuuut, pl_tuubr, pl_tuuub, pl_tuuir, pl_tuuui, pl_tuusi, pl_tuiiu, pl_tuiggu, pl_turrrb, pl_tuusit, pl_tuurbr, pl_tusiis, pl_tusuig, pl_tuuubr, pl_tuuiuui, pl_tubiiiu, pl_su, pl_ps, pl_sui, pl_sug, pl_psi, pl_psb, pl_psu, pl_sus, pl_psg, pl_psgi, pl_psiu, pl_psut, pl_suuub, pl_psugt, pl_psiuub, pl_psrrrb, pl_psgbiiiit, pl_psiiuusu, pl_pu, pl_pur, pl_pub, pl_pui, pl_pug, pl_pus, pl_put, pl_pugi, pl_pubi, pl_puri, pl_pust, pl_pusi, pl_pusu, pl_pugu, pl_puiu, pl_puiig, pl_puigu, pl_pusiu, pl_pusub, pl_puuiu, pl_puiiu, pl_pussu, pl_puibu, pl_pusig, pl_puiigi, pl_pugiiu, pl_puuubu, pl_pusigu, pl_pusiiu, pl_puuiiu, pl_pusiuiu, pl_puuusuug, pl_pusiuibu, pl_b, pl_bt, pl_tb, pl_bti, pl_btiib, pl_bsu, pl_bsigb, pl_buuusuug, pl_bu, pl_pb, pl_bur, pl_bug, pl_bus, pl_bui, pl_bub, pl_buui, pl_buus, pl_busu, pl_buub, pl_buig, pl_busib, pl_buuub, pl_buttu, pl_busgu, pl_buuui, pl_buuig, pl_buiuig, pl_buusib, pl_buuuub, pl_buurbr, pl_iit, pl_iiit, pl_gi, pl_igi, pl_i, pl_g, pl_ti, pl_it, pl_tiu, pl_itsub, pl_itiiub, pl_itstttg, pl_itgiiut, pl_bpt; #if GTK_CHECK_VERSION(3, 0, 0) - s7_pointer pl_buigu, pl_tuuugi, pl_tuuuub, pl_pgr, pl_gug, pl_puuig, pl_puiiui; + s7_pointer pl_pgr, pl_gug, pl_tuuugi, pl_tuuuub, pl_puuig, pl_puiiui, pl_buigu; #endif #if GTK_CHECK_VERSION(3, 4, 0) - s7_pointer pl_tsu, pl_prrru, pl_suiig; + s7_pointer pl_prrru, pl_tsu, pl_suiig; #endif #if GTK_CHECK_VERSION(3, 6, 0) @@ -47453,11 +47453,11 @@ static void define_functions(s7_scheme *sc) #endif #if GTK_CHECK_VERSION(3, 94, 0) - s7_pointer pl_busi, pl_buib, pl_iuugs, pl_piigui, pl_tuiut, pl_tuuur, pl_tugug, pl_tugui, pl_tuuiut, pl_tutisi, pl_tuiiut, pl_tubbbt, pl_tusuiut, pl_tuugggi, pl_tuuuggu, pl_pst, pl_purru, pl_purrrru; + s7_pointer pl_iuugs, pl_piigui, pl_tuiut, pl_tuuur, pl_tugug, pl_tugui, pl_tuuiut, pl_tutisi, pl_tuiiut, pl_tubbbt, pl_tusuiut, pl_tuugggi, pl_tuuuggu, pl_pst, pl_purru, pl_purrrru, pl_busi, pl_buib; #endif #if GTK_CHECK_VERSION(3, 96, 0) - s7_pointer pl_buiu, pl_buiib, pl_tuiiiu, pl_tuugiu, pl_purrg, pl_puuugi, pl_bg; + s7_pointer pl_tuiiiu, pl_tuugiu, pl_bg, pl_purrg, pl_puuugi, pl_buiu, pl_buiib; #endif @@ -47471,62 +47471,15 @@ static void define_functions(s7_scheme *sc) s_gtk_enum_t = s7_make_symbol(sc, "gtk_enum_t?"); s_any = s7_t(sc); - pl_bsu = s7_make_circular_signature(sc, 2, 3, s_boolean, s_string, s_pair_false); - pl_bsigb = s7_make_circular_signature(sc, 4, 5, s_boolean, s_string, s_integer, s_gtk_enum_t, s_boolean); - pl_buuusuug = s7_make_circular_signature(sc, 7, 8, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_string, s_pair_false, s_pair_false, s_gtk_enum_t); - pl_i = s7_make_circular_signature(sc, 0, 1, s_integer); - pl_bu = s7_make_circular_signature(sc, 1, 2, s_boolean, s_pair_false); - pl_pb = s7_make_circular_signature(sc, 1, 2, s_pair, s_boolean); - pl_bur = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_real); - pl_bug = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_gtk_enum_t); - pl_bus = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_string); - pl_bui = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_integer); - pl_bub = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_boolean); - pl_buui = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_pair_false, s_integer); - pl_buus = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_pair_false, s_string); - pl_busu = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_string, s_pair_false); - pl_buub = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_pair_false, s_boolean); - pl_buig = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_integer, s_gtk_enum_t); - pl_busib = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_string, s_integer, s_boolean); - pl_buuub = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_boolean); - pl_buttu = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_any, s_any, s_pair_false); - pl_busgu = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_string, s_gtk_enum_t, s_pair_false); - pl_buuui = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_integer); - pl_buuig = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t); - pl_buiuig = s7_make_circular_signature(sc, 5, 6, s_boolean, s_pair_false, s_integer, s_pair_false, s_integer, s_gtk_enum_t); - pl_buusib = s7_make_circular_signature(sc, 5, 6, s_boolean, s_pair_false, s_pair_false, s_string, s_integer, s_boolean); - pl_buuuub = s7_make_circular_signature(sc, 5, 6, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean); - pl_buurbr = s7_make_circular_signature(sc, 5, 6, s_boolean, s_pair_false, s_pair_false, s_real, s_boolean, s_real); - pl_t = s7_make_circular_signature(sc, 0, 1, s_any); - pl_iit = s7_make_circular_signature(sc, 2, 3, s_integer, s_integer, s_any); - pl_iiit = s7_make_circular_signature(sc, 3, 4, s_integer, s_integer, s_integer, s_any); - pl_ti = s7_make_circular_signature(sc, 1, 2, s_any, s_integer); - pl_it = s7_make_circular_signature(sc, 1, 2, s_integer, s_any); - pl_tiu = s7_make_circular_signature(sc, 2, 3, s_any, s_integer, s_pair_false); - pl_itsub = s7_make_circular_signature(sc, 4, 5, s_integer, s_any, s_string, s_pair_false, s_boolean); - pl_itiiub = s7_make_circular_signature(sc, 5, 6, s_integer, s_any, s_integer, s_integer, s_pair_false, s_boolean); - pl_itstttg = s7_make_circular_signature(sc, 6, 7, s_integer, s_any, s_string, s_any, s_any, s_any, s_gtk_enum_t); - pl_itgiiut = s7_make_circular_signature(sc, 6, 7, s_integer, s_any, s_gtk_enum_t, s_integer, s_integer, s_pair_false, s_any); - pl_tts = s7_make_circular_signature(sc, 2, 3, s_any, s_any, s_string); - pl_tti = s7_make_circular_signature(sc, 2, 3, s_any, s_any, s_integer); - pl_g = s7_make_circular_signature(sc, 0, 1, s_gtk_enum_t); - pl_s = s7_make_circular_signature(sc, 0, 1, s_string); - pl_gi = s7_make_circular_signature(sc, 1, 2, s_gtk_enum_t, s_integer); - pl_igi = s7_make_circular_signature(sc, 2, 3, s_integer, s_gtk_enum_t, s_integer); - pl_tg = s7_make_circular_signature(sc, 1, 2, s_any, s_gtk_enum_t); - pl_p = s7_make_circular_signature(sc, 0, 1, s_pair); pl_si = s7_make_circular_signature(sc, 1, 2, s_string, s_integer); pl_is = s7_make_circular_signature(sc, 1, 2, s_integer, s_string); pl_isi = s7_make_circular_signature(sc, 2, 3, s_integer, s_string, s_integer); pl_sig = s7_make_circular_signature(sc, 2, 3, s_string, s_integer, s_gtk_enum_t); pl_isgt = s7_make_circular_signature(sc, 3, 4, s_integer, s_string, s_gtk_enum_t, s_any); pl_isigutttiiu = s7_make_circular_signature(sc, 10, 11, s_integer, s_string, s_integer, s_gtk_enum_t, s_pair_false, s_any, s_any, s_any, s_integer, s_integer, s_pair_false); - pl_ts = s7_make_circular_signature(sc, 1, 2, s_any, s_string); - pl_tsi = s7_make_circular_signature(sc, 2, 3, s_any, s_string, s_integer); - pl_tsig = s7_make_circular_signature(sc, 3, 4, s_any, s_string, s_integer, s_gtk_enum_t); - pl_tsiu = s7_make_circular_signature(sc, 3, 4, s_any, s_string, s_integer, s_pair_false); - pl_tsiuui = s7_make_circular_signature(sc, 5, 6, s_any, s_string, s_integer, s_pair_false, s_pair_false, s_integer); - pl_tsiiuui = s7_make_circular_signature(sc, 6, 7, s_any, s_string, s_integer, s_integer, s_pair_false, s_pair_false, s_integer); + pl_tg = s7_make_circular_signature(sc, 1, 2, s_any, s_gtk_enum_t); + pl_sg = s7_make_circular_signature(sc, 1, 2, s_string, s_gtk_enum_t); + pl_gs = s7_make_circular_signature(sc, 1, 2, s_gtk_enum_t, s_string); pl_iu = s7_make_circular_signature(sc, 1, 2, s_integer, s_pair_false); pl_pi = s7_make_circular_signature(sc, 1, 2, s_pair, s_integer); pl_iur = s7_make_circular_signature(sc, 2, 3, s_integer, s_pair_false, s_real); @@ -47542,6 +47495,38 @@ static void define_functions(s7_scheme *sc) pl_iuisi = s7_make_circular_signature(sc, 4, 5, s_integer, s_pair_false, s_integer, s_string, s_integer); pl_iuuuui = s7_make_circular_signature(sc, 5, 6, s_integer, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_integer); pl_iuisut = s7_make_circular_signature(sc, 5, 6, s_integer, s_pair_false, s_integer, s_string, s_pair_false, s_any); + pl_gu = s7_make_circular_signature(sc, 1, 2, s_gtk_enum_t, s_pair_false); + pl_pg = s7_make_circular_signature(sc, 1, 2, s_pair, s_gtk_enum_t); + pl_gus = s7_make_circular_signature(sc, 2, 3, s_gtk_enum_t, s_pair_false, s_string); + pl_pgi = s7_make_circular_signature(sc, 2, 3, s_pair, s_gtk_enum_t, s_integer); + pl_pgu = s7_make_circular_signature(sc, 2, 3, s_pair, s_gtk_enum_t, s_pair_false); + pl_gui = s7_make_circular_signature(sc, 2, 3, s_gtk_enum_t, s_pair_false, s_integer); + pl_guut = s7_make_circular_signature(sc, 3, 4, s_gtk_enum_t, s_pair_false, s_pair_false, s_any); + pl_pgbi = s7_make_circular_signature(sc, 3, 4, s_pair, s_gtk_enum_t, s_boolean, s_integer); + pl_guuut = s7_make_circular_signature(sc, 4, 5, s_gtk_enum_t, s_pair_false, s_pair_false, s_pair_false, s_any); + pl_gurrsiu = s7_make_circular_signature(sc, 6, 7, s_gtk_enum_t, s_pair_false, s_real, s_real, s_string, s_integer, s_pair_false); + pl_gussitu = s7_make_circular_signature(sc, 6, 7, s_gtk_enum_t, s_pair_false, s_string, s_string, s_integer, s_any, s_pair_false); + pl_t = s7_make_circular_signature(sc, 0, 1, s_any); + pl_s = s7_make_circular_signature(sc, 0, 1, s_string); + pl_du = s7_make_circular_signature(sc, 1, 2, s_float, s_pair_false); + pl_pr = s7_make_circular_signature(sc, 1, 2, s_pair, s_real); + pl_dui = s7_make_circular_signature(sc, 2, 3, s_float, s_pair_false, s_integer); + pl_dus = s7_make_circular_signature(sc, 2, 3, s_float, s_pair_false, s_string); + pl_dusi = s7_make_circular_signature(sc, 3, 4, s_float, s_pair_false, s_string, s_integer); + pl_dusr = s7_make_circular_signature(sc, 3, 4, s_float, s_pair_false, s_string, s_real); + pl_p = s7_make_circular_signature(sc, 0, 1, s_pair); + pl_tts = s7_make_circular_signature(sc, 2, 3, s_any, s_any, s_string); + pl_tti = s7_make_circular_signature(sc, 2, 3, s_any, s_any, s_integer); + pl_ts = s7_make_circular_signature(sc, 1, 2, s_any, s_string); + pl_tsi = s7_make_circular_signature(sc, 2, 3, s_any, s_string, s_integer); + pl_tsig = s7_make_circular_signature(sc, 3, 4, s_any, s_string, s_integer, s_gtk_enum_t); + pl_tsiu = s7_make_circular_signature(sc, 3, 4, s_any, s_string, s_integer, s_pair_false); + pl_tsiuui = s7_make_circular_signature(sc, 5, 6, s_any, s_string, s_integer, s_pair_false, s_pair_false, s_integer); + pl_tsiiuui = s7_make_circular_signature(sc, 6, 7, s_any, s_string, s_integer, s_integer, s_pair_false, s_pair_false, s_integer); + pl_ssi = s7_make_circular_signature(sc, 2, 3, s_string, s_string, s_integer); + pl_ssig = s7_make_circular_signature(sc, 3, 4, s_string, s_string, s_integer, s_gtk_enum_t); + pl_bi = s7_make_circular_signature(sc, 1, 2, s_boolean, s_integer); + pl_big = s7_make_circular_signature(sc, 2, 3, s_boolean, s_integer, s_gtk_enum_t); pl_tusiuiui = s7_make_circular_signature(sc, 7, 8, s_any, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_pair_false, s_integer); pl_tuiiiiui = s7_make_circular_signature(sc, 7, 8, s_any, s_pair_false, s_integer, s_integer, s_integer, s_integer, s_pair_false, s_integer); pl_tuuiiiirrrrg = s7_make_circular_signature(sc, 11, 12, s_any, s_pair_false, s_pair_false, s_integer, s_integer, s_integer, s_integer, s_real, s_real, s_real, s_real, s_gtk_enum_t); @@ -47601,35 +47586,8 @@ static void define_functions(s7_scheme *sc) pl_tuuubr = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_boolean, s_real); pl_tuuiuui = s7_make_circular_signature(sc, 6, 7, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false, s_pair_false, s_integer); pl_tubiiiu = s7_make_circular_signature(sc, 6, 7, s_any, s_pair_false, s_boolean, s_integer, s_integer, s_integer, s_pair_false); - pl_du = s7_make_circular_signature(sc, 1, 2, s_float, s_pair_false); - pl_pr = s7_make_circular_signature(sc, 1, 2, s_pair, s_real); - pl_dui = s7_make_circular_signature(sc, 2, 3, s_float, s_pair_false, s_integer); - pl_dus = s7_make_circular_signature(sc, 2, 3, s_float, s_pair_false, s_string); - pl_dusi = s7_make_circular_signature(sc, 3, 4, s_float, s_pair_false, s_string, s_integer); - pl_dusr = s7_make_circular_signature(sc, 3, 4, s_float, s_pair_false, s_string, s_real); - pl_sg = s7_make_circular_signature(sc, 1, 2, s_string, s_gtk_enum_t); - pl_gs = s7_make_circular_signature(sc, 1, 2, s_gtk_enum_t, s_string); - pl_b = s7_make_circular_signature(sc, 0, 1, s_boolean); - pl_gu = s7_make_circular_signature(sc, 1, 2, s_gtk_enum_t, s_pair_false); - pl_pg = s7_make_circular_signature(sc, 1, 2, s_pair, s_gtk_enum_t); - pl_gus = s7_make_circular_signature(sc, 2, 3, s_gtk_enum_t, s_pair_false, s_string); - pl_pgi = s7_make_circular_signature(sc, 2, 3, s_pair, s_gtk_enum_t, s_integer); - pl_pgu = s7_make_circular_signature(sc, 2, 3, s_pair, s_gtk_enum_t, s_pair_false); - pl_gui = s7_make_circular_signature(sc, 2, 3, s_gtk_enum_t, s_pair_false, s_integer); - pl_guut = s7_make_circular_signature(sc, 3, 4, s_gtk_enum_t, s_pair_false, s_pair_false, s_any); - pl_pgbi = s7_make_circular_signature(sc, 3, 4, s_pair, s_gtk_enum_t, s_boolean, s_integer); - pl_guuut = s7_make_circular_signature(sc, 4, 5, s_gtk_enum_t, s_pair_false, s_pair_false, s_pair_false, s_any); - pl_gurrsiu = s7_make_circular_signature(sc, 6, 7, s_gtk_enum_t, s_pair_false, s_real, s_real, s_string, s_integer, s_pair_false); - pl_gussitu = s7_make_circular_signature(sc, 6, 7, s_gtk_enum_t, s_pair_false, s_string, s_string, s_integer, s_any, s_pair_false); - pl_ssi = s7_make_circular_signature(sc, 2, 3, s_string, s_string, s_integer); - pl_ssig = s7_make_circular_signature(sc, 3, 4, s_string, s_string, s_integer, s_gtk_enum_t); - pl_bi = s7_make_circular_signature(sc, 1, 2, s_boolean, s_integer); - pl_big = s7_make_circular_signature(sc, 2, 3, s_boolean, s_integer, s_gtk_enum_t); pl_su = s7_make_circular_signature(sc, 1, 2, s_string, s_pair_false); pl_ps = s7_make_circular_signature(sc, 1, 2, s_pair, s_string); - pl_bt = s7_make_circular_signature(sc, 1, 2, s_boolean, s_any); - pl_tb = s7_make_circular_signature(sc, 1, 2, s_any, s_boolean); - pl_bti = s7_make_circular_signature(sc, 2, 3, s_boolean, s_any, s_integer); pl_sui = s7_make_circular_signature(sc, 2, 3, s_string, s_pair_false, s_integer); pl_sug = s7_make_circular_signature(sc, 2, 3, s_string, s_pair_false, s_gtk_enum_t); pl_psi = s7_make_circular_signature(sc, 2, 3, s_pair, s_string, s_integer); @@ -47640,7 +47598,6 @@ static void define_functions(s7_scheme *sc) pl_psgi = s7_make_circular_signature(sc, 3, 4, s_pair, s_string, s_gtk_enum_t, s_integer); pl_psiu = s7_make_circular_signature(sc, 3, 4, s_pair, s_string, s_integer, s_pair_false); pl_psut = s7_make_circular_signature(sc, 3, 4, s_pair, s_string, s_pair_false, s_any); - pl_btiib = s7_make_circular_signature(sc, 4, 5, s_boolean, s_any, s_integer, s_integer, s_boolean); pl_suuub = s7_make_circular_signature(sc, 4, 5, s_string, s_pair_false, s_pair_false, s_pair_false, s_boolean); pl_psugt = s7_make_circular_signature(sc, 4, 5, s_pair, s_string, s_pair_false, s_gtk_enum_t, s_any); pl_psiuub = s7_make_circular_signature(sc, 5, 6, s_pair, s_string, s_integer, s_pair_false, s_pair_false, s_boolean); @@ -47680,20 +47637,63 @@ static void define_functions(s7_scheme *sc) pl_pusiuiu = s7_make_circular_signature(sc, 6, 7, s_pair, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_pair_false); pl_puuusuug = s7_make_circular_signature(sc, 7, 8, s_pair, s_pair_false, s_pair_false, s_pair_false, s_string, s_pair_false, s_pair_false, s_gtk_enum_t); pl_pusiuibu = s7_make_circular_signature(sc, 7, 8, s_pair, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_boolean, s_pair_false); + pl_b = s7_make_circular_signature(sc, 0, 1, s_boolean); + pl_bt = s7_make_circular_signature(sc, 1, 2, s_boolean, s_any); + pl_tb = s7_make_circular_signature(sc, 1, 2, s_any, s_boolean); + pl_bti = s7_make_circular_signature(sc, 2, 3, s_boolean, s_any, s_integer); + pl_btiib = s7_make_circular_signature(sc, 4, 5, s_boolean, s_any, s_integer, s_integer, s_boolean); + pl_bsu = s7_make_circular_signature(sc, 2, 3, s_boolean, s_string, s_pair_false); + pl_bsigb = s7_make_circular_signature(sc, 4, 5, s_boolean, s_string, s_integer, s_gtk_enum_t, s_boolean); + pl_buuusuug = s7_make_circular_signature(sc, 7, 8, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_string, s_pair_false, s_pair_false, s_gtk_enum_t); + pl_bu = s7_make_circular_signature(sc, 1, 2, s_boolean, s_pair_false); + pl_pb = s7_make_circular_signature(sc, 1, 2, s_pair, s_boolean); + pl_bur = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_real); + pl_bug = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_gtk_enum_t); + pl_bus = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_string); + pl_bui = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_integer); + pl_bub = s7_make_circular_signature(sc, 2, 3, s_boolean, s_pair_false, s_boolean); + pl_buui = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_pair_false, s_integer); + pl_buus = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_pair_false, s_string); + pl_busu = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_string, s_pair_false); + pl_buub = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_pair_false, s_boolean); + pl_buig = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_integer, s_gtk_enum_t); + pl_busib = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_string, s_integer, s_boolean); + pl_buuub = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_boolean); + pl_buttu = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_any, s_any, s_pair_false); + pl_busgu = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_string, s_gtk_enum_t, s_pair_false); + pl_buuui = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_integer); + pl_buuig = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t); + pl_buiuig = s7_make_circular_signature(sc, 5, 6, s_boolean, s_pair_false, s_integer, s_pair_false, s_integer, s_gtk_enum_t); + pl_buusib = s7_make_circular_signature(sc, 5, 6, s_boolean, s_pair_false, s_pair_false, s_string, s_integer, s_boolean); + pl_buuuub = s7_make_circular_signature(sc, 5, 6, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean); + pl_buurbr = s7_make_circular_signature(sc, 5, 6, s_boolean, s_pair_false, s_pair_false, s_real, s_boolean, s_real); + pl_iit = s7_make_circular_signature(sc, 2, 3, s_integer, s_integer, s_any); + pl_iiit = s7_make_circular_signature(sc, 3, 4, s_integer, s_integer, s_integer, s_any); + pl_gi = s7_make_circular_signature(sc, 1, 2, s_gtk_enum_t, s_integer); + pl_igi = s7_make_circular_signature(sc, 2, 3, s_integer, s_gtk_enum_t, s_integer); + pl_i = s7_make_circular_signature(sc, 0, 1, s_integer); + pl_g = s7_make_circular_signature(sc, 0, 1, s_gtk_enum_t); + pl_ti = s7_make_circular_signature(sc, 1, 2, s_any, s_integer); + pl_it = s7_make_circular_signature(sc, 1, 2, s_integer, s_any); + pl_tiu = s7_make_circular_signature(sc, 2, 3, s_any, s_integer, s_pair_false); + pl_itsub = s7_make_circular_signature(sc, 4, 5, s_integer, s_any, s_string, s_pair_false, s_boolean); + pl_itiiub = s7_make_circular_signature(sc, 5, 6, s_integer, s_any, s_integer, s_integer, s_pair_false, s_boolean); + pl_itstttg = s7_make_circular_signature(sc, 6, 7, s_integer, s_any, s_string, s_any, s_any, s_any, s_gtk_enum_t); + pl_itgiiut = s7_make_circular_signature(sc, 6, 7, s_integer, s_any, s_gtk_enum_t, s_integer, s_integer, s_pair_false, s_any); pl_bpt = s7_make_signature(sc, 2, s_pair_false, s_any); #if GTK_CHECK_VERSION(3, 0, 0) - pl_buigu = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_integer, s_gtk_enum_t, s_pair_false); - pl_tuuugi = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer); - pl_tuuuub = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean); pl_pgr = s7_make_circular_signature(sc, 2, 3, s_pair, s_gtk_enum_t, s_real); pl_gug = s7_make_circular_signature(sc, 2, 3, s_gtk_enum_t, s_pair_false, s_gtk_enum_t); + pl_tuuugi = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer); + pl_tuuuub = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean); pl_puuig = s7_make_circular_signature(sc, 4, 5, s_pair, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t); pl_puiiui = s7_make_circular_signature(sc, 5, 6, s_pair, s_pair_false, s_integer, s_integer, s_pair_false, s_integer); + pl_buigu = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_integer, s_gtk_enum_t, s_pair_false); #endif #if GTK_CHECK_VERSION(3, 4, 0) - pl_tsu = s7_make_circular_signature(sc, 2, 3, s_any, s_string, s_pair_false); pl_prrru = s7_make_circular_signature(sc, 4, 5, s_pair, s_real, s_real, s_real, s_pair_false); + pl_tsu = s7_make_circular_signature(sc, 2, 3, s_any, s_string, s_pair_false); pl_suiig = s7_make_circular_signature(sc, 4, 5, s_string, s_pair_false, s_integer, s_integer, s_gtk_enum_t); #endif @@ -47725,8 +47725,6 @@ static void define_functions(s7_scheme *sc) #endif #if GTK_CHECK_VERSION(3, 94, 0) - pl_busi = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_string, s_integer); - pl_buib = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_integer, s_boolean); pl_iuugs = s7_make_circular_signature(sc, 4, 5, s_integer, s_pair_false, s_pair_false, s_gtk_enum_t, s_string); pl_piigui = s7_make_circular_signature(sc, 5, 6, s_pair, s_integer, s_integer, s_gtk_enum_t, s_pair_false, s_integer); pl_tuiut = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_integer, s_pair_false, s_any); @@ -47743,16 +47741,18 @@ static void define_functions(s7_scheme *sc) pl_pst = s7_make_circular_signature(sc, 2, 3, s_pair, s_string, s_any); pl_purru = s7_make_circular_signature(sc, 4, 5, s_pair, s_pair_false, s_real, s_real, s_pair_false); pl_purrrru = s7_make_circular_signature(sc, 6, 7, s_pair, s_pair_false, s_real, s_real, s_real, s_real, s_pair_false); + pl_busi = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_string, s_integer); + pl_buib = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_integer, s_boolean); #endif #if GTK_CHECK_VERSION(3, 96, 0) - pl_buiu = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_integer, s_pair_false); - pl_buiib = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_integer, s_integer, s_boolean); pl_tuiiiu = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_integer, s_integer, s_integer, s_pair_false); pl_tuugiu = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer, s_pair_false); + pl_bg = s7_make_circular_signature(sc, 1, 2, s_boolean, s_gtk_enum_t); pl_purrg = s7_make_circular_signature(sc, 4, 5, s_pair, s_pair_false, s_real, s_real, s_gtk_enum_t); pl_puuugi = s7_make_circular_signature(sc, 5, 6, s_pair, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer); - pl_bg = s7_make_circular_signature(sc, 1, 2, s_boolean, s_gtk_enum_t); + pl_buiu = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_integer, s_pair_false); + pl_buiib = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_integer, s_integer, s_boolean); #endif @@ -54888,7 +54888,7 @@ void libgtk_s7_init(s7_scheme *sc) define_functions(sc); s7_define_function(sc, "g_signal_connect", lg_g_signal_connect, 3, 1, 0, H_g_signal_connect); s7_set_shadow_rootlet(sc, old_shadow); - s7_define(sc, cur_env, s7_make_symbol(sc, "libgtk-version"), s7_make_string(sc, "26-Jul-19")); + s7_define(sc, cur_env, s7_make_symbol(sc, "libgtk-version"), s7_make_string(sc, "27-Aug-19")); } /* gcc -c libgtk_s7.c -o libgtk_s7.o -I. -fPIC `pkg-config --libs gtk+-3.0 --cflags` -lm -ldl */ /* gcc libgtk_s7.o -shared -o libgtk_s7.so */ @@ -1261,7 +1261,7 @@ (tree-subst new old (cdr tree)))))) - (define (do->make-list caller form var1 var2) ; (var1: (... (+/-)) var2: (... (cons))) + (define (do->make-list caller form original-form var1 var2) ; (var1: (... (+/-)) var2: (... (cons))) (when (and (len=2? (cdr var2)) (len=3? (caddr var1)) (len=3? (caddr var2))) @@ -1333,7 +1333,7 @@ (not (eq? (car fill) 'quote))) (format #f ", (assuming ~S is not problematic), " fill) "") - (lists->string form + (lists->string original-form `(make-list ,len ,fill)))))) ((and (memq (car fill) '(string-ref vector-ref)) @@ -1341,7 +1341,7 @@ (or (eq? (caddr fill) name1) (equal? (caddr fill) `(- ,name1 1)))) (lint-format "perhaps ~A" caller - (format #f "~A -> ~A" form + (format #f "~A -> ~A" original-form (if (eq? (car fill) 'string-ref) 'string->list 'vector->list)))) ((and (len=2? fill) @@ -1349,7 +1349,7 @@ (memq (caadr fill) '(vector-ref string-ref byte-vector-ref float-vector-ref int-vector-ref list-ref)) (eq? name1 (caddr (cadr fill)))) (lint-format "perhaps ~A" caller - (format #f "~A -> ~A" form + (format #f "~A -> ~A" original-form `(map ,(car fill) ,(cadadr fill))))))))))) (define recursion->iteration @@ -1729,12 +1729,12 @@ (if (and (len=2? (cdr var1)) (pair? (caddr var1)) (eq? (caaddr var1) 'cons)) - (do->make-list name do-loop (cadadr do-loop) var1) + (do->make-list name do-loop initial-value (cadadr do-loop) var1) (let ((var2 (cadadr do-loop))) (if (and (len=2? (cdr var2)) (pair? (caddr var2)) (eq? (caaddr var2) 'cons)) - (do->make-list name do-loop var1 var2)))))) + (do->make-list name do-loop initial-value var1 var2)))))) ))))))))))))) (define (improper-arglist->define* name ftype arglist initial-value) @@ -10253,7 +10253,8 @@ gc-protected-objects file-names rootlet-size c-types stack-top stack-size stacktrace-defaults history-enabled max-stack-size stack catches float-format-precision bignum-precision default-rationalize-error default-random-state equivalent-float-epsilon hash-table-float-epsilon undefined-identifier-warnings - undefined-constant-warnings gc-stats history-size history profile-info autoloading? max-format-length)) + undefined-constant-warnings gc-stats history-size history profile-info autoloading? max-format-length + most-positive-fixnum most-negative-fixnum)) h))) (lambda (caller head form env) (if (len=2? form) @@ -11237,6 +11238,7 @@ (set! bad-ops (cons op bad-ops))))) (let-ref fdata 'macro-ops)) + (if (equal? bad-quoted-locals '(quote)) (set! bad-quoted-locals ())) (when (or (pair? bad-locals) (pair? bad-quoted-locals) ;; (define-macro (mac8 b) `(let ((a 12)) (+ (symbol->value ,b) a))) @@ -14442,7 +14444,7 @@ (when (pair? body) (let ((args (cdr body))) (case (car body) - ((list-values) + ((list-values list) (when (and (pair? args) (quoted-symbol? (car args))) (if (proper-list? outer-args) @@ -18692,12 +18694,12 @@ (if (and (len=2? (cdr var1)) (pair? (caddr var1)) (eq? (caaddr var1) 'cons)) - (do->make-list caller form (cadadr form) var1) + (do->make-list caller form form (cadadr form) var1) (let ((var2 (cadadr form))) (if (and (len=2? (cdr var2)) (pair? (caddr var2)) (eq? (caaddr var2) 'cons)) - (do->make-list caller form var1 var2)))))))) + (do->make-list caller form form var1 var2)))))))) ;; -------- do-walker -------- (define (do-walker caller form env) @@ -22363,11 +22365,11 @@ ((and (len=3? arg1) ; `((a . b) (c . d)) -> (list (cons a b) (cons c d)) (eq? (car arg1) 'append) ; `((a . (b . c))...) -> (list (cons a (cons b c)) ...) (pair? (cadr arg1)) - (eq? (caadr arg1) 'list-values) + (memq (caadr arg1) '(list list-values)) (len=3? arg2) (eq? (car arg2) 'append) (pair? (cadr arg2)) - (eq? (caadr arg2) 'list-values)) + (memq (caadr arg2) '(list list-values))) (let ((ca1 (cadr arg1)) (ca2 (cadr arg2))) (let ((len1 (length ca1)) @@ -23228,5 +23230,5 @@ #f)) |# -;;; 57 919120 +;;; 54 896368 diff --git a/mockery.scm b/mockery.scm index 9ed38f5..1d33d9e 100644 --- a/mockery.scm +++ b/mockery.scm @@ -53,21 +53,24 @@ (define (with-mock-wrapper* func) (lambda args - (let* ((unknown-openlets #f) - (new-args (map (lambda (arg) - (if (mock? arg) - (arg 'value) - (begin - (if (and (openlet? arg) - (not (procedure? arg)) - (not (macro? arg)) - (not (c-pointer? arg))) - (set! unknown-openlets #t)) - arg))) - args))) + (let ((unknown-openlets #f) + (new-args ())) + (for-each (lambda (arg) ; not map here because (values) should not be ignored: (+ (mock-number 4/3) (values)) + (set! new-args + (cons (if (mock? arg) + (arg 'value) + (begin + (if (and (openlet? arg) + (not (procedure? arg)) + (not (macro? arg)) + (not (c-pointer? arg))) + (set! unknown-openlets #t)) + arg)) + new-args))) + args) (if unknown-openlets - (apply func new-args) - (dynamic-wind coverlets (lambda () (apply func new-args)) openlets))))) + (apply func (reverse new-args)) + (dynamic-wind coverlets (lambda () (apply func (reverse new-args))) openlets))))) ;; one tricky thing here is that a mock object can be the let of with-let: (with-let (mock-port ...) ...) ;; so a mock object's method can be called even when no argument is a mock object. Even trickier, the diff --git a/reactive.scm b/reactive.scm index 9e39a88..c68806b 100644 --- a/reactive.scm +++ b/reactive.scm @@ -3,8 +3,10 @@ ;;; reimplementation of code formerly in stuff.scm (provide 'reactive.scm) +;(set! (*s7* 'gc-stats) #t) (define (symbol->let symbol env) + ;(format *stderr* "symbol->let ~S~%" symbol) ;; return let in which symbol lives (not necessarily curlet) (if (defined? symbol env #t) env @@ -55,11 +57,13 @@ (define (setter-update cp) ; cp: (slot var expr env expr-env) ;; when var set, all other vars dependent on it need to be set also, watching out for GC'd followers - (when (and (let? (slot-env cp)) ; when slot-env is GC'd, the c-pointer field is set to #f (by the GC) - (let? (slot-expr-env cp))) - (let-set! (slot-env cp) - (slot-symbol cp) - (eval (slot-expr cp) (slot-expr-env cp))))) + (when (and (let? (slot-env cp)) + (let? (slot-expr-env cp))) ; when slot-env is GC'd, the c-pointer field is set to #f (by the GC) + (let ((val (eval (slot-expr cp) (slot-expr-env cp)))) + (when (let? (slot-env cp)) ; same as above, but eval may trigger gc + (let-set! (slot-env cp) + (slot-symbol cp) + val))))) (define (slot-equal? cp1 cp2) @@ -81,35 +85,50 @@ (setters setters) (cp (slot var expr env expr-env))) (lambda (sym val) + ;(format *stderr* "make-setter ~S ~S~%" sym val) (let-temporarily (((setter (slot-symbol cp) (slot-env cp)) #f)) ;(setter (c-pointer-type cp) (c-pointer-weak1 cp)) #f)) (let-set! (slot-env cp) (slot-symbol cp) val) ; set new value without retriggering the setter (for-each setter-update followers) ; set any variables dependent on var val)))) - -(define-bacro (reactive-set! place value) ; or maybe macro* with trailing arg: (e (outlet (curlet)))?? +(define (update-setters setters cp e) + ;; add the slot to the followers setter list of each variable in expr + (for-each (lambda (s) + (unless (and (setter s e) + (defined? 'followers (funclet (setter s e)))) + (set! (setter s e) (make-setter s e))) + (let ((setter-followers (let-ref (funclet (setter s e)) 'followers))) + (unless (member cp setter-followers slot-equal?) + (let-set! (funclet (setter s e)) + 'followers + (cons cp setter-followers))))) + setters)) + +(define (clean-up-setter old-setter old-followers lt place e) + ;; if previous set expr, remove it from setters' followers lists + (when (and old-setter + (defined? 'followers (funclet old-setter)) + (defined? 'setters (funclet old-setter))) + (set! old-followers ((funclet old-setter) 'followers)) + (for-each (lambda (s) + (when (and (setter s e) + (defined? 'followers (funclet (setter s e)))) + (let ((setter-followers (let-ref (funclet (setter s e)) 'followers))) + (let-set! (funclet (setter s e)) + 'followers + (setter-remove (slot place 0 lt e) setter-followers))))) + (let-ref (funclet old-setter) 'setters))) + old-followers) + +(define-bacro (reactive-set! place value) (with-let (inlet 'place place ; with-let here gives us control over the names 'value value 'e (outlet (curlet))) ; the run-time (calling) environment `(let ((old-followers ()) (old-setter (setter ',place)) (lt (symbol->let ',place ,e))) - - ;; if previous set expr, remove it from setters' followers lists - (when (and old-setter - (defined? 'followers (funclet old-setter)) - (defined? 'setters (funclet old-setter))) - (set! old-followers ((funclet old-setter) 'followers)) - (for-each (lambda (s) - (when (and (setter s) - (defined? 'followers (funclet (setter s)))) - (let ((setter-followers (let-ref (funclet (setter s)) 'followers))) - (let-set! (funclet (setter s)) - 'followers - (setter-remove (slot ',place 0 lt ,e) setter-followers))))) - (let-ref (funclet old-setter) 'setters))) - + (set! old-followers (clean-up-setter old-setter old-followers lt ',place ,e)) ;; set up new setter (let ((setters (gather-symbols ',value ,e () ()))) (when (pair? setters) @@ -117,21 +136,11 @@ (let ((cp (slot ',place expr lt ,e))) (set! (setter ',place lt) (make-setter ',place lt old-followers setters expr ,e)) - - ;; add the slot to the followers setter list of each variable in expr - (for-each (lambda (s) - (unless (and (setter s) - (defined? 'followers (funclet (setter s)))) - (set! (setter s) (make-setter s (symbol->let s ,e)))) - (let ((setter-followers (let-ref (funclet (setter s)) 'followers))) - (unless (member cp setter-followers slot-equal?) - (let-set! (funclet (setter s)) - 'followers - (cons cp setter-followers))))) - setters))))) + (update-setters setters cp ,e))))) (set! ,place ,value)))) + ;; -------------------------------------------------------------------------------- #| (let () @@ -1379,7 +1379,7 @@ (* 0.000001 (- (cadr end) (cadr ,start)))))))) -(define apropos +(define apropos ; this misses syntax names (they aren't in rootlet) (let ((levenshtein (lambda (s1 s2) (let ((L1 (length s1)) @@ -1425,7 +1425,8 @@ (lambda* (name (e (*repl* 'top-level-let))) (let ((ap-name (if (string? name) name - (if (symbol? name) (symbol->string name) + (if (symbol? name) + (symbol->string name) (error 'wrong-type-arg "apropos argument 1 should be a string or a symbol")))) (ap-env (if (let? e) e (error 'wrong-type-arg "apropos argument 2 should be an environment")))) @@ -45,7 +45,7 @@ * mockery.scm has the mock-data definitions. * reactive.scm has reactive-set and friends. * stuff.scm has some stuff. - * timing tests are in the snd tools directory + * timing tests are in the s7 tools directory * * s7.c is organized as follows: * structs and type flags @@ -513,7 +513,7 @@ typedef struct block_t { typedef block_t hash_entry_t; #define hash_entry_key(p) p->dx.d_ptr -#define hash_entry_value(p) p->ex.ex_ptr +#define hash_entry_value(p) (p)->ex.ex_ptr #define hash_entry_set_value(p, Val) p->ex.ex_ptr = Val #define hash_entry_next(p) block_next(p) #define hash_entry_raw_hash(p) block_size(p) @@ -1169,7 +1169,7 @@ struct s7_scheme { int32_t num_fdats, last_error_line; s7_pointer elist_1, elist_2, elist_3, elist_4, elist_5, plist_1, plist_2, plist_2_2, plist_3, qlist_2, qlist_3, clist_1; gc_list *strings, *vectors, *input_ports, *output_ports, *continuations, *c_objects, *hash_tables; - gc_list *gensyms, *unknowns, *lambdas, *multivectors, *weak_refs, *weak_hash_iterators; + gc_list *gensyms, *unknowns, *lambdas, *multivectors, *weak_refs, *weak_hash_iterators, *lamlets; s7_pointer *setters; s7_int setters_size, setters_loc; s7_pointer *tree_pointers; @@ -1301,20 +1301,20 @@ struct s7_scheme { s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, pcl_e, pcl_f, pcl_i, pcl_n, pcl_r, pcl_s, pcl_v, pl_bc, pl_bn, pl_bt, pl_p, pl_sf, pl_tl, pl_nn; /* optimizer s7_functions */ - s7_pointer add_2, add_1s, add_s1, subtract_1, subtract_2, subtract_s1, subtract_2f, subtract_f2, simple_char_eq, + s7_pointer add_2, add_3, add_1x, add_x1, subtract_1, subtract_2, subtract_3, subtract_s1, subtract_2f, subtract_f2, simple_char_eq, char_equal_2, char_greater_2, char_less_2, char_position_csi, string_equal_2, substring_to_temp, display_2, string_greater_2, string_less_2, symbol_to_string_uncopied, vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, read_char_1, fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_2i, iv_ref_3, iv_set_3, bv_ref_2, bv_ref_3, bv_set_3, - list_0, list_1, list_2, list_set_i, hash_table_ref_2, hash_table_2, - format_allg, format_allg_no_column, format_just_control_string, format_as_objstr, + list_0, list_1, list_2, list_3, list_set_i, hash_table_ref_2, hash_table_2, + format_f, format_allg_no_column, format_just_control_string, format_as_objstr, memq_2, memq_3, memq_4, memq_any, tree_set_memq_syms, read_line_uncopied, simple_inlet, lint_let_ref, lint_let_set, or_n, or_2, or_3, and_n, and_2, and_3, if_a_a, if_a_aa, if_not_a_a, - if_not_a_aa, if_a_qq, if_a_qa, or_s_direct, and_s_direct, geq_2, or_s_direct_2, and_s_direct_2, or_s_type_2; + if_not_a_aa, if_a_qq, if_a_qa, or_s, and_s, geq_2, or_s_2, and_s_2, or_s_type_2; #if (!WITH_GMP) - s7_pointer multiply_2, invert_1, divide_1r, divide_2, - num_eq_2, num_eq_2i, less_xi, less_xf, less_x0, less_2, greater_xi, greater_xf, greater_2, + s7_pointer multiply_2, invert_1, divide_1r, divide_2, divide_by_2, + 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, 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, add_2_ff, add_2_ii, add_2_if, add_2_fi, add_2_xi, add_2_ix, add_2_fx, add_2_xf; @@ -2018,11 +2018,11 @@ static void init_types(void) #define is_t_big_ratio(p) (type(p) == T_BIG_RATIO) #define is_t_big_real(p) (type(p) == T_BIG_REAL) #define is_t_big_complex(p) (type(p) == T_BIG_COMPLEX) -#define is_float(p) is_t_real(p) /* ((is_real(p)) && (!is_rational(p))) */ +#define is_float(p) is_t_real(p) #define is_free(p) (type(p) == T_FREE) #define is_free_and_clear(p) (typeflag(p) == T_FREE) -#define is_simple(P) t_simple_p[type(P)] +#define is_simple(P) t_simple_p[type(P)] /* eq? */ #define has_structure(P) ((t_structure_p[type(P)]) && ((!is_normal_vector(P)) || (!has_simple_elements(P)))) #define is_any_macro(P) t_any_macro_p[type(P)] @@ -2344,9 +2344,13 @@ static void init_types(void) #define set_no_bool_opt(p) set_type_bit(T_Pair(p), T_NO_BOOL_OPT) #define no_bool_opt(p) has_type_bit(T_Pair(p), T_NO_BOOL_OPT) -#define T_DIRECT_X_OPT T_SAFE_STEPPER -#define set_direct_x_opt(p) set_type_bit(T_Pair(p), T_DIRECT_X_OPT) -#define has_direct_x_opt(p) has_type_bit(T_Pair(p), T_DIRECT_X_OPT) +#define T_DIRECT_OPT T_SAFE_STEPPER +#define set_direct_opt(p) set_type_bit(T_Pair(p), T_DIRECT_OPT) +#define has_direct_opt(p) has_type_bit(T_Pair(p), T_DIRECT_OPT) + +#define T_INTEGER_KEYS T_SETTER +#define set_has_integer_keys(p) set_type_bit(T_Pair(p), T_INTEGER_KEYS) +#define has_integer_keys(p) has_type_bit(T_Pair(p), T_INTEGER_KEYS) #define T_SAFE_STEPPER (1 << (TYPE_BITS + 19)) #define is_safe_stepper(p) has_type_bit(T_Slt(p), T_SAFE_STEPPER) @@ -2439,6 +2443,11 @@ static void init_types(void) #define set_has_let_arg(p) set_type1_bit(T_Prc(p), T_HAS_LET_ARG) /* p is a setter procedure, "let arg" refers to the setter's optional third (let) argument */ +#define T_SLOTS_SET T_SYMCONS +#define slots_set(p) has_type1_bit(T_Let(p), T_SLOTS_SET) +#define set_slots_set(p) set_type1_bit(T_Let(p), T_SLOTS_SET) +#define clear_slots_set(p) clear_type1_bit(T_Let(p), T_SLOTS_SET) + /* symbol free here */ #define T_FULL_HAS_LET_FILE (1LL << (TYPE_BITS + BIT_ROOM + 25)) #define T_HAS_LET_FILE (1 << 1) @@ -2537,6 +2546,10 @@ static void init_types(void) #define ctr3_is_set(p) has_type1_bit(T_Pair(p), T_CTR3_SET) #define set_ctr3_is_set(p) do {set_type1_bit(T_Pair(p), T_CTR3_SET); clear_type_bit(p, T_LINE_NUMBER);} while (0) +#define T_SAFE_SETTER T_SIMPLE_ELEMENTS +#define is_safe_setter(p) has_type1_bit(T_Sym(p), T_SAFE_SETTER) +#define set_safe_setter(p) set_type1_bit(T_Sym(p), T_SAFE_SETTER) + #define T_FULL_CASE_KEY (1LL << (TYPE_BITS + BIT_ROOM + 33)) #define T_CASE_KEY (1 << 9) #define is_case_key(p) has_type1_bit(T_Pos(p), T_CASE_KEY) @@ -2612,9 +2625,9 @@ static void init_types(void) * all of this machinery vanishes if debugging is turned off. */ #define E_SET (1 << 0) -#define E_FAST (1 << 7) /* fast list in member/assoc circular list check */ -#define E_CFUNC (1 << 8) /* c-function */ -#define E_CLAUSE (1 << 9) /* case clause */ +#define E_FAST (1 << 8) /* fast list in member/assoc circular list check */ +#define E_CFUNC (1 << 9) /* c-function */ +#define E_CLAUSE (1 << 10) /* case clause */ #define E_LAMBDA (1 << 11) /* lambda(*) */ #define E_SYM (1 << 12) /* symbol */ #define E_PAIR (1 << 13) /* pair */ @@ -2645,7 +2658,7 @@ static void init_types(void) #define opt2_role_matches(p, Role) (((p)->debugger_bits & F_MASK) == Role) #define set_opt2_role(p, Role) (p)->debugger_bits = (Role | ((p)->debugger_bits & ~F_MASK)) #define opt2(p, Role) opt2_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt2(p, x, Role) set_opt2_1(sc, T_Pair(p), (s7_pointer)(x), Role, __func__, __LINE__) +#define set_opt2(p, x, Role) set_opt2_1(cur_sc, T_Pair(p), (s7_pointer)(x), Role, __func__, __LINE__) #define G_SET (1 << 2) #define G_ARGLEN (1 << 3) /* arglist length */ @@ -2655,8 +2668,8 @@ static void init_types(void) #define G_ANY (1 << 29) #define G_LET (1 << 17) /* let or #f */ #define G_CTR (1 << 30) -#define G_CON 0x80000000 /* not (1LL < 31) ! */ -#define G_MASK (G_ARGLEN | G_SYM | G_AND | G_ANY | G_LET | G_CTR | G_CON | S_LINE | S_LEN | G_DIRECT) +#define G_BYTE 0x80000000 /* not (1LL < 31) ! */ +#define G_MASK (G_ARGLEN | G_SYM | G_AND | G_ANY | G_LET | G_CTR | G_BYTE | S_LINE | S_LEN | G_DIRECT) #define opt3_is_set(p) (((p)->debugger_bits & G_SET) != 0) #define set_opt3_is_set(p) (p)->debugger_bits |= G_SET @@ -2715,8 +2728,8 @@ static void init_types(void) #define set_opt2_con(P, X) set_opt2(P, T_Pos(X), F_CON) #define opt2_lambda(P) T_Pair(opt2(P, F_LAMBDA)) #define set_opt2_lambda(P, X) set_opt2(P, T_Pair(X), F_LAMBDA) -#define opt2_direct_x_call(P) opt2(P, F_LAMBDA) -#define set_opt2_direct_x_call(P, X) set_opt2(P, (s7_pointer)(X), F_LAMBDA) +#define opt2_direct(P) opt2(P, F_LAMBDA) +#define set_opt2_direct(P, X) set_opt2(P, (s7_pointer)(X), F_LAMBDA) #define opt3_arglen(P) T_Int(opt3(cdr(P), G_ARGLEN)) #define set_opt3_arglen(P, X) set_opt3(cdr(P), T_Int(X), G_ARGLEN) @@ -2728,18 +2741,20 @@ static void init_types(void) #define set_opt3_any(P, X) set_opt3(P, X, G_ANY) #define opt3_let(P) T_Lid(opt3(P, G_LET)) #define set_opt3_let(P, X) set_opt3(P, T_Lid(X), G_LET) -#define opt3_direct_x(P) opt3(P, G_DIRECT) -#define set_opt3_direct_x(P, X) set_opt3(P, (s7_pointer)(X), G_DIRECT) +#define opt3_lamlet(P) T_Pos(opt3(P, G_LET)) +#define set_opt3_lamlet(P, X) set_opt3(P, T_Pos(X), G_LET) +#define opt3_direct(P) opt3(P, G_DIRECT) +#define set_opt3_direct(P, X) set_opt3(P, (s7_pointer)(X), G_DIRECT) #if S7_DEBUGGING -#define opt3_con(p) opt3_con_1(T_Pair(p), G_CON, __func__, __LINE__) -#define set_opt3_con(p, x) set_opt3_con_1(T_Pair(p), x, G_CON, __func__, __LINE__) +#define opt3_byte(p) opt3_byte_1(T_Pair(p), G_BYTE, __func__, __LINE__) +#define set_opt3_byte(p, x) set_opt3_byte_1(T_Pair(p), x, G_BYTE, __func__, __LINE__) #define opt3_ctr(p) opt3_ctr_1(T_Pair(p), G_CTR, __func__, __LINE__) #define set_opt3_ctr(p, x) set_opt3_ctr_1(T_Pair(p), x, G_CTR, __func__, __LINE__) #define increment_opt3_ctr(p) increment_opt3_ctr_1(T_Pair(p), G_CTR, __func__, __LINE__) #else -#define opt3_con(P) T_Pair(P)->object.cons_ext.ce.opt_type /* op_if_is_type */ -#define set_opt3_con(P, X) do {T_Pair(P)->object.cons_ext.ce.opt_type = X; clear_type_bit(P, T_LINE_NUMBER);} while (0) +#define opt3_byte(P) T_Pair(P)->object.cons_ext.ce.opt_type /* op_if_is_type */ +#define set_opt3_byte(P, X) do {T_Pair(P)->object.cons_ext.ce.opt_type = X; clear_type_bit(P, T_LINE_NUMBER);} while (0) #define opt3_ctr(P) T_Pair(P)->object.cons_ext.ce.ctr #define set_opt3_ctr(P, X) do {T_Pair(P)->object.cons_ext.ce.ctr = X; clear_type_bit(P, T_LINE_NUMBER); set_ctr3_is_set(P);} while(0) #define increment_opt3_ctr(P) do {if (ctr3_is_set(P)) P->object.cons_ext.ce.ctr++; else set_opt3_ctr(P, 0);} while (0) @@ -2749,7 +2764,7 @@ static void init_types(void) #define c_call(f) ((s7_function)opt2(f, F_CALL)) #define set_c_call_checked(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, F_CALL); if (X) set_has_fx(f); else clear_has_fx(f);} while (0) #if S7_DEBUGGING - #define set_c_call(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); if (!(X)) fprintf(stderr, "%s[%d] x_call null: %s\n", __func__, __LINE__, DISPLAY(f)); set_opt2(f, X, F_CALL); if (X) set_has_fx(f); else clear_has_fx(f);} while (0) + #define set_c_call(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); if (!(X)) fprintf(stderr, "%s[%d] x_call null\n", __func__, __LINE__); set_opt2(f, X, F_CALL); if (X) set_has_fx(f); else clear_has_fx(f);} while (0) #else #define set_c_call(f, X) do {set_opt2(f, (s7_pointer)(X), F_CALL); set_has_fx(f);} while (0) #endif @@ -2952,6 +2967,7 @@ static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p)) #define ROOTLET_SIZE 512 #define let_id(p) (T_Lid(p))->object.envr.id #define is_let(p) (type(p) == T_LET) +#define is_let_unchecked(p) (unchecked_type(p) == T_LET) #define let_slots(p) T_Sln((T_Let(p))->object.envr.slots) #define outlet(p) T_Lid((T_Let(p))->object.envr.nxt) #define set_outlet(p, ol) (T_Let(p))->object.envr.nxt = T_Lid(ol) @@ -3599,10 +3615,15 @@ static void local_memset(void *s, uint8_t val, size_t n) static inline s7_int safe_strlen(const char *str) { /* this is safer than strlen, and slightly faster */ - char *tmp = (char *)str; + const char *tmp = str; if ((!tmp) || (!(*tmp))) return(0); +#if 0 while (*tmp++) {}; return(tmp - str - 1); +#else + for (; *tmp; ++tmp); + return(tmp - str); +#endif } static char *copy_string_with_length(const char *str, s7_int len) @@ -3833,11 +3854,9 @@ static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme *sc, s7_pointe /* ---------------- evaluator ops ---------------- */ /* C=constant, S=symbol, A=fx-callable, Q=quote, D=list of constants, FX=list of A's */ -enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, +enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_protect used below as boundary marker (is_h_optimized etc) */ - OP_SAFE_C_D, HOP_SAFE_C_D, - OP_X, HOP_X, - OP_SAFE_C_S, HOP_SAFE_C_S, + OP_SAFE_C_D, HOP_SAFE_C_D, OP_SAFE_C_S, HOP_SAFE_C_S, OP_SAFE_C_SS, HOP_SAFE_C_SS, OP_SAFE_C_SC, HOP_SAFE_C_SC, OP_SAFE_C_CS, HOP_SAFE_C_CS, OP_SAFE_C_CQ, HOP_SAFE_C_CQ, OP_SAFE_C_SSS, HOP_SAFE_C_SSS, OP_SAFE_C_SCS, HOP_SAFE_C_SCS, OP_SAFE_C_SSC, HOP_SAFE_C_SSC, OP_SAFE_C_CSS, HOP_SAFE_C_CSS, OP_SAFE_C_SCC, HOP_SAFE_C_SCC, OP_SAFE_C_CSC, HOP_SAFE_C_CSC, @@ -3878,19 +3897,19 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_SAFE_C_opAq, HOP_SAFE_C_opAq, OP_SAFE_C_opAAq, HOP_SAFE_C_opAAq, OP_SAFE_C_opAAAq, HOP_SAFE_C_opAAAq, OP_SAFE_C_S_opAq, HOP_SAFE_C_S_opAq, OP_SAFE_C_opAq_S, HOP_SAFE_C_opAq_S, OP_SAFE_C_S_opAAq, HOP_SAFE_C_S_opAAq, OP_SAFE_C_S_opAAAq, HOP_SAFE_C_S_opAAAq, - OP_SAFE_IFA_SS_A, HOP_SAFE_IFA_SS_A, OP_SAFE_C_STAR, HOP_SAFE_C_STAR, OP_SAFE_C_STAR_A, HOP_SAFE_C_STAR_A, OP_SAFE_C_STAR_AA, HOP_SAFE_C_STAR_AA, OP_SAFE_C_STAR_FX, HOP_SAFE_C_STAR_FX, OP_SAFE_C_P, HOP_SAFE_C_P, - OP_THUNK, HOP_THUNK, OP_THUNK_P, HOP_THUNK_P, + OP_THUNK, HOP_THUNK, OP_THUNK_P, HOP_THUNK_P, OP_THUNK_NIL, HOP_THUNK_NIL, OP_SAFE_THUNK, HOP_SAFE_THUNK, OP_SAFE_THUNK_P, HOP_SAFE_THUNK_P, OP_SAFE_THUNK_A, HOP_SAFE_THUNK_A, OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_S_P, HOP_CLOSURE_S_P, OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_S_P, HOP_SAFE_CLOSURE_S_P, OP_SAFE_CLOSURE_S_A, HOP_SAFE_CLOSURE_S_A, + OP_SAFE_CLOSURE_S_TO_S, HOP_SAFE_CLOSURE_S_TO_S, OP_CLOSURE_C, HOP_CLOSURE_C, OP_CLOSURE_C_P, HOP_CLOSURE_C_P, OP_SAFE_CLOSURE_C, HOP_SAFE_CLOSURE_C, OP_SAFE_CLOSURE_C_P, HOP_SAFE_CLOSURE_C_P, OP_SAFE_CLOSURE_C_A, HOP_SAFE_CLOSURE_C_A, - OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_P, HOP_CLOSURE_A_P, OP_CLOSURE_SUB_P, HOP_CLOSURE_SUB_P, + OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_P, HOP_CLOSURE_A_P, OP_SAFE_CLOSURE_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_A_P, HOP_SAFE_CLOSURE_A_P, OP_SAFE_CLOSURE_A_A, HOP_SAFE_CLOSURE_A_A, OP_CLOSURE_P, HOP_CLOSURE_P, OP_SAFE_CLOSURE_P, HOP_SAFE_CLOSURE_P, @@ -3906,14 +3925,15 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_CLOSURE_CS, HOP_CLOSURE_CS, OP_SAFE_CLOSURE_CS, HOP_SAFE_CLOSURE_CS, - OP_CLOSURE_3S, HOP_CLOSURE_3S, OP_CLOSURE_3S_P, HOP_CLOSURE_3S_P, - OP_CLOSURE_4S, HOP_CLOSURE_4S, OP_CLOSURE_4S_P, HOP_CLOSURE_4S_P, + OP_CLOSURE_3S, HOP_CLOSURE_3S, OP_CLOSURE_3S_P, HOP_CLOSURE_3S_P, OP_CLOSURE_3S_B, HOP_CLOSURE_3S_B, + OP_CLOSURE_4S, HOP_CLOSURE_4S, OP_CLOSURE_4S_P, HOP_CLOSURE_4S_P, OP_CLOSURE_4S_B, HOP_CLOSURE_4S_B, OP_CLOSURE_AA, HOP_CLOSURE_AA, OP_CLOSURE_AA_P, HOP_CLOSURE_AA_P, OP_SAFE_CLOSURE_AA, HOP_SAFE_CLOSURE_AA, OP_SAFE_CLOSURE_AA_P, HOP_SAFE_CLOSURE_AA_P, OP_SAFE_CLOSURE_AA_A, HOP_SAFE_CLOSURE_AA_A, OP_CLOSURE_FX, HOP_CLOSURE_FX, OP_CLOSURE_ALL_S, HOP_CLOSURE_ALL_S, OP_CLOSURE_ANY_FX, HOP_CLOSURE_ANY_FX, OP_SAFE_CLOSURE_SA, HOP_SAFE_CLOSURE_SA, OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA, OP_SAFE_CLOSURE_FX, HOP_SAFE_CLOSURE_FX, + OP_SAFE_CLOSURE_3S, HOP_SAFE_CLOSURE_3S, OP_SAFE_CLOSURE_ALL_S, HOP_SAFE_CLOSURE_ALL_S, OP_CLOSURE_STAR_A, HOP_CLOSURE_STAR_A, OP_CLOSURE_STAR_FX, HOP_CLOSURE_STAR_FX, OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A, OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA, @@ -3922,7 +3942,6 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_SAFE_CLOSURE_FP, HOP_SAFE_CLOSURE_FP, /* these can't be embedded, and have to be the last thing called */ - OP_APPLY_SS, HOP_APPLY_SS, OP_APPLY_SA, HOP_APPLY_SA, OP_APPLY_SL, HOP_APPLY_SL, OP_C_FX, HOP_C_FX, OP_CALL_WITH_EXIT, HOP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_P, HOP_CALL_WITH_EXIT_P, OP_C_CATCH, HOP_C_CATCH, OP_C_CATCH_ALL, HOP_C_CATCH_ALL, OP_C_CATCH_ALL_P, HOP_C_CATCH_ALL_P, OP_C_CATCH_ALL_FX, HOP_C_CATCH_ALL_FX, OP_C_S_opSq, HOP_C_S_opSq, OP_C_S_opDq, HOP_C_S_opDq, OP_C_SS, HOP_C_SS, @@ -3936,7 +3955,9 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_SAFE_C_AP, HOP_SAFE_C_AP, OP_SAFE_C_PA, HOP_SAFE_C_PA, OP_SAFE_C_PS, HOP_SAFE_C_PS, OP_SAFE_C_PC, HOP_SAFE_C_PC, OP_SAFE_C_SSP, HOP_SAFE_C_SSP, OP_SAFE_C_FP, HOP_SAFE_C_FP, + /* end of h_opts */ + OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, OP_SAFE_IFA_SS_A, OP_MACRO_D, OP_S, OP_S_S, OP_S_C, OP_S_A, OP_C_FA_1, OP_S_AA, OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A, OP_IMPLICIT_ITERATE, OP_IMPLICIT_CONTINUATION_A, OP_IMPLICIT_VECTOR_REF_A, OP_IMPLICIT_VECTOR_REF_AA, OP_IMPLICIT_STRING_REF_A, @@ -3944,16 +3965,19 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_IMPLICIT_S7_LET_REF, OP_IMPLICIT_VECTOR_SET_3, OP_IMPLICIT_VECTOR_SET_4, OP_UNKNOWN, OP_UNKNOWN_ALL_S, OP_UNKNOWN_FX, OP_UNKNOWN_G, OP_UNKNOWN_GG, OP_UNKNOWN_A, OP_UNKNOWN_AA, - OP_GC_PROTECT, + OP_SYM, OP_GLOBAL_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, + OP_SSA_DIRECT, OP_SAFE_C_TUS, + OP_READ_INTERNAL, OP_EVAL, OP_EVAL_ARGS, OP_EVAL_ARGS1, OP_EVAL_ARGS2, OP_EVAL_ARGS3, OP_EVAL_ARGS4, OP_EVAL_ARGS5, OP_APPLY, OP_EVAL_MACRO, OP_LAMBDA, OP_QUOTE, OP_MACROEXPAND, OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN0, OP_BEGIN1, OP_BEGIN_UNCHECKED, + OP_BEGIN_1, OP_BEGIN_1_UNCHECKED, OP_BEGIN_2_UNCHECKED, OP_IF, OP_IF1, OP_WHEN, OP_UNLESS, OP_SET, OP_SET1, OP_SET2, OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2, OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1, OP_LET_TEMPORARILY, OP_LET_TEMP_UNCHECKED, OP_LET_TEMP_INIT1, OP_LET_TEMP_INIT2, OP_LET_TEMP_DONE, OP_LET_TEMP_DONE1, - OP_LET_TEMP_S7, OP_LET_TEMP_FX, OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, + OP_LET_TEMP_S7, OP_LET_TEMP_FX, OP_LET_TEMP_FX_1, OP_LET_TEMP_SETTER, OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, OP_LET_TEMP_SETTER_UNWIND, OP_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE, OP_COND_SIMPLE_P, OP_COND1_SIMPLE_P, OP_AND, OP_OR, OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION, OP_DEFINE_EXPANSION_STAR, @@ -3979,12 +4003,11 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_LAMBDA_UNCHECKED, OP_LET_UNCHECKED, OP_CATCH_1, OP_CATCH_2, OP_CATCH_ALL, OP_SET_UNCHECKED, OP_SET_SYMBOL_C, OP_SET_SYMBOL_S, OP_SET_SYMBOL_P, OP_SET_SYMBOL_A, - OP_SET_SYMBOL_opSq, OP_SET_SYMBOL_opSSq, 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_WITH_SETTER, OP_SET_PWS, OP_SET_LET_S, OP_SET_LET_FX, OP_SET_SAFE, OP_INCREMENT_1, OP_DECREMENT_1, OP_SET_CONS, - OP_INCREMENT_SS, OP_INCREMENT_SSS, OP_INCREMENT_SP, OP_INCREMENT_SA, OP_INCREMENT_SAA, + OP_INCREMENT_SS, OP_INCREMENT_SP, OP_INCREMENT_SA, OP_INCREMENT_SAA, OP_LETREC_UNCHECKED, OP_LETREC_STAR_UNCHECKED, OP_COND_UNCHECKED, OP_LAMBDA_STAR_UNCHECKED, OP_DO_UNCHECKED, OP_DEFINE_UNCHECKED, OP_DEFINE_STAR_UNCHECKED, OP_DEFINE_FUNCHECKED, OP_DEFINE_CONSTANT_UNCHECKED, @@ -3995,7 +4018,7 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_LET_opSSq_OLD, OP_LET_opSSq_NEW, OP_LET_opSSq_E_OLD, OP_LET_opSSq_E_NEW, OP_LET_opaSSq_OLD, OP_LET_opaSSq_NEW, OP_LET_opaSSq_E_OLD, OP_LET_opaSSq_E_NEW, OP_LET_ONE_OLD, OP_LET_ONE_NEW, OP_LET_ONE_P_OLD, OP_LET_ONE_P_NEW, OP_LET_ONE_OLD_1, OP_LET_ONE_NEW_1, OP_LET_ONE_P_OLD_1, OP_LET_ONE_P_NEW_1, - OP_LET_A_OLD, OP_LET_A_NEW, OP_LET_A_P_OLD, OP_LET_A_P_NEW, OP_LET_A_A_OLD, OP_LET_A_A_NEW, OP_LET_A_FX_OLD, OP_LET_A_FX_NEW, + OP_LET_A_OLD, OP_LET_A_NEW, OP_LET_A_P_OLD, OP_LET_A_P_NEW, OP_LET_A_A_OLD, OP_LET_A_A_NEW, OP_LET_A_FX_OLD, OP_LET_A_FX_NEW, OP_LET_A_OLD_2, OP_LET_A_NEW_2, OP_LET_STAR_FX_OLD, OP_LET_STAR_FX_NEW, OP_LET_STAR_FX_A_OLD, OP_LET_STAR_FX_A_NEW, OP_CASE_A_E_S, OP_CASE_A_I_S, OP_CASE_A_G_S, OP_CASE_A_E_G, OP_CASE_A_G_G, OP_CASE_A_S_S, OP_CASE_A_S_G, @@ -4011,16 +4034,10 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P, OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N, - OP_IF_D_P, OP_IF_D_P_P, OP_IF_D_R, OP_IF_D_N, OP_IF_D_N_N, - OP_IF_CS_P, OP_IF_CS_P_P, OP_IF_CS_R, OP_IF_CS_N, OP_IF_CS_N_N, - OP_IF_CSS_P, OP_IF_CSS_P_P, OP_IF_CSS_R, OP_IF_CSS_N, OP_IF_CSS_N_N, - OP_IF_CSC_P, OP_IF_CSC_P_P, OP_IF_CSC_R, OP_IF_CSC_N, OP_IF_CSC_N_N, - OP_IF_S_opDq_P, OP_IF_S_opDq_P_P, OP_IF_S_opDq_R, OP_IF_S_opDq_N, OP_IF_S_opDq_N_N, + OP_IF_opSq_P, OP_IF_opSq_P_P, OP_IF_opSq_R, OP_IF_opSq_N, OP_IF_opSq_N_N, OP_IF_IS_TYPE_S_P, OP_IF_IS_TYPE_S_P_P, OP_IF_IS_TYPE_S_R, OP_IF_IS_TYPE_S_N, OP_IF_IS_TYPE_S_N_N, - OP_IF_IS_TYPE_opSq_P, OP_IF_IS_TYPE_opSq_P_P, OP_IF_IS_TYPE_opSq_R, OP_IF_IS_TYPE_opSq_N, OP_IF_IS_TYPE_opSq_N_N, OP_IF_A_P, OP_IF_A_P_P, OP_IF_A_R, OP_IF_A_N, OP_IF_A_N_N, OP_IF_AND2_P, OP_IF_AND2_P_P, OP_IF_AND2_R, OP_IF_AND2_N, OP_IF_AND2_N_N, - OP_IF_AND3_P, OP_IF_AND3_P_P, OP_IF_AND3_R, OP_IF_AND3_N, OP_IF_AND3_N_N, OP_IF_P_P, OP_IF_P_P_P, OP_IF_P_R, OP_IF_P_N, OP_IF_P_N_N, OP_IF_ANDP_P, OP_IF_ANDP_P_P, OP_IF_ANDP_R, OP_IF_ANDP_N, OP_IF_ANDP_N_N, OP_IF_ORP_P, OP_IF_ORP_P_P, OP_IF_ORP_R, OP_IF_ORP_N, OP_IF_ORP_N_N, @@ -4028,7 +4045,7 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_IF_PPP, OP_IF_PP, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP, OP_COND_FX, OP_COND_FX_2, OP_COND_FX_P, OP_COND_FX_1P_ELSE, OP_COND_FX_2P_ELSE, - OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, OP_SAFE_DOTIMES_STEP_P, OP_SAFE_DOTIMES_STEP_O, + OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, OP_SAFE_DOTIMES_STEP_P, OP_SAFE_DO, OP_SAFE_DO_STEP, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_P, OP_DOX_NO_BODY, OP_DOX_PENDING_NO_BODY, OP_DOX_INIT, OP_DOTIMES_P, OP_DOTIMES_STEP_P, OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1, @@ -4040,10 +4057,10 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, OP_SAFE_CLOSURE_P_1, OP_CLOSURE_P_1, OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_FP_1, OP_SAFE_CLOSURE_FP_MV_1, OP_INCREMENT_SP_1, OP_INCREMENT_SP_MV, OP_SAFE_C_FP_1, OP_SAFE_C_FP_MV_1, OP_SAFE_C_SSP_1, OP_SAFE_C_SSP_MV_1, - OP_C_P_1, OP_C_P_MV, OP_C_AP_1, OP_C_AP_MV, OP_NOT_P_1, + OP_C_P_1, OP_C_P_MV, OP_C_AP_1, OP_C_AP_MV, OP_NOT_P_1, OP_SAFE_C_FP_2, OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_P_MV, OP_CLOSURE_AP_MV, OP_CLOSURE_PA_MV, - OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV, + OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV, OP_SAFE_CLOSURE_FP_2, OP_SET_WITH_LET_1, OP_SET_WITH_LET_2, @@ -4069,16 +4086,17 @@ enum {OP_UNOPT, OP_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, NUM_OPS}; +#define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_LA)) +#define is_rec_op(Op) ((Op >= OP_RECUR_IF_A_A_opA_LAq) && (Op <= OP_RECUR_COND_A_A_A_LAA_opA_LAAq)) + typedef enum{E_C_P, E_C_PP, E_C_CP, E_C_SP, E_C_PC, E_C_PS} combine_op_t; #if S7_DEBUGGING || OP_NAMES static const char* op_names[NUM_OPS] = - {"unopt", "symbol", "constant", "pair_sym", "pair_pair", "pair_any", + {"unopt", "gc_protect", - "safe_c_d", "h_safe_c_d", - "x", "h_x", - "safe_c_s", "h_safe_c_s", + "safe_c_d", "h_safe_c_d", "safe_c_s", "h_safe_c_s", "safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs", "h_safe_c_cs", "safe_c_cq", "h_safe_c_cq", "safe_c_sss", "h_safe_c_sss", "safe_c_scs", "h_safe_c_scs", "safe_c_ssc", "h_safe_c_ssc", "safe_c_css", "h_safe_c_css", "safe_c_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc", @@ -4119,19 +4137,19 @@ static const char* op_names[NUM_OPS] = "safe_c_opaq", "h_safe_c_opaq", "safe_c_opaaq", "h_safe_c_opaaq", "safe_c_opaaaq", "h_safe_c_opaaaq", "safe_c_s_opaq", "h_safe_c_s_opaq", "safe_c_opaq_s", "h_safe_c_opaq_s", "safe_c_s_opaaq", "h_safe_c_s_opaaq", "safe_c_s_opaaaq", "h_safe_c_s_opaaaq", - "safe_ifa_ss_a", "h_safe_ifa_ss_a", "safe_c*", "h_safe_c*", "safe_c*_a", "h_safe_c*_a", "safe_c*_aa", "h_safe_c*_aa", "safe_c*_fx", "h_safe_c*_fx", "safe_c_p", "h_safe_c_p", - "thunk", "h_thunk", "thunk_p", "h_thunk_p", + "thunk", "h_thunk", "thunk_p", "h_thunk_p", "thunk_nil", "h_thunk_nil", "safe_thunk", "h_safe_thunk", "safe_thunk_p", "h_safe_thunk_p", "safe_thunk_a", "h_safe_thunk_a", "closure_s", "h_closure_s", "closure_s_p", "h_closure_s_p", "safe_closure_s", "h_safe_closure_s", "safe_closure_s_p", "h_safe_closure_s_p", "safe_closure_s_a", "h_safe_closure_s_a", + "safe_closure_s_to_s", "h_safe_closure_s_to_s", "closure_c", "h_closure_c", "closure_c_p", "h_closure_c_p", "safe_closure_c", "h_safe_closure_c", "safe_closure_c_p", "h_safe_closure_c_p", "safe_closure_c_a", "h_safe_closure_c_a", - "closure_a", "h_closure_a", "closure_a_p", "h_closure_a_p", "closure_sub_p", "h_closure_sub_p", + "closure_a", "h_closure_a", "closure_a_p", "h_closure_a_p", "safe_closure_a", "h_safe_closure_a", "safe_closure_a_p", "h_safe_closure_a_p", "safe_closure_a_a", "h_safe_closure_a_a", "closure_p", "h_closure_p", "safe_closure_p", "h_safe_closure_p", @@ -4146,14 +4164,15 @@ static const char* op_names[NUM_OPS] = "closure_cs", "h_closure_cs", "safe_closure_cs", "h_safe_closure_cs", - "closure_3s", "h_closure_3s", "closure_3s_p", "h_closure_3s_p", - "closure_4s", "h_closure_4s", "closure_4s_p", "h_closure_4s_p", + "closure_3s", "h_closure_3s", "closure_3s_p", "h_closure_3s_p", "closure_3s_b", "h_closure_3s_b", + "closure_4s", "h_closure_4s", "closure_4s_p", "h_closure_4s_p", "closure_4s_b", "h_closure_4s_b", "closure_aa", "h_closure_aa", "closure_aa_p", "h_closure_aa_p", "safe_closure_aa", "h_safe_closure_aa", "safe_closure_aa_p", "h_safe_closure_aa_p", "safe_closure_aa_a", "h_safe_closure_aa_a", "closure_fx", "h_closure_fx", "closure_all_s", "h_closure_all_s", "closure_any_fx", "h_closure_any_fx", "safe_closure_sa", "h_safe_closure_sa", "safe_closure_saa", "h_safe_closure_saa", "safe_closure_fx", "h_safe_closure_fx", + "safe_closure_3s", "h_safe_closure_3s", "safe_closure_all_s", "h_safe_closure_all_s", "closure*_a", "h_closure*_a", "closure*_fx", "h_closure*_fx", "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa", @@ -4161,7 +4180,6 @@ static const char* op_names[NUM_OPS] = "safe_closure*_fx_1", "h_safe_closure*_fx_1", "safe_closure*_fx_2", "h_safe_closure*_fx_2", "safe_closure_fp", "h_safe_closure_fp", - "apply_ss", "h_apply_ss", "apply_sa", "h_apply_sa", "apply_sl", "h_apply_sl", "c_fx", "h_c_fx", "call_with_exit", "h_call_with_exit", "call_with_exit_p", "h_call_with_exit_p", "c_catch", "h_c_catch", "c_catch_all", "h_c_catch_all", "c_catch_all_p", "h_c_catch_all_p", "c_catch_all_fx", "h_c_catch_all_fx", "c_s_opsq", "h_c_s_opsq", "c_s_opdq", "h_c_s_opdq", "c_ss", "h_c_ss", @@ -4175,6 +4193,8 @@ static const char* op_names[NUM_OPS] = "safe_c_ap", "h_safe_c_ap", "safe_c_pa", "h_safe_c_pa", "safe_c_ps", "h_safe_c_ps", "safe_c_pc", "h_safe_c_pc", "safe_c_ssp", "h_safe_c_ssp", "safe_c_fp", "h_safe_c_fp", + + "apply_ss", "apply_sa", "apply_sl", "safe_ifa_ss_a", "macro_d", "s", "s_s", "s_c", "s_a", "c_fa_1", "s_aa", "implicit_goto", "implicit_goto_a", "implicit_iterate", "implicit_continuation_a", "implicit_vector_ref_a", "implicit_vector_ref_aa", "implicit_string_ref_a", @@ -4182,16 +4202,19 @@ static const char* op_names[NUM_OPS] = "implicit_*s7*_ref", "implicit_vector_set_3", "implicit_vector_set_4", "unknown", "unknown_all_s", "unknown_fx", "unknown_g", "unknown_gg", "unknown_a", "unknown_aa", - "gc_protect", + "symbol", "global-symbol", "constant", "pair_sym", "pair_pair", "pair_any", + "ssa_direct", "safe_c_tus", + "read_internal", "eval", "eval_args", "eval_args1", "eval_args2", "eval_args3", "eval_args4", "eval_args5", "apply", "eval_macro", "lambda", "quote", "macroexpand", "define", "define1", "begin", "begin0", "begin1", "begin_unchecked", + "begin_1", "begin_1_unchecked", "begin_2_unchecked", "if", "if1", "when", "unless", "set", "set1", "set2", "let", "let1", "let*", "let*1", "let*2", "letrec", "letrec1", "letrec*", "letrec*1", "let_temporarily", "let_temp_unchecked", "let_temp_init1", "let_temp_init2", "let_temp_done", "let_temp_done1", - "let_temp_s7", "let_temp_fx", "let_temp_unwind", "let_temp_s7_unwind", + "let_temp_s7", "let_temp_fx", "let_temp_fx_1", "let_temp_setter", "let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind", "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", "cond_simple_p", "cond1_simple_p", "and", "or", "define_macro", "define_macro*", "define_expansion", "define_expansion*", @@ -4215,12 +4238,11 @@ static const char* op_names[NUM_OPS] = "member_if", "assoc_if", "member_if1", "assoc_if1", "lambda_unchecked", "let_unchecked", "catch_1", "catch_2", "catch_all", "set_unchecked", "set_symbol_c", "set_symbol_s", "set_symbol_p", "set_symbol_a", - "set_symbol_opsq", "set_symbol_opssq", "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_with_setter", "set_pws", "set_let_s", "set_let_fx", "set_safe", "increment_1", "decrement_1", "set_cons", - "increment_ss", "increment_sss", "increment_sp", "increment_sa", "increment_saa", + "increment_ss", "increment_sp", "increment_sa", "increment_saa", "letrec_unchecked", "letrec*_unchecked", "cond_unchecked", "lambda*_unchecked", "do_unchecked", "define_unchecked", "define*_unchecked", "define_funchecked", "define_constant_unchecked", "define_with_setter", "define_macro_with_setter", @@ -4230,7 +4252,7 @@ static const char* op_names[NUM_OPS] = "let_opssq_old", "let_opssq_new", "let_opssq_e_old", "let_opssq_e_new", "let_opassq_old", "let_opassq_new", "let_opassq_e_old", "let_opassq_e_new", "let_one_old", "let_one_new", "let_one_p_old", "let_one_p_new", "let_one_old_1", "let_one_new_1", "let_one_p_old_1", "let_one_p_new_1", - "let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new", "let_a_a_old", "let_a_a_new", "let_a_fx_old", "let_a_fx_new", + "let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new", "let_a_a_old", "let_a_a_new", "let_a_fx_old", "let_a_fx_new", "let_a_old_2", "let_a_new_2", "let*_fx_old", "let*_fx_new", "let*_fx_a_old", "let*_fx_a_new", "case_a_e_s", "case_a_i_s", "case_a_g_s", "case_a_e_g", "case_a_g_g", "case_a_s_s", "case_a_s_g", @@ -4246,16 +4268,10 @@ static const char* op_names[NUM_OPS] = "when_s", "when_a", "when_p", "when_and_ap", "unless_s", "unless_a", "unless_p", "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n", - "if_d_p", "if_d_p_p", "if_d_r", "if_d_n", "if_d_n_n", - "if_cs_p", "if_cs_p_p", "if_cs_r", "if_cs_n", "if_cs_n_n", - "if_css_p", "if_css_p_p", "if_css_r", "if_css_n", "if_css_n_n", - "if_csc_p", "if_csc_p_p", "if_csc_r", "if_csc_n", "if_csc_n_n", - "if_s_opdq_p", "if_s_opdq_p_p", "if_s_opdq_r", "if_s_opdq_n", "if_s_opdq_n_n", + "if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n", "if_is_type_s_p", "if_is_type_s_p_p", "if_is_type_s_r", "if_is_type_s_n", "if_is_type_s_n_n", - "if_is_type_opsq_p", "if_is_type_opsq_p_p", "if_is_type_opsq_r", "if_is_type_opsq_n", "if_is_type_opsq_n_n", "if_a_p", "if_a_p_p", "if_a_r", "if_a_n", "if_a_n_n", "if_and2_p", "if_and2_p_p", "if_and2_r", "if_and2_n", "if_and2_n_n", - "if_and3_p", "if_and3_p_p", "if_and3_r", "if_and3_n", "if_and3_n_n", "if_p_p", "if_p_p_p", "if_p_r", "if_p_n", "if_p_n_n", "if_andp_p", "if_andp_p_p", "if_andp_r", "if_andp_n", "if_andp_n_n", "if_orp_p", "if_orp_p_p", "if_orp_r", "if_orp_n", "if_orp_n_n", @@ -4263,7 +4279,7 @@ static const char* op_names[NUM_OPS] = "if_ppp", "if_pp", "if_pr", "if_prr", "when_pp", "unless_pp", "cond_fx", "cond_fx_2", "cond_fx_p", "cond_fx_1p_else", "cond_fx_2p_else", - "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_p", "safe_dotimes_step_o", + "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_p", "safe_do", "safe_do_step", "dox", "dox_step", "dox_step_p", "dox_no_body", "dox_pending_no_body", "dox_init", "dotimes_p", "dotimes_step_p", "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1", @@ -4275,10 +4291,10 @@ static const char* op_names[NUM_OPS] = "safe_closure_p_1", "closure_p_1", "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_fp_1", "safe_closure_fp_mv_1", "increment_sp_1", "increment_sp_mv", "safe_c_fp_1", "safe_c_fp_mv_1", "safe_c_ssp_1", "safe_c_ssp_mv_1", - "c_p_1", "c_p_mv", "c_ap_1", "c_ap_mv", "not_1", + "c_p_1", "c_p_mv", "c_ap_1", "c_ap_mv", "not_1", "safe_c_fp_2", "closure_ap_1", "closure_pa_1", "closure_p_mv", "closure_ap_mv", "closure_pa_mv", - "safe_c_pa_1", "safe_c_pa_mv", + "safe_c_pa_1", "safe_c_pa_mv", "safe_closure_fp_2", "set_with_let_1", "set_with_let_2", @@ -4307,7 +4323,6 @@ static const char* op_names[NUM_OPS] = #define in_reader(Sc) ((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE) && (is_input_port(Sc->input_port))) #define is_safe_c_op(op) ((op >= OP_SAFE_C_D) && (op < OP_THUNK)) #define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_AA)) -#define is_fxa_op(op) ((op >= OP_SAFE_C_D) && (op < OP_SAFE_C_A)) #define is_h_safe_c_d(P) ((is_optimized(P)) && (optimize_op(P) >= HOP_SAFE_C_D) && (optimize_op(P) < OP_SAFE_C_S) && ((optimize_op(P) & 1) != 0)) #define is_safe_c_s(P) ((optimize_op(P) == OP_SAFE_C_S) || (optimize_op(P) == HOP_SAFE_C_S)) #define is_h_safe_c_s(P) (optimize_op(P) == HOP_SAFE_C_S) @@ -4317,7 +4332,7 @@ static bool is_h_optimized(s7_pointer p) return((is_optimized(p)) && ((optimize_op(p) & 1) != 0) && (optimize_op(p) < OP_S) && - (optimize_op(p) > OP_PAIR_ANY)); + (optimize_op(p) > OP_GC_PROTECT)); } static bool is_not_h_optimized(s7_pointer p) @@ -4325,7 +4340,7 @@ static bool is_not_h_optimized(s7_pointer p) return((is_optimized(p)) && ((optimize_op(p) & 1) == 0) && (optimize_op(p) < OP_S) && - (optimize_op(p) > OP_PAIR_ANY)); + (optimize_op(p) > OP_GC_PROTECT)); } /* -------- */ @@ -4947,6 +4962,8 @@ static void process_continuation(s7_scheme *sc, s7_pointer s1) liberate_block(sc, continuation_block(s1)); } +static void process_noop(void) {} + static void sweep(s7_scheme *sc) { s7_int i, j; @@ -5021,6 +5038,9 @@ static void sweep(s7_scheme *sc) gp = sc->continuations; process_gc_list(process_continuation(sc, s1)); + gp = sc->lamlets; + process_gc_list(process_noop()); + gp = sc->weak_refs; if (gp->loc > 0) { @@ -5102,6 +5122,7 @@ static void add_gensym(s7_scheme *sc, s7_pointer p) #define add_multivector(sc, p) add_to_gc_list(sc->multivectors, p) #define add_lambda(sc, p) add_to_gc_list(sc->lambdas, p) #define add_weak_ref(sc, p) add_to_gc_list(sc->weak_refs, p) +#define add_lamlet(sc, p) add_to_gc_list(sc->lamlets, p) #define add_weak_hash_iterator(sc, p) add_to_gc_list(sc->weak_hash_iterators, p) #if WITH_GMP @@ -5126,6 +5147,7 @@ static void init_gc_caches(s7_scheme *sc) sc->c_objects = make_gc_list(); sc->lambdas = make_gc_list(); sc->weak_refs = make_gc_list(); + sc->lamlets = make_gc_list(); sc->weak_hash_iterators = make_gc_list(); #if WITH_GMP sc->big_integers = make_gc_list(); @@ -5657,6 +5679,35 @@ static void unmark_permanent_objects(s7_scheme *sc) #endif } +static void mark_lamlets(s7_scheme *sc) +{ + s7_int i; + gc_list *gp; + gp = sc->lamlets; + for (i = 0; i < gp->loc; i++) + { + s7_pointer s1; + s1 = gp->list[i]; + if (!is_free_and_clear(s1)) + { + s7_pointer lt; + lt = opt3_lamlet(s1); + if ((is_let(lt)) && (!is_marked(lt)) && (slots_set(lt))) + { + s7_pointer slot; + slot = let_slots(lt); + if (is_closure(slot_value(slot))) + { + for (slot = let_slots(closure_let(slot_value(slot))); tis_slot(slot); slot = next_slot(slot)) + slot_set_value(slot, sc->F); + } + clear_slots_set(lt); + } + gc_mark(lt); + } + } +} + #if (!MS_WINDOWS) #include <time.h> @@ -5768,6 +5819,13 @@ static int64_t gc(s7_scheme *sc) for (i = 0; i < sc->num_fdats; i++) if (sc->fdats[i]) gc_mark(sc->fdats[i]->curly_arg); + + if (sc->rec_stack) + { + just_mark(sc->rec_stack); + for (i = 0; i < sc->rec_loc; i++) + gc_mark(vector_element(sc->rec_stack, i)); + } } mark_vector(sc->protected_objects); mark_vector(sc->protected_setters); @@ -5795,6 +5853,7 @@ static int64_t gc(s7_scheme *sc) } mark_op_stack(sc); mark_permanent_objects(sc); + mark_lamlets(sc); /* free up all unmarked objects */ old_free_heap_top = sc->free_heap_top; @@ -5920,8 +5979,8 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) #define resize_heap(Sc) resize_heap_to(Sc, 0) #ifndef GC_FRACTION -#define GC_FRACTION 3/4 -/* 1/2 is ok, 3/4 speeds up some GC benchmarks, 7/8 is a bit faster +#define GC_FRACTION 0.8 +/* 1/2 is ok, 3/4 speeds up some GC benchmarks, 7/8 is a bit faster, 95/100 comes to a halt (giant heap) * in my tests, only tvect.scm ends up larger if 3/4 used */ #endif @@ -6374,7 +6433,7 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c Sc->stack_end[0] = Code; \ Sc->stack_end[1] = Sc->envir; \ Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)Op; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) @@ -6382,14 +6441,14 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c do { \ Sc->stack_end[1] = Sc->envir; \ Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)Op; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) #define push_stack_no_let_no_code(Sc, Op, Args) \ do { \ Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)Op; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) @@ -6397,7 +6456,7 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c do { \ Sc->stack_end[0] = Code; \ Sc->stack_end[1] = Sc->envir; \ - Sc->stack_end[3] = (s7_pointer)Op; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) @@ -6405,20 +6464,20 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c do { \ Sc->stack_end[0] = Code; \ Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)Op; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) #define push_stack_op(Sc, Op) \ do { \ - Sc->stack_end[3] = (s7_pointer)Op; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) #define push_stack_op_let(Sc, Op) \ do { \ Sc->stack_end[1] = Sc->envir; \ - Sc->stack_end[3] = (s7_pointer)Op; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ Sc->stack_end += 4; \ } while (0) #endif @@ -7287,13 +7346,11 @@ static s7_pointer make_permanent_let(s7_scheme *sc, s7_pointer vars) set_type(frame, T_LET | T_SAFE_PROCEDURE | T_UNHEAP); let_id(frame) = ++sc->let_number; set_outlet(frame, sc->envir); - var = vars; - slot = make_permanent_slot(sc, caar(var), sc->F); + slot = make_permanent_slot(sc, caar(vars), sc->F); add_permanent_let_or_slot(sc, slot); - symbol_set_local(caar(var), sc->let_number, slot); + symbol_set_local(caar(vars), sc->let_number, slot); let_set_slots(frame, slot); - var = cdr(var); - while (is_pair(var)) + for (var = cdr(vars); is_pair(var); var = cdr(var)) { s7_pointer last_slot; last_slot = slot; @@ -7301,7 +7358,6 @@ static s7_pointer make_permanent_let(s7_scheme *sc, s7_pointer vars) add_permanent_let_or_slot(sc, slot); symbol_set_local(caar(var), sc->let_number, slot); slot_set_next(last_slot, slot); - var = cdr(var); } slot_set_next(slot, slot_end(sc)); add_permanent_let_or_slot(sc, frame); /* need to mark outlet and maybe slot values */ @@ -7364,8 +7420,8 @@ static s7_pointer let_fill(s7_scheme *sc, s7_pointer args) s7_pointer e, val; e = car(args); - if (e == sc->rootlet) - return(out_of_range(sc, sc->fill_symbol, small_int(1), e, wrap_string(sc, "can't fill! rootlet", 19))); + if ((e == sc->rootlet) || (e == sc->s7_let)) + eval_error(sc, "attempt to fill! ~S?", 19, e); if (e == sc->owlet) /* (owlet) copies sc->owlet, so this probably can't happen */ return(out_of_range(sc, sc->fill_symbol, small_int(1), e, wrap_string(sc, "can't fill! owlet", 17))); if (is_funclet(e)) @@ -7412,6 +7468,8 @@ static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol) return(sc->undefined); } +static s7_int s7_let_length(void); + static s7_int let_length(s7_scheme *sc, s7_pointer e) { /* used by length, applicable_length, copy, and some length optimizations */ @@ -7420,6 +7478,8 @@ static s7_int let_length(s7_scheme *sc, s7_pointer e) if (e == sc->rootlet) return(sc->rootlet_entries); + if (e == sc->s7_let) + return(s7_let_length()); if (has_active_methods(sc, e)) { @@ -7782,8 +7842,8 @@ static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args) sc->temp3 = e; check_method_uncopied(sc, e, sc->coverlet_symbol, list_1(sc, e)); sc->temp3 = sc->nil; - if (e == sc->rootlet) - s7_error(sc, sc->error_symbol, set_elist_1(sc, wrap_string(sc, "can't coverlet rootlet", 22))); + if ((e == sc->rootlet) || (e == sc->s7_let)) + s7_error(sc, sc->error_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), e)); if ((is_let(e)) || (has_closure_let(e)) || @@ -7802,15 +7862,10 @@ static void append_let(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e) { s7_pointer x; - if (old_e == sc->rootlet) + if ((old_e == sc->rootlet) || (new_e == sc->s7_let)) return; - if (new_e != sc->rootlet) - { - for (x = let_slots(old_e); tis_slot(x); x = next_slot(x)) - make_slot_1(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ - } - else + if (new_e == sc->rootlet) { for (x = let_slots(old_e); tis_slot(x); x = next_slot(x)) { @@ -7822,6 +7877,32 @@ static void append_let(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e) else s7_make_slot(sc, new_e, sym, val); } } + else + { + if (old_e == sc->s7_let) + { + s7_pointer iter, carrier; + s7_int gc_loc; + iter = s7_make_iterator(sc, sc->s7_let); + gc_loc = s7_gc_protect(sc, iter); + carrier = cons(sc, sc->F, sc->F); + iterator_current(iter) = carrier; + set_mark_seq(iter); /* so carrier is GC protected by mark_iterator */ + while (true) + { + s7_pointer y; + y = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + make_slot_1(sc, new_e, car(y), cdr(y)); + } + s7_gc_unprotect_at(sc, gc_loc); + } + else + { + for (x = let_slots(old_e); tis_slot(x); x = next_slot(x)) + make_slot_1(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ + } + } } static s7_pointer check_c_obj_env(s7_scheme *sc, s7_pointer old_e, s7_pointer caller) @@ -7874,7 +7955,7 @@ to the let env, and returns env. (varlet (curlet) 'a 1) adds 'a to the current check_method(sc, e, sc->varlet_symbol, args); if (!is_let(e)) return(wrong_type_argument_with_type(sc, sc->varlet_symbol, 1, e, a_let_string)); - if (is_immutable(e)) + if ((is_immutable(e)) || (e == sc->s7_let)) return(s7_wrong_type_arg_error(sc, "varlet", 1, e, "a mutable let")); } for (x = cdr(args); is_pair(x); x = cdr(x)) @@ -7960,7 +8041,7 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) check_method(sc, e, sc->cutlet_symbol, args); if (!is_let(e)) return(wrong_type_argument_with_type(sc, sc->cutlet_symbol, 1, e, a_let_string)); - if (is_immutable(e)) + if ((is_immutable(e)) || (e == sc->s7_let)) return(immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, e))); } /* besides removing the slot we have to make sure the symbol_id does not match else @@ -8272,12 +8353,21 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env) else { s7_pointer iter, func; + s7_int gc_loc = -1; /* need to check make-iterator method before dropping into let->list */ if ((has_active_methods(sc, env)) && ((func = find_method(sc, env, sc->make_iterator_symbol)) != sc->undefined)) iter = s7_apply_function(sc, func, list_1(sc, env)); - else iter = sc->nil; + else + { + if (env == sc->s7_let) + { + iter = s7_make_iterator(sc, env); + gc_loc = s7_gc_protect(sc, iter); + } + else iter = sc->nil; + } if (is_null(iter)) { @@ -8295,6 +8385,8 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env) } sc->w = safe_reverse_in_place(sc, sc->w); } + if (gc_loc != -1) + s7_gc_unprotect_at(sc, gc_loc); } x = sc->w; sc->w = sc->temp3; @@ -8455,8 +8547,6 @@ static s7_pointer lint_let_ref_1(s7_scheme *sc, s7_pointer lt, s7_pointer sym) return(sc->undefined); } -static s7_pointer let_ref_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(s7_let_ref(sc, p1, p2));} - static inline s7_pointer g_lint_let_ref(s7_scheme *sc, s7_pointer args) { s7_pointer lt, y, sym; @@ -8588,16 +8678,6 @@ static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args) return(s7_let_set(sc, car(args), cadr(args), caddr(args))); } -static s7_pointer let_set_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - return(s7_let_set(sc, p1, p2, p3)); -} - -static s7_pointer let_set_p_ppp_1(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - return(let_set_1(sc, p1, p2, p3)); -} - static s7_pointer let_set_p_ppp_2(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) { if (!is_symbol(p2)) @@ -8839,7 +8919,7 @@ static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args) env = car(args); if (!is_let(env)) return(s7_wrong_type_arg_error(sc, "set! outlet", 1, env, "a let")); - if (is_immutable(env)) + if ((is_immutable(env)) || (env == sc->s7_let)) return(s7_wrong_type_arg_error(sc, "set! outlet", 1, env, "a mutable let")); new_outer = cadr(args); @@ -8888,6 +8968,7 @@ static inline s7_pointer lookup(s7_scheme *sc, s7_pointer symbol) /* lookup_chec if (slot_symbol(y) == symbol) return(slot_value(y)); } + /* if (is_global(symbol)) fprintf(stderr, "%s in %s\n", DISPLAY(symbol), DISPLAY_80(sc->code)); */ x = global_slot(symbol); if (is_slot(x)) return(slot_value(x)); #if WITH_GCC @@ -8982,7 +9063,7 @@ s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local /* -------------------------------- symbol->value -------------------------------- */ -#define find_global_symbol_checked(Sc, Sym) ((is_global(Sym)) ? slot_value(global_slot(Sym)) : lookup_checked(Sc, Sym)) +#define lookup_global(Sc, Sym) ((is_global(Sym)) ? slot_value(global_slot(Sym)) : lookup_checked(Sc, Sym)) static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args); static s7_pointer g_s7_let_set_fallback(s7_scheme *sc, s7_pointer args); @@ -9082,7 +9163,7 @@ static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args) return(val); for (i = s7_stack_top(sc) - 1; i > 0; i -= 4) - if (is_let(stack_let(sc->stack, i))) /* OP_GC_PROTECT envir slot can be anything */ + if (is_let_unchecked(stack_let(sc->stack, i))) /* OP_GC_PROTECT envir slot can be anything (even free) */ { s7_pointer cur_val; cur_val = find_dynamic_value(sc, stack_let(sc->stack, i), sym, &top_id); @@ -10167,22 +10248,8 @@ s7_pointer s7_make_continuation(s7_scheme *sc) return(x); } -static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_pointer let) -{ - /* called in call/cc, call-with-exit and, catch (unwind to catch) */ - push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); - sc->args = T_Pos(args); - sc->code = code; - sc->envir = let; - eval(sc, OP_LET_TEMP_DONE); -} - -static void op_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) */ - slot_set_value(slot, s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); - else slot_set_value(slot, new_value); -} +static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_pointer let); +static void op_let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value); static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c) { @@ -11136,6 +11203,7 @@ s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b) s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b) { s7_pointer x; + /* fprintf(stderr, "%s[%d]: %ld %ld\n", __func__, __LINE__, a, b); */ if (b == 0) return(division_by_zero_error(sc, wrap_string(sc, "make-ratio", 10), set_elist_2(sc, wrap_integer1(sc, a), small_int(0)))); @@ -11524,7 +11592,7 @@ static void init_pows(void) pepow[i][j + MAX_POW] = pow((double)i, (double)j); } -static double ipow(int32_t x, int32_t y) +static double dpow(int32_t x, int32_t y) { if ((y >= MAX_POW) || (y < -MAX_POW)) return(pow((double)x, (double)y)); @@ -12281,7 +12349,7 @@ static char *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t int_part = (s7_int)floor(x); frac_part = x - int_part; integer_to_string_any_base(n, int_part, radix); - min_frac = (s7_double)ipow(radix, -precision); + min_frac = dpow(radix, -precision); /* doesn't this assume precision < 128/256 and that we can fit in 256 digits (1e308)? */ for (i = 0, base = radix; (i < precision) && (frac_part > min_frac); i++, base *= radix) @@ -12762,9 +12830,15 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow) if ((multiply_overflow(lval, (s7_int)10, &lval)) || (add_overflow(lval, (s7_int)dig, &lval))) { - if ((lval == s7_int_min) && (digits[(uint8_t)(*tmp++)] > 9)) - return(lval); + /* fprintf(stderr, "%d %s lval: %ld, %s %d\n", __LINE__, str, lval, tmp, digits[(uint8_t)*tmp]); */ + if ((radix == 10) && + (strncmp(str, "-9223372036854775808", 20) == 0) && + (digits[(uint8_t)(*tmp++)] > 9)) /* i.e. next thing is not a digit -- "/" for example */ + return(s7_int_min); *overflow = true; + /* fprintf(stderr, "%d set overflow\n", __LINE__); */ + /* if (lval == s7_int_min) && (digits[(uint8_t)(*tmp++)] > 9)) return(lval); */ + return((negative) ? s7_int_min : s7_int_max); break; } #else @@ -12800,6 +12874,7 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow) if ((lval == s7_int_min) && (digits[(uint8_t)(*tmp++)] > 9)) return(lval); *overflow = true; + /* fprintf(stderr, "%d set overflow\n", __LINE__); */ break; } else lval = oval; @@ -12807,6 +12882,7 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow) { if (lval == s7_int_min) return(lval); *overflow = true; + /* fprintf(stderr, "%d set overflow\n", __LINE__); */ break; } } @@ -12820,8 +12896,9 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow) } #if WITH_GMP - (*overflow) = ((lval > s7_int32_max) || - ((tmp - tmp1) > s7_int_digits_by_radix[radix])); + if (!(*overflow)) + (*overflow) = ((lval > s7_int32_max) || + ((tmp - tmp1) > s7_int_digits_by_radix[radix])); /* this tells the string->number readers to create a bignum. We need to be very * conservative here to catch contexts such as (/ 1/524288 19073486328125) */ @@ -12996,13 +13073,13 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix #endif if (int_part != 0) /* 0.<310 zeros here>1e310 for example -- - * pow (via ipow) thinks it has to be too big, returns Nan, + * pow (via dpow) thinks it has to be too big, returns Nan, * then Nan * 0 -> Nan and the NaN propagates */ { if (int_len <= max_len) - dval = int_part * ipow(radix, exponent); - else dval = int_part * ipow(radix, exponent + int_len - max_len); + dval = int_part * dpow(radix, exponent); + else dval = int_part * dpow(radix, exponent + int_len - max_len); } else dval = 0.0; @@ -13024,7 +13101,7 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); if (frac_part != 0) /* same pow->NaN problem as above can occur here */ - dval += frac_part * ipow(radix, exponent - flen - k); + dval += frac_part * dpow(radix, exponent - flen - k); } } else @@ -13041,7 +13118,7 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix for (i = 0; i < ilen; i++) frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += frac_part * ipow(radix, exponent - ilen); + dval += frac_part * dpow(radix, exponent - ilen); } } @@ -13074,7 +13151,7 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix int_part = digits[(int32_t)(*str++)] + (int_part * radix); } if (int_exponent != 0) - dval = int_part * ipow(radix, int_exponent); + dval = int_part * dpow(radix, int_exponent); else dval = (s7_double)int_part; } else @@ -13100,8 +13177,8 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix frpart = digits[(int32_t)(*str++)] + (frpart * radix); if (len <= 0) - dval = int_part + frpart * ipow(radix, len - flen); - else dval = int_part + frpart * ipow(radix, -flen); + dval = int_part + frpart * dpow(radix, len - flen); + else dval = int_part + frpart * dpow(radix, -flen); } if (frac_len > 0) @@ -13129,7 +13206,7 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix while (str <= fend) frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); } - dval += frac_part * ipow(radix, exponent - frac_len); + dval += frac_part * dpow(radix, exponent - frac_len); /* 0.6: frac: 6, exp: 0.10000000000000000555, val: 0.60000000000000008882 * 0.60: frac: 60, exp: 0.01000000000000000021, val: 0.59999999999999997780 @@ -13148,7 +13225,7 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix for (i = 0; i < max_len; i++) frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += frac_part * ipow(radix, exponent - max_len); + dval += frac_part * dpow(radix, exponent - max_len); } else { @@ -13171,7 +13248,7 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix for (i = 0; i < frac_len; i++) frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += int_part + frac_part * ipow(radix, -frac_len); + dval += int_part + frac_part * dpow(radix, -frac_len); } } } @@ -13497,6 +13574,7 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym s7_int num, den; num = string_to_integer(q, radix, &overflow); den = string_to_integer(slash1, radix, &overflow); + /* fprintf(stderr, "%d %s: %ld %ld\n", __LINE__, q, num, den); */ if (den == 0) rl = NAN; else @@ -13593,6 +13671,7 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym n = string_to_integer(q, radix, &overflow); d = string_to_integer(slash1, radix, &overflow); + /* fprintf(stderr, "%d %s: %ld %ld %d\n", __LINE__, q, n, d, overflow); */ if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */ return(small_int(0)); @@ -13636,6 +13715,17 @@ static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix) } #if (!WITH_GMP) +static s7_pointer string_to_number_p_p(s7_scheme *sc, s7_pointer str1) +{ + char *str; + if (!is_string(str1)) + return(wrong_type_argument(sc, sc->string_to_number_symbol, 1, str1, T_STRING)); + str = (char *)string_value(str1); + if ((!str) || (!(*str))) + return(sc->F); + return(string_to_number(sc, str, 10)); +} + static s7_pointer string_to_number_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer radix1) { s7_int radix; @@ -15462,18 +15552,15 @@ static s7_double remainder_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) return(c_rem_dbl(sc, x1, x2)); } -static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) +static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { #define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1" #define Q_remainder sc->pcl_r /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */ - s7_pointer x, y; s7_int quo, d1, d2, n1, n2; s7_double pre_quo; - x = car(args); - y = cadr(args); if ((is_t_integer(x)) && (is_t_integer(y))) return(make_integer(sc, c_rem_int(sc, integer(x), integer(y)))); @@ -15494,18 +15581,18 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) case T_REAL: if (real(y) == 0.0) - return(division_by_zero_error(sc, sc->remainder_symbol, args)); + return(division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, x, y))); if ((is_inf(real(y))) || (is_NaN(real(y)))) return(wrong_type_argument_with_type(sc, sc->remainder_symbol, 2, y, a_normal_real_string)); pre_quo = (s7_double)integer(x) / real(y); if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min)) - return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string)); + return(simple_out_of_range(sc, sc->remainder_symbol, set_elist_2(sc, x, y), its_too_large_string)); if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo); return(make_real(sc, integer(x) - real(y) * quo)); default: - return(method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2)); + return(method_or_bust(sc, y, sc->remainder_symbol, list_2(sc, x, y), T_REAL, 2)); } case T_RATIO: @@ -15514,7 +15601,7 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) case T_INTEGER: n2 = integer(y); if (n2 == 0) - return(division_by_zero_error(sc, sc->remainder_symbol, args)); + return(division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, x, y))); n1 = numerator(x); d1 = denominator(x); d2 = 1; @@ -15541,7 +15628,7 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) { pre_quo = ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1); if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min)) - return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string)); + return(simple_out_of_range(sc, sc->remainder_symbol, set_elist_2(sc, x, y), its_too_large_string)); if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo); } else quo = n1d2 / n2d1; @@ -15575,25 +15662,25 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) return(s7_make_ratio(sc, n1 * d2 - n2 * d1 * quo, d1 * d2)); #endif - return(simple_out_of_range(sc, sc->remainder_symbol, args, wrap_string(sc, "intermediate (a/b) is too large", 31))); + return(simple_out_of_range(sc, sc->remainder_symbol, set_elist_2(sc, x, y), wrap_string(sc, "intermediate (a/b) is too large", 31))); case T_REAL: { s7_double frac; if (real(y) == 0.0) - return(division_by_zero_error(sc, sc->remainder_symbol, args)); + return(division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, x, y))); if ((is_inf(real(y))) || (is_NaN(real(y)))) return(wrong_type_argument_with_type(sc, sc->remainder_symbol, 2, y, a_normal_real_string)); frac = (s7_double)fraction(x); pre_quo = frac / real(y); if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min)) - return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string)); + return(simple_out_of_range(sc, sc->remainder_symbol, set_elist_2(sc, x, y), its_too_large_string)); if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo); return(make_real(sc, frac - real(y) * quo)); } default: - return(method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2)); + return(method_or_bust(sc, y, sc->remainder_symbol, list_2(sc, x, y), T_REAL, 2)); } case T_REAL: @@ -15604,10 +15691,10 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) { case T_INTEGER: if (integer(y) == 0) - return(division_by_zero_error(sc, sc->remainder_symbol, args)); + return(division_by_zero_error(sc, sc->remainder_symbol, set_elist_2(sc, x, y))); pre_quo = real(x) / (s7_double)integer(y); if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min)) - return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string)); + return(simple_out_of_range(sc, sc->remainder_symbol, set_elist_2(sc, x, y), its_too_large_string)); if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo); return(make_real(sc, real(x) - integer(y) * quo)); /* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */ @@ -15621,7 +15708,7 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) frac = (s7_double)fraction(y); pre_quo = real(x) / frac; if ((pre_quo > s7_int_max) || (pre_quo < s7_int_min)) - return(simple_out_of_range(sc, sc->remainder_symbol, args, its_too_large_string)); + return(simple_out_of_range(sc, sc->remainder_symbol, set_elist_2(sc, x, y), its_too_large_string)); if (pre_quo > 0.0) quo = (s7_int)floor(pre_quo); else quo = (s7_int)ceil(pre_quo); return(make_real(sc, real(x) - frac * quo)); } @@ -15639,14 +15726,23 @@ static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) */ default: - return(method_or_bust(sc, y, sc->remainder_symbol, args, T_REAL, 2)); + return(method_or_bust(sc, y, sc->remainder_symbol, list_2(sc, x, y), T_REAL, 2)); } default: - return(method_or_bust(sc, x, sc->remainder_symbol, args, T_REAL, 1)); + return(method_or_bust(sc, x, sc->remainder_symbol, list_2(sc, x, y), T_REAL, 1)); } } +static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) +{ + #define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1" + #define Q_remainder sc->pcl_r + /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */ + + return(remainder_p_pp(sc, car(args), cadr(args))); +} + /* -------------------------------- floor -------------------------------- */ @@ -16536,24 +16632,23 @@ static s7_pointer add_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) static inline s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { + /* "inline" here is mostly ignored, but not in g_add_2 where it affects trec and other timing tests */ if (type(x) == type(y)) { - if (is_t_real(x)) - return(make_real(sc, real(x) + real(y))); - - switch (type(x)) - { + if (is_t_integer(x)) #if HAVE_OVERFLOW_CHECKS - case T_INTEGER: - { - s7_int val; - if (add_overflow(integer(x), integer(y), &val)) - return(make_real(sc, (double)integer(x) + (double)integer(y))); - return(make_integer(sc, val)); - } + { + s7_int val; + if (add_overflow(integer(x), integer(y), &val)) + return(make_real(sc, (double)integer(x) + (double)integer(y))); + return(make_integer(sc, val)); + } #else - case T_INTEGER: return(make_integer(sc, integer(x) + integer(y))); + return(make_integer(sc, integer(x) + integer(y))); #endif + + switch (type(x)) + { case T_RATIO: return(add_ratios(sc, x, y)); case T_REAL: return(make_real(sc, real(x) + real(y))); case T_COMPLEX: return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); @@ -16617,8 +16712,10 @@ static inline s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) } static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args) {return(add_p_pp(sc, car(args), cadr(args)));} +static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args) {return(add_p_pp(sc, add_p_pp(sc, car(args), cadr(args)), caddr(args)));} +/* trade-off in add_3: time saved by using add_p_pp, but it conses up a new number cell, so subsequent gc can overwhelm the gains, and add add_p_pp overhead */ -static s7_pointer g_add_s1_1(s7_scheme *sc, s7_pointer x, s7_pointer args) +static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, s7_pointer args) { switch (type(x)) { @@ -16642,16 +16739,16 @@ static s7_pointer g_add_s1_1(s7_scheme *sc, s7_pointer x, s7_pointer args) return(x); } -static s7_pointer g_add_s1(s7_scheme *sc, s7_pointer args) +static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) { s7_pointer x; x = car(args); if (is_t_integer(x)) return(make_integer(sc, integer(x) + 1)); - return(g_add_s1_1(sc, x, args)); + return(g_add_x1_1(sc, x, args)); } -static s7_pointer g_add_1s(s7_scheme *sc, s7_pointer args) +static s7_pointer g_add_1x(s7_scheme *sc, s7_pointer args) { s7_pointer x; @@ -16672,7 +16769,7 @@ static s7_pointer g_add_1s(s7_scheme *sc, s7_pointer args) } #if (!WITH_GMP) -static s7_pointer g_add_sis(s7_scheme *sc, s7_pointer x, s7_int y) +static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y) { switch (type(x)) { @@ -16697,7 +16794,7 @@ static s7_pointer g_add_sis(s7_scheme *sc, s7_pointer x, s7_int y) } -static s7_pointer g_add_sfs(s7_scheme *sc, s7_pointer x, s7_double y) +static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y) { switch (type(x)) { @@ -16729,10 +16826,10 @@ static s7_pointer g_add_2_ii(s7_scheme *sc, s7_pointer args) static s7_pointer g_add_2_if(s7_scheme *sc, s7_pointer args) {return(make_real(sc, integer(car(args)) + real(cadr(args))));} static s7_pointer g_add_2_fi(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) + integer(cadr(args))));} -static s7_pointer g_add_2_xi(s7_scheme *sc, s7_pointer args) {return(g_add_sis(sc, car(args), integer(cadr(args))));} -static s7_pointer g_add_2_ix(s7_scheme *sc, s7_pointer args) {return(g_add_sis(sc, cadr(args), integer(car(args))));} -static s7_pointer g_add_2_xf(s7_scheme *sc, s7_pointer args) {return(g_add_sfs(sc, car(args), real(cadr(args))));} -static s7_pointer g_add_2_fx(s7_scheme *sc, s7_pointer args) {return(g_add_sfs(sc, cadr(args), real(car(args))));} +static s7_pointer g_add_2_xi(s7_scheme *sc, s7_pointer args) {return(g_add_xi(sc, car(args), integer(cadr(args))));} +static s7_pointer g_add_2_ix(s7_scheme *sc, s7_pointer args) {return(g_add_xi(sc, cadr(args), integer(car(args))));} +static s7_pointer g_add_2_xf(s7_scheme *sc, s7_pointer args) {return(g_add_xf(sc, car(args), real(cadr(args))));} +static s7_pointer g_add_2_fx(s7_scheme *sc, s7_pointer args) {return(g_add_xf(sc, cadr(args), real(car(args))));} static s7_pointer add_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 + x2));} /* add_p_ii and add_d_id unhittable apparently */ @@ -17060,7 +17157,7 @@ static s7_pointer g_subtract_1(s7_scheme *sc, s7_pointer args) } } -static inline s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) /* inline here simply trades overheads with subtract_2 et al */ +static inline s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (type(x) == type(y)) { @@ -17141,10 +17238,8 @@ static inline s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y return(x); } -static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args) -{ - return(subtract_p_pp(sc, car(args), cadr(args))); -} +static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp(sc, car(args), cadr(args)));} +static s7_pointer g_subtract_3(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp(sc, car(args), add_p_pp(sc, cadr(args), caddr(args))));} static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x) { @@ -17541,7 +17636,7 @@ static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args) } #if (!WITH_GMP) -static inline s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { if (type(x) == type(y)) { @@ -17655,7 +17750,7 @@ static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args) {return(multiply_ * how to catch this? (affects * - +) */ -static s7_pointer g_mul_sis(s7_scheme *sc, s7_pointer x, s7_int n, s7_pointer args) +static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n, s7_pointer args) { switch (type(x)) { @@ -17689,7 +17784,7 @@ static s7_pointer g_mul_sis(s7_scheme *sc, s7_pointer x, s7_int n, s7_pointer ar return(x); } -static s7_pointer g_mul_sfs(s7_scheme *sc, s7_pointer x, s7_double y) +static s7_pointer g_mul_xf(s7_scheme *sc, s7_pointer x, s7_double y) { switch (type(x)) { @@ -17719,10 +17814,10 @@ static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args) } static s7_pointer g_mul_2_if(s7_scheme *sc, s7_pointer args) {return(make_real(sc, integer(car(args)) * real(cadr(args))));} static s7_pointer g_mul_2_fi(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) * integer(cadr(args))));} -static s7_pointer g_mul_2_xi(s7_scheme *sc, s7_pointer args) {return(g_mul_sis(sc, car(args), integer(cadr(args)), args));} -static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {return(g_mul_sis(sc, cadr(args), integer(car(args)), args));} -static s7_pointer g_mul_2_xf(s7_scheme *sc, s7_pointer args) {return(g_mul_sfs(sc, car(args), real(cadr(args))));} -static s7_pointer g_mul_2_fx(s7_scheme *sc, s7_pointer args) {return(g_mul_sfs(sc, cadr(args), real(car(args))));} +static s7_pointer g_mul_2_xi(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, car(args), integer(cadr(args)), args));} +static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, cadr(args), integer(car(args)), args));} +static s7_pointer g_mul_2_xf(s7_scheme *sc, s7_pointer args) {return(g_mul_xf(sc, car(args), real(cadr(args))));} +static s7_pointer g_mul_2_fx(s7_scheme *sc, s7_pointer args) {return(g_mul_xf(sc, cadr(args), real(car(args))));} #endif /* with-gmp */ @@ -18056,6 +18151,33 @@ static s7_pointer g_divide_2(s7_scheme *sc, s7_pointer args) return(g_divide_xy(sc, car(args), cadr(args), args)); } +static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) +{ + s7_pointer num; + num = car(args); + if (is_t_integer(num)) + { + s7_int i; + i = integer(num); + if (i & 1) + { + s7_pointer x; + new_cell(sc, x, T_RATIO); + numerator(x) = i; + denominator(x) = 2; + return(x); + } + return(make_integer(sc, i >> 1)); + } + switch (type(num)) + { + case T_RATIO: return(s7_make_ratio(sc, numerator(num), denominator(num) * 2)); + case T_REAL: return(make_real(sc, real(num) * 0.5)); + case T_COMPLEX: return(make_complex(sc, real_part(num) * 0.5, imag_part(num) * 0.5)); + default: return(method_or_bust_with_type(sc, num, sc->divide_symbol, list_2(sc, num, small_int(2)), a_number_string, 1)); + } +} + static s7_pointer g_divide_1r(s7_scheme *sc, s7_pointer args) { if (s7_is_real(cadr(args))) @@ -18645,7 +18767,7 @@ static s7_pointer eq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) return(wrong_type_argument_with_type(sc, sc->num_eq_symbol, 2, y, a_number_string)); } -static s7_pointer c_num_eq_2(s7_scheme *sc, s7_pointer x, s7_pointer y) +static s7_pointer num_eq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { #if (!MS_WINDOWS) if (type(x) == type(y)) @@ -18725,7 +18847,6 @@ static s7_pointer c_num_eq_2(s7_scheme *sc, s7_pointer x, s7_pointer y) return(sc->F); } -static s7_pointer num_eq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(c_num_eq_2(sc, p1, p2));} static s7_pointer num_eq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) { if (is_t_integer(p1)) @@ -18755,23 +18876,37 @@ static s7_pointer g_num_eq_2(s7_scheme *sc, s7_pointer args) y = cadr(args); if ((is_t_integer(x)) && (is_t_integer(y))) /* this is by far the most common case (ratios aren't used much, and = with floats is frowned upon) */ return(make_boolean(sc, integer(x) == integer(y))); - return(c_num_eq_2(sc, x, y)); + return(num_eq_p_pp(sc, x, y)); } -static s7_pointer g_num_eq_2i(s7_scheme *sc, s7_pointer args) +static s7_pointer g_num_eq_xi(s7_scheme *sc, s7_pointer args) { s7_pointer x, y; x = car(args); y = cadr(args); - if (type(x) == T_INTEGER) + if (is_t_integer(x)) return(make_boolean(sc, integer(x) == integer(y))); - if (type(x) == T_REAL) + if (is_t_real(x)) return(make_boolean(sc, real(x) == integer(y))); if (!is_number(x)) return(eq_out_x(sc, x, y)); return(sc->F); } +static s7_pointer g_num_eq_ix(s7_scheme *sc, s7_pointer args) +{ + s7_pointer x, y; + x = car(args); + y = cadr(args); + if (is_t_integer(y)) + return(make_boolean(sc, integer(x) == integer(y))); + if (is_t_real(y)) + return(make_boolean(sc, integer(x) == real(y))); + if (!is_number(y)) + return(eq_out_x(sc, y, x)); + return(sc->F); +} + static s7_pointer g_less(s7_scheme *sc, s7_pointer args) { #define H_less "(< x1 ...) returns #t if its arguments are in increasing order" @@ -19977,7 +20112,7 @@ static s7_pointer g_geq_xi(s7_scheme *sc, s7_pointer args) } -static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(c_num_eq_2(sc, x, y) != sc->F);} +static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(num_eq_p_pp(sc, x, y) != sc->F);} static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) { @@ -20450,17 +20585,38 @@ static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args) static bool is_zero_b_7p(s7_scheme *sc, s7_pointer p) { - if (!is_number(p)) - simple_wrong_type_argument_with_type(sc, sc->is_zero_symbol, p, a_number_string); +#if WITH_GMP + 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 } +static s7_pointer is_zero_p_p(s7_scheme *sc, s7_pointer p) +{ +#if WITH_GMP + 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 +} + +#if (!WITH_GMP) static bool is_zero_i(s7_int p) {return(p == 0);} static bool is_zero_d(s7_double p) {return(p == 0.0);} +#endif /* -------------------------------- positive? -------------------------------- */ @@ -20488,13 +20644,32 @@ static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args) static bool is_positive_b_7p(s7_scheme *sc, s7_pointer p) { - if (!is_real(p)) - simple_wrong_type_argument(sc, sc->is_positive_symbol, p, T_REAL); +#if WITH_GMP + 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_real(p)) + simple_wrong_type_argument(sc, sc->is_positive_symbol, p, T_REAL); return(numerator(p) > 0); +#endif +} + +static s7_pointer is_positive_p_p(s7_scheme *sc, s7_pointer p) +{ +#if WITH_GMP + 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_real(p)) + simple_wrong_type_argument(sc, sc->is_positive_symbol, p, T_REAL); + return((numerator(p) > 0) ? sc->T : sc->F); +#endif } static bool is_positive_i(s7_int p) {return(p > 0);} @@ -20529,13 +20704,17 @@ static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args) static bool is_negative_b_7p(s7_scheme *sc, s7_pointer p) { - if (!is_real(p)) - simple_wrong_type_argument(sc, sc->is_negative_symbol, p, T_REAL); +#if WITH_GMP + 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_real(p)) + simple_wrong_type_argument(sc, sc->is_negative_symbol, p, T_REAL); return(numerator(p) < 0); +#endif } static bool is_negative_i(s7_int p) {return(p < 0);} @@ -21180,11 +21359,6 @@ static s7_int random_i_7i(s7_scheme *sc, s7_int i) return((s7_int)(i * next_random(sc->default_rng))); } -static s7_pointer random_p_p(s7_scheme *sc, s7_pointer p) -{ - return(g_random(sc, set_plist_1(sc, p))); -} - static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args) { return(make_integer(sc, (s7_int)(integer(car(args)) * next_random(sc->default_rng)))); @@ -21207,6 +21381,17 @@ static s7_pointer g_random_1(s7_scheme *sc, s7_pointer args) return(g_random(sc, args)); } +static s7_pointer random_p_p(s7_scheme *sc, s7_pointer num) +{ + s7_pointer r; + r = sc->default_rng; + if (is_t_integer(num)) + return(make_integer(sc, (s7_int)(integer(num) * next_random(r)))); + if (is_t_real(num)) + return(make_real(sc, real(num) * next_random(r))); + return(g_random(sc, set_plist_1(sc, num))); +} + static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) { if (!ops) return(f); @@ -21898,7 +22083,7 @@ static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args) static s7_pointer char_position_p_ppi(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int start) { - /* p1 is char, p2 is string, p3 is int32_t */ + /* p1 is char, p2 is string */ if (is_string(p2)) { if (start >= 0) @@ -25083,8 +25268,8 @@ 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)); - port_data_size(p) = 64; - block = mallocate(sc, 64); + port_data_size(p) = sc->initial_string_port_length; + block = mallocate(sc, port_data_size(p)); port_data_block(p) = block; port_data(p) = (uint8_t *)(block_data(block)); port_position(p) = 0; @@ -25690,7 +25875,7 @@ static void leave_lock_scope(lock_scope_t *st) #define TRACK(Sc) #endif -/* various changes in this section courtesy of Woody Douglas 12-Jul-19 */ +/* various changes in this section courtesy of Woody Douglass 12-Jul-19 */ static block_t *search_load_path(s7_scheme *sc, const char *name) { @@ -25903,11 +26088,13 @@ s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_poin declare_jump_info(); TRACK(sc); + if (e == sc->s7_let) return(NULL); + #if WITH_C_LOADER if (load_shared_object(sc, filename, (is_null(e)) ? sc->rootlet : e)) return(sc->F); #endif - + if (is_directory(filename)) return(NULL); fp = fopen(filename, "r"); @@ -25967,6 +26154,8 @@ defaults to the rootlet. To load into the current environment instead, pass (cu e = cadr(args); if (!is_let(e)) return(wrong_type_argument_with_type(sc, sc->load_symbol, 2, e, a_let_string)); + if (e == sc->s7_let) + return(s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't load ~S into *s7*", 23), name))); if (e == sc->rootlet) sc->envir = sc->nil; else sc->envir = e; @@ -26677,10 +26866,11 @@ static s7_pointer titr_len(s7_pointer p, const char *func, int32_t line) static s7_pointer titr_pos(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) { if (((is_let(iterator_sequence(p))) && - (iterator_sequence(p) != sc->rootlet)) || + (iterator_sequence(p) != sc->rootlet) && + (iterator_sequence(p) != sc->s7_let)) || (is_pair(iterator_sequence(p)))) { - fprintf(stderr, "%s%s[%d]: iterator position sequence is %s%s\n", BOLD_TEXT, func, line, check_name(unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); + fprintf(stderr, "%s%s[%d]: iterator-position sequence is %s%s\n", BOLD_TEXT, func, line, check_name(unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); if (sc->stop_at_error) abort(); } return(p); @@ -26938,11 +27128,6 @@ static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym) if ((has_closure_let(x)) && (is_let(closure_let(x)))) { s7_pointer val; -#if 0 - fprintf(stderr, "%s[%d]: %s %s %s %d %s %s\n", __func__, __LINE__, - DISPLAY(x), DISPLAY(sym), DISPLAY(closure_let(x)), is_funclet(closure_let(x)), DISPLAY(outlet(closure_let(x))), - (is_let(outlet(closure_let(x)))) ? DISPLAY(outlet(outlet(closure_let(x)))) : "unlet"); -#endif val = symbol_to_local_slot(sc, sym, closure_let(x)); if ((!is_slot(val)) && (is_let(outlet(closure_let(x))))) val = symbol_to_local_slot(sc, sym, outlet(closure_let(x))); @@ -26961,9 +27146,11 @@ static bool is_iterable_closure(s7_scheme *sc, s7_pointer x) return((iter) && (iter != sc->F)); } +static s7_pointer s7_let_make_iterator(s7_scheme *sc, s7_pointer iter); + s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) { - s7_pointer iter; + s7_pointer iter, p; new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK); iterator_sequence(iter) = e; @@ -26978,18 +27165,18 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) iterator_current(iter) = rootlet_element(e, 0); /* unfortunately tricky -- let_iterate uses different fields */ iterator_position(iter) = 0; iterator_next(iter) = rootlet_iterate; + return(iter); } - else - { - s7_pointer f; - sc->temp6 = iter; - f = iterator_method(sc, e); - sc->temp6 = sc->nil; - if (f) {free_cell(sc, iter); return(f);} - iterator_set_current_slot(iter, let_slots(e)); - iterator_next(iter) = let_iterate; - iterator_let_cons(iter) = NULL; - } + if (e == sc->s7_let) + return(s7_let_make_iterator(sc, iter)); + + sc->temp6 = iter; + p = iterator_method(sc, e); + sc->temp6 = sc->nil; + if (p) {free_cell(sc, iter); return(p);} + iterator_set_current_slot(iter, let_slots(e)); + iterator_next(iter) = let_iterate; + iterator_let_cons(iter) = NULL; break; case T_HASH_TABLE: @@ -27047,7 +27234,6 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) case T_CLOSURE: case T_CLOSURE_STAR: if (is_iterable_closure(sc, e)) { - s7_pointer p; p = cons(sc, small_int(0), sc->nil); iterator_current(iter) = p; set_mark_seq(iter); @@ -27065,17 +27251,14 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) break; case T_C_OBJECT: - { - s7_pointer f; - iterator_length(iter) = c_object_length_to_int(sc, e); - sc->temp6 = iter; - f = iterator_method(sc, e); - sc->temp6 = sc->nil; - if (f) {free_cell(sc, iter); return(f);} - iterator_current(iter) = list_2(sc, e, small_int(0)); - set_mark_seq(iter); - iterator_next(iter) = c_object_iterate; - } + iterator_length(iter) = c_object_length_to_int(sc, e); + sc->temp6 = iter; + p = iterator_method(sc, e); + sc->temp6 = sc->nil; + if (p) {free_cell(sc, iter); return(p);} + iterator_current(iter) = list_2(sc, e, small_int(0)); + set_mark_seq(iter); + iterator_next(iter) = c_object_iterate; break; default: @@ -29354,121 +29537,123 @@ static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ port_write_string(port)(sc, "(rootlet)", 9, port); else { - if (sc->short_print) - port_write_string(port)(sc, "#<let>", 6, port); + if (obj == sc->s7_let) + port_write_string(port)(sc, "*s7*", 4, port); else { - /* circles can happen here: - * (let () (let ((b (curlet))) (curlet))): #<let 'b #<let>> - * or (let ((b #f)) (set! b (curlet)) (curlet)): #1=#<let 'b #1#> - */ - if (use_write == P_READABLE) + if (sc->short_print) + port_write_string(port)(sc, "#<let>", 6, port); + else { - int32_t lref; - if ((ci) && - (is_cyclic(obj)) && - ((lref = peek_shared_ref(ci, obj)) != 0)) - { - if (lref < 0) lref = -lref; - if ((ci->defined[lref]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t len; - len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - return; - } - if ((outlet(obj) != sc->nil) && - (outlet(obj) != sc->rootlet)) - { - char buf[128]; - int32_t len; - len = catstrs_direct(buf, " (set! (outlet <", pos_int_to_str_direct(sc, lref), ">) ", NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - let_to_port(sc, outlet(obj), ci->cycle_port, use_write, ci); - port_write_string(ci->cycle_port)(sc, ")\n", 2, ci->cycle_port); - } - if (has_methods(obj)) - port_write_string(port)(sc, "(openlet ", 9, port); - /* not immutable here because we'll need to set the let fields below, then declare it immutable */ - if (let_has_setter(sc, obj)) - { - port_write_string(port)(sc, "(let (", 6, port); - slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, true); - port_write_string(port)(sc, ") ", 2, port); - slot_setters_to_port(sc, obj, port, ci); - port_write_string(port)(sc, " (curlet))", 10, port); - } - else - { - port_write_string(port)(sc, "(inlet", 6, port); - slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, false); - port_write_character(port)(sc, ')', port); - } - if (has_methods(obj)) - port_write_character(port)(sc, ')', port); - } - else + /* circles can happen here: + * (let () (let ((b (curlet))) (curlet))): #<let 'b #<let>> + * or (let ((b #f)) (set! b (curlet)) (curlet)): #1=#<let 'b #1#> + */ + if (use_write == P_READABLE) { - if (has_methods(obj)) - port_write_string(port)(sc, "(openlet ", 9, port); - if (is_immutable(obj)) - port_write_string(port)(sc, "(immutable! ", 12, port); - - /* this ignores outlet -- but is that a problem? */ - /* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */ - if (let_has_setter(sc, obj)) + int32_t lref; + if ((ci) && + (is_cyclic(obj)) && + ((lref = peek_shared_ref(ci, obj)) != 0)) { - port_write_string(port)(sc, "(let (", 6, port); - slot_list_to_port(sc, let_slots(obj), port, ci, true); - port_write_string(port)(sc, ") ", 2, port); - slot_setters_to_port(sc, obj, port, ci); - /* perhaps set outlet here?? */ - port_write_string(port)(sc, " (curlet))", 10, port); + if (lref < 0) lref = -lref; + if ((ci->defined[lref]) || (port == ci->cycle_port)) + { + char buf[128]; + int32_t len; + len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", NULL); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + return; + } + if ((outlet(obj) != sc->nil) && + (outlet(obj) != sc->rootlet)) + { + char buf[128]; + int32_t len; + len = catstrs_direct(buf, " (set! (outlet <", pos_int_to_str_direct(sc, lref), ">) ", NULL); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + let_to_port(sc, outlet(obj), ci->cycle_port, use_write, ci); + port_write_string(ci->cycle_port)(sc, ")\n", 2, ci->cycle_port); + } + if (has_methods(obj)) + port_write_string(port)(sc, "(openlet ", 9, port); + /* not immutable here because we'll need to set the let fields below, then declare it immutable */ + if (let_has_setter(sc, obj)) + { + port_write_string(port)(sc, "(let (", 6, port); + slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, true); + port_write_string(port)(sc, ") ", 2, port); + slot_setters_to_port(sc, obj, port, ci); + port_write_string(port)(sc, " (curlet))", 10, port); + } + else + { + port_write_string(port)(sc, "(inlet", 6, port); + slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, false); + port_write_character(port)(sc, ')', port); + } + if (has_methods(obj)) + port_write_character(port)(sc, ')', port); } else { - if ((outlet(obj) != sc->nil) && - (outlet(obj) != sc->rootlet)) + if (has_methods(obj)) + port_write_string(port)(sc, "(openlet ", 9, port); + if (is_immutable(obj)) + port_write_string(port)(sc, "(immutable! ", 12, port); + + /* this ignores outlet -- but is that a problem? */ + /* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */ + if (let_has_setter(sc, obj)) { - int32_t ref; - port_write_string(port)(sc, "(sublet ", 8, port); - if ((ci) && ((ref = peek_shared_ref(ci, outlet(obj))) < 0)) - { - char buf[128]; - int32_t len; - len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", NULL); - port_write_string(port)(sc, buf, len, port); - } - else + port_write_string(port)(sc, "(let (", 6, port); + slot_list_to_port(sc, let_slots(obj), port, ci, true); + port_write_string(port)(sc, ") ", 2, port); + slot_setters_to_port(sc, obj, port, ci); + /* perhaps set outlet here?? */ + port_write_string(port)(sc, " (curlet))", 10, port); + } + else + { + if ((outlet(obj) != sc->nil) && + (outlet(obj) != sc->rootlet)) { - s7_pointer name; - name = s7_let_ref(sc, obj, make_symbol(sc, "class-name")); - if (is_symbol(name)) - symbol_to_port(sc, name, port, P_DISPLAY, ci); - else let_to_port(sc, outlet(obj), port, use_write, ci); + int32_t ref; + port_write_string(port)(sc, "(sublet ", 8, port); + if ((ci) && ((ref = peek_shared_ref(ci, outlet(obj))) < 0)) + { + char buf[128]; + int32_t len; + len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", NULL); + port_write_string(port)(sc, buf, len, port); + } + else + { + s7_pointer name; + name = s7_let_ref(sc, obj, make_symbol(sc, "class-name")); + if (is_symbol(name)) + symbol_to_port(sc, name, port, P_DISPLAY, ci); + else let_to_port(sc, outlet(obj), port, use_write, ci); + } } + else port_write_string(port)(sc, "(inlet", 6, port); + slot_list_to_port(sc, let_slots(obj), port, ci, false); + port_write_character(port)(sc, ')', port); } - else port_write_string(port)(sc, "(inlet", 6, port); - slot_list_to_port(sc, let_slots(obj), port, ci, false); - port_write_character(port)(sc, ')', port); + if (is_immutable(obj)) + port_write_character(port)(sc, ')', port); + if (has_methods(obj)) + port_write_character(port)(sc, ')', port); } - if (is_immutable(obj)) - port_write_character(port)(sc, ')', port); - if (has_methods(obj)) - port_write_character(port)(sc, ')', port); } - } - else /* not readable write */ - { - port_write_string(port)(sc, "(inlet", 6, port); - if (is_funclet(obj)) - funclet_slots_to_port(sc, obj, port, use_write, ci); - else slot_to_port_1(sc, let_slots(obj), port, use_write, ci, 0); - port_write_character(port)(sc, ')', port); - } - } - } + else /* not readable write */ + { + port_write_string(port)(sc, "(inlet", 6, port); + if (is_funclet(obj)) + funclet_slots_to_port(sc, obj, port, use_write, ci); + else slot_to_port_1(sc, let_slots(obj), port, use_write, ci, 0); + port_write_character(port)(sc, ')', port); + }}}} } static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port) @@ -29969,7 +30154,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((is_slot(obj)) ? " safe-stepper" : ((is_c_function(obj)) ? " maybe-safe" : ((is_number(obj)) ? " print-name" : - ((is_pair(obj)) ? " direct_x_opt" : + ((is_pair(obj)) ? " direct_opt" : ((is_hash_table(obj)) ? " weak-hash" : " ?19?")))))) : "", /* bit 20, for c_function case see sc->apply */ @@ -29991,7 +30176,8 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S /* bit 24+16 */ ((full_typ & T_FULL_SYMCONS) != 0) ? ((is_symbol(obj)) ? " possibly-constant" : ((is_procedure(obj)) ? " has-let-arg" : - " ?24?")) : "", + ((is_let(obj)) ? " slots-set" : + " ?24?"))) : "", /* bit 25+16 */ ((full_typ & T_FULL_HAS_LET_FILE) != 0) ? ((is_let(obj)) ? " has-let-file" : @@ -30023,8 +30209,9 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S ((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) ? ((is_normal_vector(obj)) ? " simple-elements" : ((is_hash_table(obj)) ? " simple-keys" : ((is_pair(obj)) ? " ctr3-set" : - ((typ >= T_C_MACRO) ? " function-simple-elements" : - " 32?")))) : "", + ((is_symbol(obj)) ? " safe-setter" : + ((typ >= T_C_MACRO) ? " function-simple-elements" : + " 32?"))))) : "", /* bit 33+16 */ ((full_typ & T_FULL_CASE_KEY) != 0) ? " case-key" : "", @@ -30056,7 +30243,7 @@ static bool has_odd_bits(s7_pointer obj) 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))) return(true); if (((full_typ & T_FULL_DEFINER) != 0) && (!is_symbol(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj))) return(true); - if (((full_typ & T_FULL_SYMCONS) != 0) && (!is_symbol(obj)) && (!is_procedure(obj))) return(true); + if (((full_typ & T_FULL_SYMCONS) != 0) && (!is_symbol(obj)) && (!is_procedure(obj)) && (!is_let(obj))) return(true); if (((full_typ & T_LOCAL) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); if (((full_typ & T_COPY_ARGS) != 0) && (!is_pair(obj)) && (!is_any_macro(obj)) && (!is_any_closure(obj)) && (!is_c_function(obj))) return(true); if (((full_typ & T_UNSAFE) != 0) && (!is_symbol(obj)) && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj))) return(true); @@ -30082,7 +30269,7 @@ static bool has_odd_bits(s7_pointer obj) (!is_let(obj)) && (!is_symbol(obj)) && (!is_string(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) && (!is_any_vector(obj))) return(true); if (((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) && - ((!is_normal_vector(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) && (unchecked_type(obj) < T_C_MACRO))) + ((!is_normal_vector(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) && (!is_symbol(obj)) && (unchecked_type(obj) < T_C_MACRO))) return(true); if (is_symbol(obj)) @@ -30505,7 +30692,7 @@ static const char *opt3_role_name(uint32_t role) if (role == G_ANY) return("opt3_any"); if (role == G_LET) return("opt3_let"); if (role == G_CTR) return("opt3_ctr"); - if (role == G_CON) return("opt3_con"); + if (role == G_BYTE) return("opt3_byte"); if (role == G_DIRECT) return("direct_opt3"); if (role == S_LEN) return("s_len"); if (role == S_LINE) return("s_line"); @@ -30543,8 +30730,8 @@ static char* show_debugger_bits(int64_t bits) ((bits & G_ANY) != 0) ? " opt3_any " : "", ((bits & G_LET) != 0) ? " opt3_let " : "", ((bits & G_CTR) != 0) ? " opt3_ctr " : "", - ((bits & G_CON) != 0) ? " opt3_con " : "", - ((bits & G_DIRECT) != 0) ? " opt3_direct_x" : "", + ((bits & G_BYTE) != 0) ? " opt3_byte " : "", + ((bits & G_DIRECT) != 0) ? " opt3_direct" : "", ((bits & S_NAME) != 0) ? " raw-name" : "", ((bits & S_HASH) != 0) ? " raw-hash" : "", ((bits & S_LINE) != 0) ? " line" : "", @@ -30636,7 +30823,8 @@ static bool f_call_func_mismatch(const char *func) (!safe_strcmp(func, "set_safe_closure_fp")) && (!safe_strcmp(func, "optimize_func_two_args")) && (!safe_strcmp(func, "optimize_func_many_args")) && - (!safe_strcmp(func, "optimize_func_three_args"))); + (!safe_strcmp(func, "optimize_func_three_args")) && + (!safe_strcmp(func, "op_c_fa_1"))); } static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, uint32_t role, const char *func, int32_t line) @@ -30738,13 +30926,13 @@ static void set_opt3_1(s7_pointer p, s7_pointer x, uint32_t role, const char *fu base_opt3(p, role, func, line); } -static uint8_t opt3_con_1(s7_pointer p, uint32_t role, const char *func, int32_t line) +static uint8_t opt3_byte_1(s7_pointer p, uint32_t role, const char *func, int32_t line) { check_opt3_bits(p, role, func, line); return(p->object.cons_ext.ce.opt_type); } -static void set_opt3_con_1(s7_pointer p, uint8_t x, uint32_t role, const char *func, int32_t line) +static void set_opt3_byte_1(s7_pointer p, uint8_t x, uint32_t role, const char *func, int32_t line) { clear_type_bit(p, T_LINE_NUMBER); p->object.cons_ext.ce.opt_type = x; @@ -32373,36 +32561,9 @@ static s7_int format_numeric_arg(s7_scheme *sc, const char *str, s7_int str_len, return(width); } -#if WITH_GMP -static bool s7_is_one_or_big_one(s7_pointer p); -#else -#define s7_is_one_or_big_one(Num) s7_is_one(Num) -#endif - -static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj); - -static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, - s7_pointer *next_arg, bool with_result, bool columnized, s7_int len, s7_pointer orig_str) +static format_data *open_format_data(s7_scheme *sc) { - s7_int i, str_len; format_data *fdat; - s7_pointer deferred_port; - - if (len <= 0) - { - str_len = safe_strlen(str); - if (str_len == 0) - { - if (is_not_null(args)) - return(s7_error(sc, sc->format_error_symbol, - set_elist_2(sc, wrap_string(sc, "format control string is null, but there are arguments: ~S", 58), args))); - if (with_result) - return(make_empty_string(sc, 0, 0)); - return(sc->F); - } - } - else str_len = len; - sc->format_depth++; if (sc->format_depth >= sc->num_fdats) { @@ -32432,9 +32593,43 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s fdat->port = NULL; fdat->strport = NULL; fdat->loc = 0; + fdat->curly_arg = sc->nil; + return(fdat); +} + +#if WITH_GMP +static bool s7_is_one_or_big_one(s7_pointer p); +#else +#define s7_is_one_or_big_one(Num) s7_is_one(Num) +#endif + +static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj); + +static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, + s7_pointer *next_arg, bool with_result, bool columnized, s7_int len, s7_pointer orig_str) +{ + s7_int i, str_len; + format_data *fdat; + s7_pointer deferred_port; + + if (len <= 0) + { + str_len = safe_strlen(str); + if (str_len == 0) + { + if (is_not_null(args)) + return(s7_error(sc, sc->format_error_symbol, + set_elist_2(sc, wrap_string(sc, "format control string is null, but there are arguments: ~S", 58), args))); + if (with_result) + return(make_empty_string(sc, 0, 0)); + return(sc->F); + } + } + else str_len = len; + + fdat = open_format_data(sc); fdat->args = args; fdat->orig_str = orig_str; - fdat->curly_arg = sc->nil; /* choose whether to write to a temporary string port, or simply use the in-coming port * if with_result, returned string is wanted. @@ -33023,34 +33218,6 @@ static s7_pointer format_to_port(s7_scheme *sc, s7_pointer port, const char *str return(sc->F); } -static s7_pointer g_format_1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer pt, str; - sc->format_column = 0; - pt = car(args); - if (is_null(pt)) - { - pt = sc->output_port; /* () -> (current-output-port) */ - if (pt == sc->F) /* otherwise () -> #f so we get a returned string, which is confusing */ - return(pt); /* but this means some error checks are skipped? */ - } - - if (!((s7_is_boolean(pt)) || /* #f or #t */ - ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ - (!port_is_closed(pt))))) - return(method_or_bust_with_type(sc, pt, sc->format_symbol, args, an_output_port_string, 1)); - - if (!is_pair(cdr(args))) /* (format #f) */ - return(s7_error(sc, sc->format_error_symbol, - set_elist_2(sc, wrap_string(sc, "format has no control string: ~S", 32), args))); - str = cadr(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->format_symbol, args, T_STRING, 2)); - - return(format_to_port_1(sc, (pt == sc->T) ? sc->output_port : pt, - string_value(str), cddr(args), NULL, !is_output_port(pt), true, string_length(str), str)); -} - static s7_pointer g_format(s7_scheme *sc, s7_pointer args) { #define H_format "(format out str . args) substitutes args into str sending the result to out. Most of \ @@ -33073,18 +33240,50 @@ If the 'out' it is not an output port, the resultant string is returned. If it is #t, the string is also sent to the current-output-port." #define Q_format s7_make_circular_signature(sc, 2, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T) - return(g_format_1(sc, args)); + + s7_pointer pt, str; + sc->format_column = 0; + pt = car(args); + if (is_null(pt)) + { + pt = sc->output_port; /* () -> (current-output-port) */ + if (pt == sc->F) /* otherwise () -> #f so we get a returned string, which is confusing */ + return(pt); /* but this means some error checks are skipped? */ + } + + if (!((s7_is_boolean(pt)) || /* #f or #t */ + ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ + (!port_is_closed(pt))))) + return(method_or_bust_with_type(sc, pt, sc->format_symbol, args, an_output_port_string, 1)); + + str = cadr(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sc->format_symbol, args, T_STRING, 2)); + + return(format_to_port_1(sc, (pt == sc->T) ? sc->output_port : pt, + string_value(str), cddr(args), NULL, !is_output_port(pt), true, string_length(str), str)); } const char *s7_format(s7_scheme *sc, s7_pointer args) { s7_pointer result; - result = g_format_1(sc, args); + result = g_format(sc, args); if (is_string(result)) return(string_value(result)); return(NULL); } +static s7_pointer g_format_f(s7_scheme *sc, s7_pointer args) +{ + /* port == #f, there are other args */ + s7_pointer str; + sc->format_column = 0; + str = cadr(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sc->format_symbol, args, T_STRING, 2)); + return(format_to_port_1(sc, sc->F, string_value(str), cddr(args), NULL, true, true, string_length(str), str)); +} + /* -------------------------------- system extras -------------------------------- */ @@ -33886,15 +34085,10 @@ static bool tree_set_memq(s7_scheme *sc, s7_pointer tree) return(pair_set_memq(sc, tree)); } -static s7_pointer g_tree_set_memq(s7_scheme *sc, s7_pointer args) +static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) { - #define H_tree_set_memq "(tree-set-memq symbols tree) returns #t if any of the list of symbols is in the tree" - #define Q_tree_set_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) - - s7_pointer syms, p, tree; - syms = car(args); - if (!is_pair(syms)) return(sc->F); - tree = cadr(args); + s7_pointer p; + if (!is_pair(syms)) return(false); if (sc->safety > NO_SAFETY) { if (tree_is_cyclic(sc, syms)) @@ -33906,24 +34100,39 @@ static s7_pointer g_tree_set_memq(s7_scheme *sc, s7_pointer args) for (p = syms; is_pair(p); p = cdr(p)) if (is_symbol(car(p))) add_symbol_to_list(sc, car(p)); - return(make_boolean(sc, tree_set_memq(sc, tree))); + return(tree_set_memq(sc, tree)); } -static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) {return(g_tree_set_memq(sc, set_plist_2(sc, syms, tree)) != sc->F);} +static s7_pointer tree_set_memq_p_pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) +{ + return(make_boolean(sc, tree_set_memq_b_7pp(sc, syms, tree))); +} -static s7_pointer g_tree_set_memq_1(s7_scheme *sc, s7_pointer args) +static s7_pointer g_tree_set_memq(s7_scheme *sc, s7_pointer args) { - s7_pointer p, tree; - tree = cadr(args); + #define H_tree_set_memq "(tree-set-memq symbols tree) returns #t if any of the list of symbols is in the tree" + #define Q_tree_set_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) + + return(make_boolean(sc, tree_set_memq_b_7pp(sc, car(args), cadr(args)))); +} + +static s7_pointer tree_set_memq_direct(s7_scheme *sc, s7_pointer syms, s7_pointer tree) +{ + s7_pointer p; if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, tree))) s7_error(sc, sc->wrong_type_arg_symbol, wrap_string(sc, "tree-set-memq: tree is cyclic", 29)); clear_symbol_list(sc); - for (p = car(args); is_pair(p); p = cdr(p)) + for (p = syms; is_pair(p); p = cdr(p)) add_symbol_to_list(sc, car(p)); return(make_boolean(sc, tree_set_memq(sc, tree))); } +static s7_pointer g_tree_set_memq_1(s7_scheme *sc, s7_pointer args) +{ + return(tree_set_memq_direct(sc, car(args), cadr(args))); +} + static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) { if ((is_proper_quote(sc, cadr(expr))) && /* not (tree-set-memq (quote) ... */ @@ -33933,7 +34142,7 @@ static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer f, int32_t arg for (p = cadadr(expr); is_pair(p); p = cdr(p)) if (!is_symbol(car(p))) return(f); - return(sc->tree_set_memq_syms); + return(sc->tree_set_memq_syms); /* this is tree_set_memq_1 */ } return(f); } @@ -34792,6 +35001,15 @@ static s7_pointer g_caadr(s7_scheme *sc, s7_pointer args) return(caadr(lst)); } +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)); + return(simple_wrong_type_argument(sc, sc->caadr_symbol, p, T_PAIR)); +} + /* -------- cadar -------- */ static s7_pointer g_cadar(s7_scheme *sc, s7_pointer args) { @@ -34806,6 +35024,15 @@ static s7_pointer g_cadar(s7_scheme *sc, s7_pointer args) return(cadar(lst)); } +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)); + return(simple_wrong_type_argument(sc, sc->cadar_symbol, p, T_PAIR)); +} + /* -------- cdaar -------- */ static s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args) { @@ -34871,6 +35098,15 @@ static s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args) return(cdadr(lst)); } +static s7_pointer cdadr_p_p(s7_scheme *sc, s7_pointer p) +{ + if ((is_pair(p)) && + (is_pair(cdr(p))) && + (is_pair(cadr(p)))) + return(cdadr(p)); + return(simple_wrong_type_argument(sc, sc->cdadr_symbol, p, T_PAIR)); +} + /* -------- cddar -------- */ static s7_pointer g_cddar(s7_scheme *sc, s7_pointer args) { @@ -34960,6 +35196,16 @@ static s7_pointer g_caaddr(s7_scheme *sc, s7_pointer args) return(caaddr(lst)); } +static s7_pointer caaddr_p_p(s7_scheme *sc, s7_pointer p) +{ + if ((is_pair(p)) && + (is_pair(cdr(p))) && + (is_pair(cddr(p))) && + (is_pair(caddr(p)))) + return(caaddr(p)); + return(simple_wrong_type_argument(sc, sc->caaddr_symbol, p, T_PAIR)); +} + /* -------- cadddr -------- */ static s7_pointer g_cadddr(s7_scheme *sc, s7_pointer args) { @@ -34990,6 +35236,16 @@ static s7_pointer g_cadadr(s7_scheme *sc, s7_pointer args) return(cadadr(lst)); } +static s7_pointer cadadr_p_p(s7_scheme *sc, s7_pointer p) +{ + if ((is_pair(p)) && + (is_pair(cdr(p))) && + (is_pair(cadr(p))) && + (is_pair(cdadr(p)))) + return(cadadr(p)); + return(simple_wrong_type_argument(sc, sc->cadadr_symbol, p, T_PAIR)); +} + /* -------- caddar -------- */ static s7_pointer g_caddar(s7_scheme *sc, s7_pointer args) { @@ -35005,6 +35261,16 @@ static s7_pointer g_caddar(s7_scheme *sc, s7_pointer args) return(caddar(lst)); } +static s7_pointer caddar_p_p(s7_scheme *sc, s7_pointer p) +{ + if ((is_pair(p)) && + (is_pair(car(p))) && + (is_pair(cdar(p))) && + (is_pair(cddar(p)))) + return(caddar(p)); + return(simple_wrong_type_argument(sc, sc->caddar_symbol, p, T_PAIR)); +} + /* -------- cdaaar -------- */ static s7_pointer g_cdaaar(s7_scheme *sc, s7_pointer args) { @@ -35435,6 +35701,13 @@ s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x) return(sc->F); } +static s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + if (is_pair(y)) return(s7_memq(sc, x, y)); + if (is_null(y)) return(sc->F); + return(method_or_bust_with_type(sc, y, sc->memq_symbol, list_2(sc, x, y), a_list_string, 2)); +} + static s7_pointer g_memq(s7_scheme *sc, s7_pointer args) { s7_pointer x, y; @@ -35463,6 +35736,13 @@ static s7_pointer g_memq_2(s7_scheme *sc, s7_pointer args) return(sc->F); } +static s7_pointer memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) +{ + if (obj == car(x)) return(x); + if (obj == cadr(x)) return(cdr(x)); + return(sc->F); +} + static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args) { s7_pointer x, obj; @@ -35726,7 +36006,8 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c { s7_pointer body; body = closure_body(eq_func); - if (is_null(cdr(body))) + if ((!no_bool_opt(body)) && + (is_null(cdr(body)))) { s7_function func; new_frame_with_two_slots(sc, sc->envir, sc->envir, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F); @@ -35753,6 +36034,7 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c } return(sc->F); } + else set_no_bool_opt(body); } } @@ -35847,17 +36129,20 @@ static s7_pointer g_list(s7_scheme *sc, s7_pointer args) static s7_pointer g_list_0(s7_scheme *sc, s7_pointer args) {return(sc->nil);} static s7_pointer g_list_1(s7_scheme *sc, s7_pointer args) {return(list_1(sc, car(args)));} static s7_pointer g_list_2(s7_scheme *sc, s7_pointer args) {return(list_2(sc, car(args), cadr(args)));} +static s7_pointer g_list_3(s7_scheme *sc, s7_pointer args) {return(list_3(sc, car(args), cadr(args), caddr(args)));} static s7_pointer list_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) { if (args == 0) return(sc->list_0); if (args == 1) return(sc->list_1); if (args == 2) return(sc->list_2); + if (args == 3) return(sc->list_3); return(f); } static s7_pointer list_p_p(s7_scheme *sc, s7_pointer p1) {return(list_1(sc, p1));} static s7_pointer list_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(list_2(sc, p1, p2));} +static s7_pointer list_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(list_3(sc, p1, p2, p3));} static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer lst) { @@ -36094,9 +36379,9 @@ 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(type(p) == T_FLOAT_VECTOR);} -bool s7_is_int_vector(s7_pointer p) {return(type(p) == T_INT_VECTOR);} +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));} s7_int s7_vector_length(s7_pointer vec) {return(vector_length(vec));} @@ -37789,6 +38074,27 @@ static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args) return(val); } +static s7_pointer vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val) +{ + s7_int index; + + if ((!is_any_vector(vec)) || (vector_rank(vec) > 1)) + return(g_vector_set(sc, set_plist_3(sc, vec, ind, val))); + if (is_immutable_vector(vec)) + return(immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec))); + if (!s7_is_integer(ind)) + return(g_vector_set(sc, set_plist_3(sc, vec, ind, val))); + index = s7_integer(ind); + if ((index < 0) || + (index >= vector_length(vec))) + return(out_of_range(sc, sc->vector_set_symbol, small_int(2), wrap_integer1(sc, index), (index < 0) ? its_negative_string : its_too_large_string)); + + if (is_typed_vector(vec)) + return(typed_vector_setter(sc, vec, index, val)); + vector_setter(vec)(sc, vec, index, val); + return(val); +} + static s7_pointer g_vector_set_4(s7_scheme *sc, s7_pointer args) { s7_pointer v, ip1, ip2, val; @@ -39304,7 +39610,12 @@ static int32_t vector_sort(const void *v1, const void *v2, void *arg) static int32_t vector_sort_lt(const void *v1, const void *v2, void *arg) /* for qsort_r */ { - return((lt_b_7pp((s7_scheme *)arg, (*(s7_pointer *)v1), (*(s7_pointer *)v2))) ? -1 : 1); + s7_pointer s1, s2; + s1 = (*(s7_pointer *)v1); + s2 = (*(s7_pointer *)v2); + if ((is_t_integer(s1)) && (is_t_integer(s2))) + return((integer(s1) < integer(s2)) ? -1 : 1); + return((lt_b_7pp((s7_scheme *)arg, s1, s2)) ? -1 : 1); } static int32_t vector_car_sort(const void *v1, const void *v2, void *arg) @@ -39372,12 +39683,24 @@ static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, void *arg) return((o->v[0].fb(o)) ? -1 : 1); } +static int32_t opt_begin_bool_sort_b2(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *)arg; + opt_info *o; + slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); + slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); + sc->pc = 0; + o = sc->opts[0]; + o->v[0].fp(o); + o = sc->opts[++sc->pc]; + return((o->v[0].fb(o)) ? -1 : 1); +} + static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2, void *arg) { s7_scheme *sc = (s7_scheme *)arg; s7_int i; opt_info *o; - s7_pointer val; slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); sc->pc = -1; @@ -39387,8 +39710,7 @@ static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2, void *arg) o->v[0].fp(o); } o = sc->opts[++sc->pc]; - val = o->v[0].fp(o); - return((val != sc->F) ? -1 : 1); + return((o->v[0].fp(o) != sc->F) ? -1 : 1); } static int32_t closure_sort(const void *v1, const void *v2, void *arg) @@ -39578,7 +39900,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) int32_t start; start = sc->pc; if (bool_optimize_nw(sc, p)) - sort_func = opt_begin_bool_sort_b; + sort_func = (sc->sort_body_len == 2) ? opt_begin_bool_sort_b2 : opt_begin_bool_sort_b; else { pc_fallback(sc, start); @@ -40675,16 +40997,30 @@ static hash_entry_t *hash_number(s7_scheme *sc, s7_pointer table, s7_pointer key { hash_entry_t *x; s7_int hash_mask, loc; + hash_map_t map; hash_mask = hash_table_mask(table); - loc = hash_loc(sc, table, key) & hash_mask; - + map = hash_table_mapper(table)[type(key)]; #if (!WITH_GMP) - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((is_number(hash_entry_key(x))) && - (is_true(sc, c_num_eq_2(sc, key, hash_entry_key(x))))) - return(x); + if (map == hash_map_int) /* surely by far the most common case? */ + { + s7_int keyi; + keyi = integer(key); + for (x = hash_table_element(table, keyi & hash_mask); x; x = hash_entry_next(x)) + if ((is_t_integer(hash_entry_key(x))) && + (keyi == integer(hash_entry_key(x)))) + return(x); + } + else + { + loc = map(sc, table, key) & hash_mask; + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if ((is_number(hash_entry_key(x))) && + (is_true(sc, num_eq_p_pp(sc, key, hash_entry_key(x))))) + return(x); + } #else + loc = map(sc, table, key) & hash_mask; for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) if ((is_number(hash_entry_key(x))) && (is_true(sc, big_num_eq(sc, set_plist_2(sc, key, hash_entry_key(x)))))) @@ -41221,11 +41557,9 @@ static void resize_hash_table(s7_scheme *sc, s7_pointer table) /* -------------------------------- hash-table-ref -------------------------------- */ -inline s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key) +s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key) { - hash_entry_t *x; - x = (*hash_table_checker(table))(sc, table, key); - return(hash_entry_value(x)); + return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); } static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args) @@ -41248,23 +41582,17 @@ static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args) static s7_pointer g_hash_table_ref_2(s7_scheme *sc, s7_pointer args) { s7_pointer table; - hash_entry_t *x; - table = car(args); if (!is_hash_table(table)) return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE, 1)); - - x = (*hash_table_checker(table))(sc, table, cadr(args)); - return(hash_entry_value(x)); + return(hash_entry_value((*hash_table_checker(table))(sc, table, cadr(args)))); } static s7_pointer hash_table_ref_p_pp(s7_scheme *sc, s7_pointer table, s7_pointer key) { - hash_entry_t *x; if (!is_hash_table(table)) simple_wrong_type_argument(sc, sc->hash_table_ref_symbol, table, T_HASH_TABLE); - x = (*hash_table_checker(table))(sc, table, key); - return(hash_entry_value(x)); + return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); } static bool op_hash_table_a(s7_scheme *sc) @@ -41468,9 +41796,7 @@ static s7_pointer g_hash_table_set(s7_scheme *sc, s7_pointer args) static s7_pointer hash_table_set_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) { - if (!is_hash_table(p1)) - simple_wrong_type_argument(sc, sc->hash_table_set_symbol, p1, T_HASH_TABLE); - if (!is_mutable_hash_table(p1)) + if (!is_mutable_hash_table(p1)) /* is_hash_table(p1) is here */ return(mutable_method_or_bust(sc, p1, sc->hash_table_set_symbol, list_3(sc, p1, p2, p3), T_HASH_TABLE, 1)); return(s7_hash_table_set(sc, p1, p2, p3)); } @@ -42293,6 +42619,9 @@ const char *s7_help(s7_scheme *sc, s7_pointer obj) if (is_procedure_or_macro(obj)) return(s7_documentation(sc, obj)); + if (obj == sc->s7_let) + return("*s7* is a let that gives access to s7's internal state: e.g. (*s7* 'print-length)"); + /* if is string, apropos? (can scan symbol table) */ return(NULL); } @@ -42786,7 +43115,7 @@ static void op_set_dilambda_p(s7_scheme *sc) sc->code = caddr(sc->code); } -static void op_set_dilambda(s7_scheme *sc) +static void op_set_dilambda(s7_scheme *sc) /* ([set!] (dilambda-setter g) s) */ { sc->code = cdr(sc->code); sc->value = cadr(sc->code); @@ -43403,6 +43732,7 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) * (set! (< 1) 2) -> #t */ + /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY(args)); */ if (is_symbol(p)) { s7_pointer sym, func, slot; @@ -43432,6 +43762,8 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) slot = symbol_to_slot(sc, sym); func = cadr(args); } + /* fprintf(stderr, "slot: %s\n", DISPLAY(slot)); */ + if ((!is_any_procedure(func)) && /* disallow continuation/goto here */ (func != sc->F)) return(s7_wrong_type_arg_error(sc, "set! setter", 3, func, "a function or #f")); @@ -43448,6 +43780,7 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) return(func); } + /* fprintf(stderr, "calling slot_set_setter %s\n", DISPLAY(func)); */ slot_set_setter(slot, func); if (func != sc->F) { @@ -43463,6 +43796,8 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) if ((setter != sc->F) && (!is_any_procedure(setter))) return(s7_wrong_type_arg_error(sc, "set! setter", 2, setter, "a procedure or #f")); + if (p == sc->s7_let) + return(s7_wrong_type_arg_error(sc, "set! setter", 1, p, "something other than *s7*")); switch (type(p)) { @@ -43637,6 +43972,11 @@ bool s7_is_eq(s7_pointer obj1, s7_pointer obj2) ((is_unspecified(obj1)) && (is_unspecified(obj2)))); /* this is needed because this function is used by s7_b_pp */ } +static s7_pointer is_eq_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) +{ + return(make_boolean(sc, ((obj1 == obj2) || ((is_unspecified(obj1)) && (is_unspecified(obj2)))))); +} + static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args) { #define H_is_eq "(eq? obj1 obj2) returns #t if obj1 is eq to (the same object as) obj2" @@ -43675,6 +44015,8 @@ static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args) return(make_boolean(sc, s7_is_eqv(car(args), cadr(args)))); } +static s7_pointer is_eqv_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) {return(make_boolean(sc, s7_is_eqv(obj1, obj2)));} + static bool s7_is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci); static bool s7_is_equivalent_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info *ci); @@ -45182,7 +45524,7 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) check_method(sc, source, sc->copy_symbol, args); if (source == sc->rootlet) return(wrong_type_argument_with_type(sc, caller, 1, source, wrap_string(sc, "a sequence other than the rootlet", 33))); - if ((!have_indices) && (is_let(dest))) + if ((!have_indices) && (is_let(dest)) && (dest != sc->s7_let)) { s7_pointer slot; if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ @@ -45283,8 +45625,8 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) break; case T_LET: - if (dest == sc->rootlet) - return(wrong_type_argument_with_type(sc, caller, 2, dest, wrap_string(sc, "a sequence other than the rootlet", 33))); + if ((dest == sc->rootlet) || (dest == sc->s7_let)) + return(wrong_type_argument_with_type(sc, caller, 2, dest, wrap_string(sc, "a sequence other than the rootlet or *s7*", 41))); set = let_setter; dest_len = source_len; /* grows via set, so dest_len isn't relevant */ set_cadr(sc->elist_3, caller); /* for possible error handling in let_setter */ @@ -45345,51 +45687,76 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) /* implicit index can give n-way reality check (ht growth by new entries) * if shadowed entries are they unshadowed by reversal? */ - { - /* source and dest can't be rootlet (checked above) */ - s7_pointer slot; - slot = let_slots(source); - for (i = 0; i < start; i++) slot = next_slot(slot); - if (is_pair(dest)) - { - s7_pointer p; - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p), slot = next_slot(slot)) - set_car(p, cons(sc, slot_symbol(slot), slot_value(slot))); - } - else - { - if (is_let(dest)) - { - if ((has_let_fallback(source)) && - (has_let_fallback(dest))) - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && - (slot_symbol(slot) != sc->let_set_fallback_symbol)) + if (source == sc->s7_let) + { + s7_pointer iter; + s7_int gc_loc; + iter = s7_make_iterator(sc, sc->s7_let); + gc_loc = s7_gc_protect(sc, iter); + for (i = 0; i < start; i++) + { + s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) + { + s7_gc_unprotect_at(sc, gc_loc); + return(dest); + } + } + for (i = start, j = 0; i < end; i++, j++) + { + s7_pointer val; + val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + set(sc, dest, j, val); + } + s7_gc_unprotect_at(sc, gc_loc); + } + else + { + /* source and dest can't be rootlet (checked above), dest also can't be *s7* */ + s7_pointer slot; + slot = let_slots(source); + for (i = 0; i < start; i++) slot = next_slot(slot); + if (is_pair(dest)) + { + s7_pointer p; + for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p), slot = next_slot(slot)) + set_car(p, cons(sc, slot_symbol(slot), slot_value(slot))); + } + else + { + if (is_let(dest)) + { + if ((has_let_fallback(source)) && + (has_let_fallback(dest))) + { + for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) + if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && + (slot_symbol(slot) != sc->let_set_fallback_symbol)) + make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + { + for (i = start; i < end; i++, slot = next_slot(slot)) make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - { - for (i = start; i < end; i++, slot = next_slot(slot)) - make_slot_1(sc, dest, slot_symbol(slot), slot_value(slot)); - } - } - else - { - if (is_hash_table(dest)) - { - for (i = start; i < end; i++, slot = next_slot(slot)) - s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - { - for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) - set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot))); - } - } - } - return(dest); - } + } + } + else + { + if (is_hash_table(dest)) + { + for (i = start; i < end; i++, slot = next_slot(slot)) + s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + { + for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) + set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot))); + } + } + } + } + return(dest); case T_HASH_TABLE: { @@ -49147,6 +49514,22 @@ static void improper_arglist_error(s7_scheme *sc) append_in_place(sc, sc->args = safe_reverse_in_place(sc, sc->args), sc->code))); } +static void op_error_hook_quit(s7_scheme *sc) +{ + sc->error_hook = sc->code; /* restore old value */ + /* now mimic the end of the normal error handler. Since this error hook evaluation can happen + * in an arbitrary s7_call nesting, we can't just return from the current evaluation -- + * we have to jump to the original (top-level) call. Otherwise '#<unspecified> or whatever + * is simply treated as the (non-error) return value, and the higher level evaluations + * get confused. + */ + stack_reset(sc); /* is this necessary? is it a good idea?? */ + push_stack_op(sc, OP_ERROR_QUIT); /* added 3-Dec-16: try to make sure we actually exit! */ + sc->cur_op = OP_ERROR_QUIT; + if (sc->longjmp_ok) + longjmp(sc->goto_start, ERROR_QUIT_JUMP); +} + /* -------------------------------- leftovers -------------------------------- */ @@ -49717,15 +50100,15 @@ s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args /* -------------------------------- type-of -------------------------------- */ -#if 0 -static inline bool gen_type_match(s7_scheme *sc, s7_pointer val, uint8_t typ) /* opt3_con = uint8_t */ +#if (!WITH_GCC) +static inline bool gen_type_match(s7_scheme *sc, s7_pointer val, uint8_t typ) /* opt3_byte = uint8_t */ { return((type(val) == typ) || ((has_active_methods(sc, val)) && (apply_boolean_method(sc, val, sc->type_to_typers[typ]) != sc->F))); } #else -#define gen_type_match(Sc, Val, Typ) ((type(Val) == Typ) || ((has_active_methods(Sc, Val)) && (apply_boolean_method(Sc, Val, Sc->type_to_typers[Typ]) != Sc->F))) +#define gen_type_match(Sc, Val, Typ) ({s7_pointer _val_ = Val; ((type(_val_) == Typ) || ((has_active_methods(Sc, _val_)) && (apply_boolean_method(Sc, _val_, Sc->type_to_typers[Typ]) != Sc->F)));}) #endif static void init_typers(s7_scheme *sc) @@ -49901,6 +50284,7 @@ static s7_pointer fx_q(s7_scheme *sc, s7_pointer arg) {return(cadr(arg));} static s7_pointer fx_unsafe_s(s7_scheme *sc, s7_pointer arg){return(lookup_checked(sc, arg));} static s7_pointer fx_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, arg));} +static s7_pointer fx_g(s7_scheme *sc, s7_pointer arg) {return((is_global(arg)) ? slot_value(global_slot(arg)) : lookup(sc, arg));} static s7_pointer fx_t(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, arg); @@ -49925,12 +50309,19 @@ static s7_pointer fx_U(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_d(s7_scheme *sc, s7_pointer arg) {return(d_call(sc, arg));} +static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg) +{ + return(make_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_rng)))); +} + #if (!WITH_GMP) 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 switch (type(val)) { - case T_INTEGER: return(make_boolean(sc, integer(val) == y)); case T_RATIO: return(sc->F); case T_REAL: return(make_boolean(sc, real(val) == y)); case T_COMPLEX: return(sc->F); @@ -49976,6 +50367,19 @@ static s7_pointer fx_num_eq_ui(s7_scheme *sc, s7_pointer arg) return(make_boolean(sc, integer(val) == y)); return(fx_num_eq_xi_1(sc, args, val, y)); } + +static s7_pointer fx_num_eq_Ti(s7_scheme *sc, s7_pointer arg) +{ + s7_int y; + s7_pointer val, args; + args = cdr(arg); + check_outer_let_slots(sc, __func__, arg, cadr(arg)); + val = slot_value(let_slots(outlet(sc->envir))); + y = integer(cadr(args)); + if (is_t_integer(val)) + return(make_boolean(sc, integer(val) == y)); + return(fx_num_eq_xi_1(sc, args, val, y)); +} #endif static s7_pointer fx_add_s1(s7_scheme *sc, s7_pointer arg) @@ -49984,7 +50388,7 @@ static s7_pointer fx_add_s1(s7_scheme *sc, s7_pointer arg) x = lookup(sc, cadr(arg)); if (is_t_integer(x)) return(make_integer(sc, integer(x) + 1)); - return(g_add_s1_1(sc, x, cdr(arg))); /* arg=(+ x 1) */ + return(g_add_x1_1(sc, x, cdr(arg))); /* arg=(+ x 1) */ } static s7_pointer fx_add_t1(s7_scheme *sc, s7_pointer arg) /* sub_t1 was not useful */ @@ -49994,7 +50398,7 @@ static s7_pointer fx_add_t1(s7_scheme *sc, s7_pointer arg) /* sub_t1 was not use check_let_slots(sc, __func__, arg, cadr(arg)); if (is_t_integer(x)) return(make_integer(sc, integer(x) + 1)); - return(g_add_s1_1(sc, x, cdr(arg))); + return(g_add_x1_1(sc, x, cdr(arg))); } static s7_pointer fx_add_u1(s7_scheme *sc, s7_pointer arg) @@ -50004,7 +50408,7 @@ static s7_pointer fx_add_u1(s7_scheme *sc, s7_pointer arg) x = slot_value(next_slot(let_slots(sc->envir))); if (is_t_integer(x)) return(make_integer(sc, integer(x) + 1)); - return(g_add_s1_1(sc, x, cdr(arg))); + return(g_add_x1_1(sc, x, cdr(arg))); } static s7_pointer fx_add_T1(s7_scheme *sc, s7_pointer arg) @@ -50014,7 +50418,7 @@ static s7_pointer fx_add_T1(s7_scheme *sc, s7_pointer arg) x = slot_value(let_slots(outlet(sc->envir))); if (is_t_integer(x)) return(make_integer(sc, integer(x) + 1)); - return(g_add_s1_1(sc, x, cdr(arg))); /* arg=(+ x 1) */ + return(g_add_x1_1(sc, x, cdr(arg))); /* arg=(+ x 1) */ } static s7_pointer fx_add_U1(s7_scheme *sc, s7_pointer arg) /* sub_t1 was not useful */ @@ -50024,17 +50428,17 @@ static s7_pointer fx_add_U1(s7_scheme *sc, s7_pointer arg) /* sub_t1 was not use x = slot_value(next_slot(let_slots(outlet(sc->envir)))); if (is_t_integer(x)) return(make_integer(sc, integer(x) + 1)); - return(g_add_s1_1(sc, x, cdr(arg))); + return(g_add_x1_1(sc, x, cdr(arg))); } #if (!WITH_GMP) -static s7_pointer fx_add_sf(s7_scheme *sc, s7_pointer arg) {return(g_add_sfs(sc, lookup(sc, cadr(arg)), real(caddr(arg))));} -static s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer arg) {return(g_add_sfs(sc, lookup(sc, caddr(arg)), real(cadr(arg))));} +static s7_pointer fx_add_sf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, cadr(arg)), real(caddr(arg))));} +static s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, caddr(arg)), real(cadr(arg))));} static s7_pointer fx_add_tf(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); - return(g_add_sfs(sc, slot_value(let_slots(sc->envir)), real(caddr(arg)))); + return(g_add_xf(sc, slot_value(let_slots(sc->envir)), real(caddr(arg)))); } #endif @@ -50130,6 +50534,12 @@ static s7_pointer fx_is_eq_sc(s7_scheme *sc, s7_pointer arg) return(make_boolean(sc, lookup(sc, cadr(arg)) == opt2_con(cdr(arg)))); /* fx_choose checks that the second arg is not unspecified */ } +static s7_pointer fx_is_eq_tc(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + return(make_boolean(sc, slot_value(let_slots(sc->envir)) == opt2_con(cdr(arg)))); +} + static s7_pointer fx_is_eq_car_q(s7_scheme *sc, s7_pointer arg) { s7_pointer lst, a; @@ -50177,7 +50587,15 @@ static s7_pointer fx_is_pair_car_s(s7_scheme *sc, s7_pointer arg) p = lookup(sc, opt2_sym(cdr(arg))); if (is_pair(p)) return(make_boolean(sc, is_pair(car(p)))); - return(g_is_pair(sc, set_plist_1(sc, g_car(sc, set_plist_1(sc, p))))); + + if (has_active_methods(sc, p)) + { + s7_pointer func; + func = find_method(sc, p, sc->car_symbol); + if (func != sc->undefined) + return(make_boolean(sc, is_pair(s7_apply_function(sc, func, list_1(sc, p))))); + } + return(wrong_type_argument(sc, sc->car_symbol, 1, p, T_PAIR)); } static s7_pointer fx_is_pair_car_t(s7_scheme *sc, s7_pointer arg) @@ -50303,12 +50721,28 @@ static s7_pointer fx_is_symbol_cadr_s(s7_scheme *sc, s7_pointer arg) return(g_is_symbol(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); } +static s7_pointer fx_is_symbol_cadr_t(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p; + check_let_slots(sc, __func__, arg, cadadr(arg)); + p = slot_value(let_slots(sc->envir)); + if ((is_pair(p)) && (is_pair(cdr(p)))) + return(make_boolean(sc, is_symbol(cadr(p)))); + return(g_is_symbol(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); +} + static s7_pointer fx_c_s(s7_scheme *sc, s7_pointer arg) { set_car(sc->t1_1, lookup(sc, cadr(arg))); return(c_call(arg)(sc, sc->t1_1)); } +static s7_pointer fx_c_g(s7_scheme *sc, s7_pointer arg) +{ + set_car(sc->t1_1, lookup_global(sc, cadr(arg))); + return(c_call(arg)(sc, sc->t1_1)); +} + static s7_pointer fx_c_t(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); @@ -50330,28 +50764,41 @@ static s7_pointer fx_c_u(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } +static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer arg) +{ + check_next_let_slot(sc, __func__, arg, cadr(arg)); + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir))))); +} + static s7_pointer fx_o_p_p_s(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_p_t)opt2_direct_x_call(cdr(arg)))(sc, lookup(sc, cadr(arg)))); + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)))); } static s7_pointer fx_o_p_p_t(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); - return(((s7_p_p_t)opt2_direct_x_call(cdr(arg)))(sc, slot_value(let_slots(sc->envir)))); + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir)))); } static s7_pointer fx_o_p_p_u(s7_scheme *sc, s7_pointer arg) { check_next_let_slot(sc, __func__, arg, cadr(arg)); - return(((s7_p_p_t)opt2_direct_x_call(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir))))); + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir))))); } -static s7_pointer fx_length_s(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_iterate_p_p(s7_scheme *sc, s7_pointer arg) { - return(s7_length(sc, lookup(sc, cadr(arg)))); + s7_pointer iter; + iter = lookup(sc, cadr(arg)); + if (is_iterator(iter)) + return((iterator_next(iter))(sc, iter)); + return(method_or_bust_one_arg(sc, iter, sc->iterate_symbol, set_plist_1(sc, iter), T_ITERATOR)); } +static s7_pointer fx_length_s(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, lookup(sc, cadr(arg))));} +static s7_pointer fx_length_t(s7_scheme *sc, s7_pointer arg) {check_let_slots(sc, __func__, arg, cadr(arg)); return(s7_length(sc, slot_value(let_slots(sc->envir))));} + #if (!WITH_GMP) static s7_pointer fx_num_eq_length_i(s7_scheme *sc, s7_pointer arg) { @@ -50531,13 +50978,13 @@ static s7_pointer fx_is_symbol_t(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_is_type_s(s7_scheme *sc, s7_pointer arg) { - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(lookup(sc, cadr(arg))))); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(lookup(sc, cadr(arg))))); } static s7_pointer fx_is_type_t(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(slot_value(let_slots(sc->envir))))); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(slot_value(let_slots(sc->envir))))); } static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg) @@ -50554,6 +51001,12 @@ 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) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + return((is_string(slot_value(let_slots(sc->envir)))) ? 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); @@ -50641,6 +51094,12 @@ static s7_pointer fx_not_is_symbol_s(s7_scheme *sc, s7_pointer arg) return((is_symbol(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T); } +static s7_pointer fx_not_is_symbol_t(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, opt3_sym(arg)); + return((is_symbol(slot_value(let_slots(sc->envir)))) ? sc->F : sc->T); +} + static s7_pointer fx_c_sc(s7_scheme *sc, s7_pointer arg) { set_car(sc->t2_1, lookup(sc, cadr(arg))); @@ -50656,6 +51115,45 @@ static s7_pointer fx_c_tc(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +#if (!WITH_GMP) +static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir)), opt2_con(cdr(arg)))); +} + +static s7_pointer fx_vector_ref_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + return(vector_ref_p_pi(sc, slot_value(let_slots(sc->envir)), integer(opt2_con(cdr(arg))))); +} + +#if 0 +static s7_pointer fx_vector_ref_a_to_a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer body; + body = closure_body(opt1_lambda(arg)); + check_let_slots(sc, __func__, arg, cadar(body)); + return(vector_ref_p_pi(sc, fx_call(sc, cdr(arg)), integer(opt2_con(cdar(body))))); +} +#endif +#endif + +static s7_pointer fx_c_uc(s7_scheme *sc, s7_pointer arg) /* few hits */ +{ + check_next_let_slot(sc, __func__, arg, cadr(arg)); + set_car(sc->t2_1, slot_value(next_slot(let_slots(sc->envir)))); + set_car(sc->t2_2, opt2_con(cdr(arg))); + return(c_call(arg)(sc, sc->t2_1)); +} + +#if 0 +static s7_pointer fx_c_sc_direct(s7_scheme *sc, s7_pointer arg) +{ + return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), opt2_any(cdr(arg)))); +} +#endif + static s7_pointer fx_char_equal_tc(s7_scheme *sc, s7_pointer arg) { s7_pointer c; @@ -50683,6 +51181,12 @@ static s7_pointer fx_c_ct(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_ct_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, caddr(arg)); + return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, opt1_con(cdr(arg)), slot_value(let_slots(sc->envir)))); +} + static s7_pointer fx_c_cu(s7_scheme *sc, s7_pointer arg) { check_next_let_slot(sc, __func__, arg, caddr(arg)); @@ -50706,19 +51210,24 @@ static s7_pointer fx_c_st(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_gt(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, opt2_sym(cdr(arg))); + set_car(sc->t2_1, lookup_global(sc, cadr(arg))); + set_car(sc->t2_2, slot_value(let_slots(sc->envir))); + return(c_call(arg)(sc, sc->t2_1)); +} -static s7_pointer fx_c_Wt(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_c_Wt_direct(s7_scheme *sc, s7_pointer arg) { - s7_pointer old_e; + s7_pointer old_e, W; old_e = sc->envir; sc->envir = outlet(outlet(old_e)); - set_car(sc->t2_1, lookup(sc, cadr(arg))); + W = lookup(sc, cadr(arg)); sc->envir = old_e; - set_car(sc->t2_2, slot_value(let_slots(sc->envir))); - return(c_call(arg)(sc, sc->t2_1)); + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, W, slot_value(let_slots(sc->envir)))); } - static s7_pointer fx_c_ts(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); @@ -50830,11 +51339,11 @@ static s7_pointer fx_subtract_fs(s7_scheme *sc, s7_pointer arg) } static s7_pointer fx_multiply_ss(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer arg) {return(g_mul_sfs(sc, lookup(sc, caddr(arg)), real(cadr(arg))));} -static s7_pointer fx_multiply_sf(s7_scheme *sc, s7_pointer arg) {return(g_mul_sfs(sc, lookup(sc, cadr(arg)), real(caddr(arg))));} +static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, caddr(arg)), real(cadr(arg))));} +static s7_pointer fx_multiply_sf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, cadr(arg)), real(caddr(arg))));} -static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer arg) {return(g_mul_sis(sc, lookup(sc, cadr(arg)), integer(caddr(arg)), arg));} -static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_sis(sc, lookup(sc, caddr(arg)), integer(cadr(arg)), arg));} +static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, cadr(arg)), integer(caddr(arg)), arg));} +static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, caddr(arg)), integer(cadr(arg)), arg));} static s7_pointer fx_multiply_tu(s7_scheme *sc, s7_pointer arg) { @@ -50923,13 +51432,44 @@ static s7_pointer fx_gt_ss(s7_scheme *sc, s7_pointer arg) return(gt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); } -static s7_pointer fx_gt_tu(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_gt_ts(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + return(gt_p_pp(sc, slot_value(let_slots(sc->envir)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_gt_tg(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + return(gt_p_pp(sc, slot_value(let_slots(sc->envir)), slot_value(global_slot(opt2_sym(cdr(arg)))))); +} + +static s7_pointer fx_gt_tT(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + check_outer_let_slots(sc, __func__, arg, caddr(arg)); + return(gt_p_pp(sc, slot_value(let_slots(sc->envir)), slot_value(let_slots(outlet(sc->envir))))); +} + + static s7_pointer fx_gt_tu(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, cadr(arg)); check_next_let_slot(sc, __func__, arg, caddr(arg)); return(gt_p_pp(sc, slot_value(let_slots(sc->envir)), slot_value(next_slot(let_slots(sc->envir))))); } +static s7_pointer fx_gt_ti(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x; + check_let_slots(sc, __func__, arg, cadr(arg)); + x = slot_value(let_slots(sc->envir)); + if (is_t_integer(x)) + return(make_boolean(sc, integer(x) > integer(opt2_con(cdr(arg))))); + set_car(sc->t2_1, x); + set_car(sc->t2_2, opt2_con(cdr(arg))); + return(g_greater_xi(sc, sc->t2_1)); +} + static s7_pointer fx_leq_ss(s7_scheme *sc, s7_pointer arg) { return(leq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); @@ -50942,6 +51482,18 @@ static s7_pointer fx_leq_tu(s7_scheme *sc, s7_pointer arg) return(leq_p_pp(sc, slot_value(let_slots(sc->envir)), slot_value(next_slot(let_slots(sc->envir))))); } +static s7_pointer fx_leq_ti(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x; + check_let_slots(sc, __func__, arg, cadr(arg)); + x = slot_value(let_slots(sc->envir)); + if (is_t_integer(x)) + return(make_boolean(sc, integer(x) <= integer(opt2_con(cdr(arg))))); + set_car(sc->t2_1, x); + set_car(sc->t2_2, opt2_con(cdr(arg))); + return(g_leq_xi(sc, sc->t2_1)); +} + static s7_pointer fx_lt_ss(s7_scheme *sc, s7_pointer arg) { return(lt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); @@ -51005,7 +51557,12 @@ static s7_pointer fx_geq_ti(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_num_eq_ss(s7_scheme *sc, s7_pointer arg) { - return(c_num_eq_2(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); + s7_pointer x, y; + x = lookup(sc, cadr(arg)); + y = lookup(sc, opt2_sym(cdr(arg))); + if ((is_t_integer(x)) && (is_t_integer(y))) + return(make_boolean(sc, integer(x) == integer(y))); + return(num_eq_p_pp(sc, x, y)); } static s7_pointer fx_num_eq_ts(s7_scheme *sc, s7_pointer arg) @@ -51016,7 +51573,18 @@ static s7_pointer fx_num_eq_ts(s7_scheme *sc, s7_pointer arg) y = lookup(sc, opt2_sym(cdr(arg))); if ((is_t_integer(x)) && (is_t_integer(y))) return(make_boolean(sc, integer(x) == integer(y))); - return(c_num_eq_2(sc, x, y)); + return(num_eq_p_pp(sc, x, y)); +} + +static s7_pointer fx_num_eq_tg(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x, y; + check_let_slots(sc, __func__, arg, cadr(arg)); + x = slot_value(let_slots(sc->envir)); + y = slot_value(global_slot(opt2_sym(cdr(arg)))); + if ((is_t_integer(x)) && (is_t_integer(y))) + return(make_boolean(sc, integer(x) == integer(y))); + return(num_eq_p_pp(sc, x, y)); } static s7_pointer fx_num_eq_tT(s7_scheme *sc, s7_pointer arg) @@ -51028,7 +51596,7 @@ static s7_pointer fx_num_eq_tT(s7_scheme *sc, s7_pointer arg) y = slot_value(let_slots(outlet(sc->envir))); if ((is_t_integer(x)) && (is_t_integer(y))) return(make_boolean(sc, integer(x) == integer(y))); - return(c_num_eq_2(sc, x, y)); + return(num_eq_p_pp(sc, x, y)); } static s7_pointer fx_num_eq_tu(s7_scheme *sc, s7_pointer arg) @@ -51040,7 +51608,7 @@ static s7_pointer fx_num_eq_tu(s7_scheme *sc, s7_pointer arg) y = slot_value(next_slot(let_slots(sc->envir))); if ((is_t_integer(x)) && (is_t_integer(y))) return(make_boolean(sc, integer(x) == integer(y))); - return(c_num_eq_2(sc, x, y)); + return(num_eq_p_pp(sc, x, y)); } static s7_pointer fx_num_eq_us(s7_scheme *sc, s7_pointer arg) @@ -51051,7 +51619,7 @@ static s7_pointer fx_num_eq_us(s7_scheme *sc, s7_pointer arg) y = lookup(sc, opt2_sym(cdr(arg))); if ((is_t_integer(x)) && (is_t_integer(y))) return(make_boolean(sc, integer(x) == integer(y))); - return(c_num_eq_2(sc, x, y)); + return(num_eq_p_pp(sc, x, y)); } #endif @@ -51100,11 +51668,9 @@ static s7_pointer fx_not_is_eq_sq(s7_scheme *sc, s7_pointer arg) static s7_pointer x_hash_table_ref_ss(s7_scheme *sc, s7_pointer table, s7_pointer key) { - hash_entry_t *x; if (!is_hash_table(table)) return(g_hash_table_ref(sc, set_plist_2(sc, table, key))); - x = (*hash_table_checker(table))(sc, table, key); - return(hash_entry_value(x)); + return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); } static s7_pointer fx_hash_table_ref_ss(s7_scheme *sc, s7_pointer arg) @@ -51121,8 +51687,7 @@ static s7_pointer fx_hash_table_ref_st(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_hash_table_ref_car(s7_scheme *sc, s7_pointer arg) { s7_pointer table, lst; - hash_entry_t *x; - + table = lookup(sc, cadr(arg)); lst = lookup(sc, opt2_sym(cdr(arg))); if (!is_pair(lst)) @@ -51131,18 +51696,16 @@ static s7_pointer fx_hash_table_ref_car(s7_scheme *sc, s7_pointer arg) if (!is_hash_table(table)) return(g_hash_table_ref(sc, set_plist_2(sc, table, car(lst)))); - x = (*hash_table_checker(table))(sc, table, car(lst)); - return(hash_entry_value(x)); + return(hash_entry_value((*hash_table_checker(table))(sc, table, car(lst)))); } static s7_pointer fx_lint_let_ref(s7_scheme *sc, s7_pointer arg) { s7_pointer lt, sym, y; - check_let_slots(sc, __func__, arg, cadadr(arg)); - lt = cdr(slot_value(let_slots(sc->envir))); + lt = cdr(lookup(sc, opt2_sym(arg))); /* TODO: this is sometimes slot_value(let_slots(sc->envir)); */ if (!is_let(lt)) return(wrong_type_argument_with_type(sc, sc->let_ref_symbol, 1, lt, a_let_string)); - sym = opt3_sym(cdr(arg)); /* cadaddr(arg); */ + sym = opt3_sym(cdar(closure_body(opt1_lambda(arg)))); for (y = let_slots(lt); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) return(slot_value(y)); @@ -51319,6 +51882,12 @@ static s7_pointer fx_c_optq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } +static s7_pointer fx_c_optq_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadadr(arg)); + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir))))); +} + static s7_pointer fx_c_car_s(s7_scheme *sc, s7_pointer arg) { s7_pointer val; @@ -51365,14 +51934,14 @@ static s7_pointer fx_c_cdr_t(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_is_type_opsq(s7_scheme *sc, s7_pointer arg) { set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(arg)))); - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(c_call(cadr(arg))(sc, sc->t1_1)))); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(c_call(cadr(arg))(sc, sc->t1_1)))); } static s7_pointer fx_is_type_optq(s7_scheme *sc, s7_pointer arg) { check_let_slots(sc, __func__, arg, opt2_sym(cdr(arg))); set_car(sc->t1_1, slot_value(let_slots(sc->envir))); - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(c_call(cadr(arg))(sc, sc->t1_1)))); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(c_call(cadr(arg))(sc, sc->t1_1)))); } static s7_pointer fx_is_type_car_s(s7_scheme *sc, s7_pointer arg) @@ -51380,8 +51949,8 @@ static s7_pointer fx_is_type_car_s(s7_scheme *sc, s7_pointer arg) s7_pointer val; val = lookup(sc, opt2_sym(cdr(arg))); if (is_pair(val)) - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(car(val)))); - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(g_car(sc, set_plist_1(sc, val))))); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(car(val)))); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(g_car(sc, set_plist_1(sc, val))))); } static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) @@ -51390,19 +51959,47 @@ static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) check_let_slots(sc, __func__, arg, cadadr(arg)); val = slot_value(let_slots(sc->envir)); if (is_pair(val)) - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(car(val)))); - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(g_car(sc, set_plist_1(sc, val))))); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(car(val)))); + + if (has_active_methods(sc, val)) + { + s7_pointer func; + func = find_method(sc, val, sc->car_symbol); + if (func != sc->undefined) + return(make_boolean(sc, type(s7_apply_function(sc, func, list_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); + } + return(wrong_type_argument(sc, sc->car_symbol, 1, val, T_PAIR)); } -static s7_pointer fx_c_weak1_type(s7_scheme *sc, s7_pointer arg) +static s7_pointer fx_c_weak1_type_s(s7_scheme *sc, s7_pointer arg) { s7_pointer val; val = lookup(sc, opt2_sym(cdr(arg))); if (is_c_pointer(val)) /* (let? (c-pointer-weak1 val)) etc */ - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(c_pointer_weak1(val)))); - return(make_boolean(sc, (uint8_t)(opt3_con(cdr(arg))) == type(c_pointer_weak1_p_p(sc, val)))); + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(c_pointer_weak1(val)))); + + if (has_active_methods(sc, val)) + { + s7_pointer func; + func = find_method(sc, val, sc->c_pointer_weak1_symbol); + if (func != sc->undefined) + return(make_boolean(sc, type(s7_apply_function(sc, func, list_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); + } + return(wrong_type_argument(sc, sc->c_pointer_weak1_symbol, 1, val, T_C_POINTER)); } +#if 0 +static s7_pointer fx_c_weak1_type_t(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer val; + check_let_slots(sc, __func__, arg, cadadr(arg)); + val = slot_value(let_slots(sc->envir)); + if (is_c_pointer(val)) /* (let? (c-pointer-weak1 val)) etc */ + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(c_pointer_weak1(val)))); + return(method_or_bust(sc, val, sc->c_pointer_weak1_symbol, list_1(sc, val), T_C_POINTER, 1)); +} +#endif + static s7_pointer fx_not_opsq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -51422,6 +52019,16 @@ static s7_pointer fx_c_opssq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t1_1)); } +static s7_pointer fx_c_optuq(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(cadr(arg))); + check_next_let_slot(sc, __func__, arg, caddr(cadr(arg))); + set_car(sc->t2_1, slot_value(let_slots(sc->envir))); + set_car(sc->t2_2, slot_value(next_slot(let_slots(sc->envir)))); + set_car(sc->t1_1, c_call(cadr(arg))(sc, sc->t2_1)); + return(c_call(arg)(sc, sc->t1_1)); +} + static s7_pointer fx_c_opstq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -51435,8 +52042,8 @@ static s7_pointer fx_c_opstq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_opstq_direct(s7_scheme *sc, s7_pointer arg) { - return(((s7_p_p_t)opt2_direct_x_call(cdr(arg)))(sc, - ((s7_p_pp_t)opt3_direct_x(cdr(arg)))(sc, lookup(sc, cadadr(arg)), slot_value(let_slots(sc->envir))))); + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadadr(arg)), slot_value(let_slots(sc->envir))))); } static s7_pointer fx_not_opssq(s7_scheme *sc, s7_pointer arg) @@ -51449,6 +52056,7 @@ static s7_pointer fx_not_opssq(s7_scheme *sc, s7_pointer arg) return(sc->F); } +#if (!WITH_GMP) static s7_pointer fx_not_oputq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -51461,7 +52069,6 @@ static s7_pointer fx_not_oputq(s7_scheme *sc, s7_pointer arg) return(sc->F); } -#if (!WITH_GMP) static s7_pointer fx_not_lt_ut(s7_scheme *sc, s7_pointer arg) { s7_pointer x, y; @@ -51532,11 +52139,20 @@ static s7_pointer fx_c_opssq_s_direct(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; largs = cdadr(arg); - return(((s7_p_pp_t)opt2_direct_x_call(cdr(arg)))(sc, - ((s7_p_pp_t)opt3_direct_x(cdr(arg)))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); } +static s7_pointer fx_c_opgsq_t_direct(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer largs; + largs = cdadr(arg); + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, slot_value(global_slot(car(largs))), lookup(sc, opt2_sym(largs))), + slot_value(let_slots(sc->envir)))); +} + static s7_pointer fx_c_opscq_c(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; @@ -51641,6 +52257,12 @@ static s7_pointer fx_c_optq_c(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_optq_c_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, opt1_con(cdr(arg))); + return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir))), opt2_con(cdr(arg)))); +} + static s7_pointer fx_memq_car_s(s7_scheme *sc, s7_pointer arg) { s7_pointer x, obj; @@ -51685,8 +52307,8 @@ static s7_pointer fx_c_s_opssq_direct(s7_scheme *sc, s7_pointer arg) s7_pointer largs; arg = cdr(arg); largs = cdadr(arg); - return(((s7_p_pp_t)opt2_direct_x_call(arg))(sc, lookup(sc, car(arg)), - ((s7_p_pp_t)opt3_direct_x(arg))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); + return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)), + ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))))); } #if (!WITH_GMP) @@ -51699,7 +52321,7 @@ static s7_pointer fx_num_eq_add_ss(s7_scheme *sc, s7_pointer arg) z = lookup(sc, cadr(arg)); if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) return(make_boolean(sc, (integer(x) + integer(y)) == integer(z))); - return(c_num_eq_2(sc, z, add_p_pp(sc, x, y))); + return(num_eq_p_pp(sc, z, add_p_pp(sc, x, y))); } #endif @@ -51714,15 +52336,15 @@ static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer direct_x_c_c_opssq(s7_scheme *sc, s7_pointer arg) +static s7_pointer direct_c_c_opssq(s7_scheme *sc, s7_pointer arg) { s7_pointer largs; s7_double x2; arg = cdr(arg); largs = cdadr(arg); - x2 = ((s7_d_pd_t)opt3_direct_x(cdr(arg)))(lookup(sc, car(largs)), + x2 = ((s7_d_pd_t)opt3_direct(cdr(arg)))(lookup(sc, car(largs)), real_to_double(sc, lookup(sc, opt2_sym(largs)), "number_to_double")); - return(((s7_p_dd_t)opt2_direct_x_call(arg))(sc, real_to_double(sc, car(arg), "*"), x2)); + return(((s7_p_dd_t)opt2_direct(arg))(sc, real_to_double(sc, car(arg), "*"), x2)); } static s7_pointer fx_c_s_opscq(s7_scheme *sc, s7_pointer arg) @@ -51746,6 +52368,20 @@ static s7_pointer fx_c_s_opsq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_s_opsq_direct(s7_scheme *sc, s7_pointer arg) +{ + arg = cdr(arg); + return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup(sc, car(arg)), ((s7_p_p_t)opt3_direct(arg))(sc, lookup(sc, cadadr(arg))))); +} + +static s7_pointer fx_c_t_opuq_direct(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(arg)); + check_next_let_slot(sc, __func__, arg, cadr(caddr(arg))); + arg = cdr(arg); + return(((s7_p_pp_t)opt2_direct(arg))(sc, slot_value(let_slots(sc->envir)), ((s7_p_p_t)opt3_direct(arg))(sc, slot_value(next_slot(let_slots(sc->envir)))))); +} + static s7_pointer fx_c_s_car_s(s7_scheme *sc, s7_pointer arg) { s7_pointer val; @@ -51826,14 +52462,25 @@ static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } -static s7_pointer direct_x_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) +#if 0 +static s7_pointer fx_c_c_optq(s7_scheme *sc, s7_pointer arg) +{ + check_let_slots(sc, __func__, arg, cadr(caddr(arg))); + set_car(sc->t1_1, slot_value(let_slots(sc->envir))); + set_car(sc->t2_2, c_call(caddr(arg))(sc, sc->t1_1)); + set_car(sc->t2_1, cadr(arg)); + return(c_call(arg)(sc, sc->t2_1)); +} +#endif + +static s7_pointer direct_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) { s7_double x1, x2; s7_pointer p; p = cdr(arg); - x1 = ((s7_d_p_t)opt3_direct_x(p))(lookup(sc, cadar(p))); - x2 = ((s7_d_p_t)opt3_direct_x(cdr(p)))(lookup(sc, cadadr(p))); - return(((s7_p_dd_t)opt2_direct_x_call(p))(sc, x1, x2)); + x1 = ((s7_d_p_t)opt3_direct(p))(lookup(sc, cadar(p))); + x2 = ((s7_d_p_t)opt3_direct(cdr(p)))(lookup(sc, cadadr(p))); + return(((s7_p_dd_t)opt2_direct(p))(sc, x1, x2)); } static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) @@ -51973,6 +52620,18 @@ static s7_pointer fx_c_s_op_s_opssqq(s7_scheme *sc, s7_pointer code) return(c_call(code)(sc, sc->t2_1)); } +static s7_pointer fx_c_s_op_s_opssqq_direct(s7_scheme *sc, s7_pointer code) +{ + s7_pointer args, val1; + args = caddr(code); + val1 = caddr(args); + return(((s7_p_pp_t)opt3_direct(code))(sc, + lookup(sc, cadr(code)), + ((s7_p_pp_t)opt2_direct(cdr(code)))(sc, + lookup(sc, cadr(args)), + ((s7_p_pp_t)opt3_direct(cdr(code)))(sc, lookup(sc, cadr(val1)), lookup(sc, caddr(val1)))))); +} + static s7_pointer fx_c_op_opsq_q_c(s7_scheme *sc, s7_pointer code) { s7_pointer arg; @@ -51997,50 +52656,69 @@ static s7_pointer fx_not_a(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_ssa(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t3_3, fx_call(sc, cdddr(arg))); + s7_pointer p; + p = cddr(arg); + set_car(sc->t3_3, fx_call(sc, cdr(p))); set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_2, lookup(sc, caddr(arg))); + set_car(sc->t3_2, lookup(sc, car(p))); return(c_call(arg)(sc, sc->t3_1)); } +static s7_pointer fx_c_ssa_direct(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p; + p = cddr(arg); + return(((s7_p_ppp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, car(p)), fx_call(sc, cdr(p)))); +} + static s7_pointer fx_c_sas(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t3_2, fx_call(sc, cddr(arg))); + s7_pointer p; + p = cddr(arg); + set_car(sc->t3_2, fx_call(sc, p)); set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_3, lookup(sc, cadddr(arg))); + set_car(sc->t3_3, lookup(sc, cadr(p))); return(c_call(arg)(sc, sc->t3_1)); } static s7_pointer fx_c_sca(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t3_3, fx_call(sc, cdddr(arg))); + s7_pointer p; + p = cddr(arg); + set_car(sc->t3_3, fx_call(sc, cdr(p))); set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_2, caddr(arg)); + set_car(sc->t3_2, car(p)); return(c_call(arg)(sc, sc->t3_1)); } static s7_pointer fx_c_Tca(s7_scheme *sc, s7_pointer arg) { + s7_pointer p; + p = cddr(arg); check_outer_let_slots(sc, __func__, arg, cadr(arg)); - set_car(sc->t3_3, fx_call(sc, cdddr(arg))); + set_car(sc->t3_3, fx_call(sc, cdr(p))); set_car(sc->t3_1, slot_value(let_slots(outlet(sc->envir)))); - set_car(sc->t3_2, caddr(arg)); + set_car(sc->t3_2, car(p)); return(c_call(arg)(sc, sc->t3_1)); } static s7_pointer fx_c_csa(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t3_3, fx_call(sc, cdddr(arg))); + s7_pointer p; + p = cddr(arg); + set_car(sc->t3_3, fx_call(sc, cdr(p))); set_car(sc->t3_1, cadr(arg)); - set_car(sc->t3_2, lookup(sc, caddr(arg))); + set_car(sc->t3_2, lookup(sc, car(p))); return(c_call(arg)(sc, sc->t3_1)); } static s7_pointer fx_c_cac(s7_scheme *sc, s7_pointer arg) { - set_car(sc->t3_2, fx_call(sc, cddr(arg))); + s7_pointer p; + p = cddr(arg); + set_car(sc->t3_2, fx_call(sc, p)); set_car(sc->t3_1, cadr(arg)); - set_car(sc->t3_3, cadddr(arg)); + set_car(sc->t3_3, cadr(p)); return(c_call(arg)(sc, sc->t3_1)); } @@ -52063,6 +52741,15 @@ static s7_pointer fx_c_sa(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t2_1)); } +static s7_pointer fx_c_as(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer a1; + a1 = cdr(arg); + set_car(sc->t2_1, fx_call(sc, a1)); + set_car(sc->t2_2, lookup(sc, cadr(a1))); + return(c_call(arg)(sc, sc->t2_1)); +} + static s7_pointer fx_add_aa(s7_scheme *sc, s7_pointer arg) { s7_pointer a1, a2; @@ -52116,6 +52803,16 @@ static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg) return(c_call(arg)(sc, sc->t3_1)); } +static s7_pointer fx_c_gac(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p; + p = cdr(arg); + set_car(sc->t3_2, fx_call(sc, cdr(p))); + set_car(sc->t3_3, caddr(p)); + set_car(sc->t3_1, lookup_global(sc, car(p))); + return(c_call(arg)(sc, sc->t3_1)); +} + /* add s_opaaq opaaaq s_opaaaq aaaa all_ca check ifa_ss_a */ /* op_safe_c_* for these below */ @@ -52269,7 +52966,7 @@ static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_op_opssq_q_s(s7_scheme *sc, s7_pointer code) { s7_pointer arg; - arg = opt3_pair(code); /* cadadr(code); */ + arg = opt1_pair(cdr(code)); set_car(sc->t2_1, lookup(sc, cadr(arg))); set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg)))); set_car(sc->t1_1, c_call(arg)(sc, sc->t2_1)); @@ -52278,6 +52975,16 @@ static s7_pointer fx_c_op_opssq_q_s(s7_scheme *sc, s7_pointer code) return(c_call(code)(sc, sc->t2_1)); } +static s7_pointer fx_c_op_opssq_q_s_direct(s7_scheme *sc, s7_pointer code) +{ + s7_pointer arg; + arg = opt1_pair(cdr(code)); + return(((s7_p_pp_t)opt3_direct(code))(sc, + ((s7_p_p_t)opt2_direct(cdr(code)))(sc, + ((s7_p_pp_t)opt3_direct(cdr(code)))(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)))), + lookup(sc, caddr(code)))); +} + static s7_pointer fx_c_op_opssq_sq_s(s7_scheme *sc, s7_pointer code) { s7_pointer arg; @@ -52375,9 +53082,8 @@ static s7_pointer fx_if_a_aa(s7_scheme *sc, s7_pointer arg) s7_pointer p; p = cdr(arg); if (is_true(sc, fx_call(sc, p))) - p = cdr(p); - else p = cddr(p); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(p))); + return(fx_call(sc, cddr(p))); } static s7_pointer fx_and_2(s7_scheme *sc, s7_pointer arg) @@ -52387,8 +53093,16 @@ static s7_pointer fx_and_2(s7_scheme *sc, s7_pointer arg) p = cdr(arg); val = fx_call(sc, p); if (val == sc->F) return(val); - p = cdr(p); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(p))); +} + +static s7_pointer fx_and_s_2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x; + set_car(sc->t1_1, lookup(sc, cadadr(arg))); + x = c_call(cadr(arg))(sc, sc->t1_1); + if (x == sc->F) return(x); + return(c_call(caddr(arg))(sc, sc->t1_1)); } static s7_pointer fx_and_3(s7_scheme *sc, s7_pointer arg) @@ -52400,8 +53114,7 @@ static s7_pointer fx_and_3(s7_scheme *sc, s7_pointer arg) p = cdr(p); val = fx_call(sc, p); if (val == sc->F) return(val); - p = cdr(p); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(p))); } static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer arg) @@ -52417,19 +53130,29 @@ static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer arg) return(x); } -static s7_pointer fx_x(s7_scheme *sc, s7_pointer arg) -{ - return(fx_call(sc, arg)); -} - static s7_pointer fx_or_2(s7_scheme *sc, s7_pointer arg) { s7_pointer p, val; p = cdr(arg); val = fx_call(sc, p); if (val != sc->F) return(val); - p = cdr(p); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(p))); +} + +static s7_pointer fx_or_s_2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x; + set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg))); */ + x = c_call(cadr(arg))(sc, sc->t1_1); + if (x != sc->F) return(x); + return(c_call(caddr(arg))(sc, sc->t1_1)); +} + +static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x; + x = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg)); */ + return(make_boolean(sc, (type(x) == integer(opt3_any(arg))) || (type(x) == integer(opt2_any(cdr(arg)))))); } static s7_pointer fx_or_and_2(s7_scheme *sc, s7_pointer arg) @@ -52441,8 +53164,7 @@ static s7_pointer fx_or_and_2(s7_scheme *sc, s7_pointer arg) p = cdadr(p); val = fx_call(sc, p); if (val == sc->F) return(val); - p = cdr(p); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(p))); } static s7_pointer fx_or_and_3(s7_scheme *sc, s7_pointer arg) @@ -52457,8 +53179,7 @@ static s7_pointer fx_or_and_3(s7_scheme *sc, s7_pointer arg) p = cdr(p); val = fx_call(sc, p); if (val == sc->F) return(val); - p = cdr(p); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(p))); } static s7_pointer fx_or_3(s7_scheme *sc, s7_pointer arg) @@ -52470,8 +53191,7 @@ static s7_pointer fx_or_3(s7_scheme *sc, s7_pointer arg) p = cdr(p); val = fx_call(sc, p); if (val != sc->F) return(val); - p = cdr(p); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(p))); } static s7_pointer fx_or_n(s7_scheme *sc, s7_pointer arg) @@ -52489,134 +53209,160 @@ static s7_pointer fx_or_n(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_thunk_a(s7_scheme *sc, s7_pointer code) { - s7_pointer f, result, old_e; - old_e = sc->envir; + s7_pointer f, result; + gc_protect_direct(sc, sc->envir); f = opt1_lambda(code); sc->envir = closure_let(f); - code = closure_body(f); - result = fx_call(sc, code); - sc->envir = old_e; + result = fx_call(sc, closure_body(f)); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } -static s7_pointer fx_closure_s_a(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */ { - s7_pointer result, old_e; - old_e = sc->envir; + s7_pointer result; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - code = closure_body(opt1_lambda(code)); - result = fx_call(sc, code); - sc->envir = old_e; + result = fx_call(sc, closure_body(opt1_lambda(code))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } -static s7_pointer fx_closure_t_a(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code) { - s7_pointer result, old_e; + s7_pointer result; check_let_slots(sc, __func__, code, opt2_sym(code)); - old_e = sc->envir; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), slot_value(let_slots(sc->envir))); - code = closure_body(opt1_lambda(code)); - result = fx_call(sc, code); - sc->envir = old_e; + result = fx_call(sc, closure_body(opt1_lambda(code))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } +static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer arg) +{ + set_car(sc->t1_1, lookup(sc, opt2_sym(arg))); + return(c_call(car(closure_body(opt1_lambda(arg))))(sc, sc->t1_1)); +} + static s7_pointer fx_c_closure_s_a(s7_scheme *sc, s7_pointer arg) { - s7_pointer old_e, clo_arg; + s7_pointer clo_arg; clo_arg = cadr(arg); - old_e = sc->envir; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(clo_arg)), lookup(sc, opt2_sym(clo_arg))); - clo_arg = closure_body(opt1_lambda(clo_arg)); - set_car(sc->t1_1, fx_call(sc, clo_arg)); - sc->envir = old_e; + set_car(sc->t1_1, fx_call(sc, closure_body(opt1_lambda(clo_arg)))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(c_call(arg)(sc, sc->t1_1)); } -static s7_pointer fx_closure_s_d(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_safe_closure_s_d(s7_scheme *sc, s7_pointer code) { - s7_pointer result, old_e; - old_e = sc->envir; + s7_pointer result; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - code = closure_body(opt1_lambda(code)); - result = d_call(sc, car(code)); - sc->envir = old_e; + result = d_call(sc, car(closure_body(opt1_lambda(code)))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } -static s7_pointer fx_closure_t_d(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_safe_closure_t_d(s7_scheme *sc, s7_pointer code) { - s7_pointer result, old_e; + s7_pointer result; check_let_slots(sc, __func__, code, opt2_sym(code)); - old_e = sc->envir; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), slot_value(let_slots(sc->envir))); - code = closure_body(opt1_lambda(code)); - result = d_call(sc, car(code)); - sc->envir = old_e; + result = d_call(sc, car(closure_body(opt1_lambda(code)))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } static s7_pointer fx_c_closure_s_d(s7_scheme *sc, s7_pointer arg) { - s7_pointer old_e, clo_arg; + s7_pointer clo_arg; clo_arg = cadr(arg); - old_e = sc->envir; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(clo_arg)), lookup(sc, opt2_sym(clo_arg))); - clo_arg = closure_body(opt1_lambda(clo_arg)); - set_car(sc->t1_1, d_call(sc, car(clo_arg))); - sc->envir = old_e; + set_car(sc->t1_1, d_call(sc, car(closure_body(opt1_lambda(clo_arg))))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(c_call(arg)(sc, sc->t1_1)); } static s7_pointer fx_and_2_closure_s(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is g_and_2 */ { - s7_pointer result, old_e; - old_e = sc->envir; + s7_pointer result; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); code = cdar(closure_body(opt1_lambda(code))); result = fx_call(sc, code); if (result != sc->F) result = fx_call(sc, cdr(code)); - sc->envir = old_e; + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } static s7_pointer fx_and_pair_closure_s(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is g_and_2 with is_pair as first clause */ { - s7_pointer result, old_e; - old_e = sc->envir; + s7_pointer result; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); code = cdar(closure_body(opt1_lambda(code))); if (is_pair(slot_value(let_slots(sc->envir)))) /* pair? arg = func par, pair? is global, symbol_id=0 */ result = fx_call(sc, cdr(code)); else result = sc->F; - sc->envir = old_e; + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } -static s7_pointer fx_closure_a_a(s7_scheme *sc, s7_pointer code) +/* here fx_and_2|3 lg, vector_ref_direct and fx_is_eq_ts b */ +static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer code) { - s7_pointer result, old_e; - old_e = sc->envir; + s7_pointer result; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))); - code = closure_body(opt1_lambda(code)); - result = fx_call(sc, code); - sc->envir = old_e; + result = fx_call(sc, closure_body(opt1_lambda(code))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } -static s7_pointer fx_closure_ss_a(s7_scheme *sc, s7_pointer code) +static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) { - s7_pointer result, old_e; - old_e = sc->envir; + s7_pointer result; + gc_protect_direct(sc, sc->envir); sc->envir = old_frame_with_two_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code))); - code = closure_body(opt1_lambda(code)); - result = fx_call(sc, code); - sc->envir = old_e; + result = fx_call(sc, closure_body(opt1_lambda(code))); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; return(result); } +/* fx_c_s b, dx_c+fx_cdr_s->fx_tc_if_a_laa_z lg */ +static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer p; + p = cdr(code); + gc_protect_direct(sc, sc->envir); + sc->stack_end[-4] = fx_call(sc, cdr(p)); + sc->stack_end[-3] = fx_call(sc, p); + p = opt1_lambda(sc->code); + sc->envir = old_frame_with_two_slots(sc, closure_let(p), sc->stack_end[-3], sc->stack_end[-4]); + p = fx_call(sc, closure_body(p)); + sc->envir = sc->stack_end[-2]; + sc->stack_end -= 4; + return(p); +} + + static s7_pointer fx_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer arg); static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg); static s7_pointer fx_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer arg); @@ -52654,7 +53400,6 @@ static void fx_function_init(void) fx_function[i] = NULL; fx_function[HOP_SAFE_C_D] = fx_c_d; - fx_function[HOP_X] = fx_x; fx_function[HOP_SAFE_C_S] = fx_c_s; fx_function[HOP_SAFE_C_opDq] = fx_c_opdq; @@ -52709,6 +53454,8 @@ static void fx_function_init(void) fx_function[HOP_SAFE_C_SCA] = fx_c_sca; fx_function[HOP_SAFE_C_SAS] = fx_c_sas; fx_function[HOP_SAFE_C_SSA] = fx_c_ssa; + fx_function[OP_SSA_DIRECT] = fx_c_ssa_direct; + fx_function[OP_SAFE_C_TUS] = fx_c_tus; fx_function[HOP_SAFE_C_SSC] = fx_c_ssc; fx_function[HOP_SAFE_C_SSS] = fx_c_sss; fx_function[HOP_SAFE_C_SCS] = fx_c_scs; @@ -52733,9 +53480,11 @@ static void fx_function_init(void) fx_function[HOP_SAFE_C_S_opAAAq] = fx_c_s_opaaaq; fx_function[HOP_SAFE_THUNK_A] = fx_thunk_a; - fx_function[HOP_SAFE_CLOSURE_S_A] = fx_closure_s_a; - fx_function[HOP_SAFE_CLOSURE_A_A] = fx_closure_a_a; - fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_closure_ss_a; + fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a; + fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s; + fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a; + fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a; + fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a; fx_function[OP_TC_AND_A_OR_A_LA] = fx_tc_and_a_or_a_la; fx_function[OP_TC_OR_A_AND_A_LA] = fx_tc_or_a_and_a_la; @@ -52769,11 +53518,9 @@ static void fx_function_init(void) static bool is_fxable(s7_scheme *sc, s7_pointer p) { if (!is_pair(p)) return(true); - if ((is_optimized(p)) && + if ((is_optimized(p)) && /* this is needed */ (fx_function[optimize_op(p)])) - { - return(true); - } + return(true); return(is_proper_quote(sc, p)); } @@ -52787,13 +53534,21 @@ static int32_t fx_count(s7_scheme *sc, s7_pointer x) return(count); } +static bool is_code_constant(s7_scheme *sc, s7_pointer p) +{ + if (is_pair(p)) return(car(p) == sc->quote_symbol); + return(is_constant(sc, p)); +} static s7_pointer g_if_a_a(s7_scheme *sc, s7_pointer args); static s7_pointer g_if_a_aa(s7_scheme *sc, s7_pointer args); static s7_pointer g_and_2(s7_scheme *sc, s7_pointer args); +static s7_pointer g_and_s_2(s7_scheme *sc, s7_pointer args); static s7_pointer g_and_3(s7_scheme *sc, s7_pointer args); static s7_pointer g_and_n(s7_scheme *sc, s7_pointer args); static s7_pointer g_or_2(s7_scheme *sc, s7_pointer args); +static s7_pointer g_or_s_2(s7_scheme *sc, s7_pointer args); +static s7_pointer g_or_s_type_2(s7_scheme *sc, s7_pointer args); static s7_pointer g_or_3(s7_scheme *sc, s7_pointer args); static s7_pointer g_or_n(s7_scheme *sc, s7_pointer args); @@ -52801,6 +53556,7 @@ static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code); static s7_p_p_t s7_p_p_function(s7_pointer f); static s7_p_pp_t s7_p_pp_function(s7_pointer f); +static s7_p_ppp_t s7_p_ppp_function(s7_pointer f); static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, safe_sym_t *checker) { @@ -52827,7 +53583,10 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf } if (c_callee(arg) == g_or_3) return(fx_or_3); if (c_callee(arg) == g_or_n) return(fx_or_n); - + if (c_callee(arg) == g_or_s_2) return(fx_or_s_2); + if (c_callee(arg) == g_or_s_type_2) return(fx_or_s_type_2); + if (c_callee(arg) == g_and_s_2) return(fx_and_s_2); + if (c_callee(arg) == g_random_i) return(fx_random_i); return(fx_c_d); case HOP_SAFE_C_S: @@ -52851,7 +53610,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf typ = symbol_type(car(arg)); if (typ > 0) { - set_opt3_con(cdr(arg), typ); + set_opt3_byte(cdr(arg), typ); return(fx_is_type_s); } } @@ -52867,12 +53626,15 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf f = s7_p_p_function(slot_value(global_slot(car(arg)))); if (f) { - set_direct_x_opt(arg); - set_opt2_direct_x_call(cdr(arg), (s7_pointer)f); + set_direct_opt(arg); + set_opt2_direct(cdr(arg), (s7_pointer)f); + if (f == iterate_p_p) + return(fx_iterate_p_p); return(fx_o_p_p_s); } } } + if (is_global(cadr(arg))) return(fx_c_g); return(fx_c_s); case HOP_SAFE_C_SS: @@ -52894,6 +53656,19 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_hash_table_ref_ss); return(fx_c_ss); + case HOP_SAFE_C_SSA: + if (s7_p_ppp_function(slot_value(global_slot(car(arg))))) + { + set_direct_opt(arg); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(slot_value(global_slot(car(arg)))))); + return(fx_c_ssa_direct); + } + return(fx_c_ssa); + + case HOP_SAFE_C_AAA: + if ((c_callee(cdr(arg)) == fx_g) && (c_callee(cdddr(arg)) == fx_c)) return(fx_c_gac); + return(fx_c_aaa); + case HOP_SAFE_C_S_opSSq: #if (!WITH_GMP) { @@ -52909,9 +53684,17 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && (s7_p_pp_function(slot_value(global_slot(caaddr(arg)))))) { - set_direct_x_opt(arg); - set_opt2_direct_x_call(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); - set_opt3_direct_x(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg)))))); +#if 0 + fprintf(stderr, "%s %d, %s %d, %s %d\n", + DISPLAY(cadr(caddr(arg))), is_global(cadr(caddr(arg))), + DISPLAY(caddr(caddr(arg))), is_global(caddr(caddr(arg))), + DISPLAY(cadr(arg)), is_global(cadr(arg))); + /* op_g_opgTq or opg_opgtq or op_g_opgsq */ +#endif + set_direct_opt(arg); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg)))))); + /* fprintf(stderr, "fx_c_s_opssq_direct: %s\n", DISPLAY(arg)); */ return(fx_c_s_opssq_direct); } return(fx_c_s_opssq); @@ -52920,9 +53703,18 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && (s7_p_pp_function(slot_value(global_slot(caadr(arg)))))) { - set_direct_x_opt(arg); - set_opt2_direct_x_call(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); - set_opt3_direct_x(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(arg)))))); +#if 0 + fprintf(stderr, "%s %d, %s %d, %s %d\n", + DISPLAY(cadr(cadr(arg))), is_global(cadr(cadr(arg))), + DISPLAY(caddr(cadr(arg))), is_global(caddr(cadr(arg))), + DISPLAY(caddr(arg)), is_global(caddr(arg))); +#endif + /* op_c_opgsq_t */ + /* also gt_tT gt_tg */ + + set_direct_opt(arg); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(arg)))))); return(fx_c_opssq_s_direct); } return(fx_c_opssq_s); @@ -53020,10 +53812,10 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */ { set_opt2_sym(cdr(arg), cadadr(arg)); - set_opt3_con(cdr(arg), typ); + set_opt3_byte(cdr(arg), typ); if (c_callee(cadr(arg)) == (s7_function)g_c_pointer_weak1) - return(fx_c_weak1_type); - if (caadr(arg) == sc->car_symbol) + return(fx_c_weak1_type_s); + if (caadr(arg) == sc->car_symbol) /* trclo: symbol? integer?, trec: symbol?, lt: symbol? integer? string? */ return(fx_is_type_car_s); return(fx_is_type_opsq); } @@ -53089,6 +53881,21 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_add_s_car_s); return(fx_c_s_car_s); } + + if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && + (s7_p_p_function(slot_value(global_slot(caaddr(arg)))))) + { + set_direct_opt(arg); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caaddr(arg)))))); + return(fx_c_s_opsq_direct); + } +#if 0 + if (!s7_p_pp_function(slot_value(global_slot(car(arg))))) + fprintf(stderr, "no p_pp: %s in %s\n", DISPLAY(car(arg)), DISPLAY(arg)); + if (!s7_p_p_function(slot_value(global_slot(caaddr(arg))))) + fprintf(stderr, "no p_p: %s in %s\n", DISPLAY(caaddr(arg)), DISPLAY(arg)); +#endif return(fx_c_s_opsq); case HOP_SAFE_C_opSq_C: @@ -53159,11 +53966,11 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_c_c_sqr); } #endif - if (has_direct_x_opt(arg)) return(direct_x_c_c_opssq); + if (has_direct_opt(arg)) return(direct_c_c_opssq); return(fx_c_c_opssq); case HOP_SAFE_C_opSq_opSq: - if (has_direct_x_opt(arg)) return(direct_x_c_opsq_opsq); + if (has_direct_opt(arg)) return(direct_c_opsq_opsq); return(fx_c_opsq_opsq); case HOP_SAFE_C_op_opSq_q: @@ -53179,10 +53986,36 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf } return(fx_c_op_opsq_q); + case HOP_SAFE_C_S_op_S_opSSqq: + if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && + (s7_p_pp_function(slot_value(global_slot(caaddr(arg))))) && + (s7_p_pp_function(slot_value(global_slot(caaddr(caddr(arg))))))) + { + set_direct_opt(arg); + set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(caddr(arg))))))); + return(fx_c_s_op_s_opssqq_direct); + } + return(fx_c_s_op_s_opssqq); + + case HOP_SAFE_C_op_opSSq_q_S: + if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) && + (s7_p_p_function(slot_value(global_slot(caadr(arg))))) && + (s7_p_pp_function(slot_value(global_slot(car(cadr(cadr(arg)))))))) + { + set_direct_opt(arg); + set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg)))))); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(arg)))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(cadr(arg))))))); + return(fx_c_op_opssq_q_s_direct); + } + return(fx_c_op_opssq_q_s); + case HOP_SAFE_C_A: if (car(arg) == sc->not_symbol) return(fx_not_a); - if (c_callee(cdr(arg)) == fx_closure_s_d) return(fx_c_closure_s_d); - if (c_callee(cdr(arg)) == fx_closure_s_a) return(fx_c_closure_s_a); + if (c_callee(cdr(arg)) == fx_safe_closure_s_d) return(fx_c_closure_s_d); + if (c_callee(cdr(arg)) == fx_safe_closure_s_a) return(fx_c_closure_s_a); return(fx_c_a); case HOP_SAFE_C_AA: @@ -53191,32 +54024,43 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf if (c_callee(arg) == g_subtract_2) return(fx_subtract_aa); if (c_callee(arg) == g_number_to_string) return(fx_number_to_string_aa); #if WITH_GMP - return((c_callee(arg) == fx_s) ? fx_c_sa : fx_c_aa); + if (c_callee(cdr(arg)) == fx_s) return(fx_c_sa); #else if (c_callee(cdr(arg)) == fx_s) return((c_callee(arg) == g_multiply_2) ? fx_multiply_sa : fx_c_sa); /* watch out for fx_unsafe_s here */ - return((c_callee(arg) == g_multiply_2) ? fx_multiply_aa : fx_c_aa); + if (c_callee(arg) == g_multiply_2) return(fx_multiply_aa); #endif + if (c_callee(cddr(arg)) == fx_s) return(fx_c_as); + return(fx_c_aa); case HOP_SAFE_CLOSURE_S_A: { s7_pointer body; body = car(closure_body(opt1_lambda(arg))); - if ((is_pair(body)) && - (is_h_safe_c_d(body))) + if (is_pair(body)) { - if (c_callee(body) == g_and_2) + if (is_h_safe_c_d(body)) { - if ((caadr(body) == sc->is_pair_symbol) && - (symbol_id(sc->is_pair_symbol) == 0) && + if (c_callee(body) == g_and_2) + { + if ((caadr(body) == sc->is_pair_symbol) && + (symbol_id(sc->is_pair_symbol) == 0) && + (cadadr(body) == car(closure_args(opt1_lambda(arg))))) + return(fx_and_pair_closure_s); + return(fx_and_2_closure_s); + } + return(fx_safe_closure_s_d); + } + if (optimize_op(body) == HOP_SAFE_C_opSq_C) + { + /* fprintf(stderr, "%s %d %s\n", DISPLAY(body), (c_callee(body) == g_lint_let_ref), DISPLAY(closure_args(opt1_lambda(arg)))); */ + if ((c_callee(body) == g_lint_let_ref) && (cadadr(body) == car(closure_args(opt1_lambda(arg))))) - return(fx_and_pair_closure_s); - return(fx_and_2_closure_s); + return(fx_lint_let_ref); } - return(fx_closure_s_d); } - return(fx_closure_s_a); + return(fx_safe_closure_s_a); } - + default: /* if ((!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], DISPLAY(arg)); */ return(fx_function[optimize_op(arg)]); @@ -53235,6 +54079,11 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf ((arg == sc->else_symbol) && (is_global(arg)))) return(fx_c); +#if S7_DEBUGGING + if ((is_global(arg)) && (!checker(sc, arg, e))) fprintf(stderr, "%s global: %d\n", DISPLAY(arg), checker(sc, arg, e)); +#endif + if (is_global(arg)) + return(fx_g); if (checker(sc, arg, e)) return(fx_s); return(fx_unsafe_s); @@ -53242,6 +54091,16 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf return(fx_c); } +#if 0 +#include "fx_tree.h" +#endif + +static bool with_c_call(s7_pointer p, s7_function f) +{ + set_c_call(p, f); + return(true); +} + static bool fx_tree_out2(s7_scheme *sc, s7_pointer tree, s7_pointer v1, s7_pointer v2, s7_pointer v3, s7_pointer v4) { s7_pointer p; @@ -53250,7 +54109,14 @@ static bool fx_tree_out2(s7_scheme *sc, s7_pointer tree, s7_pointer v1, s7_point { if ((c_callee(tree) == fx_c_st) && (cadr(p) != v1) && (cadr(p) != v2) && (cadr(p) != v3) && (cadr(p) != v4)) - {set_c_call(tree, fx_c_Wt); return(true);} + { + if (s7_p_pp_function(slot_value(global_slot(car(p))))) + { + set_direct_opt(p); + set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); + return(with_c_call(tree, fx_c_Wt_direct)); + } + } } return(false); } @@ -53258,13 +54124,14 @@ static bool fx_tree_out2(s7_scheme *sc, s7_pointer tree, s7_pointer v1, s7_point static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2) { s7_pointer p; + /* fprintf(stderr, "%s[%d] %s %s %d %s: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), fx_name(sc, tree), DISPLAY(tree)); */ p = car(tree); if (is_symbol(p)) { if (c_callee(tree) == fx_s) { - if (p == var1) {set_c_call(tree, fx_T); return(true);} - if (p == var2) {set_c_call(tree, fx_U); return(true);} + if (p == var1) return(with_c_call(tree, fx_T)); + if (p == var2) return(with_c_call(tree, fx_U)); } return(false); } @@ -53272,226 +54139,339 @@ static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_poin { if (cadr(p) == var1) { - if (c_callee(tree) == fx_c_s) {set_c_call(tree, fx_c_T); return(true);} - if (c_callee(tree) == fx_subtract_s1) {set_c_call(tree, fx_subtract_T1); return(true);} - if (c_callee(tree) == fx_add_s1) {set_c_call(tree, fx_add_T1); return(true);} - if (c_callee(tree) == fx_c_sca) {set_c_call(tree, fx_c_Tca); return(true);} + if (c_callee(tree) == fx_c_s) return(with_c_call(tree, fx_c_T)); + if (c_callee(tree) == fx_subtract_s1) return(with_c_call(tree, fx_subtract_T1)); + if (c_callee(tree) == fx_add_s1) return(with_c_call(tree, fx_add_T1)); + if (c_callee(tree) == fx_c_sca) return(with_c_call(tree, fx_c_Tca)); +#if (!WITH_GMP) + if (c_callee(tree) == fx_num_eq_si) return(with_c_call(tree, fx_num_eq_Ti)); +#endif } if (cadr(p) == var2) { - if (c_callee(tree) == fx_subtract_s1) {set_c_call(tree, fx_subtract_U1); return(true);} - if (c_callee(tree) == fx_add_s1) {set_c_call(tree, fx_add_U1); return(true);} + if (c_callee(tree) == fx_subtract_s1) return(with_c_call(tree, fx_subtract_U1)); + if (c_callee(tree) == fx_add_s1) return(with_c_call(tree, fx_add_U1)); } if (is_pair(cddr(p))) { - if (caddr(p) == var2) + if (caddr(p) == var1) { - if (c_callee(tree) == fx_c_ts) {set_c_call(tree, fx_c_tU); return(true);} #if (!WITH_GMP) - if (c_callee(tree) == fx_lt_ts) {set_c_call(tree, fx_lt_tU); return(true);} + if (c_callee(tree) == fx_num_eq_ts) return(with_c_call(tree, fx_num_eq_tT)); + if (c_callee(tree) == fx_gt_ts) return(with_c_call(tree, fx_gt_tT)); #endif - if (c_callee(tree) == fx_cons_ts) {set_c_call(tree, fx_cons_tU); return(true);} } - if (caddr(p) == var1) + if (caddr(p) == var2) { + if (c_callee(tree) == fx_c_ts) return(with_c_call(tree, fx_c_tU)); #if (!WITH_GMP) - if (c_callee(tree) == fx_num_eq_ts) {set_c_call(tree, fx_num_eq_tT); return(true);} + if (c_callee(tree) == fx_lt_ts) return(with_c_call(tree, fx_lt_tU)); #endif + if (c_callee(tree) == fx_cons_ts) return(with_c_call(tree, fx_cons_tU)); } } } return(false); } +static s7_b_7p_t s7_b_7p_function(s7_pointer f); + +#if 0 +static void tree_globals(s7_scheme *sc, s7_pointer tree, s7_pointer orig) +{ + if ((is_symbol(tree)) && (!is_keyword(tree))) + { + if (is_global(tree)) fprintf(stderr, "%s in %s\n", DISPLAY(tree), DISPLAY_80(orig)); + } + else + { + if ((is_pair(tree)) && (car(tree) != sc->quote_symbol)) + { + s7_pointer p; + for (p = cdr(tree); is_pair(p); p = cdr(p)) + tree_globals(sc, car(p), orig); + } + } +} +#endif + static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2) /* var2 can be NULL */ { + /* extending this to a third variable did not get many hits */ s7_pointer p; - /* fprintf(stderr, "%s[%d] %s %s %d: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), DISPLAY(tree)); */ + + /* fprintf(stderr, "%s[%d] %s %s %s\n", __func__, __LINE__, DISPLAY(tree), DISPLAY(var1), (var2) ? DISPLAY(var2) : ""); */ + /* fprintf(stderr, "%s[%d] %s %s %d %s: %s\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), fx_name(sc, tree), DISPLAY(tree)); */ +#if S7_DEBUGGING + /* tree_globals(sc, tree, tree); */ + + if ((!is_symbol(var1)) || ((var2) && (!is_symbol(var2)))) + { + fprintf(stderr, "%s %s %s\n", __func__, DISPLAY(var1), (var2) ? DISPLAY(var2) : ""); + if (sc->stop_at_error) abort(); + } +#endif p = car(tree); if (is_symbol(p)) { if (c_callee(tree) == fx_s) { - if (p == var1) {set_c_call(tree, fx_t); return(true);} - if (p == var2) {set_c_call(tree, fx_u); return(true);} + if (p == var1) return(with_c_call(tree, fx_t)); + if (p == var2) return(with_c_call(tree, fx_u)); } return(false); } +#if 0 + if ((c_callee(tree) == fx_sqr_ss) && + ((s7_tree_memq(sc, var1, p)) || (s7_tree_memq(sc, var2, p)))) + fprintf(stderr, "%s %s %s\n", DISPLAY(var1), (var2) ? DISPLAY(var2) : "", DISPLAY_80(p)); +#endif + if ((is_pair(p)) && (is_pair(cdr(p)))) { if (cadr(p) == var1) { - if (c_callee(tree) == fx_c_s) {set_c_call(tree, fx_c_t); return(true);} - if (c_callee(tree) == fx_o_p_p_s) {set_c_call(tree, fx_o_p_p_t); return(true);} - if (c_callee(tree) == fx_c_ss) {set_c_call(tree, fx_c_ts); return(true);} - if (c_callee(tree) == fx_c_scs) {set_c_call(tree, fx_c_tcs); return(true);} - if ((c_callee(tree) == fx_c_sss) && (caddr(p) == var2)) {set_c_call(tree, fx_c_tus); return(true);} + if (c_callee(tree) == fx_c_s) return(with_c_call(tree, fx_c_t)); + if (c_callee(tree) == fx_o_p_p_s) return(with_c_call(tree, fx_o_p_p_t)); + if (c_callee(tree) == fx_c_ss) return(with_c_call(tree, fx_c_ts)); + if (c_callee(tree) == fx_c_scs) return(with_c_call(tree, fx_c_tcs)); #if (!WITH_GMP) - if (c_callee(tree) == fx_subtract_sf) {set_c_call(tree, fx_subtract_tf); return(true);} - if ((c_callee(tree) == fx_multiply_ss) && (is_pair(cddr(p))) && (caddr(p) == var2)) {set_c_call(tree, fx_multiply_tu); return(true);} - if (c_callee(tree) == fx_add_sf) {set_c_call(tree, fx_add_tf); return(true);} + if (c_callee(tree) == fx_subtract_sf) return(with_c_call(tree, fx_subtract_tf)); + if ((c_callee(tree) == fx_multiply_ss) && (is_pair(cddr(p))) && (caddr(p) == var2)) return(with_c_call(tree, fx_multiply_tu)); + if (c_callee(tree) == fx_add_sf) return(with_c_call(tree, fx_add_tf)); #endif if (c_callee(tree) == fx_c_sc) { set_c_call(tree, fx_c_tc); + if (c_callee(p) == g_char_equal_2) return(with_c_call(tree, fx_char_equal_tc)); #if (!WITH_GMP) - if (c_callee(p) == g_less_xf) - set_c_call(tree, fx_lt_tf); - else + if (c_callee(p) == g_less_xf) return(with_c_call(tree, fx_lt_tf)); + if ((c_callee(p) == g_less_xi) || (c_callee(p) == g_less_x0)) return(with_c_call(tree, fx_lt_ti)); + if (c_callee(p) == g_geq_xf) return(with_c_call(tree, fx_geq_tf)); + if (c_callee(p) == g_geq_xi) return(with_c_call(tree, fx_geq_ti)); + if (c_callee(p) == g_leq_xi) return(with_c_call(tree, fx_leq_ti)); + if (c_callee(p) == g_greater_xi) return(with_c_call(tree, fx_gt_ti)); + if ((is_global(car(p))) && (s7_p_pp_function(slot_value(global_slot(car(p)))))) { - if ((c_callee(p) == g_less_xi) || (c_callee(p) == g_less_x0)) - set_c_call(tree, fx_lt_ti); - } - if (c_callee(p) == g_geq_xf) - set_c_call(tree, fx_geq_tf); - else - { - if (c_callee(p) == g_geq_xi) - set_c_call(tree, fx_geq_ti); + set_direct_opt(p); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); + if ((opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && (is_t_integer(caddr(p)))) + set_c_call(tree, fx_vector_ref_direct); + else set_c_call(tree, fx_c_tc_direct); } #endif - if (c_callee(p) == g_char_equal_2) - set_c_call(tree, fx_char_equal_tc); - return(true); - } - - if (c_callee(tree) == fx_car_s) {set_c_call(tree, fx_car_t); return(true);} - if (c_callee(tree) == fx_cdr_s) {set_c_call(tree, fx_cdr_t); return(true);} - if (c_callee(tree) == fx_cadr_s) {set_c_call(tree, fx_cadr_t); return(true);} - if (c_callee(tree) == fx_not_s) {set_c_call(tree, fx_not_t); return(true);} - if (c_callee(tree) == fx_is_null_s) {set_c_call(tree, fx_is_null_t); return(true);} - if (c_callee(tree) == fx_is_pair_s) {set_c_call(tree, fx_is_pair_t); return(true);} - if (c_callee(tree) == fx_is_symbol_s) {set_c_call(tree, fx_is_symbol_t); return(true);} - if (c_callee(tree) == fx_is_vector_s) {set_c_call(tree, fx_is_vector_t); return(true);} - if (c_callee(tree) == fx_is_type_s) {set_c_call(tree, fx_is_type_t); return(true);} - if (c_callee(tree) == fx_is_eq_ss) {set_c_call(tree, (caddr(p) == var2) ? fx_is_eq_tu : fx_is_eq_ts); return(true);} - if (c_callee(tree) == fx_add_ss) {set_c_call(tree, (caddr(p) == var2) ? fx_add_tu : fx_add_ts); return(true);} - if (c_callee(tree) == fx_add_si) {set_c_call(tree, fx_add_ti); return(true);} - if (c_callee(tree) == fx_add_s1) {set_c_call(tree, fx_add_t1); return(true);} - if (c_callee(tree) == fx_subtract_s1) {set_c_call(tree, fx_subtract_t1); return(true);} - if (c_callee(tree) == fx_subtract_si) {set_c_call(tree, fx_subtract_ti); return(true);} - if (c_callee(tree) == fx_closure_s_a) {set_c_call(tree, fx_closure_t_a); return(true);} - if (c_callee(tree) == fx_closure_s_d) {set_c_call(tree, fx_closure_t_d); return(true);} + return(true); /* fx_c_tc as default above */ + } + + if (c_callee(tree) == fx_car_s) return(with_c_call(tree, fx_car_t)); + if (c_callee(tree) == fx_cdr_s) return(with_c_call(tree, fx_cdr_t)); + if (c_callee(tree) == fx_cadr_s) return(with_c_call(tree, fx_cadr_t)); + if (c_callee(tree) == fx_not_s) return(with_c_call(tree, fx_not_t)); + if (c_callee(tree) == fx_is_null_s) return(with_c_call(tree, fx_is_null_t)); + if (c_callee(tree) == fx_is_pair_s) return(with_c_call(tree, fx_is_pair_t)); + if (c_callee(tree) == fx_is_symbol_s) return(with_c_call(tree, fx_is_symbol_t)); + if (c_callee(tree) == fx_is_string_s) return(with_c_call(tree, fx_is_string_t)); + if (c_callee(tree) == fx_is_vector_s) return(with_c_call(tree, fx_is_vector_t)); + if (c_callee(tree) == fx_is_type_s) return(with_c_call(tree, fx_is_type_t)); + if (c_callee(tree) == fx_is_eq_ss) return(with_c_call(tree, (caddr(p) == var2) ? fx_is_eq_tu : fx_is_eq_ts)); + if (c_callee(tree) == fx_is_eq_sc) return(with_c_call(tree, fx_is_eq_tc)); + if (c_callee(tree) == fx_add_ss) return(with_c_call(tree, (caddr(p) == var2) ? fx_add_tu : fx_add_ts)); + if (c_callee(tree) == fx_add_si) return(with_c_call(tree, fx_add_ti)); + if (c_callee(tree) == fx_add_s1) return(with_c_call(tree, fx_add_t1)); + if (c_callee(tree) == fx_subtract_s1) return(with_c_call(tree, fx_subtract_t1)); + if (c_callee(tree) == fx_subtract_si) return(with_c_call(tree, fx_subtract_ti)); + if (c_callee(tree) == fx_safe_closure_s_a) return(with_c_call(tree, fx_safe_closure_t_a)); + if (c_callee(tree) == fx_safe_closure_s_d) return(with_c_call(tree, fx_safe_closure_t_d)); + if (c_callee(tree) == fx_length_s) return(with_c_call(tree, fx_length_t)); + if ((c_callee(tree) == fx_c_s_opsq_direct) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_opuq_direct)); #if (!WITH_GMP) if (c_callee(tree) == fx_num_eq_ss) { - if (caddr(p) == var2) {set_c_call(tree, fx_num_eq_tu); return(true);} - set_c_call(tree, fx_num_eq_ts); - return(true); + if (caddr(p) == var2) return(with_c_call(tree, fx_num_eq_tu)); + /* return(with_c_call(tree, fx_num_eq_ts)); */ + return(with_c_call(tree, (is_global(caddr(p))) ? fx_num_eq_tg : fx_num_eq_ts)); } if (is_pair(cddr(p))) { if (caddr(p) == var2) { - if (c_callee(tree) == fx_gt_ss) {set_c_call(tree, fx_gt_tu); return(true);} - if (c_callee(tree) == fx_lt_ss) {set_c_call(tree, fx_lt_tu); return(true);} - if (c_callee(tree) == fx_leq_ss) {set_c_call(tree, fx_leq_tu); return(true);} - if (c_callee(tree) == fx_geq_ss) {set_c_call(tree, fx_geq_tu); return(true);} + if (c_callee(tree) == fx_gt_ss) return(with_c_call(tree, fx_gt_tu)); + if (c_callee(tree) == fx_lt_ss) return(with_c_call(tree, fx_lt_tu)); + if (c_callee(tree) == fx_leq_ss) return(with_c_call(tree, fx_leq_tu)); + if (c_callee(tree) == fx_geq_ss) return(with_c_call(tree, fx_geq_tu)); + if (c_callee(tree) == fx_c_sss) {set_optimize_op(p, OP_SAFE_C_TUS); return(with_c_call(tree, fx_c_tus));} } else { - if (c_callee(tree) == fx_geq_ss) {set_c_call(tree, fx_geq_ts); return(true);} - if (c_callee(tree) == fx_lt_ss) {set_c_call(tree, fx_lt_ts); return(true);} + if (c_callee(tree) == fx_geq_ss) return(with_c_call(tree, fx_geq_ts)); + if (c_callee(tree) == fx_lt_ss) return(with_c_call(tree, fx_lt_ts)); } } - if (c_callee(tree) == fx_num_eq_si) {set_c_call(tree, fx_num_eq_ti); return(true);} -#endif - if (c_callee(tree) == fx_cons_ss) {set_c_call(tree, fx_cons_ts); return(true);} - if ((c_callee(tree) == fx_c_s_car_s) && (cadr(caddr(p)) == var2)) {set_c_call(tree, fx_c_t_car_u); return(true);} - - } - - if (cadr(p) == var2) - { - if (c_callee(tree) == fx_c_s) {set_c_call(tree, fx_c_u); return(true);} - if (c_callee(tree) == fx_o_p_p_s) {set_c_call(tree, fx_o_p_p_u); return(true);} - if (c_callee(tree) == fx_cdr_s) {set_c_call(tree, fx_cdr_u); return(true);} - if (c_callee(tree) == fx_car_s) {set_c_call(tree, fx_car_u); return(true);} - if (c_callee(tree) == fx_is_null_s) {set_c_call(tree, fx_is_null_u); return(true);} -#if (!WITH_GMP) - if (c_callee(tree) == fx_num_eq_ss) {set_c_call(tree, fx_num_eq_us); return(true);} - if (c_callee(tree) == fx_num_eq_si) {set_c_call(tree, fx_num_eq_ui); return(true);} - if ((c_callee(tree) == fx_add_s_car_s) && (cadr(caddr(p)) == var1)) {set_c_call(tree, fx_add_u_car_t); return(true);} + if (c_callee(tree) == fx_num_eq_si) return(with_c_call(tree, fx_num_eq_ti)); + if (c_callee(tree) == fx_gt_ss) return(with_c_call(tree, (is_global(caddr(p))) ? fx_gt_tg : fx_gt_ts)); #endif - if (c_callee(tree) == fx_add_ss) {set_c_call(tree, (caddr(p) == var1) ? fx_add_ut : fx_add_us); return(true);} - if (c_callee(tree) == fx_add_s1) {set_c_call(tree, fx_add_u1); return(true);} - if (c_callee(tree) == fx_subtract_s1) {set_c_call(tree, fx_subtract_u1); return(true);} - if (c_callee(tree) == fx_is_pair_s) {set_c_call(tree, fx_is_pair_u); return(true);} + if (c_callee(tree) == fx_cons_ss) return(with_c_call(tree, fx_cons_ts)); + if ((c_callee(tree) == fx_c_s_car_s) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_car_u)); } - - if (is_pair(cadr(p))) + else { - if ((c_callee(tree) == fx_c_opssq) && (caddr(cadr(p)) == var1)) + if (cadr(p) == var2) { - if ((s7_p_p_function(slot_value(global_slot(car(p))))) && - (s7_p_pp_function(slot_value(global_slot(caadr(p)))))) + if (c_callee(tree) == fx_c_s) { - set_direct_x_opt(p); - set_opt2_direct_x_call(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p)))))); - set_opt3_direct_x(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(p)))))); - set_c_call(tree, fx_c_opstq_direct); + if ((is_global(car(p))) && (s7_p_p_function(slot_value(global_slot(car(p)))))) + { + set_direct_opt(p); + set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p)))))); + return(with_c_call(tree, fx_c_u_direct)); + } + return(with_c_call(tree, fx_c_u)); } - else set_c_call(tree, fx_c_opstq); - return(true); + if (c_callee(tree) == fx_o_p_p_s) return(with_c_call(tree, fx_o_p_p_u)); + if (c_callee(tree) == fx_cdr_s) return(with_c_call(tree, fx_cdr_u)); + if (c_callee(tree) == fx_car_s) return(with_c_call(tree, fx_car_u)); + if (c_callee(tree) == fx_is_null_s) return(with_c_call(tree, fx_is_null_u)); +#if (!WITH_GMP) + if (c_callee(tree) == fx_num_eq_ss) return(with_c_call(tree, fx_num_eq_us)); + if (c_callee(tree) == fx_num_eq_si) return(with_c_call(tree, fx_num_eq_ui)); + if ((c_callee(tree) == fx_add_s_car_s) && (cadr(caddr(p)) == var1)) return(with_c_call(tree, fx_add_u_car_t)); +#endif + if (c_callee(tree) == fx_add_ss) {set_c_call(tree, (caddr(p) == var1) ? fx_add_ut : fx_add_us); return(true);} + if (c_callee(tree) == fx_add_s1) return(with_c_call(tree, fx_add_u1)); + if (c_callee(tree) == fx_subtract_s1) return(with_c_call(tree, fx_subtract_u1)); + if (c_callee(tree) == fx_is_pair_s) return(with_c_call(tree, fx_is_pair_u)); + if (c_callee(tree) == fx_c_sc) return(with_c_call(tree, fx_c_uc)); } - if ((c_callee(tree) == fx_c_opssq_c) && (caddr(cadr(p)) == var1)) {set_c_call(tree, fx_c_opstq_c); return(true);} - - if ((is_pair(cdadr(p))) && (cadadr(p) == var1)) + else { - /* fprintf(stderr, "%d: %s %s\n", __LINE__, DISPLAY(var1), DISPLAY(p)); */ - if ((c_callee(tree) == fx_c_opsq_c) || (c_callee(tree) == fx_c_optq_c)) + if (is_pair(cadr(p))) { - set_c_call(tree, (c_callee(car(tree)) == g_lint_let_ref) ? fx_lint_let_ref : fx_c_optq_c); - return(true); - } - if (c_callee(tree) == fx_is_pair_car_s) {set_c_call(tree, fx_is_pair_car_t); return(true);} - if (c_callee(tree) == fx_is_pair_cdr_s) {set_c_call(tree, fx_is_pair_cdr_t); return(true);} - if (c_callee(tree) == fx_is_pair_cadr_s) {set_c_call(tree, fx_is_pair_cadr_t); return(true);} - if (c_callee(tree) == fx_is_pair_cddr_s) {set_c_call(tree, fx_is_pair_cddr_t); return(true);} - if (c_callee(tree) == fx_is_null_cdr_s) {set_c_call(tree, fx_is_null_cdr_t); return(true);} - if (c_callee(tree) == fx_is_null_cddr_s) {set_c_call(tree, fx_is_null_cddr_t); return(true);} - if (c_callee(tree) == fx_not_is_pair_s) {set_c_call(tree, fx_not_is_pair_t); return(true);} - if (c_callee(tree) == fx_not_is_null_s) {set_c_call(tree, fx_not_is_null_t); return(true);} - if (c_callee(tree) == fx_is_type_car_s) {set_c_call(tree, fx_is_type_car_t); return(true);} - if (c_callee(tree) == fx_c_opsq) {set_c_call(tree, fx_c_optq); return(true);} - if (c_callee(tree) == fx_is_type_opsq) {set_c_call(tree, fx_is_type_optq); return(true);} - if (c_callee(tree) == fx_c_car_s) {set_c_call(tree, fx_c_car_t); return(true);} - if (c_callee(tree) == fx_c_cdr_s) {set_c_call(tree, fx_c_cdr_t); return(true);} - if (c_callee(tree) == fx_is_eq_car_q) {set_c_call(tree, fx_is_eq_car_t_q); return(true);} - - if ((c_callee(tree) == fx_c_opsq_cs) && (cadddr(p) == var2)) {set_c_call(tree, fx_c_optq_cu); return(true);} - if (c_callee(tree) == fx_c_opsq_s) {set_c_call(tree, fx_c_optq_s); return(true);} - - } - - if ((is_pair(cdadr(p))) && (cadadr(p) == var2)) - { - if (c_callee(tree) == fx_not_is_null_s) {set_c_call(tree, fx_not_is_null_u); return(true);} + if (c_callee(tree) == fx_c_opssq) + { + /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(p)); */ + if (caddr(cadr(p)) == var1) + { + if ((is_global(car(p))) && (is_global(caadr(p))) && + (s7_p_p_function(slot_value(global_slot(car(p))))) && + (s7_p_pp_function(slot_value(global_slot(caadr(p)))))) + { + set_direct_opt(p); + set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p)))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(p)))))); + return(with_c_call(tree, fx_c_opstq_direct)); + } + return(with_c_call(tree, fx_c_opstq)); + } + if ((cadr(cadr(p)) == var1) && (caddr(cadr(p)) == var2)) return(with_c_call(tree, fx_c_optuq)); + } + if ((c_callee(tree) == fx_c_opssq_c) && (caddr(cadr(p)) == var1)) return(with_c_call(tree, fx_c_opstq_c)); + + if ((is_pair(cdadr(p))) && (cadadr(p) == var1)) + { + /* fprintf(stderr, "%d: %s %s\n", __LINE__, DISPLAY(var1), DISPLAY(p)); */ + if ((c_callee(tree) == fx_c_opsq_c) || (c_callee(tree) == fx_c_optq_c)) + { + if (c_callee(p) != g_lint_let_ref) /* don't step on opt3_sym */ + { + if ((is_global(car(p))) && (is_global(caadr(p))) && + (s7_p_pp_function(slot_value(global_slot(car(p))))) && + (s7_p_p_function(slot_value(global_slot(caadr(p)))))) + { + set_direct_opt(p); + if (c_callee(p) == g_memq_2) + set_opt3_direct(p, (s7_pointer)memq_2_p_pp); + else set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p)))))); + set_c_call(tree, fx_c_optq_c_direct); + } + else set_c_call(tree, fx_c_optq_c); + } + return(true); + } + if (c_callee(tree) == fx_is_pair_car_s) return(with_c_call(tree, fx_is_pair_car_t)); + if (c_callee(tree) == fx_is_pair_cdr_s) return(with_c_call(tree, fx_is_pair_cdr_t)); + if (c_callee(tree) == fx_is_pair_cadr_s) return(with_c_call(tree, fx_is_pair_cadr_t)); + if (c_callee(tree) == fx_is_symbol_cadr_s) return(with_c_call(tree, fx_is_symbol_cadr_t)); + if (c_callee(tree) == fx_is_pair_cddr_s) return(with_c_call(tree, fx_is_pair_cddr_t)); + if (c_callee(tree) == fx_is_null_cdr_s) return(with_c_call(tree, fx_is_null_cdr_t)); + if (c_callee(tree) == fx_is_null_cddr_s) return(with_c_call(tree, fx_is_null_cddr_t)); + if (c_callee(tree) == fx_not_is_pair_s) return(with_c_call(tree, fx_not_is_pair_t)); + if (c_callee(tree) == fx_not_is_null_s) return(with_c_call(tree, fx_not_is_null_t)); + if (c_callee(tree) == fx_not_is_symbol_s) return(with_c_call(tree, fx_not_is_symbol_t)); + if (c_callee(tree) == fx_is_type_car_s) return(with_c_call(tree, fx_is_type_car_t)); + if (c_callee(tree) == fx_c_opsq) + { + if ((is_global(car(p))) && (is_global(caadr(p))) && + (s7_p_p_function(slot_value(global_slot(car(p))))) && + (s7_p_p_function(slot_value(global_slot(caadr(p)))))) + { + set_direct_opt(p); + set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(p)))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p)))))); + set_c_call(tree, fx_c_optq_direct); + } + else set_c_call(tree, fx_c_optq); + return(true); + } + if (c_callee(tree) == fx_is_type_opsq) return(with_c_call(tree, fx_is_type_optq)); + if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_t)); + if (c_callee(tree) == fx_c_cdr_s) return(with_c_call(tree, fx_c_cdr_t)); + if (c_callee(tree) == fx_is_eq_car_q) return(with_c_call(tree, fx_is_eq_car_t_q)); + + if ((c_callee(tree) == fx_c_opsq_cs) && (cadddr(p) == var2)) {set_c_call(tree, fx_c_optq_cu); return(true);} + if (c_callee(tree) == fx_c_opsq_s) return(with_c_call(tree, fx_c_optq_s)); + } + + if ((is_pair(cdadr(p))) && (cadadr(p) == var2)) + { + if (c_callee(tree) == fx_not_is_null_s) return(with_c_call(tree, fx_not_is_null_u)); #if (!WITH_GMP) - if ((c_callee(tree) == fx_not_opssq) && (caddr(cadr(p)) == var1)) - { - if (c_callee(cadr(p)) == g_less_2) set_c_call(tree, fx_not_lt_ut); else set_c_call(tree, fx_not_oputq); - return(true); - } + if ((c_callee(tree) == fx_not_opssq) && (caddr(cadr(p)) == var1)) + { + if (c_callee(cadr(p)) == g_less_2) set_c_call(tree, fx_not_lt_ut); else set_c_call(tree, fx_not_oputq); + return(true); + } #endif - if ((c_callee(tree) == fx_c_opsq_s) && (caddr(p) == var1)) {set_c_call(tree, fx_c_opuq_t); return(true);} - if (c_callee(tree) == fx_c_car_s) {set_c_call(tree, fx_c_car_u); return(true);} + if ((c_callee(tree) == fx_c_opsq_s) && (caddr(p) == var1)) return(with_c_call(tree, fx_c_opuq_t)); + if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_u)); + } + } } } - if (is_pair(cddr(p))) { if (caddr(p) == var1) { - if (c_callee(tree) == fx_c_cs) {set_c_call(tree, fx_c_ct); return(true);} - if (c_callee(tree) == fx_c_ss) {set_c_call(tree, fx_c_st); return(true);} - if (c_callee(tree) == fx_hash_table_ref_ss) {set_c_call(tree, fx_hash_table_ref_st); return(true);} + if (c_callee(tree) == fx_c_cs) + { + if ((is_global(car(p))) && (s7_p_pp_function(slot_value(global_slot(car(p)))))) + { + set_direct_opt(p); + if (c_callee(p) == g_tree_set_memq_1) + set_opt3_direct(cdr(p), (s7_pointer)tree_set_memq_direct); + else set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p)))))); + set_c_call(tree, fx_c_ct_direct); + } + else set_c_call(tree, fx_c_ct); + return(true); + } + if (c_callee(tree) == fx_c_ss) return(with_c_call(tree, (is_global(cadr(p))) ? fx_c_gt : fx_c_st)); + if (c_callee(tree) == fx_hash_table_ref_ss) return(with_c_call(tree, fx_hash_table_ref_st)); + if ((c_callee(tree) == fx_c_opssq_s_direct) && (is_global(cadr(cadr(p))))) + return(with_c_call(tree, fx_c_opgsq_t_direct)); } +#if 0 + if ((is_pair(caddr(p))) && (is_pair(cdr(caddr(p)))) && (var1 == cadr(caddr(p)))) + { + /* lots of opsq_opsq here */ + /* if (c_callee(tree) == fx_c_c_opsq) {set_c_call(tree, fx_c_c_optq); return(true);} */ + } +#endif if (caddr(p) == var2) { - if (c_callee(tree) == fx_c_cs) {set_c_call(tree, fx_c_cu); return(true);} + if (c_callee(tree) == fx_c_cs) return(with_c_call(tree, fx_c_cu)); } } } @@ -53501,7 +54481,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2) { #if 0 - if (is_pair(tree)) + if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %s %d %s %s\n", __func__, __LINE__, DISPLAY_80(tree), (is_optimized(tree)) ? op_names[optimize_op(tree)] : "unopt", has_fx(tree), /* (has_fx(tree)) ? fx_name(sc, tree) : "", */ @@ -53712,8 +54692,8 @@ static s7_b_i_t s7_b_i_function(s7_pointer f) {return((s7_b_i_t)opt_func(f, o_b_ static void s7_set_b_p_direct_function(s7_pointer f, s7_b_p_t df) {add_opt_func(f, o_b_p_direct, (void *)df);} static s7_b_p_t s7_b_p_direct_function(s7_pointer f) {return((s7_b_p_t)opt_func(f, o_b_p_direct));} -void s7_set_b_7p_function(s7_pointer f, s7_b_7p_t df) {add_opt_func(f, o_b_7p, (void *)df);} -s7_b_7p_t s7_b_7p_function(s7_pointer f) {return((s7_b_7p_t)opt_func(f, o_b_7p));} +static void s7_set_b_7p_function(s7_pointer f, s7_b_7p_t df) {add_opt_func(f, o_b_7p, (void *)df);} +static s7_b_7p_t s7_b_7p_function(s7_pointer f) {return((s7_b_7p_t)opt_func(f, o_b_7p));} static void s7_set_b_pp_function(s7_pointer f, s7_b_pp_t df) {add_opt_func(f, o_b_pp, (void *)df);} static s7_b_pp_t s7_b_pp_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, o_b_pp));} @@ -54492,13 +55472,13 @@ static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer } /* -------- i_ii -------- */ -static s7_int opt_i_ii_cc(opt_info *o) {oo_rc(o->sc, o, 4, 0); return(o->v[3].i_ii_f(o->v[1].i, o->v[2].i));} -static s7_int opt_i_ii_cs(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(o->v[3].i_ii_f(o->v[1].i, integer(slot_value(o->v[2].p))));} +static s7_int opt_i_ii_cc(opt_info *o) {oo_rc(o->sc, o, 4, 0); return(o->v[3].i_ii_f(o->v[1].i, o->v[2].i));} +static s7_int opt_i_ii_cs(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(o->v[3].i_ii_f(o->v[1].i, integer(slot_value(o->v[2].p))));} static s7_int opt_i_ii_cs_mul(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(o->v[1].i * integer(slot_value(o->v[2].p)));} -static s7_int opt_i_ii_sc(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));} +static s7_int opt_i_ii_sc(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));} static s7_int opt_i_ii_sc_add(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(integer(slot_value(o->v[1].p)) + o->v[2].i);} static s7_int opt_i_ii_sc_sub(opt_info *o) {oo_rc(o->sc, o, 4, 1); return(integer(slot_value(o->v[1].p)) - o->v[2].i);} -static s7_int opt_i_ii_ss(opt_info *o) {oo_rc(o->sc, o, 4, 2); return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} +static s7_int opt_i_ii_ss(opt_info *o) {oo_rc(o->sc, o, 4, 2); return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} static s7_int opt_i_ii_ss_add(opt_info *o) {oo_rc(o->sc, o, 4, 2); return(integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p)));} static s7_pointer opt_p_ii_ss_add(opt_info *o) {oo_rc(o->sc, o, 4, 2); return(make_integer(o->sc, integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p))));} @@ -54719,7 +55699,7 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer else { if (opc->v[3].i_ii_f == subtract_i_ii) - opc->v[0].fi = opt_i_ii_sc_sub; + opc->v[0].fi = opt_i_ii_sc_sub; /* sub1 is not faster */ else opc->v[0].fi = opt_i_ii_sc; } } @@ -60303,10 +61283,10 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[4].p = cadr(arg2); opc->v[2].p = val_slot; opc->v[0].fp = opt_p_ppp_scs; - if (opc->v[3].p_ppp_f == let_set_p_ppp) + if (opc->v[3].p_ppp_f == s7_let_set) { if (is_symbol(cadr(arg2))) /* checked is_let, has_methods and is_immutable above */ - opc->v[3].p_ppp_f = let_set_p_ppp_1; + opc->v[3].p_ppp_f = let_set_1; else return(return_false(sc, car_x, __func__, __LINE__)); } return(oo_set_type_2(opc, 5, 1, 2, op2, OO_P)); @@ -60502,7 +61482,9 @@ static s7_pointer opt_p_fx_any(opt_info *o) static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer x) { s7_function f; - f = fx_choose(sc, x, sc->envir, let_symbol_is_safe); + if (has_fx(x)) + f = c_callee(x); + else f = fx_choose(sc, x, sc->envir, let_symbol_is_safe); if (f) { opc->v[0].fp = opt_p_fx_any; @@ -60538,7 +61520,7 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len) { case T_PAIR: opc->v[3].p_pi_f = list_ref_p_pi_direct; op2 = OO_L; break; case T_HASH_TABLE: opc->v[3].p_pp_f = s7_hash_table_ref; op2 = OO_H; break; - case T_LET: opc->v[3].p_pp_f = let_ref_p_pp; op2 = OO_E; break; + case T_LET: opc->v[3].p_pp_f = s7_let_ref; op2 = OO_E; break; case T_STRING: opc->v[3].p_pi_f = string_ref_p_pi_direct; op2 = OO_S; break; case T_BYTE_VECTOR: @@ -60936,12 +61918,6 @@ static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer else counts = tree_count(sc, target, sc->code, 0); } else counts = 2; -#if 0 - fprintf(stderr, "%s[%d]: %s %ld%s %s\n", __func__, __LINE__, - DISPLAY(target), counts, - (has_high_c(sc->code)) ? " (from high_c)" : "", - DISPLAY_80(sc->code)); -#endif /* can be from lambda: (lambda (n)...): ((n) (set! sum (+ sum n))) etc */ if (counts <= 2) { @@ -61221,7 +62197,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy op2 = OO_E; if ((is_keyword(cadr(target))) || ((is_quoted_symbol(cadr(target))))) - opc->v[3].p_ppp_f = let_set_p_ppp_1; + opc->v[3].p_ppp_f = let_set_1; else opc->v[3].p_ppp_f = let_set_p_ppp_2; break; @@ -62486,6 +63462,39 @@ static s7_pointer opt_do_1(opt_info *o) loop = ++sc->pc; ostart = sc->opts[loop]; + + if ((o->v[8].i == 1) && + (is_t_integer(slot_value(vp)))) + { + if (sc->opts[o->v[9].i]->v[0].fp == opt_p_ii_ss_add) + { + s7_pointer step_val; + opt_info *step_o; + step_val = make_mutable_integer(sc, integer(slot_value(vp))); + slot_set_value(vp, step_val); + step_o = sc->opts[o->v[9].i]; + while (true) + { + if (ostart->v[0].fb(ostart)) break; + o1 = sc->opts[++sc->pc]; + o1->v[0].fp(o1); + integer(step_val) = opt_i_ii_ss_add(step_o); + sc->pc = loop; + } + sc->pc = o->v[5].i; + unstack(sc); + sc->envir = old_e; + return(sc->T); + } + else + { +#if S7_DEBUGGING && (0) + fprintf(stderr, "%s: not add: %s\n", __func__, DISPLAY(o->vexpr)); +#endif + o->v[8].i = 2; + } + } + while (true) { if (ostart->v[0].fb(ostart)) break; @@ -62676,12 +63685,57 @@ static s7_pointer opt_do_very_simple(opt_info *o) sc->pc = loop; o1 = sc->opts[loop]; /* the body */ f = o1->v[0].fp; - while (integer(vp) < end) + if (f == opt_p_pip_ssf) { - f(o1); - sc->pc = loop; - integer(vp)++; + opt_info *o; + o = o1; + o1 = sc->opts[++loop]; + while (integer(vp) < end) + { + sc->pc = loop; + o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fp(o1)); + integer(vp)++; + } } + else + { + if (f == opt_p_pip_sso) + { + while (integer(vp) < end) + { + o1->v[5].p_pip_f(o1->sc, slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p)), + o1->v[6].p_pi_f(o1->sc, slot_value(o1->v[3].p), integer(slot_value(o1->v[4].p)))); + sc->pc = loop; + integer(vp)++; + } + } + else + { + if ((f == opt_set_p_i_f) && + (is_t_integer(slot_value(o1->v[1].p))) && + (o1->v[1].p != let_dox_slot1(o->v[2].p))) + { + s7_pointer ival; + opt_info *o2; + ival = make_mutable_integer(sc, integer(slot_value(o1->v[1].p))); + slot_set_value(o1->v[1].p, ival); + o2 = sc->opts[++loop]; + while (integer(vp) < end) + { + sc->pc = loop; + integer(ival) = o2->v[0].fi(o2); + integer(vp)++; + } + slot_set_value(o1->v[1].p, make_integer(sc, integer(slot_value(o1->v[1].p)))); + } + else + { + while (integer(vp) < end) + { + f(o1); + sc->pc = loop; + integer(vp)++; + }}}} sc->pc = o->v[5].i; unstack(sc); sc->envir = old_e; @@ -62837,6 +63891,19 @@ static bool stop_is_safe(s7_scheme *sc, s7_pointer stop, s7_pointer body) return(true); } +static bool tree_has_setters(s7_scheme *sc, s7_pointer tree) +{ + clear_symbol_list(sc); + add_symbol_to_list(sc, sc->set_symbol); + add_symbol_to_list(sc, sc->vector_set_symbol); + add_symbol_to_list(sc, sc->list_set_symbol); + add_symbol_to_list(sc, sc->let_set_symbol); + add_symbol_to_list(sc, sc->hash_table_set_symbol); + add_symbol_to_list(sc, sc->set_car_symbol); + add_symbol_to_list(sc, sc->set_cdr_symbol); + return(tree_set_memq(sc, tree)); /* TODO: if val is constant don't treat as a hit */ +} + static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_pointer var_list, bool *has_set); static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) @@ -62846,6 +63913,8 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) int32_t i, var_len, body_len, body_index, step_len, rtn_len; bool has_set = false; + /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY_80(car_x)); */ + if (len < 3) return(return_false(sc, car_x, __func__, __LINE__)); @@ -63049,6 +64118,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer var; var = car(p); + opc->v[9].i = sc->pc; if ((is_pair(cddr(var))) && (!cell_optimize(sc, cddr(var)))) break; @@ -63089,7 +64159,18 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) opc->v[0].fp = opt_do_no_vars; return(oo_set_type_0(opc, 6)); } - + opc->v[8].i = 0; + if (body_len == 1) + { + s7_pointer expr; + expr = cadddr(car_x); + if ((is_pair(expr)) && + ((is_safe_setter(car(expr))) || + ((car(expr) == sc->vector_set_symbol) && + (is_null(cddddr(expr))) && + (is_code_constant(sc, cadddr(expr)))))) + opc->v[8].i = 1; + } if ((var_len != 1) || (step_len != 1) || (rtn_len != 0)) { opc->v[0].fp = ((step_len == 1) && (body_len == 1) && (rtn_len == 1)) ? opt_do_step_1 : opt_do_any; @@ -63797,7 +64878,7 @@ static s7_function s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nr) } if (cell_optimize(sc, expr)) return((nr) ? opt_cell_any_nr : opt_wrap_cell); - set_no_cell_opt(expr); + set_no_cell_opt(expr); /* checked elsewhere */ } return(NULL); } @@ -63841,6 +64922,10 @@ static s7_function s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nr) /* ---------------------------------------- for-each ---------------------------------------- */ +#if WITH_GCC +static inline s7_pointer make_counter(s7_scheme *sc, s7_pointer iter) __attribute__((always_inline)); +#endif + static inline s7_pointer make_counter(s7_scheme *sc, s7_pointer iter) { s7_pointer x; @@ -63870,19 +64955,6 @@ static s7_pointer make_iterators(s7_scheme *sc, s7_pointer args) return(safe_reverse_in_place(sc, sc->z)); } -static bool tree_has_setters(s7_scheme *sc, s7_pointer tree) -{ - clear_symbol_list(sc); - add_symbol_to_list(sc, sc->set_symbol); - add_symbol_to_list(sc, sc->vector_set_symbol); - add_symbol_to_list(sc, sc->list_set_symbol); - add_symbol_to_list(sc, sc->let_set_symbol); - add_symbol_to_list(sc, sc->hash_table_set_symbol); - add_symbol_to_list(sc, sc->set_car_symbol); - add_symbol_to_list(sc, sc->set_cdr_symbol); - return(tree_set_memq(sc, tree)); -} - static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) { s7_pointer body; @@ -63984,6 +65056,10 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq s7_pointer sv; sv = make_mutable_integer(sc, 0); slot_set_value(slot, sv); + /* since there are no setters, the inner step is also mutable if there is one + * func=opt_cell_any_nr, sc->opts[0]->v[0].fp(sc->opts[0]) fp=opt_do_1 -> mutable version + * see opt_do_1 + */ for (i = 0; i < len; i++) { integer(sv) = vals[i]; @@ -64219,7 +65295,11 @@ static bool op_for_each_1(s7_scheme *sc) return(false); } -static bool op_for_each_2(s7_scheme *sc) +#if WITH_GCC +static inline bool op_for_each_2(s7_scheme *sc) __attribute__((always_inline)); +#endif + +static inline bool op_for_each_2(s7_scheme *sc) { s7_pointer c, lst, arg, code; c = sc->args; /* the counter */ @@ -64474,10 +65554,11 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table sc->z = sc->nil; return(sc->nil); } + /* fprintf(stderr, "fargs: %d, len: %ld, args: %s\n", fargs, len, DISPLAY(closure_args(f))); */ if ((fargs > len) || - ((fargs < len) && - ((fargs >= 0) || - (abs(fargs) > len)))) + ((fargs < len) && + ((fargs >= 0) || + (abs(fargs) > len)))) return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "map ~A: ~A args?", 16), f, small_int(len)))); if (got_nil) return(sc->nil); @@ -64621,7 +65702,6 @@ static bool op_map_2(s7_scheme *sc) /* -------------------------------- multiple-values -------------------------------- */ - static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) { int64_t top; @@ -64652,11 +65732,18 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) /* in the next set, the main evaluator branches blithely assume no multiple-values, * and if it happens anyway, we go to a different branch here */ + case OP_SAFE_CLOSURE_FP_2: + stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_CLOSURE_FP_MV_1; + goto FP_MV; + case OP_SAFE_C_FP_2: + stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_FP_MV_1; + goto FP_MV; case OP_SAFE_C_FP_1: case OP_SAFE_CLOSURE_FP_1: - stack_element(sc->stack, top) = (s7_pointer)(stack_op(sc->stack, top) + 1); + stack_element(sc->stack, top) = (s7_pointer)(stack_op(sc->stack, top) + 1); /* replace with mv version */ case OP_SAFE_C_FP_MV_1: case OP_SAFE_CLOSURE_FP_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))) { @@ -64803,22 +65890,10 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) return(car(x)); case OP_IF1: /* (if (values ...) ...) */ - case OP_IF_PP: - case OP_IF_PPP: - case OP_IF_PR: - case OP_IF_PRR: - case OP_WHEN_PP: - case OP_UNLESS_PP: - case OP_WITH_LET1: - case OP_CASE_G_G: - case OP_CASE_G_S: - case OP_CASE_E_G: - case OP_CASE_E_S: - case OP_CASE_S_G: - case OP_CASE_S_S: - case OP_CASE_I_S: - case OP_COND1: - case OP_COND1_SIMPLE: + case OP_IF_PP: case OP_IF_PPP: case OP_IF_PR: case OP_IF_PRR: + case OP_WHEN_PP: case OP_UNLESS_PP: case OP_WITH_LET1: + case OP_CASE_G_G: case OP_CASE_G_S: case OP_CASE_E_G: case OP_CASE_E_S: case OP_CASE_S_G: case OP_CASE_S_S: case OP_CASE_I_S: + case OP_COND1: case OP_COND1_SIMPLE: return(car(args)); case OP_BARRIER: @@ -64829,8 +65904,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) sc->stack_end -= 4; return(splice_in_values(sc, args)); - case OP_BEGIN0: - case OP_BEGIN1: + case OP_BEGIN0: case OP_BEGIN1: case OP_BEGIN_1: case OP_BEGIN_1_UNCHECKED: case OP_BEGIN_2_UNCHECKED: /* here we have a values call with nothing to splice into. So flush it... * otherwise the multiple-values bit gets set in some innocent list and never unset: * (let ((x '((1 2)))) (eval `(apply apply values x)) x) -> ((values 1 2)) @@ -64880,6 +65954,8 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) return(args); } + +/* -------------------------------- values -------------------------------- */ s7_pointer s7_values(s7_scheme *sc, s7_pointer args) { #define H_values "(values obj ...) splices its arguments into whatever list holds it (its 'continuation')" @@ -64899,8 +65975,7 @@ static s7_pointer values_p(s7_scheme *sc) {return(sc->no_value);} static s7_pointer values_p_p(s7_scheme *sc, s7_pointer p) {return(p);} -/* -------------------------------- quasiquote -------------------------------- */ - +/* -------------------------------- list-values -------------------------------- */ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) { #define H_list_values "(list-values ...) returns its arguments in a list (internal to quasiquote)" @@ -64952,7 +66027,7 @@ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) * (badmac1 (let ((x (lambda () 1))) (eq? x x))) * clear_all_optimizations assumes its argument has no cycles, and automatically calling copy_tree slows * everything down intolerably, so... - * if the checked bit it on in a macro expansion, that means we're re-expanding this macro, and therefore + * if the checked bit is on in a macro expansion, that means we're re-expanding this macro, and therefore * have to copy the tree. * we can't set_cdr(pc...) as in earlier versions of this code -- might be an embedded permanent list */ @@ -64972,23 +66047,23 @@ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) return(sc->nil); } + +/* -------------------------------- apply-values -------------------------------- */ static s7_pointer g_apply_values(s7_scheme *sc, s7_pointer args) { #define H_apply_values "(apply-values var) applies values to var. This is an internal function." #define Q_apply_values s7_make_signature(sc, 2, sc->T, sc->is_list_symbol) s7_pointer x; - + /* apply-values takes 1 arg: ,@a -> (apply-values a) */ if (is_null(args)) return(sc->no_value); - if (is_null(cdr(args))) - x = car(args); - else x = apply_list_star(sc, args); + x = car(args); + if (is_null(x)) + return(sc->no_value); if (!s7_is_proper_list(sc, x)) return(apply_list_error(sc, args)); - if (is_null(x)) - return(sc->no_value); return(g_values(sc, x)); } @@ -65008,6 +66083,8 @@ static s7_pointer g_apply_values(s7_scheme *sc, s7_pointer args) * If this is in a function body, and the function is called twice, it is self-modifying code and behaves in unexpected ways. */ + +/* -------------------------------- quasiquote -------------------------------- */ static bool is_simple_code(s7_scheme *sc, s7_pointer form) { s7_pointer tmp, slow; @@ -65086,7 +66163,7 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - { s7_int len, i; - s7_pointer orig, bq, old_scw; + s7_pointer orig, bq, old_scw, old_lv; bool dotted = false; len = s7_list_length(sc, form); @@ -65103,9 +66180,11 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - sc->w = cons(sc, sc->nil, sc->w); set_car(sc->w, sc->list_values_symbol); + old_lv = sc->w; if (!dotted) { + bool simple = true; for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) { if ((is_pair(cdr(orig))) && /* this was is_pair(orig) which seems to be always the case */ @@ -65123,7 +66202,16 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - break; } else set_car(bq, g_quasiquote_1(sc, car(orig), false)); + +#if S7_DEBUGGING + if (car(bq) == sc->no_value) fprintf(stderr, "%s[%d] no-values!: %s\n", __func__, __LINE__, DISPLAY(form)); +#endif + if ((simple) && + ((is_pair(car(bq))) && (caar(bq) != sc->quote_symbol))) + simple = false; } + if (simple) + set_car(old_lv, sc->list_symbol); } else { @@ -65662,6 +66750,31 @@ static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt) } } +static void read_double_quote(s7_scheme *sc) +{ + sc->value = read_string_constant(sc, sc->input_port); + if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */ + string_read_error(sc, "end of input encountered while in a string"); + if (sc->value == sc->T) + read_error(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); +} + +static bool read_sharp_const(s7_scheme *sc) +{ + sc->value = port_read_sharp(sc->input_port)(sc, sc->input_port); + if (sc->value == sc->no_value) + { + /* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*)) + * (+ 1 #;(* 2 3) 4) + * so we need to get the next token, act on it without any assumptions about read list + */ + sc->tok = token(sc); + return(true); + } + return(false); +} + static s7_pointer read_expression_read_error(s7_scheme *sc) { s7_pointer pt; @@ -65779,12 +66892,7 @@ static s7_pointer read_expression(s7_scheme *sc) /* If reading list (from lparen), this will finally get us to op_read_list */ case TOKEN_DOUBLE_QUOTE: - sc->value = read_string_constant(sc, sc->input_port); - if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */ - return(string_read_error(sc, "end of input encountered while in a string")); - if (sc->value == sc->T) - return(read_error(sc, "unknown backslash usage -- perhaps you meant two backslashes?")); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); + read_double_quote(sc); return(sc->value); case TOKEN_SHARP_CONST: @@ -66026,11 +67134,6 @@ static s7_pointer binder_syntax(s7_scheme *sc, const char *name, opcode_t op, s7 return(x); } -static s7_pointer g_format_allg(s7_scheme *sc, s7_pointer args) -{ - return(g_format_1(sc, args)); -} - static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args) { s7_pointer pt, str; @@ -66153,8 +67256,9 @@ static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_p /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */ if (!is_columnizing(string_value(str_arg))) return(sc->format_allg_no_column); - return(sc->format_allg); } + if (port == sc->F) + return(sc->format_f); } return(f); } @@ -66269,15 +67373,17 @@ static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poin arg1 = cadr(expr); arg2 = caddr(expr); if (arg2 == small_int(1)) /* (+ ... 1) */ - return(sc->add_s1); + return(sc->add_x1); if (arg1 == small_int(1)) - return(sc->add_1s); + return(sc->add_1x); return(chooser_check_arg_types(sc, arg1, arg2, sc->add_2, sc->add_2_ff, sc->add_2_ii, sc->add_2_if, sc->add_2_fi, sc->add_2_xi, sc->add_2_ix, sc->add_2_fx, sc->add_2_xf)); } return(sc->add_2); } + if (args == 3) + return(sc->add_3); #endif return(f); } @@ -66316,6 +67422,8 @@ static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7 } return(sc->subtract_2); } + if (args == 3) + return(sc->subtract_3); #endif return(f); } @@ -66331,9 +67439,10 @@ static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_p { s7_pointer arg1; arg1 = cadr(expr); - if ((is_t_real(arg1)) && - (real(arg1) == 1.0)) + if ((is_t_real(arg1)) && (real(arg1) == 1.0)) return(sc->divide_1r); + if ((is_t_integer(caddr(expr))) && (integer(caddr(expr)) == 2)) + return(sc->divide_by_2); return(sc->divide_2); } } @@ -66347,7 +67456,9 @@ static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer ur_f, int32_t args, s if (args == 2) { if ((ops) && (s7_is_integer(caddr(expr)))) - return(sc->num_eq_2i); + return(sc->num_eq_xi); + if ((ops) && (s7_is_integer(cadr(expr)))) + return(sc->num_eq_ix); return(sc->num_eq_2); } return(ur_f); @@ -66630,11 +67741,9 @@ static s7_pointer g_and_3(s7_scheme *sc, s7_pointer args) static s7_pointer g_if_a_a(s7_scheme *sc, s7_pointer args) { - s7_pointer p; if (is_true(sc, fx_call(sc, args))) - p = cdr(args); - else return(sc->unspecified); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(args))); + return(sc->unspecified); } static s7_pointer g_if_a_aa(s7_scheme *sc, s7_pointer args) @@ -66648,11 +67757,9 @@ static s7_pointer g_if_a_aa(s7_scheme *sc, s7_pointer args) static s7_pointer g_if_not_a_a(s7_scheme *sc, s7_pointer args) { - s7_pointer p; if (is_true(sc, c_call(args)(sc, cadar(args)))) return(sc->unspecified); - p = cdr(args); - return(fx_call(sc, p)); + return(fx_call(sc, cdr(args))); } static s7_pointer g_if_not_a_aa(s7_scheme *sc, s7_pointer args) @@ -66678,7 +67785,7 @@ static s7_pointer g_if_a_qa(s7_scheme *sc, s7_pointer args) return(fx_call(sc, cddr(args))); } -static s7_pointer g_or_s_direct(s7_scheme *sc, s7_pointer args) +static s7_pointer g_or_s(s7_scheme *sc, s7_pointer args) { s7_pointer p; set_car(sc->t1_1, lookup(sc, cadar(args))); @@ -66692,7 +67799,7 @@ static s7_pointer g_or_s_direct(s7_scheme *sc, s7_pointer args) return(sc->F); } -static s7_pointer g_or_s_direct_2(s7_scheme *sc, s7_pointer args) +static s7_pointer g_or_s_2(s7_scheme *sc, s7_pointer args) { s7_pointer x; set_car(sc->t1_1, lookup(sc, cadar(args))); @@ -66708,7 +67815,7 @@ static s7_pointer g_or_s_type_2(s7_scheme *sc, s7_pointer args) return(make_boolean(sc, (type(x) == symbol_type(caar(args))) || (type(x) == symbol_type(caadr(args))))); } -static s7_pointer g_and_s_direct(s7_scheme *sc, s7_pointer args) +static s7_pointer g_and_s(s7_scheme *sc, s7_pointer args) { s7_pointer p, x = sc->T; set_car(sc->t1_1, lookup(sc, cadar(args))); @@ -66721,7 +67828,7 @@ static s7_pointer g_and_s_direct(s7_scheme *sc, s7_pointer args) return(x); } -static s7_pointer g_and_s_direct_2(s7_scheme *sc, s7_pointer args) +static s7_pointer g_and_s_2(s7_scheme *sc, s7_pointer args) { s7_pointer x; set_car(sc->t1_1, lookup(sc, cadar(args))); @@ -66731,11 +67838,11 @@ static s7_pointer g_and_s_direct_2(s7_scheme *sc, s7_pointer args) } static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, - int32_t required_args, int32_t optional_args, bool rest_arg, const char *doc) + int32_t required_args, int32_t optional_args, bool rest_arg) { s7_pointer uf; /* the "safe_function" business here doesn't matter -- this is after the optimizer decides what is safe */ - uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, doc); + uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); s7_function_set_class(uf, cls); c_function_signature(uf) = c_function_signature(cls); return(uf); @@ -66757,127 +67864,130 @@ static void init_choosers(s7_scheme *sc) f = set_function_chooser(sc, sc->add_symbol, add_chooser); sc->add_class = c_function_class(f); - sc->add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false, "+ opt"); - sc->add_1s = make_function_with_class(sc, f, "+", g_add_1s, 2, 0, false, "+ opt"); - sc->add_s1 = make_function_with_class(sc, f, "+", g_add_s1, 2, 0, false, "+ opt"); - + sc->add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false); + sc->add_3 = make_function_with_class(sc, f, "+", g_add_3, 3, 0, false); + sc->add_1x = make_function_with_class(sc, f, "+", g_add_1x, 2, 0, false); + sc->add_x1 = make_function_with_class(sc, f, "+", g_add_x1, 2, 0, false); #if (!WITH_GMP) - sc->add_2_ff = make_function_with_class(sc, f, "+", g_add_2_ff, 2, 0, false, "+ opt"); - sc->add_2_ii = make_function_with_class(sc, f, "+", g_add_2_ii, 2, 0, false, "+ opt"); - sc->add_2_if = make_function_with_class(sc, f, "+", g_add_2_if, 2, 0, false, "+ opt"); - sc->add_2_fi = make_function_with_class(sc, f, "+", g_add_2_fi, 2, 0, false, "+ opt"); - sc->add_2_xi = make_function_with_class(sc, f, "+", g_add_2_xi, 2, 0, false, "+ opt"); - sc->add_2_ix = make_function_with_class(sc, f, "+", g_add_2_ix, 2, 0, false, "+ opt"); - sc->add_2_fx = make_function_with_class(sc, f, "+", g_add_2_fx, 2, 0, false, "+ opt"); - sc->add_2_xf = make_function_with_class(sc, f, "+", g_add_2_xf, 2, 0, false, "+ opt"); + sc->add_2_ff = make_function_with_class(sc, f, "+", g_add_2_ff, 2, 0, false); + sc->add_2_ii = make_function_with_class(sc, f, "+", g_add_2_ii, 2, 0, false); + sc->add_2_if = make_function_with_class(sc, f, "+", g_add_2_if, 2, 0, false); + sc->add_2_fi = make_function_with_class(sc, f, "+", g_add_2_fi, 2, 0, false); + sc->add_2_xi = make_function_with_class(sc, f, "+", g_add_2_xi, 2, 0, false); + sc->add_2_ix = make_function_with_class(sc, f, "+", g_add_2_ix, 2, 0, false); + sc->add_2_fx = make_function_with_class(sc, f, "+", g_add_2_fx, 2, 0, false); + sc->add_2_xf = make_function_with_class(sc, f, "+", g_add_2_xf, 2, 0, false); #endif /* - */ f = set_function_chooser(sc, sc->subtract_symbol, subtract_chooser); sc->subtract_class = c_function_class(f); - sc->subtract_1 = make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false, "- opt"); - sc->subtract_2 = make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false, "- opt"); - sc->subtract_s1 = make_function_with_class(sc, f, "-", g_subtract_s1, 2, 0, false, "- opt"); - sc->subtract_2f = make_function_with_class(sc, f, "-", g_subtract_2f, 2, 0, false, "- opt"); - sc->subtract_f2 = make_function_with_class(sc, f, "-", g_subtract_f2, 2, 0, false, "- opt"); + sc->subtract_1 = make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false); + sc->subtract_2 = make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false); + sc->subtract_3 = make_function_with_class(sc, f, "-", g_subtract_3, 3, 0, false); + sc->subtract_s1 = make_function_with_class(sc, f, "-", g_subtract_s1, 2, 0, false); + sc->subtract_2f = make_function_with_class(sc, f, "-", g_subtract_2f, 2, 0, false); + sc->subtract_f2 = make_function_with_class(sc, f, "-", g_subtract_f2, 2, 0, false); /* * */ f = set_function_chooser(sc, sc->multiply_symbol, multiply_chooser); sc->multiply_class = c_function_class(f); #if (!WITH_GMP) - sc->multiply_2 = make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false, "* opt"); - sc->mul_2_ff = make_function_with_class(sc, f, "*", g_mul_2_ff, 2, 0, false, "* opt"); - sc->mul_2_ii = make_function_with_class(sc, f, "*", g_mul_2_ii, 2, 0, false, "* opt"); - sc->mul_2_if = make_function_with_class(sc, f, "*", g_mul_2_if, 2, 0, false, "* opt"); - sc->mul_2_fi = make_function_with_class(sc, f, "*", g_mul_2_fi, 2, 0, false, "* opt"); - sc->mul_2_xi = make_function_with_class(sc, f, "*", g_mul_2_xi, 2, 0, false, "* opt"); - sc->mul_2_ix = make_function_with_class(sc, f, "*", g_mul_2_ix, 2, 0, false, "* opt"); - sc->mul_2_fx = make_function_with_class(sc, f, "*", g_mul_2_fx, 2, 0, false, "* opt"); - sc->mul_2_xf = make_function_with_class(sc, f, "*", g_mul_2_xf, 2, 0, false, "* opt"); + sc->multiply_2 = make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false); + sc->mul_2_ff = make_function_with_class(sc, f, "*", g_mul_2_ff, 2, 0, false); + sc->mul_2_ii = make_function_with_class(sc, f, "*", g_mul_2_ii, 2, 0, false); + sc->mul_2_if = make_function_with_class(sc, f, "*", g_mul_2_if, 2, 0, false); + sc->mul_2_fi = make_function_with_class(sc, f, "*", g_mul_2_fi, 2, 0, false); + sc->mul_2_xi = make_function_with_class(sc, f, "*", g_mul_2_xi, 2, 0, false); + sc->mul_2_ix = make_function_with_class(sc, f, "*", g_mul_2_ix, 2, 0, false); + sc->mul_2_fx = make_function_with_class(sc, f, "*", g_mul_2_fx, 2, 0, false); + sc->mul_2_xf = make_function_with_class(sc, f, "*", g_mul_2_xf, 2, 0, false); #endif /* / */ f = set_function_chooser(sc, sc->divide_symbol, divide_chooser); #if (!WITH_GMP) - sc->invert_1 = make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false, "/ opt"); - sc->divide_1r = make_function_with_class(sc, f, "/", g_divide_1r, 2, 0, false, "/ opt"); - sc->divide_2 = make_function_with_class(sc, f, "/", g_divide_2, 2, 0, false, "/ opt"); + sc->invert_1 = make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false); + sc->divide_1r = make_function_with_class(sc, f, "/", g_divide_1r, 2, 0, false); + sc->divide_2 = make_function_with_class(sc, f, "/", g_divide_2, 2, 0, false); + sc->divide_by_2 = make_function_with_class(sc, f, "/", g_divide_by_2, 2, 0, false); /* = */ f = set_function_chooser(sc, sc->num_eq_symbol, num_eq_chooser); sc->num_eq_class = c_function_class(f); #if (!WITH_GMP) - sc->num_eq_2 = make_function_with_class(sc, f, "=", g_num_eq_2, 2, 0, false, "= opt"); + sc->num_eq_2 = make_function_with_class(sc, f, "=", g_num_eq_2, 2, 0, false); #endif - sc->num_eq_2i = make_function_with_class(sc, f, "=", g_num_eq_2i, 2, 0, false, "= opt"); + 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); /* < */ 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, "< opt"); - sc->less_xf = make_function_with_class(sc, f, "<", g_less_xf, 2, 0, false, "< opt"); - sc->less_x0 = make_function_with_class(sc, f, "<", g_less_x0, 2, 0, false, "< opt"); - sc->less_2 = make_function_with_class(sc, f, "<", g_less_2, 2, 0, false, "< opt"); + sc->less_xi = make_function_with_class(sc, f, "<", g_less_xi, 2, 0, false); + sc->less_xf = make_function_with_class(sc, f, "<", g_less_xf, 2, 0, false); + sc->less_x0 = make_function_with_class(sc, f, "<", g_less_x0, 2, 0, false); + sc->less_2 = make_function_with_class(sc, f, "<", g_less_2, 2, 0, false); /* > */ f = set_function_chooser(sc, sc->gt_symbol, greater_chooser); - sc->greater_xi = make_function_with_class(sc, f, ">", g_greater_xi, 2, 0, false, "> opt"); - sc->greater_xf = make_function_with_class(sc, f, ">", g_greater_xf, 2, 0, false, "> opt"); - sc->greater_2 = make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false, "> opt"); + sc->greater_xi = make_function_with_class(sc, f, ">", g_greater_xi, 2, 0, false); + sc->greater_xf = make_function_with_class(sc, f, ">", g_greater_xf, 2, 0, false); + sc->greater_2 = make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false); /* <= */ f = set_function_chooser(sc, sc->leq_symbol, leq_chooser); - sc->leq_xi = make_function_with_class(sc, f, "<=", g_leq_xi, 2, 0, false, "<= opt"); - sc->leq_2 = make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false, "<= opt"); + sc->leq_xi = make_function_with_class(sc, f, "<=", g_leq_xi, 2, 0, false); + sc->leq_2 = make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false); /* >= */ f = set_function_chooser(sc, sc->geq_symbol, geq_chooser); - sc->geq_xi = make_function_with_class(sc, f, ">=", g_geq_xi, 2, 0, false, ">= opt"); - sc->geq_xf = make_function_with_class(sc, f, ">=", g_geq_xf, 2, 0, false, ">= opt"); - sc->geq_2 = make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false, ">= opt"); + sc->geq_xi = make_function_with_class(sc, f, ">=", g_geq_xi, 2, 0, false); + sc->geq_xf = make_function_with_class(sc, f, ">=", g_geq_xf, 2, 0, false); + sc->geq_2 = make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false); /* random */ f = set_function_chooser(sc, sc->random_symbol, random_chooser); - sc->random_1 = make_function_with_class(sc, f, "random", g_random_1, 1, 0, false, "random opt"); - sc->random_i = make_function_with_class(sc, f, "random", g_random_i, 1, 0, false, "random opt"); - sc->random_f = make_function_with_class(sc, f, "random", g_random_f, 1, 0, false, "random opt"); + sc->random_1 = make_function_with_class(sc, f, "random", g_random_1, 1, 0, false); + sc->random_i = make_function_with_class(sc, f, "random", g_random_i, 1, 0, false); + sc->random_f = make_function_with_class(sc, f, "random", g_random_f, 1, 0, false); #endif /* char=? */ f = set_function_chooser(sc, sc->char_eq_symbol, char_equal_chooser); - sc->simple_char_eq = make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0, false, "char=? opt"); - sc->char_equal_2 = make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, false, "char=? opt"); + sc->simple_char_eq = make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0, false); + sc->char_equal_2 = make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, false); /* char>? */ f = set_function_chooser(sc, sc->char_gt_symbol, char_greater_chooser); - sc->char_greater_2 = make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, false, "char>? opt"); + sc->char_greater_2 = make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, false); /* char<? */ f = set_function_chooser(sc, sc->char_lt_symbol, char_less_chooser); - sc->char_less_2 = make_function_with_class(sc, f, "char<?", g_char_less_2, 2, 0, false, "char<? opt"); + sc->char_less_2 = make_function_with_class(sc, f, "char<?", g_char_less_2, 2, 0, false); /* read-char */ f = set_function_chooser(sc, sc->read_char_symbol, read_char_chooser); - sc->read_char_1 = make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, false, "read-char opt"); + sc->read_char_1 = make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, false); /* char-position */ f = set_function_chooser(sc, sc->char_position_symbol, char_position_chooser); - sc->char_position_csi = make_function_with_class(sc, f, "char-position", g_char_position_csi, 2, 1, false, "char-position opt"); + sc->char_position_csi = make_function_with_class(sc, f, "char-position", g_char_position_csi, 2, 1, false); /* string=? */ f = set_function_chooser(sc, sc->string_eq_symbol, string_equal_chooser); - sc->string_equal_2 = make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, false, "string=? opt"); + sc->string_equal_2 = make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, false); /* substring */ - sc->substring_to_temp = s7_make_function(sc, "substring", g_substring_to_temp, 2, 1, false, "substring opt"); + sc->substring_to_temp = s7_make_function(sc, "substring", g_substring_to_temp, 2, 1, false, NULL); s7_function_set_class(sc->substring_to_temp, slot_value(global_slot(sc->substring_symbol))); /* string>? */ f = set_function_chooser(sc, sc->string_gt_symbol, string_greater_chooser); - sc->string_greater_2 = make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, 0, false, "string>? opt"); + sc->string_greater_2 = make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, 0, false); /* string<? */ f = set_function_chooser(sc, sc->string_lt_symbol, string_less_chooser); - sc->string_less_2 = make_function_with_class(sc, f, "string<?", g_string_less_2, 2, 0, false, "string<? opt"); + sc->string_less_2 = make_function_with_class(sc, f, "string<?", g_string_less_2, 2, 0, false); /* string-ref et al */ set_function_chooser(sc, sc->string_ref_symbol, string_substring_chooser); @@ -66890,92 +68000,93 @@ static void init_choosers(s7_scheme *sc) /* symbol->string */ f = slot_value(global_slot(sc->symbol_to_string_symbol)); - sc->symbol_to_string_uncopied = s7_make_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, "symbol->string opt"); + sc->symbol_to_string_uncopied = s7_make_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, NULL); s7_function_set_class(sc->symbol_to_string_uncopied, f); /* display */ f = set_function_chooser(sc, sc->display_symbol, display_chooser); - sc->display_2 = make_function_with_class(sc, f, "display", g_display_2, 2, 0, false, "display opt"); + sc->display_2 = make_function_with_class(sc, f, "display", g_display_2, 2, 0, false); /* vector-ref */ f = set_function_chooser(sc, sc->vector_ref_symbol, vector_ref_chooser); - sc->vector_ref_2 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0, false, "vector-ref opt"); - sc->vector_ref_3 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_3, 3, 0, false, "vector-ref opt"); + sc->vector_ref_2 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0, false); + sc->vector_ref_3 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_3, 3, 0, false); /* vector-set! */ f = set_function_chooser(sc, sc->vector_set_symbol, vector_set_chooser); - sc->vector_set_3 = make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, 0, false, "vector-set! opt"); - sc->vector_set_4 = make_function_with_class(sc, f, "vector-set!", g_vector_set_4, 4, 0, false, "vector-set! opt"); + sc->vector_set_3 = make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, 0, false); + sc->vector_set_4 = make_function_with_class(sc, f, "vector-set!", g_vector_set_4, 4, 0, false); /* float-vector-ref */ f = set_function_chooser(sc, sc->float_vector_ref_symbol, float_vector_ref_chooser); - sc->fv_ref_2 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_2, 2, 0, false, "float-vector-ref opt"); - sc->fv_ref_3 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_3, 3, 0, false, "float-vector-ref opt"); + sc->fv_ref_2 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_2, 2, 0, false); + sc->fv_ref_3 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_3, 3, 0, false); /* float-vector-set */ f = set_function_chooser(sc, sc->float_vector_set_symbol, float_vector_set_chooser); - sc->fv_set_3 = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_3, 3, 0, false, "float-vector-set! opt"); - sc->fv_set_unchecked = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_unchecked, 3, 0, false, "float-vector-set! opt"); + sc->fv_set_3 = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_3, 3, 0, false); + sc->fv_set_unchecked = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_unchecked, 3, 0, false); /* int-vector-ref */ f = set_function_chooser(sc, sc->int_vector_ref_symbol, int_vector_ref_chooser); - sc->iv_ref_2 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_2, 2, 0, false, "int-vector-ref opt"); - sc->iv_ref_3 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_3, 3, 0, false, "int-vector-ref opt"); + sc->iv_ref_2 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_2, 2, 0, false); + sc->iv_ref_3 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_3, 3, 0, false); /* int-vector-set */ f = set_function_chooser(sc, sc->int_vector_set_symbol, int_vector_set_chooser); - sc->iv_set_3 = make_function_with_class(sc, f, "int-vector-set!", g_iv_set_3, 3, 0, false, "int-vector-set! opt"); + sc->iv_set_3 = make_function_with_class(sc, f, "int-vector-set!", g_iv_set_3, 3, 0, false); /* byte-vector-ref */ f = set_function_chooser(sc, sc->byte_vector_ref_symbol, byte_vector_ref_chooser); - sc->bv_ref_2 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_2, 2, 0, false, "byte-vector-ref opt"); - sc->bv_ref_3 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_3, 3, 0, false, "byte-vector-ref opt"); + sc->bv_ref_2 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_2, 2, 0, false); + sc->bv_ref_3 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_3, 3, 0, false); /* byte-vector-set */ f = set_function_chooser(sc, sc->byte_vector_set_symbol, byte_vector_set_chooser); - sc->bv_set_3 = make_function_with_class(sc, f, "byte-vector-set!", g_bv_set_3, 3, 0, false, "byte-vector-set! opt"); + sc->bv_set_3 = make_function_with_class(sc, f, "byte-vector-set!", g_bv_set_3, 3, 0, false); /* list-set! */ f = set_function_chooser(sc, sc->list_set_symbol, list_set_chooser); - sc->list_set_i = make_function_with_class(sc, f, "list-set!", g_list_set_i, 3, 0, false, "list-set! opt"); + sc->list_set_i = make_function_with_class(sc, f, "list-set!", g_list_set_i, 3, 0, false); /* hash-table-ref */ f = set_function_chooser(sc, sc->hash_table_ref_symbol, hash_table_ref_chooser); - sc->hash_table_ref_2 = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_2, 2, 0, false, "hash-table-ref opt"); + sc->hash_table_ref_2 = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_2, 2, 0, false); /* hash-table */ f = set_function_chooser(sc, sc->hash_table_symbol, hash_table_chooser); - sc->hash_table_2 = make_function_with_class(sc, f, "hash-table", g_hash_table_2, 2, 0, false, "hash-table opt"); + sc->hash_table_2 = make_function_with_class(sc, f, "hash-table", g_hash_table_2, 2, 0, false); /* format */ f = set_function_chooser(sc, sc->format_symbol, format_chooser); - sc->format_allg = make_function_with_class(sc, f, "format", g_format_allg, 1, 0, true, "format opt"); - sc->format_allg_no_column = make_function_with_class(sc, f, "format", g_format_allg_no_column, 1, 0, true, "format opt"); - sc->format_just_control_string = make_function_with_class(sc, f, "format", g_format_just_control_string, 2, 0, false, "format opt"); - sc->format_as_objstr = make_function_with_class(sc, f, "format", g_format_as_objstr, 3, 0, true, "format opt"); + sc->format_f = make_function_with_class(sc, f, "format", g_format_f, 1, 0, true); + sc->format_allg_no_column = make_function_with_class(sc, f, "format", g_format_allg_no_column, 1, 0, true); + sc->format_just_control_string = make_function_with_class(sc, f, "format", g_format_just_control_string, 2, 0, false); + sc->format_as_objstr = make_function_with_class(sc, f, "format", g_format_as_objstr, 3, 0, true); /* list */ f = set_function_chooser(sc, sc->list_symbol, list_chooser); - sc->list_0 = make_function_with_class(sc, f, "list", g_list_0, 0, 0, false, "list opt"); - sc->list_1 = make_function_with_class(sc, f, "list", g_list_1, 1, 0, false, "list opt"); - sc->list_2 = make_function_with_class(sc, f, "list", g_list_2, 2, 0, false, "list opt"); + sc->list_0 = make_function_with_class(sc, f, "list", g_list_0, 0, 0, false); + sc->list_1 = make_function_with_class(sc, f, "list", g_list_1, 1, 0, false); + sc->list_2 = make_function_with_class(sc, f, "list", g_list_2, 2, 0, false); + sc->list_3 = make_function_with_class(sc, f, "list", g_list_3, 3, 0, false); /* member */ set_function_chooser(sc, sc->member_symbol, member_chooser); /* memq */ f = set_function_chooser(sc, sc->memq_symbol, memq_chooser); /* is pure-s7, use member here */ - sc->memq_2 = make_function_with_class(sc, f, "memq", g_memq_2, 2, 0, false, "memq opt"); - sc->memq_3 = make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false, "memq opt"); - sc->memq_4 = make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false, "memq opt"); - sc->memq_any = make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false, "memq opt"); + sc->memq_2 = make_function_with_class(sc, f, "memq", g_memq_2, 2, 0, false); + sc->memq_3 = make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false); + sc->memq_4 = make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false); + sc->memq_any = make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false); /* tree-set-memq */ f = set_function_chooser(sc, sc->tree_set_memq_symbol, tree_set_memq_chooser); - sc->tree_set_memq_syms = make_function_with_class(sc, f, "tree-set-memq", g_tree_set_memq_1, 2, 0, false, "tree-set-memq opt"); + sc->tree_set_memq_syms = make_function_with_class(sc, f, "tree-set-memq", g_tree_set_memq_1, 2, 0, false); /* read-line */ - sc->read_line_uncopied = s7_make_function(sc, "read-line", g_read_line_uncopied, 1, 1, false, "read-line opt"); + sc->read_line_uncopied = s7_make_function(sc, "read-line", g_read_line_uncopied, 1, 1, false, NULL); s7_function_set_class(sc->read_line_uncopied, slot_value(global_slot(sc->read_line_symbol))); /* eval-string */ @@ -66983,34 +68094,34 @@ static void init_choosers(s7_scheme *sc) /* inlet */ f = set_function_chooser(sc, sc->inlet_symbol, inlet_chooser); - sc->simple_inlet = make_function_with_class(sc, f, "inlet", g_simple_inlet, 0, 0, true, "inlet opt"); + sc->simple_inlet = make_function_with_class(sc, f, "inlet", g_simple_inlet, 0, 0, true); /* let-ref */ f = set_function_chooser(sc, sc->let_ref_symbol, let_ref_chooser); - sc->lint_let_ref = make_function_with_class(sc, f, "let-ref", g_lint_let_ref, 2, 0, false, "let-ref opt"); + sc->lint_let_ref = make_function_with_class(sc, f, "let-ref", g_lint_let_ref, 2, 0, false); /* let-set */ f = set_function_chooser(sc, sc->let_set_symbol, let_set_chooser); - sc->lint_let_set = make_function_with_class(sc, f, "let-set!", g_lint_let_set, 3, 0, false, "let-set! opt"); - - sc->or_n = s7_make_function(sc, "or", g_or_n, 0, 0, true, "or opt"); - sc->or_2 = s7_make_function(sc, "or", g_or_2, 2, 0, false, "or opt"); - sc->or_3 = s7_make_function(sc, "or", g_or_3, 3, 0, false, "or opt"); - sc->and_n = s7_make_function(sc, "and", g_and_n, 0, 0, true, "and opt"); - sc->and_2 = s7_make_function(sc, "and", g_and_2, 2, 0, false, "and opt"); - sc->and_3 = s7_make_function(sc, "and", g_and_3, 3, 0, false, "and opt"); - sc->if_a_a = s7_make_function(sc, "if", g_if_a_a, 2, 0, false, "if opt"); - sc->if_a_aa = s7_make_function(sc, "if", g_if_a_aa, 3, 0, false, "if opt"); - sc->if_not_a_a = s7_make_function(sc, "if", g_if_not_a_a, 2, 0, false, "if opt"); - sc->if_not_a_aa = s7_make_function(sc, "if", g_if_not_a_aa, 3, 0, false, "if opt"); - sc->if_a_qq = s7_make_function(sc, "if", g_if_a_qq, 3, 0, false, "if opt"); - sc->if_a_qa = s7_make_function(sc, "if", g_if_a_qa, 3, 0, false, "if opt"); - - sc->or_s_direct = s7_make_function(sc, "or", g_or_s_direct, 0, 0, true, "or opt"); - sc->and_s_direct = s7_make_function(sc, "and", g_and_s_direct, 0, 0, true, "and opt"); - sc->or_s_direct_2 = s7_make_function(sc, "or", g_or_s_direct_2, 0, 0, true, "or opt"); - sc->and_s_direct_2 = s7_make_function(sc, "and", g_and_s_direct_2, 0, 0, true, "and opt"); - sc->or_s_type_2 = s7_make_function(sc, "or", g_or_s_type_2, 0, 0, true, "or opt"); + sc->lint_let_set = make_function_with_class(sc, f, "let-set!", g_lint_let_set, 3, 0, false); + + sc->or_n = s7_make_function(sc, "or", g_or_n, 0, 0, true, NULL); + sc->or_2 = s7_make_function(sc, "or", g_or_2, 2, 0, false, NULL); + sc->or_3 = s7_make_function(sc, "or", g_or_3, 3, 0, false, NULL); + sc->and_n = s7_make_function(sc, "and", g_and_n, 0, 0, true, NULL); + sc->and_2 = s7_make_function(sc, "and", g_and_2, 2, 0, false, NULL); + sc->and_3 = s7_make_function(sc, "and", g_and_3, 3, 0, false, NULL); + sc->if_a_a = s7_make_function(sc, "if", g_if_a_a, 2, 0, false, NULL); + sc->if_a_aa = s7_make_function(sc, "if", g_if_a_aa, 3, 0, false, NULL); + sc->if_not_a_a = s7_make_function(sc, "if", g_if_not_a_a, 2, 0, false, NULL); + sc->if_not_a_aa = s7_make_function(sc, "if", g_if_not_a_aa, 3, 0, false, NULL); + sc->if_a_qq = s7_make_function(sc, "if", g_if_a_qq, 3, 0, false, NULL); + sc->if_a_qa = s7_make_function(sc, "if", g_if_a_qa, 3, 0, false, NULL); + + sc->or_s = s7_make_function(sc, "or", g_or_s, 0, 0, true, NULL); + sc->and_s = s7_make_function(sc, "and", g_and_s, 0, 0, true, NULL); + sc->or_s_2 = s7_make_function(sc, "or", g_or_s_2, 0, 0, true, NULL); + sc->and_s_2 = s7_make_function(sc, "and", g_and_s_2, 0, 0, true, NULL); + sc->or_s_type_2 = s7_make_function(sc, "or", g_or_s_type_2, 0, 0, true, NULL); } #define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr, true)) @@ -67020,17 +68131,9 @@ static void annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e) /* if sc->envir is sc->nil, we're at the top-level, but the global_slot check should suffice for that */ #if S7_DEBUGGING s7_function fx; -#if 1 - /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY(arg)); */ if (has_fx(arg)) return; -#endif fx = fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe); - if (!fx) - { - /* fprintf(stderr, "%s: is_fxable: %d, fx_choose null?\n", DISPLAY(arg), is_fxable(sc, car(arg))); */ - /* abort(); */ - } - else set_c_call(arg, fx); + if (fx) set_c_call(arg, fx); #else set_c_call(arg, fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); #endif @@ -67062,9 +68165,10 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int bool safe_case; safe_case = is_safe_closure(func); if (is_immutable(func)) hop = 1; - if (is_null(closure_args(func))) /* no rest arg funny business */ + if (is_null(closure_args(func))) /* no rest arg funny business */ { s7_pointer body; + set_optimized(expr); body = closure_body(func); if (is_null(cdr(body))) { @@ -67080,14 +68184,20 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int } else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_THUNK : OP_THUNK)); set_opt1_lambda(expr, func); + return(OPT_F); } - else + if (is_symbol(closure_args(func))) /* (define* (f1 . a) ...) called (f1) -- called a closure (not closure*) in define_unchecked */ + { + set_optimized(expr); + set_opt1_lambda(expr, func); + set_optimize_op(expr, hop + OP_THUNK_NIL); + return(OPT_F); + } + if (is_closure_star(func)) { - if (is_closure_star(func)) - { - set_opt1_lambda(expr, func); - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_0 : OP_CLOSURE_STAR_FX)); - } + set_optimized(expr); + set_opt1_lambda(expr, func); + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_0 : OP_CLOSURE_STAR_FX)); } return(OPT_F); } @@ -67214,7 +68324,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_S); case OP_SAFE_C_A: return(OP_SAFE_C_opAq_S); case OP_SAFE_C_opSSq: - set_opt3_pair(expr, cadadr(expr)); + set_opt1_pair(cdr(expr), cadadr(expr)); return(OP_SAFE_C_op_opSSq_q_S); case OP_SAFE_C_opSSq_S: set_opt3_pair(expr, cadadr(expr)); @@ -67274,10 +68384,10 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb fp = s7_p_dd_function(func); if (fp) { - /* direct_x_c_c_opssq calls number_to_real on e1 */ - set_opt3_direct_x(cddr(expr), s7_d_pd_function(slot_value(global_slot(car(arg))))); - set_opt2_direct_x_call(cdr(expr), fp); - set_direct_x_opt(expr); + /* direct_c_c_opssq calls number_to_real on e1 */ + set_opt3_direct(cddr(expr), s7_d_pd_function(slot_value(global_slot(car(arg))))); + set_opt2_direct(cdr(expr), fp); + set_direct_opt(expr); } } return(OP_SAFE_C_C_opSSq); @@ -67299,10 +68409,10 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb if ((symbol_id(car(e1)) == 0) && (s7_d_p_function(slot_value(global_slot(car(e1))))) && (symbol_id(car(e2)) == 0) && (s7_d_p_function(slot_value(global_slot(car(e2)))))) { - set_opt3_direct_x(cdr(expr), s7_d_p_function(slot_value(global_slot(car(e1))))); - set_opt3_direct_x(cddr(expr), s7_d_p_function(slot_value(global_slot(car(e2))))); - set_opt2_direct_x_call(cdr(expr), fp); - set_direct_x_opt(expr); + set_opt3_direct(cdr(expr), s7_d_p_function(slot_value(global_slot(car(e1))))); + set_opt3_direct(cddr(expr), s7_d_p_function(slot_value(global_slot(car(e2))))); + set_opt2_direct(cdr(expr), fp); + set_direct_opt(expr); } } return(OP_SAFE_C_opSq_opSq); @@ -67756,7 +68866,8 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar z = cdddr(false_p); } } - if (la) + /* if ((la) && (s7_tree_memq(sc, name, car(z)))) fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, DISPLAY(name), DISPLAY(z)); */ + if ((la) && (!s7_tree_memq(sc, name, car(z)))) { if (((vars == 1) && (is_null(cddr(la)))) || ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la))))) @@ -68470,7 +69581,6 @@ static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer set_opt3_pair(la_clause, cdr(la2)); return(true); }}}}}}}}} - /* if (!(sc->got_tc)) fprintf(stderr, "%s[%d]: %s %s\n%s\n\n", __func__, __LINE__, DISPLAY(name), DISPLAY(args), DISPLAY(body)); */ return(false); } @@ -68513,7 +69623,10 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer if (is_fxable(sc, car(body))) { annotate_arg(sc, body, e); - set_safe_optimize_op(expr, hop + ((sym) ? OP_SAFE_CLOSURE_S_A : OP_SAFE_CLOSURE_C_A)); + if ((sym) && (optimize_op(car(body)) == HOP_SAFE_C_S) && (car(closure_args(func)) == cadar(body))) + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S); + else set_safe_optimize_op(expr, hop + ((sym) ? OP_SAFE_CLOSURE_S_A : OP_SAFE_CLOSURE_C_A)); + set_closure_has_fx(func); fx_tree(sc, body, car(closure_args(func)), NULL); return(OPT_T); @@ -68548,15 +69661,7 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer } set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_P); } - else - { - if ((c_callee(cdr(expr)) == fx_subtract_si) || (c_callee(cdr(expr)) == fx_subtract_s1)) - { - set_opt2_pair(expr, cdadr(expr)); - set_optimize_op(expr, hop + OP_CLOSURE_SUB_P); - } - else set_optimize_op(expr, hop + OP_CLOSURE_A_P); - } + else set_optimize_op(expr, hop + OP_CLOSURE_A_P); } else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); set_unsafely_optimized(expr); @@ -68734,6 +69839,17 @@ static bool unsafe_is_safe(s7_scheme *sc, s7_pointer f, s7_pointer e) return(false); } +static opt_t set_safe_closure_fp(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op) +{ + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + set_c_call_checked(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); + set_opt3_arglen(expr, make_permanent_integer(num_args)); + set_unsafe_optimize_op(expr, op); + set_opt1_lambda(expr, func); + return(OPT_F); +} + static bool two_args_ok(s7_scheme *sc, s7_pointer expr, s7_pointer e) { if ((car(expr) == sc->member_symbol) || (car(expr) == sc->assoc_symbol)) return(true); @@ -68759,7 +69875,7 @@ static void opt_sp_1(s7_scheme *sc, s7_function g, s7_pointer expr) #endif } -static void check_lambda_1(s7_scheme *sc, bool optl); +static int32_t check_lambda_1(s7_scheme *sc, bool optl); static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { @@ -68783,6 +69899,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f ((is_symbol(arg2)) && (!arg_findable(sc, arg2, e)))) { + /* fprintf(stderr, "bad: %s %s e: %s\n", DISPLAY(arg1), DISPLAY(arg2), DISPLAY(e)); */ /* wrap bad args */ if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2)) && @@ -68847,7 +69964,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f { if (c_function_call(func) == g_apply) { - set_optimize_op(expr, hop + OP_APPLY_SS); + set_optimize_op(expr, OP_APPLY_SS); set_opt1_cfunc(expr, func); /* not quite set_c_function */ set_opt2_sym(expr, arg2); } @@ -69261,7 +70378,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if ((c_function_call(func) == g_apply) && (is_normal_symbol(arg1))) { - set_optimize_op(expr, hop + OP_APPLY_SA); + set_optimize_op(expr, OP_APPLY_SA); if (is_pair(arg2)) { s7_pointer lister; @@ -69269,7 +70386,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if ((is_c_function(lister)) && (is_pair(c_function_signature(lister))) && (car(c_function_signature(lister)) == sc->is_proper_list_symbol)) - set_optimize_op(expr, hop + OP_APPLY_SL); + set_optimize_op(expr, OP_APPLY_SL); } set_opt1_cfunc(expr, func); /* not quite set_c_function */ } @@ -69353,6 +70470,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if (is_fxable(sc, car(body))) { annotate_arg(sc, body, e); + fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func))); set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A); set_closure_has_fx(func); return(OPT_T); @@ -69449,6 +70567,10 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f set_opt1_lambda(expr, func); return(OPT_F); } + + if (is_safe_closure(func)) + return(set_safe_closure_fp(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_FP)); + return((is_optimized(expr)) ? OPT_T : OPT_F); } @@ -69512,17 +70634,6 @@ static opt_t set_safe_c_fp(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_p return(OPT_F); } -static opt_t set_safe_closure_fp(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op) -{ - s7_pointer p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - set_c_call_checked(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); - set_opt3_arglen(expr, make_permanent_integer(num_args)); - set_unsafe_optimize_op(expr, op); - set_opt1_lambda(expr, func); - return(OPT_F); -} - static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { s7_pointer arg1, arg2, arg3; @@ -69707,7 +70818,15 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer if ((symbols == 2) && (is_normal_symbol(arg1))) { if (is_normal_symbol(arg2)) - set_optimize_op(expr, hop + OP_SAFE_C_SSA); + { + if ((hop == 1) && (s7_p_ppp_function(func))) + { + set_optimize_op(expr, OP_SSA_DIRECT); + set_direct_opt(expr); + set_opt2_direct(cdr(expr), (s7_pointer)(s7_p_ppp_function(func))); + } + else set_optimize_op(expr, hop + OP_SAFE_C_SSA); + } else set_optimize_op(expr, hop + OP_SAFE_C_SAS); } } @@ -69810,13 +70929,14 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer } else { - set_optimize_op(expr, hop + OP_C_CATCH); + set_optimize_op(expr, hop + OP_C_CATCH); /* mainly c_catch_p, but this is not a common case */ choose_c_function(sc, expr, func, 3); } return(OPT_F); } } } + return(set_safe_c_fp(sc, func, expr, e, 3, hop + OP_SAFE_C_FP)); /* safe == unsafe here */ } return((is_optimized(expr)) ? OPT_T : OPT_F); } @@ -69836,13 +70956,12 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer } if (is_immutable(func)) hop = 1; - if ((symbols == 3) && - (!is_safe_closure(func))) + if (symbols == 3) { set_unsafely_optimized(expr); set_opt1_lambda(expr, func); set_opt3_arglen(expr, small_int(3)); - set_optimize_op(expr, hop + ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_3S_P : OP_CLOSURE_3S)); + set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_3S : ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_3S_P : OP_CLOSURE_3S))); return(OPT_F); } @@ -69917,7 +71036,11 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer { bool func_is_closure; + /* fprintf(stderr, "%s[%d]: %s, args: %d, bad: %d, quotes: %d\n", __func__, __LINE__, DISPLAY_80(expr), args, bad_pairs, quotes); */ +#if 0 if (bad_pairs > quotes) return(OPT_F); +#endif + if (quotes > 0) { if (direct_memq(sc->quote_symbol, e)) @@ -70023,6 +71146,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer choose_c_function(sc, expr, func, args); return(OPT_F); } + return(set_safe_c_fp(sc, func, expr, e, 3, hop + OP_SAFE_C_FP)); } return((is_optimized(expr)) ? OPT_T : OPT_F); } @@ -70031,6 +71155,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer if (func_is_closure) { int32_t arit; + arit = closure_arity_to_int(sc, func); if (arit != args) { @@ -70052,10 +71177,13 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer set_opt3_arglen(expr, make_permanent_integer(args)); set_opt1_lambda(expr, func); - if ((!safe_case) && - (symbols == args) && + if ((symbols == args) && (symbols_are_safe(sc, cdr(expr), e))) - set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_P : OP_CLOSURE_4S) : OP_CLOSURE_ALL_S)); + { + if (safe_case) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_ALL_S); + else set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_P : OP_CLOSURE_4S) : OP_CLOSURE_ALL_S)); + } return(OPT_F); } @@ -70230,8 +71358,7 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in (is_pair(cadr(var))) && (!is_checked(cadr(var)))) { - if /* (((is_pair(car(var))) && (optimize_expression(sc, car(var), hop, e, false) == OPT_OOPS)) || */ - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS) + if (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS) return(OPT_OOPS); } } @@ -70364,8 +71491,33 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in if ((is_pair(cadr(expr))) && (caadr(expr) == sc->outlet_symbol)) return(OPT_OOPS); - body = cddr(expr); - body_export_ok = false; /* (list x (set! y (define x 0))) -- can body here have more than one expression? */ + + if (!is_pair(cddr(expr))) + return(OPT_OOPS); + + if ((is_pair(cadr(expr))) && + (!is_checked(cadr(expr)))) + { + s7_pointer p; + set_checked(cadr(expr)); + for (p = cdadr(expr); is_pair(p); p = cdr(p)) + { + if ((is_pair(car(p))) && + (!is_checked(car(p))) && + (optimize_expression(sc, car(p), hop, e, body_export_ok) == OPT_OOPS)) + return(OPT_OOPS); + } + } + + if ((is_pair(caddr(expr))) && + (!is_checked(caddr(expr))) && + (optimize_expression(sc, caddr(expr), hop, e, body_export_ok) == OPT_OOPS)) + return(OPT_OOPS); + + return(OPT_F); + + /* old form: body = cddr(expr); body_export_ok = false; */ + break; case OP_WITH_LET: @@ -70442,6 +71594,8 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in } sc->temp9 = e; + /* fprintf(stderr, "%s: %s, e: %s\n", __func__, DISPLAY_80(expr), DISPLAY(e)); */ + for (p = body; is_pair(p); p = cdr(p)) if ((is_pair(car(p))) && (!is_checked(car(p))) && /* ((typeflag & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ @@ -70498,19 +71652,24 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in set_safe_optimize_op(expr, hop + OP_SAFE_C_D); if (args == 2) { + set_opt3_sym(cdr(expr), cadadr(expr)); if ((symbol_type(caadr(expr)) > 0) && (is_global(caadr(expr))) && ((symbol_type(caaddr(expr)) > 0) && (is_global(caaddr(expr))))) - set_c_function(expr, sc->or_s_type_2); - else set_c_function(expr, sc->or_s_direct_2); + { + set_opt3_any(expr, small_int(symbol_type(caadr(expr)))); + set_opt2_any(cdr(expr), small_int(symbol_type(caaddr(expr)))); + set_c_function(expr, sc->or_s_type_2); + } + else set_c_function(expr, sc->or_s_2); } - else set_c_function(expr, sc->or_s_direct); + else set_c_function(expr, sc->or_s); } else { if (op == OP_AND) { set_safe_optimize_op(expr, hop + OP_SAFE_C_D); - set_c_function(expr, (args == 2) ? sc->and_s_direct_2 : sc->and_s_direct); + set_c_function(expr, (args == 2) ? sc->and_s_2 : sc->and_s); } } return(OPT_F); @@ -70905,7 +72064,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 { set_opt1_con(expr, ptrue); set_opt2_con(expr, pfalse); - set_safe_optimize_op(expr, hop + OP_SAFE_IFA_SS_A); + set_safe_optimize_op(expr, OP_SAFE_IFA_SS_A); annotate_arg(sc, cdr(car_expr), e); annotate_arg(sc, cdr(expr), e); return(OPT_T); @@ -70944,9 +72103,6 @@ static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e) /* ---------------------------------------- error checks ---------------------------------------- */ -typedef enum {goto_START, goto_BEGIN, fall_through, goto_DO_END_CLAUSES, goto_SAFE_DO_END_CLAUSES, goto_EVAL, - goto_TOP_NO_POP, goto_APPLY, goto_EVAL_ARGS, goto_DO_UNCHECKED, goto_POP_READ_LIST, goto_READ_TOK} goto_t; - static s7_pointer check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity) { s7_pointer x; @@ -71589,7 +72745,7 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun if (len > 0) /* i.e. not circular */ { body_t result; - s7_pointer p, lst; + s7_pointer p, lst, cleared_args; clear_symbol_list(sc); for (p = args; is_pair(p); p = cdr(p)) @@ -71638,8 +72794,9 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun sc->temp10 = lst; } else lst = sc->nil; - - if (optimize(sc, body, 1, collect_parameters(sc, args, lst)) == OPT_OOPS) + + /* TODO: check cleared_args */ + if (optimize(sc, body, 1, cleared_args = collect_parameters(sc, args, lst)) == OPT_OOPS) clear_all_optimizations(sc, body); else { @@ -71648,30 +72805,41 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun { int32_t nvars; for (nvars = 0, p = args; is_pair(p); nvars++, p = cdr(p)); + if (is_null(p)) { - /* don't we have to annotate_args first? */ if (nvars > 0) { - annotate_args(sc, body, sc->envir); - fx_tree(sc, body, car(args), (nvars > 1) ? cadr(args) : NULL); + annotate_args(sc, body, cleared_args); + fx_tree(sc, body, + (is_pair(car(args))) ? caar(args) : car(args), + (nvars > 1) ? ((is_pair(cadr(args))) ? caadr(args) : cadr(args)) : NULL); } } if ((unstarred_lambda) || (nvars == 1)) { - if ((sc->got_tc) && - (is_null(cdr(body)))) - { - if (check_tc(sc, func, nvars, args, car(body))) - set_safe_closure_body(body); - } - - if ((sc->got_rec) && - (result >= RECUR_BODY) && - (is_null(cdr(body)))) + if (is_null(cdr(body))) { - if (check_recur(sc, func, nvars, args, car(body))) - set_safe_closure_body(body); + if (sc->got_tc) + { + if (check_tc(sc, func, nvars, args, car(body))) + set_safe_closure_body(body); + } + /* fprintf(stderr, "got_rec: %d %s %d\n", sc->got_rec, op_names[optimize_op(car(body))], result); */ + if ((sc->got_rec) && + (!is_tc_op(optimize_op(car(body)))) && + (result >= RECUR_BODY)) + { + if (check_recur(sc, func, nvars, args, car(body))) + set_safe_closure_body(body); + } +#if 0 + if (((sc->got_tc) || (sc->got_rec)) && + (!is_rec_op(optimize_op(car(body)))) && + (!is_tc_op(optimize_op(car(body)))) && + (!is_symbol(cadar(body)))) /* and let as start */ + fprintf(stderr, "%s[%d]: %s %d %s\n", __func__, __LINE__, DISPLAY(func), nvars, DISPLAY(body)); +#endif } } } @@ -71686,11 +72854,12 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun } } -static void check_lambda_1(s7_scheme *sc, bool optl) +static int32_t check_lambda_1(s7_scheme *sc, bool optl) { /* code is a lambda form minus the "lambda": ((a b) (+ a b)) */ /* this includes unevaluated symbols (direct symbol table refs) in macro arg list */ s7_pointer code, body, form; + int32_t arity = 0; /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */ @@ -71709,7 +72878,7 @@ static void check_lambda_1(s7_scheme *sc, bool optl) eval_error_no_return(sc, sc->syntax_error_symbol, "lambda: no body? ~A", 19, form); /* in many cases, this is a no-op -- we already checked at define */ - check_lambda_args(sc, car(code), NULL); + check_lambda_args(sc, car(code), &arity); clear_symbol_list(sc); /* look for (define f (let (...) (lambda ...))) and treat as equivalent to (define (f ...)...) @@ -71732,13 +72901,32 @@ static void check_lambda_1(s7_scheme *sc, bool optl) clear_all_optimizations(sc, body); } pair_set_syntax_op(form, OP_LAMBDA_UNCHECKED); + if (arity < -1) arity++; /* confusing! at least 0 = (), but (lambda arg...) has same "arity" here as (lambda (a . b)...)? */ + set_opt3_any(sc->code, (s7_pointer)((intptr_t)arity)); + return(arity); } -static void check_lambda(s7_scheme *sc) +static int32_t check_lambda(s7_scheme *sc) { - check_lambda_1(sc, false); + return(check_lambda_1(sc, false)); } +static void op_lambda(s7_scheme *sc) +{ + int32_t arity; + set_current_code(sc, sc->code); /* sc->value=new closure cell, car=args, cdr=body */ + arity = check_lambda(sc); + set_opt3_any(sc->code, (s7_pointer)((intptr_t)arity)); + make_closure_with_let(sc, sc->value, car(sc->code), cdr(sc->code), sc->envir, arity); +} + +static void op_lambda_unchecked(s7_scheme *sc) +{ + set_current_code(sc, sc->code); /* sc->value=new closure cell, cadr=args, cddr=body */ + make_closure_with_let(sc, sc->value, cadr(sc->code), cddr(sc->code), sc->envir, (int32_t)((intptr_t)opt3_any(cdr(sc->code)))); +} + + static void check_lambda_star(s7_scheme *sc) { s7_pointer form; @@ -71899,6 +73087,8 @@ static s7_pointer check_case(s7_scheme *sc) set_opt1_clause(x, cadar(x)); } } + if (key_type == T_INTEGER) + set_has_integer_keys(form); pair_set_syntax_op(form, OP_CASE_P_G_G); /* fallback on this */ if ((has_feed_to) || @@ -71968,8 +73158,8 @@ static s7_pointer check_case(s7_scheme *sc) } set_current_code(sc, form); - sc->code = cdr(form); - carc = car(sc->code); + sc->code = form; + carc = cadr(sc->code); if (!is_pair(carc)) { if (is_symbol(carc)) @@ -71986,14 +73176,14 @@ static bool op_case_i_s(s7_scheme *sc) { s7_pointer x, selector, else_clause; selector = sc->value; - else_clause = opt3_any(sc->code); + else_clause = opt3_any(cdr(sc->code)); if (else_clause != sc->unspecified) { if (is_t_integer(selector)) { s7_int val; val = integer(selector); - for (x = cdr(sc->code); is_pair(x); x = cdr(x)) + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) { if (is_t_integer(opt2_any(x))) { @@ -72013,7 +73203,7 @@ static bool op_case_i_s(s7_scheme *sc) { s7_int val; val = integer(selector); - for (x = cdr(sc->code); is_pair(x); x = cdr(x)) + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) { if (integer(opt2_any(x)) == val) { @@ -72031,7 +73221,7 @@ static bool op_case_e_g_1(s7_scheme *sc, s7_pointer selector, bool ok) s7_pointer x, y; if (ok) { - for (x = cdr(sc->code); is_pair(x); x = cdr(x)) + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) { y = opt2_any(x); if (!is_pair(y)) /* i.e. else? */ @@ -72047,7 +73237,7 @@ static bool op_case_e_g_1(s7_scheme *sc, s7_pointer selector, bool ok) return(true); } - sc->code = opt3_any(sc->code); + sc->code = opt3_any(cdr(sc->code)); if (sc->code == sc->unused) /* set in check_case if no else clause */ sc->value = sc->unspecified; else @@ -72088,7 +73278,36 @@ static bool op_case_e_g_1(s7_scheme *sc, s7_pointer selector, bool ok) static bool op_case_g_g(s7_scheme *sc) { s7_pointer x, y; - sc->code = cdr(sc->code); + + if (has_integer_keys(sc->code)) + { + s7_int selector; + sc->code = cddr(sc->code); + if (type(sc->value) != T_INTEGER) + { + for (x = sc->code; is_pair(x); x = cdr(x)) /* maybe preset the else case */ + if (!is_pair(caar(x))) + goto ELSE_CASE; + } + else + { + selector = integer(sc->value); + for (x = sc->code; is_pair(x); x = cdr(x)) + { + y = caar(x); + if (!is_pair(y)) + goto ELSE_CASE; + for (; is_pair(y); y = cdr(y)) + if (integer(car(y)) == selector) + goto ELSE_CASE; + } + } + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + } + + sc->code = cddr(sc->code); if (is_simple(sc->value)) { for (x = sc->code; is_pair(x); x = cdr(x)) @@ -72102,7 +73321,7 @@ static bool op_case_g_g(s7_scheme *sc) y = cdr(y); } while (is_pair(y)); } - sc->value = sc->unspecified; /* this was sc->nil but the spec says case value is unspecified if no clauses match */ + sc->value = sc->unspecified; pop_stack(sc); return(true); } @@ -72150,14 +73369,14 @@ static void op_case_e_s(s7_scheme *sc) selector = sc->value; if (is_simple(selector)) { - for (x = cdr(sc->code); is_pair(x); x = cdr(x)) + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) if (opt2_any(x) == selector) { sc->code = opt1_clause(x); return; } } - sc->code = opt3_any(sc->code); + sc->code = opt3_any(cdr(sc->code)); } static void op_case_s_s(s7_scheme *sc) @@ -72166,27 +73385,27 @@ static void op_case_s_s(s7_scheme *sc) selector = sc->value; if (is_symbol(selector)) { - for (x = cdr(sc->code); is_pair(x); x = cdr(x)) + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) if (opt2_any(x) == selector) { sc->code = opt1_clause(x); return; } } - sc->code = opt3_any(sc->code); + sc->code = opt3_any(cdr(sc->code)); } static void op_case_g_s(s7_scheme *sc) { s7_pointer x, selector; selector = sc->value; - for (x = cdr(sc->code); is_pair(x); x = cdr(x)) + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) if (s7_is_eqv(opt2_any(x), selector)) { sc->code = opt1_clause(x); return; } - sc->code = opt3_any(sc->code); + sc->code = opt3_any(cdr(sc->code)); } @@ -72199,20 +73418,10 @@ static void check_let_a_body(s7_scheme *sc, s7_pointer form) fx_tree(sc, cdr(sc->code), caaar(sc->code), NULL); pair_set_syntax_op(form, OP_LET_A_A_OLD); } - else + else { - if ((is_optimized(cadr(sc->code))) || - (is_syntactic_pair(cadr(sc->code)))) + if (is_pair(cadr(sc->code))) pair_set_syntax_op(form, OP_LET_A_P_OLD); - else - { - if ((is_pair(cadr(sc->code))) && - (is_syntactic(caadr(sc->code)))) - { - pair_set_syntax_op(form, OP_LET_A_P_OLD); - set_optimize_op(cadr(sc->code), syntax_opcode(slot_value(global_slot(caadr(sc->code))))); - } - } } } @@ -72293,6 +73502,11 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s annotate_arg(sc, cdr(binding), sc->envir); if (is_null(cddr(sc->code))) check_let_a_body(sc, form); } + + if ((optimize_op(form) == OP_LET_A_OLD) && + (is_pair(cddr(sc->code))) && (is_null(cdddr(sc->code)))) + pair_set_syntax_op(form, OP_LET_A_OLD_2); + return(sc->code); } @@ -72408,6 +73622,7 @@ static s7_pointer check_let(s7_scheme *sc) clear_list_in_use(sc->args); sc->args = sc->nil; } + set_opt3_lamlet(sc->code, sc->nil); return(sc->code); } @@ -72466,6 +73681,10 @@ static s7_pointer check_let(s7_scheme *sc) if (optimize_op(form) >= OP_LET_FX_OLD) { + /* if body_is_safe, we could use sc->lamlets here to save the frame, even if not unheaped, but + * that means we mark the frame one extra time, which matters in random lets, and body_is_safe + * is somewhat expensive. So in most timing tests, the saved let is not an improvement. + */ if ((not_in_heap(form)) && (body_is_safe(sc, sc->unused, cdr(sc->code), true) >= SAFE_BODY)) set_opt3_let(sc->code, make_permanent_let(sc, car(sc->code))); @@ -72476,48 +73695,90 @@ static s7_pointer check_let(s7_scheme *sc) } } + /* TODO: extend to other lets? */ + if ((is_pair(cadr(form))) && + (is_let(sc->envir)) && (is_funclet(sc->envir)) && (tis_slot(let_slots(sc->envir)))) + { + s7_pointer p, s1, s2 = NULL; + s1 = let_slots(sc->envir); + if (tis_slot(next_slot(s1))) s2 = slot_symbol(next_slot(s1)); + s1 = slot_symbol(s1); + for (p = cadr(form); is_pair(p); p = cdr(p)) + { + s7_pointer init; + init = cdar(p); + fx_tree(sc, init, s1, s2); + } + } + return(sc->code); } -static bool op_named_let_1(s7_scheme *sc, s7_pointer args) +static bool op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in decl order */ { - s7_pointer x, let_name, body; + s7_pointer body, x; s7_int n; + /* fprintf(stderr, "named: %s: %s\n", DISPLAY_80(sc->code)); */ - /* fprintf(stderr, "%s[%d]: code: %s, args: %s\n", __func__, __LINE__, DISPLAY_80(sc->code), DISPLAY(args)); */ + if (is_null(opt3_lamlet(sc->code))) + { + sc->w = sc->nil; + for (n = 0, x = cadr(sc->code); is_pair(x); n++, x = cdr(x)) + sc->w = cons(sc, caar(x), sc->w); + sc->w = safe_reverse_in_place(sc, sc->w); /* init values (args) are also in "reversed" order */ + set_opt3_lamlet(sc->code, sc->w); + set_opt2_any(sc->code, small_int(n)); + add_lamlet(sc, sc->code); + } + else + { + sc->w = opt3_lamlet(sc->code); + n = integer(opt2_any(sc->code)); + } - let_name = car(sc->code); body = cddr(sc->code); - sc->envir = new_frame_in_env(sc, sc->envir); - - sc->w = sc->nil; - for (n = 0, x = cadr(sc->code); is_pair(x); n++, x = cdr(x)) - sc->w = cons(sc, caar(x), sc->w); - sc->w = safe_reverse_in_place(sc, sc->w); /* init values (args) are also in "reversed" order */ - - sc->x = make_closure(sc, sc->w, body, T_CLOSURE | T_COPY_ARGS, n); - make_slot_1(sc, sc->envir, let_name, sc->x); - sc->envir = new_frame_in_env(sc, sc->envir); - - for (x = sc->w; is_not_null(args); x = cdr(x)) /* reuse the value cells as the new frame slots */ + + if (is_let(sc->w)) { - s7_pointer sym, new_args; - sym = car(x); - if (sym == let_name) let_name = sc->nil; - new_args = cdr(args); - reuse_as_slot(args, sym, unchecked_car(args)); /* args=slot, sym=symbol, car(args)=value */ - slot_set_next(args, let_slots(sc->envir)); - let_set_slots(sc->envir, args); - symbol_set_local(sym, let_id(sc->envir), args); - args = new_args; - } - closure_set_let(sc->x, sc->envir); - let_set_slots(sc->envir, reverse_slots(sc, let_slots(sc->envir))); - + s7_pointer outer_frame, inner_frame, closure, slot; + outer_frame = sc->w; + closure = slot_value(let_slots(outer_frame)); + inner_frame = closure_let(closure); + set_outlet(outer_frame, sc->envir); + sc->envir = inner_frame; + let_id(sc->envir) = ++sc->let_number; + update_symbol_ids(sc, sc->envir); + for (x = args, slot = let_slots(sc->envir); is_pair(x); x = cdr(x), slot = next_slot(slot)) + slot_set_value(slot, car(x)); + set_slots_set(outer_frame); + } + else + { + sc->envir = new_frame_in_env(sc, sc->envir); + sc->x = make_closure(sc, sc->w, body, T_CLOSURE | T_COPY_ARGS, n); + make_slot_1(sc, sc->envir, car(sc->code), sc->x); /* let_name */ + sc->envir = new_frame_in_env(sc, sc->envir); + + for (x = sc->w; is_not_null(args); x = cdr(x)) /* reuse the value cells as the new frame slots */ + { + s7_pointer sym, new_args; + sym = car(x); + new_args = cdr(args); + reuse_as_slot(args, sym, unchecked_car(args)); /* args=slot, sym=symbol, car(args)=value */ + slot_set_next(args, let_slots(sc->envir)); + let_set_slots(sc->envir, args); + symbol_set_local(sym, let_id(sc->envir), args); + args = new_args; + } + closure_set_let(sc->x, sc->envir); + let_set_slots(sc->envir, reverse_slots(sc, let_slots(sc->envir))); + + if (is_safe_closure_body(body)) + set_opt3_lamlet(sc->code, outlet(closure_let(sc->x))); + sc->x = sc->nil; + } sc->code = T_Pair(body); sc->w = sc->nil; - sc->x = sc->nil; - sc->y = sc->nil; return(true); } @@ -72705,22 +73966,43 @@ static void op_let_one_p_old(s7_scheme *sc) sc->code = T_Pair(opt2_pair(sc->code)); } +static void op_let_one_old_1(s7_scheme *sc) +{ + s7_pointer frame; + frame = old_frame_with_slot(sc, opt3_let(sc->code), sc->value); + set_outlet(frame, sc->envir); + sc->envir = frame; + sc->code = cdr(sc->code); +} + +static void op_let_one_p_old_1(s7_scheme *sc) +{ + s7_pointer frame; + frame = old_frame_with_slot(sc, opt3_let(sc->code), sc->value); + set_outlet(frame, sc->envir); + sc->envir = frame; + sc->code = cadr(sc->code); +} + +#if WITH_GCC +static inline void op_let_a_new(s7_scheme *sc) __attribute__((always_inline)); +#endif + static inline void op_let_a_new(s7_scheme *sc) { - s7_pointer binding; start_let(sc); - binding = opt2_pair(sc->code); - sc->temp2 = fx_call(sc, cdr(binding)); /* this is probably not needed (detritus from chasing a different bug) */ - new_frame_with_slot(sc, sc->envir, sc->envir, car(binding), sc->temp2); - sc->temp2 = sc->nil; + new_frame_with_slot(sc, sc->envir, sc->envir, car(opt2_pair(sc->code)), fx_call(sc, cdr(opt2_pair(sc->code)))); } +#if WITH_GCC +static inline void op_let_a_old(s7_scheme *sc) __attribute__((always_inline)); +#endif + static inline void op_let_a_old(s7_scheme *sc) { - s7_pointer binding, frame; + s7_pointer frame; start_let(sc); - binding = opt2_pair(sc->code); - frame = old_frame_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(binding))); + frame = old_frame_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); set_outlet(frame, sc->envir); sc->envir = frame; } @@ -72739,14 +74021,12 @@ static void op_let_a_a_new(s7_scheme *sc) static void op_let_a_a_old(s7_scheme *sc) { - s7_pointer binding, frame; + s7_pointer frame; start_let(sc); - binding = opt2_pair(sc->code); - frame = old_frame_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(binding))); + frame = old_frame_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); set_outlet(frame, sc->envir); sc->envir = frame; sc->value = fx_call(sc, cdr(sc->code)); - /* upon return, we goto START, so sc->envir should be ok */ } static void op_let_a_fx_new(s7_scheme *sc) @@ -72764,10 +74044,9 @@ static void op_let_a_fx_new(s7_scheme *sc) static void op_let_a_fx_old(s7_scheme *sc) { - s7_pointer binding, frame, p; + s7_pointer frame, p; start_let(sc); - binding = opt2_pair(sc->code); - frame = old_frame_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(binding))); + frame = old_frame_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); set_outlet(frame, sc->envir); sc->envir = frame; for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) @@ -73077,6 +74356,7 @@ static bool check_let_star(s7_scheme *sc) if (optimize_op(form) >= OP_LET_FX_OLD) { if ((not_in_heap(form)) && + (is_null(cdar(sc->code))) && /* else order of vars in permanent let can confuse fx_tree */ (body_is_safe(sc, sc->unused, cdr(sc->code), true) >= SAFE_BODY)) set_opt3_let(sc->code, make_permanent_let(sc, car(sc->code))); else @@ -73469,29 +74749,30 @@ static s7_pointer check_let_temporarily(s7_scheme *sc) if ((all_fx) || (all_s7)) { - pair_set_syntax_op(form, (all_fx) ? OP_LET_TEMP_FX : OP_LET_TEMP_S7); + pair_set_syntax_op(form, (all_fx) ? ((is_null(cdar(sc->code))) ? OP_LET_TEMP_FX_1 : OP_LET_TEMP_FX) : OP_LET_TEMP_S7); for (x = car(sc->code); is_pair(x); x = cdr(x)) annotate_arg(sc, cdar(x), sc->envir); } else { -#if 0 - /* let-temp_setter (tset): get slot_setter from setter args (symbol_to_local_slot(sc, sym, e), slot_set_setter to val...restore - * this is a mess: unopt args in car-as-pair means not fxable - */ + pair_set_syntax_op(form, OP_LET_TEMP_UNCHECKED); if ((is_pair(car(sc->code))) && (is_null(cdar(sc->code))) && (is_pair(caar(sc->code)))) { - s7_pointer var; + s7_pointer var, val; var = caar(sc->code); - if ((is_pair(car(var))) && (caar(var) == sc->setter_symbol) && - (is_fxable(sc, cadar(var))) && (is_fxable(sc, caddar(var)))) - fprintf(stderr, "setter: %s\n", DISPLAY(sc->code)); - else fprintf(stderr, "%s: %d %d %s %s\n", DISPLAY(car(var)), - is_fxable(sc, cadar(var)), is_fxable(sc, caddar(var)), - op_names[optimize_op(cadar(var))], op_names[optimize_op(caddar(var))]); + val = cadr(var); + var = car(var); + if ((is_pair(var)) && (car(var) == sc->setter_symbol) && (is_pair(cdr(var))) && (is_pair(cddr(var))) && (val == sc->F)) + { + optimize_expression(sc, cadr(var), 0, sc->envir, false); + optimize_expression(sc, caddr(var), 0, sc->envir, false); + if ((is_fxable(sc, cadr(var))) && (is_fxable(sc, caddr(var)))) + { + annotate_args(sc, cdr(var), sc->envir); + pair_set_syntax_op(form, OP_LET_TEMP_SETTER); + } + } } -#endif - pair_set_syntax_op(form, OP_LET_TEMP_UNCHECKED); } sc->code = form; return(sc->code); @@ -73534,7 +74815,10 @@ static bool op_let_temp_init1(s7_scheme *sc) return(false); } -static s7_pointer op_let_temp_init2(s7_scheme *sc) +typedef enum {goto_start, goto_begin, fall_through, goto_do_end_clauses, goto_safe_do_end_clauses, goto_eval, + goto_top_no_pop, goto_apply, goto_eval_args, goto_eval_args_top, goto_do_unchecked, goto_pop_read_list, goto_read_tok} goto_t; + +static goto_t op_let_temp_init2(s7_scheme *sc) { /* now eval set car new-val, cadr=settees, cadddr= new_values */ while (is_pair(car(sc->args))) @@ -73550,7 +74834,7 @@ static s7_pointer op_let_temp_init2(s7_scheme *sc) { push_stack(sc, OP_LET_TEMP_INIT2, sc->args, sc->code); sc->code = list_3(sc, sc->set_symbol, settee, new_value); - return(NULL); + return(goto_top_no_pop); } slot = symbol_to_slot(sc, settee); if (!is_slot(slot)) @@ -73563,12 +74847,15 @@ static s7_pointer op_let_temp_init2(s7_scheme *sc) } car(sc->args) = cadr(sc->args); pop_stack(sc); - push_stack(sc, OP_LET_TEMP_DONE, sc->args, sc->code); + /* push_stack(sc, OP_LET_TEMP_DONE, sc->args, sc->code); */ /* we fall into LET_TEMP_DONE below so this seems redundant */ sc->code = cdr(sc->code); if (is_pair(sc->code)) - return(sc->unused); + { + push_stack(sc, OP_LET_TEMP_DONE, sc->args, sc->code); + return(goto_begin); + } sc->value = sc->nil; /* so (let-temporarily (<vars)) -> () like begin I guess */ - return(sc->code); + return(fall_through); } static bool op_let_temp_done1(s7_scheme *sc) @@ -73629,6 +74916,23 @@ static void op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* sc->code = cdr(sc->code); } +static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_pointer let) +{ + /* called in call/cc, call-with-exit and, catch (unwind to catch) */ + push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); + sc->args = T_Pos(args); + sc->code = code; + sc->envir = let; + eval(sc, OP_LET_TEMP_DONE); +} + +static void op_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) */ + slot_set_value(slot, s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); + else slot_set_value(slot, new_value); +} + static void op_let_temp_fx(s7_scheme *sc) /* all entries are of the form (symbol fx-able-value) */ { s7_pointer p, var, settee, new_val, slot; @@ -73662,22 +74966,61 @@ static void op_let_temp_fx(s7_scheme *sc) /* all entries are of the form (symbol sc->code = cdr(sc->code); } +static void op_let_temp_fx_1(s7_scheme *sc) /* one entry */ +{ + s7_pointer var, settee, new_val, slot; + set_current_code(sc, sc->code); + sc->code = cdr(sc->code); + var = caar(sc->code); + settee = car(var); + slot = symbol_to_slot(sc, settee); + if (!is_slot(slot)) + eval_error_no_return(sc, sc->unbound_variable_symbol, "~A: unbound variable", 20, settee); + if (is_immutable_slot(slot)) + immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); + 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))); + else slot_set_value(slot, new_val); + sc->code = cdr(sc->code); +} + +static void op_let_temp_setter(s7_scheme *sc) +{ + s7_pointer var, slot, sym, e; + set_current_code(sc, sc->code); + sc->code = cdr(sc->code); + var = caaar(sc->code); + sym = fx_call(sc, cdr(var)); + e = sc->envir; + sc->envir = fx_call(sc, cddr(var)); + slot = symbol_to_slot(sc, sym); + sc->envir = e; + push_stack(sc, OP_LET_TEMP_SETTER_UNWIND, slot_setter(slot), slot); + slot_set_setter(slot, sc->F); + sc->code = cdr(sc->code); +} + /* -------------------------------- quote -------------------------------- */ static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code) { - s7_pointer form; - form = code; - code = cdr(code); - if (!is_pair(code)) /* (quote . -1) */ + if (!is_pair(cdr(code))) /* (quote . -1) */ { - if (is_null(code)) - eval_error(sc, "quote: not enough arguments: ~A", 31, form); - eval_error(sc, "quote: stray dot?: ~A", 21, form); + if (is_null(cdr(code))) + eval_error(sc, "quote: not enough arguments: ~A", 31, code); + eval_error(sc, "quote: stray dot?: ~A", 21, code); } - if (is_not_null(cdr(code))) /* (quote . (1 2)) or (quote 1 1) */ - eval_error(sc, "quote: too many arguments ~A", 28, form); - return(code); + if (is_not_null(cddr(code))) /* (quote . (1 2)) or (quote 1 1) */ + eval_error(sc, "quote: too many arguments ~A", 28, code); + return(cadr(code)); + + /* I think a quoted list in another list can be applied to a function, come here and + * be changed to unchecked, set-cdr! or something clobbers the argument so we get + * here on the next time around with the equivalent of (quote . 0) if unchecked + * so set-cdr! of constant -- if marked immutable, we could catch this case and clear. + */ } @@ -73783,6 +75126,34 @@ static void op_and_safe_p(s7_scheme *sc) } } +static void op_and_safe_p1(s7_scheme *sc) /* sc->code: (and (func...) (fx...)...) */ +{ + sc->code = cdr(sc->code); + push_stack_no_args(sc, OP_AND_SAFE_P_REST, cdr(sc->code)); + sc->code = car(sc->code); +} + +static bool op_and_safe_p2(s7_scheme *sc) +{ + sc->value = fx_call(sc, cdr(sc->code)); + if (is_false(sc, sc->value)) return(true); + sc->code = cddr(sc->code); + push_stack_no_args(sc, OP_AND_SAFE_P_REST, cdr(sc->code)); + sc->code = car(sc->code); + return(false); +} + +static bool op_and_safe_p3(s7_scheme *sc) +{ + sc->value = fx_call(sc, cdr(sc->code)); + if (is_false(sc, sc->value)) return(true); + sc->code = cddr(sc->code); + sc->value = fx_call(sc, sc->code); + if (is_false(sc, sc->value)) return(true); + sc->code = cadr(sc->code); + return(false); +} + /* -------------------------------- or -------------------------------- */ static bool check_or(s7_scheme *sc) @@ -73853,37 +75224,33 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re test = cadr(test); } + /* [and2 tset > 5% 3088->3268][is_type titer 2836->2931][cs fb 2694->2720] */ if (is_pair(test)) { if (is_h_optimized(test)) { if (is_h_safe_c_d(test)) { - clear_has_fx(sc->code); if (c_callee(test) == g_and_2) { + clear_has_fx(sc->code); pair_set_syntax_op(form, choose_if_optc(IF_AND2, one_branch, reversed, not_case)); set_opt2_pair(sc->code, cdr(test)); set_opt3_pair(sc->code, cddr(test)); return; } - if (c_callee(test) == g_and_3) - { - pair_set_syntax_op(form, choose_if_optc(IF_AND3, one_branch, reversed, not_case)); - set_opt2_pair(sc->code, cdr(test)); - set_opt3_pair(sc->code, cddr(test)); - return; - } if (c_callee(test) == g_or_2) { + clear_has_fx(sc->code); pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case)); set_opt2_pair(sc->code, cdr(test)); set_opt3_pair(sc->code, cddr(test)); return; } - /* perhaps use if_a here? */ - set_opt2_pair(sc->code, cdr(test)); - pair_set_syntax_op(form, choose_if_optc(IF_D, one_branch, reversed, not_case)); + pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); + if (not_case) + set_c_call(cdar(sc->code), fx_choose(sc, cdar(sc->code), sc->envir, let_symbol_is_safe)); + else set_c_call(sc->code, fx_choose(sc, sc->code, sc->envir, let_symbol_is_safe)); return; } @@ -73894,54 +75261,13 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re if (typ > 0) { pair_set_syntax_op(form, choose_if_optc(IF_IS_TYPE_S, one_branch, reversed, not_case)); - set_opt3_con(sc->code, typ); + set_opt3_byte(sc->code, typ); } - else pair_set_syntax_op(form, choose_if_optc(IF_CS, one_branch, reversed, not_case)); + else pair_set_syntax_op(form, choose_if_optc(IF_opSq, one_branch, reversed, not_case)); clear_has_fx(sc->code); set_opt2_sym(sc->code, cadr(test)); return; } - - if (optimize_op(test) == HOP_SAFE_C_SS) - { - pair_set_syntax_op(form, choose_if_optc(IF_CSS, one_branch, reversed, not_case)); - clear_has_fx(sc->code); - set_opt2_sym(sc->code, caddr(test)); - set_opt3_sym(sc->code, cadr(test)); - return; - } - if (optimize_op(test) == HOP_SAFE_C_SC) - { - pair_set_syntax_op(form, choose_if_optc(IF_CSC, one_branch, reversed, not_case)); - clear_has_fx(sc->code); - set_opt2_con(sc->code, (is_pair(caddr(test))) ? cadr(caddr(test)) : caddr(test)); - set_opt3_sym(sc->code, cadr(test)); - return; - } - - /* perhaps if_sa here? */ - if (optimize_op(test) == HOP_SAFE_C_S_opDq) - { - pair_set_syntax_op(form, choose_if_optc(IF_S_opDq, one_branch, reversed, not_case)); - clear_has_fx(sc->code); - set_opt2_pair(sc->code, caddr(test)); - set_opt3_sym(sc->code, cadr(test)); - return; - } - - if (optimize_op(test) == HOP_SAFE_C_opSq) - { - uint8_t typ; - typ = symbol_type(car(test)); - clear_has_fx(sc->code); - if (typ > 0) - { - pair_set_syntax_op(form, choose_if_optc(IF_IS_TYPE_opSq, one_branch, reversed, not_case)); - set_opt2_sym(sc->code, cadadr(test)); - set_opt3_con(sc->code, typ); - return; - } - } if (is_fxable(sc, test)) { /* if (one_branch) fprintf(stderr, "%s\n", DISPLAY_80(sc->code)); */ @@ -74032,6 +75358,35 @@ static s7_pointer check_if(s7_scheme *sc) return(sc->code); } +static void op_if(s7_scheme *sc) +{ + set_current_code(sc, sc->code); + check_if(sc); + push_stack_no_args(sc, OP_IF1, cdr(sc->code)); + sc->code = car(sc->code); +} + +static void op_if_unchecked(s7_scheme *sc) +{ + set_current_code(sc, sc->code); + push_stack_no_args(sc, OP_IF1, cddr(sc->code)); + sc->code = cadr(sc->code); +} + +static bool op_if1(s7_scheme *sc) +{ + if (is_true(sc, sc->value)) + sc->code = car(sc->code); + else sc->code = unchecked_car(cdr(sc->code)); /* even pre-optimization, (if #f #f) ==> #<unspecified> because unique_car(sc->nil) = sc->unspecified */ + if (is_pair(sc->code)) + return(true); + if (is_symbol(sc->code)) + sc->value = lookup_checked(sc, sc->code); + else sc->value = sc->code; + return(false); +} + + /* -------------------------------- when -------------------------------- */ static s7_pointer check_when(s7_scheme *sc) @@ -74252,6 +75607,32 @@ static bool op_unless_pp(s7_scheme *sc) } +/* check_begin in effect */ +static bool op_begin(s7_scheme *sc) +{ + s7_pointer form; + form = sc->code; + set_current_code(sc, sc->code); + sc->code = cdr(sc->code); + if (!s7_is_proper_list(sc, sc->code)) /* proper list includes () */ + eval_error_no_return(sc, sc->syntax_error_symbol, "unexpected dot? ~A", 18, form); + if (is_null(sc->code)) /* (begin) -> () */ + { + sc->value = sc->nil; + return(true); + } + if (is_null(cdr(sc->code))) + pair_set_syntax_op(form, OP_BEGIN_1_UNCHECKED); + else + { + if (is_null(cddr(sc->code))) + pair_set_syntax_op(form, OP_BEGIN_2_UNCHECKED); + else pair_set_syntax_op(form, OP_BEGIN_UNCHECKED); + } + return(false); +} + + /* -------------------------------- define -------------------------------- */ static s7_pointer print_truncate(s7_scheme *sc, s7_pointer code) { @@ -74364,7 +75745,7 @@ static s7_pointer check_define(s7_scheme *sc) static bool op_define_unchecked(s7_scheme *sc) { - if (sc->cur_op == OP_DEFINE_STAR_UNCHECKED) + if (sc->cur_op == OP_DEFINE_STAR_UNCHECKED) /* sc->cur_op changed above if define* */ { s7_pointer x; uint64_t typ; @@ -74395,7 +75776,7 @@ static bool op_define_unchecked(s7_scheme *sc) } if (is_symbol(sc->code)) - sc->value = find_global_symbol_checked(sc, sc->code); + sc->value = lookup_global(sc, sc->code); else sc->value = sc->code; sc->code = x; } @@ -74544,6 +75925,21 @@ static bool op_define_constant(s7_scheme *sc) return(false); } +static void op_define_constant1(s7_scheme *sc) +{ + if (is_pair(sc->code)) + sc->code = car(sc->code); /* (define-constant (ex3 a)...) */ + if (is_symbol(sc->code)) + { + s7_pointer slot; + slot = symbol_to_slot(sc, sc->code); + set_possibly_constant(sc->code); + set_immutable(slot); + if (is_any_closure(slot_value(slot))) + set_immutable(slot_value(slot)); /* for the optimizer mainly */ + } +} + static void define_funchecked(s7_scheme *sc) { s7_pointer new_func, code, slot; @@ -74675,6 +76071,21 @@ static bool op_define_macro(s7_scheme *sc) return(true); } +static bool op_macro_d(s7_scheme *sc) +{ + sc->value = lookup(sc, car(sc->code)); + if (!is_macro(sc->value)) + { + set_optimize_op(sc->code, OP_PAIR_SYM); + return(true); + } + sc->args = copy_list_with_arglist_error(sc, cdr(sc->code)); + sc->code = sc->value; + push_stack_op_let(sc, OP_EVAL_MACRO); + new_frame(sc, closure_let(sc->code), sc->envir); + return(false); +} + static goto_t op_expansion(s7_scheme *sc) { int64_t loc; @@ -74758,7 +76169,7 @@ static goto_t op_expansion(s7_scheme *sc) else { sc->args = copy_list(sc, cdr(sc->value)); - return(goto_APPLY); + return(goto_apply); } } return(fall_through); @@ -74791,6 +76202,14 @@ static bool op_macroexpand(s7_scheme *sc) return(false); } +static void eval_args_expand_macro(s7_scheme *sc) +{ + sc->args = copy_list_with_arglist_error(sc, cdr(sc->code)); + if (is_macro(sc->value)) + set_optimize_op(sc->code, OP_MACRO_D); + sc->code = sc->value; +} + /* -------------------------------- with-let -------------------------------- */ static s7_pointer check_with_let(s7_scheme *sc) @@ -74906,9 +76325,13 @@ static s7_pointer check_cond(s7_scheme *sc) p = car(x); if (is_fxable(sc, car(p))) annotate_arg(sc, p, sc->envir); +#if 1 if ((is_pair(cdr(p))) && (is_fxable(sc, cadr(p)))) annotate_arg(sc, cdr(p), sc->envir); +#else + annotate_args(sc, cdr(p), sc->envir); +#endif } if (has_feed_to) @@ -75290,6 +76713,63 @@ static bool op_cond_fx_2p_else(s7_scheme *sc) return(fx_cond_value(sc)); } +static bool op_cond_feed(s7_scheme *sc) +{ + /* (cond (expr => p)) where p is (lambda (s) ...) -- see check_cond */ + set_current_code(sc, sc->code); + sc->code = cdr(sc->code); + if (has_fx(car(sc->code))) + sc->value = fx_call(sc, car(sc->code)); + else + { + push_stack_no_args(sc, OP_COND_FEED_1, sc->code); + sc->code = caar(sc->code); + return(true); + } + return(false); +} + +static bool op_cond_feed_1(s7_scheme *sc) +{ + if (is_true(sc, sc->value)) + { + if (is_multiple_value(sc->value)) + sc->code = cons(sc, opt2_lambda(sc->code), multiple_value(sc->value)); + else + { + new_frame_with_slot(sc, sc->envir, sc->envir, caadr(opt2_lambda(sc->code)), sc->value); + sc->code = caddr(opt2_lambda(sc->code)); + } + return(true); + } + sc->value = sc->unspecified; /* it's cond -- perhaps push as sc->args above; this was nil until 21-Feb-17! */ + return(false); +} + +static bool feed_to(s7_scheme *sc) +{ + if (is_multiple_value(sc->value)) + { + sc->args = multiple_value(sc->value); + clear_multiple_value(sc->args); + } + else + { + if (is_symbol(cadr(sc->code))) + { + s7_pointer func; + func = lookup_global(sc, cadr(sc->code)); /* car is => */ + sc->code = func; + sc->args = (needs_copied_args(func)) ? list_1(sc, sc->value) : set_plist_1(sc, sc->value); + return(true); + } + sc->args = list_1(sc, sc->value); /* not plist here */ + } + push_stack(sc, OP_FEED_TO_1, sc->args, sc->code); + sc->code = cadr(sc->code); /* need to evaluate the target function */ + return(false); +} + /* -------------------------------- set! -------------------------------- */ static void set_dilambda_opt(s7_scheme *sc, s7_pointer form, opcode_t opt, s7_pointer expr) @@ -75500,85 +76980,67 @@ static inline s7_pointer check_set(s7_scheme *sc) * which is caught in splice_in_values */ pair_set_syntax_op(form, OP_SET_SYMBOL_P); - if (is_h_safe_c_s(value)) + if (is_optimized(value)) { - pair_set_syntax_op(form, OP_SET_SYMBOL_opSq); - set_opt2_sym(sc->code, cadr(value)); - /* using direct_x_call here via OP_SET_SYMBOL_opSq_direct was not faster */ - } - else - { - if (is_optimized(value)) + if (is_h_safe_c_d(value)) + { + pair_set_syntax_op(form, OP_SET_SYMBOL_A); + annotate_arg(sc, cdr(sc->code), sc->envir); + } + else { - if (is_h_safe_c_d(value)) + /* most of these special cases probably don't matter; set_symbol_opscq called 500k times barely registered in callgrind */ + if (optimize_op(value) == HOP_SAFE_C_SS) { - pair_set_syntax_op(form, OP_SET_SYMBOL_A); - annotate_arg(sc, cdr(sc->code), sc->envir); + if (settee == cadr(value)) + { + pair_set_syntax_op(form, OP_INCREMENT_SS); + set_opt2_sym(sc->code, caddr(value)); + } + else + { + pair_set_syntax_op(form, OP_SET_SYMBOL_A); + annotate_arg(sc, cdr(sc->code), sc->envir); + } } else { - /* most of these special cases probably don't matter; set_symbol_opscq called 500k times barely registered in callgrind */ - if (optimize_op(value) == HOP_SAFE_C_SS) + if (is_fxable(sc, value)) /* value = cadr(sc->code) */ { - if (settee == cadr(value)) - { - pair_set_syntax_op(form, OP_INCREMENT_SS); - set_opt2_sym(sc->code, caddr(value)); - } - else - { - pair_set_syntax_op(form, OP_SET_SYMBOL_opSSq); - set_opt2_pair(sc->code, cdr(value)); - } + pair_set_syntax_op(form, OP_SET_SYMBOL_A); + annotate_arg(sc, cdr(sc->code), sc->envir); } - else + if ((is_safe_c_op(optimize_op(value))) && + (is_pair(cdr(value))) && + (settee == cadr(value)) && + (!is_null(cddr(value)))) { - if ((optimize_op(value) == HOP_SAFE_C_SSS) && - (settee == cadr(value)) && - (car(value) == sc->add_symbol)) + if (is_null(cdddr(value))) { - pair_set_syntax_op(form, OP_INCREMENT_SSS); - set_opt2_pair(sc->code, cdr(value)); + if (is_fxable(sc, caddr(value))) + { + pair_set_syntax_op(form, OP_INCREMENT_SA); + annotate_arg(sc, cddr(value), sc->envir); /* this sets c_callee(arg) */ + /* increment_sc does not happen much here */ + set_opt2_pair(sc->code, cddr(value)); + } + else + { + pair_set_syntax_op(form, OP_INCREMENT_SP); + set_opt2_pair(sc->code, caddr(value)); + } } else { - if (is_fxable(sc, value)) /* value = cadr(sc->code) */ - { - pair_set_syntax_op(form, OP_SET_SYMBOL_A); - annotate_arg(sc, cdr(sc->code), sc->envir); - } - if ((is_safe_c_op(optimize_op(value))) && - (is_pair(cdr(value))) && - (settee == cadr(value)) && - (!is_null(cddr(value)))) + if ((is_null(cddddr(value))) && + (is_fxable(sc, caddr(value))) && + (is_fxable(sc, cadddr(value)))) { - if (is_null(cdddr(value))) - { - if (is_fxable(sc, caddr(value))) - { - pair_set_syntax_op(form, OP_INCREMENT_SA); - annotate_arg(sc, cddr(value), sc->envir); /* this sets c_callee(arg) */ - /* increment_sc does not happen much here */ - set_opt2_pair(sc->code, cddr(value)); - } - else - { - pair_set_syntax_op(form, OP_INCREMENT_SP); - set_opt2_pair(sc->code, caddr(value)); - } - } - else - { - if ((is_null(cddddr(value))) && - (is_fxable(sc, caddr(value))) && - (is_fxable(sc, cadddr(value)))) - { - pair_set_syntax_op(form, OP_INCREMENT_SAA); - annotate_arg(sc, cddr(value), sc->envir); - annotate_arg(sc, cdddr(value), sc->envir); - set_opt2_pair(sc->code, cddr(value)); - }}}}}}} - } + pair_set_syntax_op(form, OP_INCREMENT_SAA); + annotate_arg(sc, cddr(value), sc->envir); + annotate_arg(sc, cdddr(value), sc->envir); + set_opt2_pair(sc->code, cddr(value)); + }}}}}} if ((is_h_optimized(value)) && (!is_unsafe(value)) && /* is_unsafe(value) can happen! */ (is_not_null(cdr(value)))) /* (set! x (y)) */ @@ -75588,7 +77050,7 @@ static inline s7_pointer check_set(s7_scheme *sc) if ((caddr(value) == small_int(1)) && (cadr(value) == settee)) { - if (opt1_cfunc(value) == sc->add_s1) + if (opt1_cfunc(value) == sc->add_x1) pair_set_syntax_op(form, OP_INCREMENT_1); else { @@ -75600,7 +77062,7 @@ static inline s7_pointer check_set(s7_scheme *sc) { if ((cadr(value) == small_int(1)) && (caddr(value) == settee) && - (opt1_cfunc(value) == sc->add_1s)) + (opt1_cfunc(value) == sc->add_1x)) pair_set_syntax_op(form, OP_INCREMENT_1); else { @@ -75643,25 +77105,6 @@ static void op_set_cons(s7_scheme *sc) slot_set_value(slot, sc->value = cons(sc, lookup(sc, opt2_sym(cdr(sc->code))), slot_value(slot))); /* ([set!] bindings (cons v bindings)) */ } -static void op_set_symbol_opsq(s7_scheme *sc) -{ - s7_pointer slot; - sc->code = cdr(sc->code); - slot = symbol_to_slot(sc, car(sc->code)); - set_car(sc->t1_1, lookup(sc, opt2_sym(sc->code))); - slot_set_value(slot, sc->value = c_call(cadr(sc->code))(sc, sc->t1_1)); -} - -static void op_set_symbol_opssq(s7_scheme *sc) -{ - s7_pointer slot; - sc->code = cdr(sc->code); - slot = symbol_to_slot(sc, car(sc->code)); - set_car(sc->t2_1, lookup(sc, car(opt2_pair(sc->code)))); - set_car(sc->t2_2, lookup(sc, cadr(opt2_pair(sc->code)))); - slot_set_value(slot, sc->value = c_call(cadr(sc->code))(sc, sc->t2_1)); -} - static void op_increment_ss(s7_scheme *sc) { s7_pointer slot; @@ -75672,32 +77115,6 @@ static void op_increment_ss(s7_scheme *sc) slot_set_value(slot, sc->value = c_call(cadr(sc->code))(sc, sc->t2_1)); } -#if WITH_GMP -#define global_add big_add -#else -#define global_add g_add -#endif - -static void op_increment_sss(s7_scheme *sc) -{ - s7_pointer slot, x1, x2, x3; - sc->code = cdr(sc->code); - slot = symbol_to_slot(sc, car(sc->code)); - x1 = slot_value(slot); - x2 = lookup(sc, opt1_sym(opt2_pair(sc->code))); - x3 = lookup(sc, opt2_sym(opt2_pair(sc->code))); - if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) - slot_set_value(slot, make_real(sc, real(x1) + real(x2) + real(x3))); - else - { - set_car(sc->t3_1, x1); - set_car(sc->t3_2, x2); - set_car(sc->t3_3, x3); - slot_set_value(slot, global_add(sc, sc->t3_1)); - } - sc->value = slot_value(slot); -} - static void op_increment_saa(s7_scheme *sc) { s7_pointer slot, arg, val; @@ -76189,6 +77606,36 @@ static void op_increment_sp_mv(s7_scheme *sc) slot_set_value(sc->args, sc->value); } +static goto_t op_set_dilambda_p_1(s7_scheme *sc) +{ + s7_pointer obj, func, arg; + arg = cadar(sc->code); + if (is_symbol(arg)) + arg = lookup_checked(sc, arg); + else + { + if (is_pair(arg)) + arg = cadr(arg); /* can only be (quote ...) in this case */ + } + obj = symbol_to_slot(sc, caar(sc->code)); + func = slot_value(obj); + if ((is_closure(func)) && + (is_safe_closure(closure_setter(func)))) + { + s7_pointer setter; + setter = closure_setter(func); + if (is_pair(closure_args(setter))) + { + sc->envir = old_frame_with_two_slots(sc, closure_let(setter), arg, sc->value); + sc->code = T_Pair(closure_body(setter)); + return(goto_begin); + } + } + if (set_pair_p_3(sc, obj, arg, sc->value)) + return(goto_apply); + return(goto_start); +} + /* -------------------------------- do -------------------------------- */ static bool safe_stepper_expr(s7_pointer expr, s7_pointer vars) @@ -76245,7 +77692,7 @@ static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer cx) sc->code = cadr(settee); } sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } index = cadr(settee); @@ -76263,18 +77710,18 @@ static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer cx) set_car(sc->t3_2, index); set_car(sc->t3_3, val); sc->value = (*(c_object_set(sc, cx)))(sc, sc->t3_1); - return(goto_START); + return(goto_start); } push_op_stack(sc, sc->c_object_set_function); sc->args = list_2(sc, index, cx); sc->code = cdr(sc->code); - return(goto_EVAL_ARGS); + return(goto_eval_args); } push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code)); push_op_stack(sc, sc->c_object_set_function); sc->code = cadr(settee); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form) @@ -76306,7 +77753,7 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form) push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); sc->code = list_2(sc, car(settee), cadr(settee)); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } /* fprintf(stderr, "%s: %s %ld %ld\n", __func__, DISPLAY(form), argnum, vector_rank(cx)); */ @@ -76349,14 +77796,14 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form) if (in_heap(args)) sc->stack_end -= 4; else clear_list_in_use(args); - return(goto_START); + return(goto_start); } } push_op_stack(sc, sc->vector_set_function); /* vector_setter(cx) has wrong args */ push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code))); /* i.e. rest(args) + val */ sc->code = cadr(settee); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } /* one index, rank == 1 */ @@ -76390,19 +77837,19 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form) typed_vector_setter(sc, cx, ind, val); else vector_setter(cx)(sc, cx, ind, val); sc->value = T_Pos(val); - return(goto_START); + return(goto_start); } push_op_stack(sc, sc->vector_set_function); sc->args = list_2(sc, index, cx); sc->code = cdr(sc->code); - return(goto_EVAL_ARGS); + return(goto_eval_args); } /* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens */ push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code)); push_op_stack(sc, sc->vector_set_function); sc->code = cadr(settee); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit_string(s7_scheme *sc, s7_pointer cx) @@ -76451,20 +77898,20 @@ static goto_t set_implicit_string(s7_scheme *sc, s7_pointer cx) { string_value(cx)[ind] = character(val); sc->value = val; - return(goto_START); + return(goto_start); } eval_error_no_return(sc, sc->wrong_type_arg_symbol, "value must be a character: ~S", 29, sc->code); } push_op_stack(sc, sc->string_set_function); sc->args = list_2(sc, index, cx); sc->code = cdr(sc->code); - return(goto_EVAL_ARGS); + return(goto_eval_args); } push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code)); push_op_stack(sc, sc->string_set_function); sc->code = cadar(sc->code); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer cx) /* code: ((lst 1) 32) from (let ((lst (list 1 2 3))) (set! (lst 1) 32)) */ @@ -76488,7 +77935,7 @@ static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer cx) /* code: ((ls push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); sc->code = list_2(sc, car(settee), cadr(settee)); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } index = cadr(settee); @@ -76501,7 +77948,7 @@ static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer cx) /* code: ((ls push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code))); sc->code = index; sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } if (is_symbol(index)) @@ -76512,7 +77959,7 @@ static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer cx) /* code: ((ls set_car(sc->t2_1, index); set_car(sc->t2_2, val); sc->value = g_list_set_1(sc, cx, sc->t2_1, 2); - return(goto_START); + return(goto_start); } static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer cx) @@ -76535,7 +77982,7 @@ static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer cx) push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); sc->code = list_2(sc, car(settee), cadr(settee)); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } key = cadr(settee); @@ -76550,18 +77997,18 @@ static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer cx) if (is_symbol(val)) val = lookup_checked(sc, val); sc->value = s7_hash_table_set(sc, cx, key, val); - return(goto_START); + return(goto_start); } push_op_stack(sc, sc->hash_table_set_function); sc->args = list_2(sc, key, cx); sc->code = cdr(sc->code); - return(goto_EVAL_ARGS); + return(goto_eval_args); } push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code)); push_op_stack(sc, sc->hash_table_set_function); sc->code = cadar(sc->code); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit_let(s7_scheme *sc, s7_pointer cx) /* sc->code = cons(sc, sc->let_set_function, s7_append(sc, car(sc->code), cdr(sc->code))); */ @@ -76585,7 +78032,7 @@ static goto_t set_implicit_let(s7_scheme *sc, s7_pointer cx) /* sc->code = c push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); sc->code = list_2(sc, car(settee), cadr(settee)); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } key = cadr(settee); @@ -76599,18 +78046,18 @@ static goto_t set_implicit_let(s7_scheme *sc, s7_pointer cx) /* sc->code = c if (is_symbol(val)) val = lookup_checked(sc, val); sc->value = s7_let_set(sc, cx, key, val); - return(goto_START); + return(goto_start); } push_op_stack(sc, sc->let_set_function); sc->args = list_2(sc, key, cx); sc->code = cdr(sc->code); - return(goto_EVAL_ARGS); + return(goto_eval_args); } push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), cdr(sc->code)); push_op_stack(sc, sc->let_set_function); sc->code = cadar(sc->code); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit_function(s7_scheme *sc, s7_pointer cx) /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */ @@ -76638,7 +78085,7 @@ static goto_t set_implicit_function(s7_scheme *sc, s7_pointer cx) /* (let ((lst sc->args = sc->t2_1; } sc->code = c_function_setter(cx); - return(goto_APPLY); /* check arg num etc */ + return(goto_apply); /* check arg num etc */ } if ((is_symbol(caddar(sc->code))) && (is_null(cdddar(sc->code)))) @@ -76656,7 +78103,7 @@ static goto_t set_implicit_function(s7_scheme *sc, s7_pointer cx) /* (let ((lst sc->args = sc->t3_1; } sc->code = c_function_setter(cx); - return(goto_APPLY); /* check arg num etc */ + return(goto_apply); /* check arg num etc */ } } push_op_stack(sc, c_function_setter(cx)); @@ -76678,7 +78125,7 @@ static goto_t set_implicit_function(s7_scheme *sc, s7_pointer cx) /* (let ((lst sc->args = sc->t1_1; } sc->code = c_function_setter(cx); - return(goto_APPLY); /* check arg num etc */ + return(goto_apply); /* check arg num etc */ } push_op_stack(sc, c_function_setter(cx)); push_stack(sc, OP_EVAL_ARGS1, sc->nil, cddr(sc->code)); @@ -76694,12 +78141,12 @@ static goto_t set_implicit_function(s7_scheme *sc, s7_pointer cx) /* (let ((lst else sc->args = s7_append(sc, cdar(sc->code), copy_list(sc, cdr(sc->code))); /* append copies except for its last arg, but for macros, we have to copy everything, hence the extra copy_list */ sc->code = c_function_setter(cx); - return(goto_APPLY); + return(goto_apply); } eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code)); } sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer cx) @@ -76734,12 +78181,12 @@ static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer cx) sc->args = copy_list(sc, cdr(sc->code)); else sc->args = s7_append(sc, cdar(sc->code), copy_list(sc, cdr(sc->code))); sc->code = setter; - return(goto_APPLY); + return(goto_apply); } eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code)); } sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer cx) @@ -76761,12 +78208,12 @@ static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer cx) { sc->args = list_1(sc, cadr(sc->code)); sc->code = setter; - return(goto_APPLY); + return(goto_apply); } eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code)); } sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer cx) @@ -76781,10 +78228,10 @@ static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer cx) sc->code = cadr(sc->code); push_stack(sc, OP_SET_WITH_LET_1, sc->args, sc->code); sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar(sc->code)); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) ...) */ @@ -76799,7 +78246,7 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) .. push_stack(sc, OP_SET2, cdar(sc->code), cdr(sc->code)); sc->code = caar_code; sc->cur_op = optimize_op(sc->code); - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } if (is_symbol(caar_code)) @@ -76853,7 +78300,7 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) .. default: /* (set! (1 2) 3) */ eval_error_no_return(sc, sc->syntax_error_symbol, "no generalized set for ~A", 25, caar_code); } - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } static void activate_let(s7_scheme *sc, s7_pointer e) @@ -77161,7 +78608,7 @@ static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v) ((is_h_safe_c_d(step_expr)) && (is_pair(cdr(step_expr))) && /* ((v 0 (+))) */ (car(v) == cadr(step_expr)) && - ((opt1_cfunc(step_expr) == sc->add_s1) || (opt1_cfunc(step_expr) == sc->subtract_s1))) || + ((opt1_cfunc(step_expr) == sc->add_x1) || (opt1_cfunc(step_expr) == sc->subtract_s1))) || ((optimize_op(step_expr) == HOP_SAFE_C_CS) && (car(v) == caddr(step_expr))))) return(step_expr); } @@ -77174,7 +78621,7 @@ static bool is_simple_end(s7_scheme *sc, s7_pointer end) (is_pair(cddr(end))) && /* end: (zero? n) */ (cadr(end) != caddr(end)) && #if (!WITH_GMP) - ((opt1_any(end) == sc->num_eq_2i) || + ((opt1_any(end) == sc->num_eq_xi) || (optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC))); #else ((optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC))); @@ -77219,7 +78666,7 @@ static s7_pointer fxify_step_exprs(s7_scheme *sc, s7_pointer code) return(code); } -static bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree) +static inline bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree) { s7_pointer p; for (p = tree; is_pair(p); p = cdr(p)) @@ -77252,7 +78699,7 @@ static s7_pointer check_do(s7_scheme *sc) form = sc->code; code = cdr(sc->code); #if DO_PRINT - fprintf(stderr, "check_do: %s\n", DISPLAY_80(form)); + fprintf(stderr, "check_do: %s %s\n", DISPLAY_80(form), DISPLAY_80(sc->envir)); #endif if ((!is_pair(code)) || /* (do . 1) */ @@ -77361,15 +78808,33 @@ static s7_pointer check_do(s7_scheme *sc) if ((is_pair(vars)) && (is_null(cdr(vars)))) { fx_tree(sc, end, caar(vars), NULL); - if ((is_pair(cdar(vars))) && (is_pair(cddar(vars)))) - fx_tree(sc, caddar(vars), caar(vars), NULL); - /* an experiment */ +#if 1 + /* either we're the first thing in the closure body or it's a safe closure, else envir is unsafe */ + /* this needs to be marked elsewhere */ + if ((tis_slot(let_slots(sc->envir))) && + ((!tis_slot(next_slot(let_slots(sc->envir)))) || + (is_funclet(sc->envir)))) + { + s7_pointer var1, var2 = NULL; + var1 = slot_symbol(let_slots(sc->envir)); + if (tis_slot(next_slot(let_slots(sc->envir)))) + var2 = slot_symbol(next_slot(let_slots(sc->envir))); + fx_tree_outer(sc, end, var1, var2); + if ((is_pair(cdar(vars))) && (is_pair(cddar(vars)))) + fx_tree_outer(sc, caddar(vars), var1, var2); + + if (((!var2) || (!tis_slot(next_slot(next_slot(let_slots(sc->envir)))))) && /* func has 1 or 2 args */ + (is_null(cdr(vars)))) /* 1 stepper */ + fx_tree_outest(sc, end, var1, var2, caar(vars), NULL); + } +#else if ((is_funclet(sc->envir)) && (tis_slot(let_slots(sc->envir))) && (is_symbol(funclet_function(sc->envir)))) { s7_pointer clos; + /* TODO: fix this! */ clos = symbol_to_local_slot(sc, funclet_function(sc->envir), outlet(sc->envir)); if (is_slot(clos)) /* else #<undefined> */ { @@ -77391,6 +78856,7 @@ static s7_pointer check_do(s7_scheme *sc) } } } +#endif } body = cddr(code); @@ -77501,8 +78967,8 @@ static s7_pointer check_do(s7_scheme *sc) previous_stepper = last_stepper; previous_expr = last_expr; last_stepper = car(var); - val = cddr(var); - last_expr = val; + last_expr = cdr(var); /* inits refer to the outer env */ + val = cdr(last_expr); if (is_pair(val)) { var = car(var); @@ -77604,14 +79070,46 @@ static s7_pointer check_do(s7_scheme *sc) } else set_opt2_con(cdr(form), small_int(0)); } + if (last_stepper) { fx_tree(sc, end, last_stepper, previous_stepper); + if ((last_expr) && (is_pair(last_expr))) - fx_tree(sc, last_expr, last_stepper, previous_stepper); - if ((previous_expr) && (is_pair(previous_expr))) - fx_tree(sc, previous_expr, last_stepper, previous_stepper); + { + if ((is_funclet(sc->envir)) && (tis_slot(let_slots(sc->envir)))) + { + s7_pointer s1; + s1 = let_slots(sc->envir); + fx_tree_in(sc, last_expr, slot_symbol(s1), (tis_slot(next_slot(s1))) ? slot_symbol(next_slot(s1)) : NULL); + } + last_expr = cdr(last_expr); + if (is_pair(last_expr)) + fx_tree(sc, last_expr, last_stepper, previous_stepper); + + if ((previous_expr) && (is_pair(previous_expr))) + { + if ((is_funclet(sc->envir)) && (tis_slot(let_slots(sc->envir)))) + { + s7_pointer s1; + s1 = let_slots(sc->envir); + fx_tree_in(sc, previous_expr, slot_symbol(s1), (tis_slot(next_slot(s1))) ? slot_symbol(next_slot(s1)) : NULL); + } + previous_expr = cdr(previous_expr); + if (is_pair(previous_expr)) + fx_tree(sc, previous_expr, last_stepper, previous_stepper); + } + } + } + + /* fprintf(stderr, "body: %s, %d %d\n", DISPLAY_80(body), is_null(cdr(body)), is_fxable(sc, car(body))); */ + if ((is_pair(body)) && (is_null(cdr(body))) && + (is_fxable(sc, car(body)))) + { + annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); + fx_tree(sc, body, last_stepper, previous_stepper); } + #if 0 { bool has_set = false; @@ -77684,6 +79182,13 @@ static bool has_safe_steppers(s7_scheme *sc, s7_pointer frame) return(true); } +static void op_do_unchecked(s7_scheme *sc) +{ + set_current_code(sc, sc->code); + push_stack_no_code(sc, OP_GC_PROTECT, sc->code); + sc->code = cdr(sc->code); +} + static bool op_dox_init(s7_scheme *sc) { s7_pointer frame, vars, test; @@ -77706,8 +79211,9 @@ static bool op_dox_init(s7_scheme *sc) sc->code = cdr(test); return(true); /* goto DO_END_CLAUSES */ } - push_stack_no_args(sc, OP_DOX_STEP, sc->code); + frame = sc->code; sc->code = T_Pair(cddr(sc->code)); + push_stack_no_args(sc, (intptr_t)((is_null(cdr(sc->code))) ? OP_DOX_STEP_P : OP_DOX_STEP), frame); return(false); /* goto BEGIN */ } @@ -77717,9 +79223,13 @@ static goto_t dox_ex(s7_scheme *sc) * since all these exprs are local, we don't need to jump until the body */ int64_t id, steppers = 0; - s7_pointer frame, vars, slot, code, end, endp, stepper = NULL; + s7_pointer frame, vars, slot, code, end, endp, stepper = NULL, form; s7_function endf; + form = sc->code; + set_current_code(sc, sc->code); + sc->code = cdr(sc->code); + new_frame(sc, sc->envir, frame); /* new frame is not tied into the symbol lookup process yet */ sc->temp10 = frame; for (vars = car(sc->code); is_pair(vars); vars = cdr(vars)) @@ -77756,7 +79266,7 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } code = cddr(sc->code); @@ -77789,7 +79299,7 @@ static goto_t dox_ex(s7_scheme *sc) { sc->value = sc->T; sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } } } @@ -77799,7 +79309,7 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } } } @@ -77816,24 +79326,36 @@ static goto_t dox_ex(s7_scheme *sc) expr1 = slot_expression(step1); step2 = next_slot(step1); expr2 = slot_expression(step2); /* presetting c_call/car(expr) is not faster */ - while (true) +#if (!WITH_GMP) + if ((c_callee(expr2) == fx_subtract_u1) && + (is_t_integer(slot_value(step2))) && + (endf == fx_num_eq_ui)) { - slot_set_value(step1, fx_call(sc, expr1)); - slot_set_value(step2, fx_call(sc, expr2)); - if (is_true(sc, sc->value = endf(sc, endp))) + s7_int i, lim; + lim = integer(caddr(endp)); + for (i = integer(slot_value(step2)) - 1; i >= lim; i--) + slot_set_value(step1, fx_call(sc, expr1)); + } + else +#endif + { + while (true) { - sc->code = cdr(end); - if (is_symbol(car(sc->code))) - { - step1 = symbol_to_slot(sc, car(sc->code)); - sc->value = slot_value(step1); - if (is_t_real(sc->value)) - clear_mutable_number(sc->value); - return(goto_START); - } - return(goto_DO_END_CLAUSES); + slot_set_value(step1, fx_call(sc, expr1)); + slot_set_value(step2, fx_call(sc, expr2)); + if (is_true(sc, sc->value = endf(sc, endp))) break; } } + sc->code = cdr(end); + if (is_symbol(car(sc->code))) + { + step1 = symbol_to_slot(sc, car(sc->code)); + sc->value = slot_value(step1); + if (is_t_real(sc->value)) + clear_mutable_number(sc->value); + return(goto_start); + } + return(goto_do_end_clauses); } while (true) @@ -77845,7 +79367,7 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } } } @@ -77894,11 +79416,10 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } } } - /* split out opt_cell_any_nr gained nothing (see tmp) */ while (true) { bodyf(sc, body); @@ -77906,7 +79427,7 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } } } @@ -77931,7 +79452,7 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } } } @@ -77945,7 +79466,7 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } } } @@ -77966,6 +79487,8 @@ static goto_t dox_ex(s7_scheme *sc) valf = c_callee(val); val = car(val); slot = symbol_to_slot(sc, cadr(body)); + if (slot == sc->undefined) + eval_error_no_return(sc, sc->unbound_variable_symbol, "~A: unbound variable", 20, cadr(body)); stepf = c_callee(slot_expression(stepper)); stepa = car(slot_expression(stepper)); while (true) @@ -77975,7 +79498,7 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } } } @@ -78061,7 +79584,7 @@ static goto_t dox_ex(s7_scheme *sc) if (is_true(sc, sc->value = endf(sc, endp))) { sc->code = cdr(end); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); }}}}} if ((is_null(cdr(code))) && /* one expr */ @@ -78081,10 +79604,49 @@ static goto_t dox_ex(s7_scheme *sc) pair_set_syntax_op(code, sc->cur_op); } sc->code = code; - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } } - return(fall_through); + + pair_set_syntax_op(form, OP_DOX_INIT); + sc->code = T_Pair(cddr(sc->code)); + push_stack_no_args(sc, (intptr_t)((is_null(cdr(sc->code))) ? OP_DOX_STEP_P : OP_DOX_STEP), cdr(form)); + + return(goto_begin); +} + +static bool op_dox_step(s7_scheme *sc) +{ + s7_pointer slot; + for (slot = let_slots(sc->envir); tis_slot(slot); slot = next_slot(slot)) + if (slot_has_expression(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + sc->value = fx_call(sc, cadr(sc->code)); + if (is_true(sc, sc->value)) + { + sc->code = cdadr(sc->code); + return(true); + } + push_stack_no_args(sc, OP_DOX_STEP, sc->code); + sc->code = T_Pair(cddr(sc->code)); + return(false); +} + +static bool op_dox_step_p(s7_scheme *sc) +{ + s7_pointer slot; + for (slot = let_slots(sc->envir); tis_slot(slot); slot = next_slot(slot)) + if (slot_has_expression(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + sc->value = fx_call(sc, cadr(sc->code)); + if (is_true(sc, sc->value)) + { + sc->code = cdadr(sc->code); + return(true); + } + push_stack_no_args(sc, OP_DOX_STEP_P, sc->code); + sc->code = caddr(sc->code); + return(false); } static void op_dox_no_body(s7_scheme *sc) @@ -78120,30 +79682,31 @@ static void op_dox_no_body(s7_scheme *sc) * because (eq? 0 x) here is false -- memv will return '(0). tree-count is similar. */ slot_set_value(slot, istep); - while (true) + if (testf == fx_or_2) { - if (is_true(sc, testf(sc, test))) - { - if ((integer(istep) < NUM_SMALL_INTS) && (integer(istep) >= 0)) - slot_set_value(slot, small_int(integer(istep))); - else clear_mutable_integer(istep); - sc->value = fx_call(sc, result); - return; - } - integer(istep) += incr; + s7_pointer t1, t2; + s7_function f1, f2; + f1 = c_callee(cdr(test)); + t1 = cadr(test); + f2 = c_callee(cddr(test)); + t2 = caddr(test); + while ((f1(sc, t1) == sc->F) && (f2(sc, t2) == sc->F)) {integer(istep) += incr;} } - } - - stepf = c_callee(cddr(var)); - step = caddr(var); - while (true) - { - if (is_true(sc, testf(sc, test))) + else { - sc->value = fx_call(sc, result); - return; + while (testf(sc, test) == sc->F) {integer(istep) += incr;} } - slot_set_value(slot, stepf(sc, step)); + if ((integer(istep) < NUM_SMALL_INTS) && (integer(istep) >= 0)) + slot_set_value(slot, small_int(integer(istep))); + else clear_mutable_integer(istep); + sc->value = fx_call(sc, result); + } + else + { + stepf = c_callee(cddr(var)); + step = caddr(var); + while (testf(sc, test) == sc->F) {slot_set_value(slot, stepf(sc, step));} + sc->value = fx_call(sc, result); } } @@ -78282,6 +79845,91 @@ static bool op_do_no_vars(s7_scheme *sc) return(false); } +static void op_do_no_vars_no_opt(s7_scheme *sc) +{ + set_current_code(sc, sc->code); + sc->code = cdr(sc->code); + new_frame(sc, sc->envir, sc->envir); +} + +static bool op_do_no_vars_no_opt_1(s7_scheme *sc) +{ + sc->value = fx_call(sc, cadr(sc->code)); + if (is_true(sc, sc->value)) + { + sc->code = cdadr(sc->code); + return(true); + } + push_stack_no_args(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code); + sc->code = T_Pair(cddr(sc->code)); + return(false); +} + +static bool do_step1(s7_scheme *sc) +{ + /* on each iteration, each arg incr expr is evaluated and the value placed in caddr while we cdr down args */ + while (true) + { + s7_pointer code; + if (is_null(sc->args)) + { + s7_pointer x; + for (x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ + { + slot_set_value(car(x), slot_pending_value(car(x))); + slot_clear_has_pending_value(car(x)); + } + pop_stack_no_op(sc); + return(true); + } + code = slot_expression(car(sc->args)); + if (has_fx(code)) + { + sc->value = fx_call(sc, code); +#if S7_DEBUGGING + /* can values happen here even in error? */ + if (is_multiple_value(sc->value)) + fprintf(stderr, "got multiple values! %s\n", DISPLAY(sc->value)); +#endif + slot_set_pending_value(car(sc->args), sc->value); + sc->args = cdr(sc->args); /* go to next step var */ + } + else + { + push_stack(sc, OP_DO_STEP2, sc->args, sc->code); + sc->code = car(code); + return(false); + } + } +} + +static bool op_do_step2(s7_scheme *sc) +{ + if (is_multiple_value(sc->value)) + eval_error(sc, "do: variable step value can't be ~S", 35, cons(sc, sc->values_symbol, sc->value)); + slot_set_pending_value(car(sc->args), sc->value); /* save current value */ + sc->args = cdr(sc->args); /* go to next step var */ + if (do_step1(sc)) return(true); + return(false); +} + +static bool op_do_step(s7_scheme *sc) +{ + /* increment all vars, return to endtest + * these are also updated in parallel at the end, so we gather all the incremented values first + * + * here we know car(sc->args) is not null, args is the list of steppable vars, + * any unstepped vars in the do var section are not in this list, so + * (do ((i 0 (+ i 1)) (j 2)) ...) arrives here with sc->args: '(slot<((+ i 1)=expr, 0=pending_value>)) + */ + push_stack(sc, OP_DO_END, sc->args, sc->code); + sc->args = car(sc->args); /* the var data lists */ + sc->code = sc->args; /* save the top of the list */ + if (do_step1(sc)) return(true); + return(false); +} + + static bool opt_do_copy(s7_scheme *sc, opt_info *o, s7_int start, s7_int stop) { s7_pointer (*fp)(opt_info *o); @@ -78355,9 +80003,9 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code) step_var = caddr(step_expr); /* use g* funcs (not fx) because we're passing the actual values, not the expressions */ - if ((stepf == g_add_s1) && + if ((stepf == g_add_x1) && (is_t_integer(slot_value(ctr_slot))) && - ((endf == g_num_eq_2) || (endf == g_num_eq_2i) || (endf == g_geq_2)) && + ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)) && (is_t_integer(slot_value(end_slot)))) { s7_int i, start, stop; @@ -78397,7 +80045,6 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code) } else { - /* (do ((i 0 (+ i 1))) ((>= i n) result) (vector-set! result i i)) */ for (i = start; i < stop; i++) { slot_set_value(ctr_slot, make_integer(sc, i)); @@ -78461,7 +80108,7 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code) if ((stepf == g_add_2_xi) && (is_t_integer(slot_value(ctr_slot))) && - ((endf == g_num_eq_2) || (endf == g_num_eq_2i) || (endf == g_geq_2)) && + ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)) && (is_t_integer(slot_value(end_slot)))) { s7_int i, start, stop, incr; @@ -78532,6 +80179,7 @@ static bool op_simple_do(s7_scheme *sc) (is_t_integer(caddr(caddr(caar(code))))) && (simple_do_ex(sc, sc->code))) return(true); /* goto DO_END_CLAUSES */ + push_stack(sc, OP_SIMPLE_DO_STEP, sc->args, code); sc->code = body; return(false); /* goto BEGIN */ @@ -78565,12 +80213,12 @@ static bool op_simple_do_step(s7_scheme *sc) if (is_true(sc, sc->value)) { sc->code = cdr(end); - return(false); + return(true); } push_stack(sc, OP_SIMPLE_DO_STEP, sc->args, code); sc->code = T_Pair(cddr(code)); - return(true); + return(false); } static bool op_safe_do_step(s7_scheme *sc) @@ -78589,14 +80237,52 @@ static bool op_safe_do_step(s7_scheme *sc) { sc->value = sc->T; sc->code = cdadr(sc->code); - return(false); + return(true); } push_stack(sc, OP_SAFE_DO_STEP, sc->args, sc->code); sc->code = T_Pair(opt2_pair(sc->code)); - return(true); + return(false); +} + +static bool op_safe_dotimes_step(s7_scheme *sc) +{ + s7_pointer arg; + arg = slot_value(sc->args); + numerator(arg)++; + if (numerator(arg) == denominator(arg)) + { + sc->value = sc->T; + sc->code = cdadr(sc->code); + return(true); + } + push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, sc->code); + sc->code = opt2_pair(sc->code); /* here we know the body has more than one form */ + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + return(false); } -static bool op_dotimes_step_p(s7_scheme *sc) +static bool op_safe_dotimes_step_p(s7_scheme *sc) +{ + s7_pointer arg; + arg = slot_value(sc->args); + numerator(arg)++; + if (numerator(arg) == denominator(arg)) + { + sc->value = sc->T; + sc->code = cdadr(sc->code); + return(true); + } + push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, sc->code); + sc->code = opt2_pair(sc->code); + return(false); +} + +#if WITH_GCC +static inline bool op_dotimes_step_p(s7_scheme *sc) __attribute__((always_inline)); +#endif + +static inline bool op_dotimes_step_p(s7_scheme *sc) { s7_pointer ctr, now, end, end_test, code; code = sc->code; @@ -78617,7 +80303,7 @@ static bool op_dotimes_step_p(s7_scheme *sc) { sc->value = sc->T; sc->code = cdadr(code); - return(false); + return(true); } } else @@ -78629,14 +80315,14 @@ static bool op_dotimes_step_p(s7_scheme *sc) if (is_true(sc, sc->value)) { sc->code = cdr(end); - return(false); + return(true); } } } else { set_car(sc->t1_1, now); - slot_set_value(ctr, g_add_s1(sc, sc->t1_1)); + slot_set_value(ctr, g_add_x1(sc, sc->t1_1)); /* (define (hi) (let ((x 0.0) (y 1.0)) (do ((i y (+ i 1))) ((= i 6)) (do ((i i (+ i 1))) ((>= i 7)) (set! x (+ x i)))) x)) */ set_car(sc->t2_1, slot_value(ctr)); set_car(sc->t2_2, end); @@ -78645,12 +80331,12 @@ static bool op_dotimes_step_p(s7_scheme *sc) if (is_true(sc, sc->value)) { sc->code = cdr(end); - return(false); + return(true); } } push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code); sc->code = caddr(code); - return(true); + return(false); } static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool safe_step) @@ -79205,7 +80891,7 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) sc->envir = old_e; sc->value = sc->T; sc->code = cdadr(scc); - return(goto_SAFE_DO_END_CLAUSES); + return(goto_safe_do_end_clauses); } static bool dotimes(s7_scheme *sc, s7_pointer code, bool safe_case) @@ -79216,13 +80902,16 @@ static bool dotimes(s7_scheme *sc, s7_pointer code, bool safe_case) (is_syntactic_symbol(car(body)))) && ((symbol_syntax_op_checked(body) == OP_LET) || (symbol_syntax_op(car(body)) == OP_LET_STAR))) - return(do_let(sc, sc->args, code) == goto_SAFE_DO_END_CLAUSES); + return(do_let(sc, sc->args, code) == goto_safe_do_end_clauses); return(opt_dotimes(sc, cddr(code), code, safe_case)); } static goto_t safe_dotimes_ex(s7_scheme *sc) { - s7_pointer init_val; + s7_pointer init_val, form; + form = sc->code; + set_current_code(sc, form); + sc->code = cdr(sc->code); init_val = fx_call(sc, cdaar(sc->code)); if (s7_is_integer(init_val)) @@ -79249,7 +80938,7 @@ static goto_t safe_dotimes_ex(s7_scheme *sc) /* safe_dotimes: (car(body) is known to be a pair here) * if 1-expr body look for syntactic case, if let(*) goto do_let, else opt_dotimes * if they are unhappy, got safe_dotimes_step_p - * else goto opt_dotimes then safe_dotimes_step_o + * else goto opt_dotimes then safe_dotimes_step_p * if multi-line body, check opt_dotimes, then safe_dotimes_step */ @@ -79257,7 +80946,7 @@ static goto_t safe_dotimes_ex(s7_scheme *sc) { sc->value = sc->T; sc->code = cdadr(code); - return(goto_SAFE_DO_END_CLAUSES); + return(goto_safe_do_end_clauses); } if ((is_null(cdr(sc->code))) && @@ -79272,7 +80961,7 @@ static goto_t safe_dotimes_ex(s7_scheme *sc) if (!is_unsafe_do(code)) { if (dotimes(sc, code, true)) - return(goto_SAFE_DO_END_CLAUSES); + return(goto_safe_do_end_clauses); set_unsafe_do(code); } push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, code); @@ -79283,30 +80972,33 @@ static goto_t safe_dotimes_ex(s7_scheme *sc) sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); pair_set_syntax_op(sc->code, sc->cur_op); } - return(goto_TOP_NO_POP); + return(goto_top_no_pop); } /* car not syntactic? */ if ((!is_unsafe_do(code)) && (opt_dotimes(sc, cddr(code), code, true))) - return(goto_SAFE_DO_END_CLAUSES); + return(goto_safe_do_end_clauses); set_unsafe_do(code); - push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); - return(goto_EVAL); + push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, code); + return(goto_eval); } /* multi-line body */ if ((!is_unsafe_do(code)) && (opt_dotimes(sc, sc->code, code, true))) - return(goto_SAFE_DO_END_CLAUSES); + return(goto_safe_do_end_clauses); set_unsafe_do(code); set_opt2_pair(code, sc->code); push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, code); - return(goto_BEGIN); + return(goto_begin); } } - /* no hits in s7test */ - return(fall_through); + pair_set_syntax_op(form, OP_SIMPLE_DO); + sc->code = form; + if (op_simple_do(sc)) return(goto_do_end_clauses); + + return(goto_begin); } static goto_t safe_do_ex(s7_scheme *sc) @@ -79320,7 +81012,7 @@ static goto_t safe_do_ex(s7_scheme *sc) s7_pointer end, init_val, end_val, code, form, old_envir; /* inits, if not >= opt_dotimes else safe_do_step */ - + set_current_code(sc, sc->code); form = sc->code; sc->code = cdr(sc->code); code = sc->code; @@ -79334,7 +81026,7 @@ static goto_t safe_do_ex(s7_scheme *sc) if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) /* this almost never happens */ { pair_set_syntax_op(form, OP_DO_UNCHECKED); - return(goto_DO_UNCHECKED); + return(goto_do_unchecked); } /* (let ((sum 0)) (define (hi) (do ((i 10 (+ i 1))) ((= i 10) i) (set! sum (+ sum i)))) (hi)) */ @@ -79347,7 +81039,7 @@ static goto_t safe_do_ex(s7_scheme *sc) { sc->value = sc->T; sc->code = cdadr(code); - return(goto_SAFE_DO_END_CLAUSES); + return(goto_safe_do_end_clauses); } if (is_symbol(end)) @@ -79361,11 +81053,11 @@ static goto_t safe_do_ex(s7_scheme *sc) (opt1_cfunc(caadr(code)) != sc->geq_2))) { if (opt_dotimes(sc, cddr(sc->code), sc->code, false)) - return(goto_SAFE_DO_END_CLAUSES); + return(goto_safe_do_end_clauses); set_unsafe_do(sc->code); /* opt_dotimes can change sc->envir (indirectly via s7_optimize I think), but OP_SAFE_DO_STEP assumes dox1 is ok (above), so we can't go on here */ if (sc->envir != old_envir) - return(goto_DO_UNCHECKED); + return(goto_do_unchecked); } if (is_null(cdddr(sc->code))) { @@ -79401,7 +81093,7 @@ static goto_t safe_do_ex(s7_scheme *sc) clear_mutable_integer(step_val); sc->value = sc->T; sc->code = cdadr(code); - return(goto_SAFE_DO_END_CLAUSES); + return(goto_safe_do_end_clauses); } } } @@ -79411,14 +81103,14 @@ static goto_t safe_do_ex(s7_scheme *sc) set_unsafe_do(sc->code); set_opt2_pair(code, sc->code); push_stack(sc, OP_SAFE_DO_STEP, sc->args, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */ - return(goto_BEGIN); + return(goto_begin); } static goto_t dotimes_p_ex(s7_scheme *sc) { - s7_pointer end, code, init_val, end_val, slot, form; + s7_pointer end, code, init_val, end_val, slot, form, old_e; /* (do ... (set! args ...)) -- one line, syntactic */ - + set_current_code(sc, sc->code); form = sc->code; sc->code = cdr(sc->code); code = sc->code; @@ -79441,9 +81133,10 @@ static goto_t dotimes_p_ex(s7_scheme *sc) if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) { pair_set_syntax_op(form, OP_DO_UNCHECKED); - return(goto_DO_UNCHECKED); + return(goto_do_unchecked); } + old_e = sc->envir; sc->envir = new_frame_in_env(sc, sc->envir); let_set_dox_slot1(sc->envir, make_slot_1(sc, sc->envir, caaar(code), init_val)); let_set_dox_slot2(sc->envir, slot); @@ -79457,7 +81150,7 @@ static goto_t dotimes_p_ex(s7_scheme *sc) if (is_true(sc, sc->value = c_call(caadr(code))(sc, sc->t2_1))) { sc->code = cdadr(code); - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); } if ((!is_unsafe_do(code)) && (opt1_cfunc(caadr(code)) != sc->geq_2)) @@ -79472,16 +81165,17 @@ static goto_t dotimes_p_ex(s7_scheme *sc) set_step_end(sc->args); /* dotimes step is by 1 */ if (dotimes(sc, code, false)) - return(goto_DO_END_CLAUSES); + return(goto_do_end_clauses); slot_set_value(sc->args, old_init); + sc->envir = old_e; /* free_cell(sc, sc->envir) beforehand is not safe */ sc->args = old_args; set_unsafe_do(code); - return(goto_DO_UNCHECKED); + return(goto_do_unchecked); } push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code); sc->code = caddr(code); - return(goto_EVAL); + return(goto_eval); } static goto_t do_init_ex(s7_scheme *sc) @@ -79503,7 +81197,7 @@ static goto_t do_init_ex(s7_scheme *sc) { push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */ sc->code = init; - return(goto_EVAL); + return(goto_eval); } if (is_symbol(init)) sc->value = lookup_checked(sc, init); @@ -79547,11 +81241,26 @@ static goto_t do_init_ex(s7_scheme *sc) return(fall_through); } +static bool op_do_init(s7_scheme *sc) +{ + if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ + eval_error_no_return(sc, sc->wrong_type_arg_symbol, "do: variable initial value can't be ~S", 38, cons(sc, sc->values_symbol, sc->value)); + if (do_init_ex(sc) == goto_eval) return(false); + return(true); +} + /* -------------------------------------------------------------------------------- */ +/* closure_is_ok_1 checks the type and the body length indications + * closure_is_fine_1 just checks the type (safe or unsafe closure) + * closure_is_ok calls _ok_1, closure_is_fine calls _fine_1 + */ 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 ((type & (T_ONE_FORM | T_MULTIFORM)) == 0) fprintf(stderr, "%s %s: type has no body bits\n", __func__, DISPLAY(code)); +#endif f = lookup_unexamined(sc, car(code)); if ((f == opt1_lambda_unchecked(code)) || ((f) && @@ -79563,9 +81272,12 @@ static inline bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type return(false); } -static inline bool closure_is_ok_2(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) +static inline bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) { s7_pointer f; +#if S7_DEBUGGING + if ((type & (T_ONE_FORM | T_MULTIFORM)) != 0) fprintf(stderr, "%s %s: type has body bits\n", __func__, DISPLAY(code)); +#endif f = lookup_unexamined(sc, car(code)); if ((f == opt1_lambda_unchecked(code)) || ((f) && @@ -79598,7 +81310,7 @@ static inline bool closure_is_ok_2(s7_scheme *sc, s7_pointer code, uint16_t type #define closure_is_fine(Sc, Code, Type, Args) \ (((symbol_ctr(car(Code)) == 1) && \ (unchecked_slot_value(local_slot(car(Code))) == opt1_lambda_unchecked(Code))) || \ - (closure_is_ok_2(Sc, Code, Type, Args))) + (closure_is_fine_1(Sc, Code, Type, Args))) static bool star_arity_is_ok(s7_scheme *sc, s7_pointer val, int32_t args) { @@ -79608,9 +81320,12 @@ static bool star_arity_is_ok(s7_scheme *sc, s7_pointer val, int32_t args) return((arity * 2) >= args); } -static bool closure_star_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) +static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) { s7_pointer val; +#if S7_DEBUGGING + if ((type & (T_ONE_FORM | T_MULTIFORM)) != 0) fprintf(stderr, "%s %s: type has body bits\n", __func__, DISPLAY(code)); +#endif val = lookup_unexamined(sc, car(code)); if ((val == opt1_lambda_unchecked(code)) || ((val) && @@ -79622,20 +81337,25 @@ static bool closure_star_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type, return(false); } -#define closure_star_is_ok(Sc, Code, Type, Args) \ +#define closure_star_is_fine(Sc, Code, Type, Args) \ (((symbol_ctr(car(Code)) == 1) && \ (unchecked_slot_value(local_slot(car(Code))) == opt1_lambda_unchecked(Code))) || \ - (closure_star_is_ok_1(Sc, Code, Type, Args))) - -#define MATCH_UNSAFE_CLOSURE (T_CLOSURE) -#define MATCH_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) -#define MATCH_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) -#define MATCH_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) -#define MATCH_UNSAFE_CLOSURE_P (T_CLOSURE | T_ONE_FORM) -#define MATCH_SAFE_CLOSURE_P (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM) -#define MATCH_UNSAFE_CLOSURE_M (T_CLOSURE | T_MULTIFORM) -#define MATCH_SAFE_CLOSURE_M (T_CLOSURE | T_SAFE_CLOSURE | T_MULTIFORM) -#define MATCH_SAFE_CLOSURE_A (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM | T_MULTIFORM) /* see set_closure_has_fx = both bits on */ + (closure_star_is_fine_1(Sc, Code, Type, Args))) + +/* closure_is_fine: */ +#define FINE_UNSAFE_CLOSURE (T_CLOSURE) +#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) + +/* closure_star_is_fine: */ +#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) +#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) + +/* closure_is_ok: */ +#define OK_UNSAFE_CLOSURE_P (T_CLOSURE | T_ONE_FORM) +#define OK_SAFE_CLOSURE_P (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM) +#define OK_UNSAFE_CLOSURE_M (T_CLOSURE | T_MULTIFORM) +#define OK_SAFE_CLOSURE_M (T_CLOSURE | T_SAFE_CLOSURE | T_MULTIFORM) +#define OK_SAFE_CLOSURE_A (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM | T_MULTIFORM) /* see set_closure_has_fx = both bits on */ /* since T_HAS_METHODS is on if there might be methods, this can protect us from that case */ static goto_t fixup_unknown_op(s7_pointer code, s7_pointer func, opcode_t op) @@ -79643,7 +81363,7 @@ static goto_t fixup_unknown_op(s7_pointer code, s7_pointer func, opcode_t op) set_optimize_op(code, op); if (is_any_closure(func)) set_opt1_lambda(code, func); /* opt_lambda works here because it is the only checked case, but ideally we'd split out all the cases via switch (op) */ - return(goto_EVAL); + return(goto_eval); } static goto_t unknown_unknown(s7_scheme *sc) @@ -79711,13 +81431,13 @@ static goto_t op_unknown(s7_scheme *sc, s7_pointer f) } else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK : OP_THUNK)); set_opt1_lambda(code, f); - return(goto_EVAL); + return(goto_eval); } if ((is_closure_star(f)) && (is_safe_closure(f))) { set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_FX_0); set_opt1_lambda(code, f); - return(goto_EVAL); + return(goto_eval); } } break; @@ -79770,13 +81490,13 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f) set_optimize_op(code, OP_SAFE_C_S); else set_optimize_op(code, OP_C_S); set_c_function(code, f); - return(goto_EVAL); + return(goto_eval); } if (is_safe_procedure(f)) { set_optimize_op(code, OP_SAFE_C_D); set_c_function(code, f); - return(goto_EVAL); + return(goto_eval); } break; @@ -79822,7 +81542,7 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f) else set_optimize_op(code, hop + ((sym_case) ? OP_CLOSURE_S : OP_CLOSURE_C)); } set_opt1_lambda(code, f); - return(goto_EVAL); + return(goto_eval); } break; @@ -79931,7 +81651,7 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f) case T_C_ANY_ARGS_FUNCTION: set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_A : OP_C_A); set_c_function(code, f); - return(goto_EVAL); + return(goto_eval); case T_CLOSURE: if ((!has_methods(f)) && @@ -79963,15 +81683,7 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f) closure_clear_multiform(f); } } - else - { - if ((c_callee(cdr(code)) == fx_subtract_si) || (c_callee(cdr(code)) == fx_subtract_s1) || (c_callee(cdr(code)) == fx_subtract_t1)) - { - set_opt2_pair(code, cdadr(code)); - set_optimize_op(code, hop + OP_CLOSURE_SUB_P); - } - else set_optimize_op(code, hop + OP_CLOSURE_A_P); - } + else set_optimize_op(code, hop + OP_CLOSURE_A_P); } else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); @@ -79983,7 +81695,7 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f) fx_tree(sc, cdr(code), car(closure_args(f)), NULL); set_opt1_lambda(code, f); - return(goto_EVAL); + return(goto_eval); } break; @@ -80125,7 +81837,7 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f) } set_opt3_arglen(code, small_int(2)); set_c_function(code, f); - return(goto_EVAL); + return(goto_eval); case T_CLOSURE: if (has_methods(f)) break; @@ -80150,6 +81862,7 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f) if (is_fxable(sc, car(body))) { annotate_arg(sc, body, sc->envir); + fx_tree(sc, body, car(closure_args(f)), cadr(closure_args(f))); set_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A); set_closure_has_fx(f); } @@ -80177,7 +81890,7 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f) set_opt2_sym(code, caddr(code)); else set_opt2_con(code, caddr(code)); set_opt1_lambda(code, f); - return(goto_EVAL); + return(goto_eval); } break; @@ -80246,7 +81959,7 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f) annotate_args(sc, cdr(code), sc->envir); } set_c_function(code, f); - return(goto_EVAL); + return(goto_eval); case T_CLOSURE: if ((!has_methods(f)) && @@ -80256,10 +81969,10 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f) if (is_immutable_and_stable(sc, car(code))) hop = 1; annotate_args(sc, cdr(code), sc->envir); if (num_args == 3) - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_FX : ((is_null(cdr(closure_body(f)))) ? OP_CLOSURE_3S_P : OP_CLOSURE_3S)))); + return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_3S : OP_CLOSURE_3S_B))); if (num_args == 4) - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_FX : ((is_null(cdr(closure_body(f)))) ? OP_CLOSURE_4S_P : OP_CLOSURE_4S)))); - return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_FX : OP_CLOSURE_ALL_S))); + return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_ALL_S : OP_CLOSURE_4S_B))); + return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_ALL_S : OP_CLOSURE_ALL_S))); } break; @@ -80308,7 +82021,7 @@ static goto_t op_unknown_aa(s7_scheme *sc, s7_pointer f) case T_C_ANY_ARGS_FUNCTION: set_optimize_op(code, (is_safe_procedure(f)) ? OP_SAFE_C_AA : OP_C_FX); set_c_function(code, f); - return(goto_EVAL); + return(goto_eval); case T_CLOSURE: if ((!has_methods(f)) && @@ -80343,7 +82056,7 @@ static goto_t op_unknown_aa(s7_scheme *sc, s7_pointer f) } else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); set_opt1_lambda(code, f); - return(goto_EVAL); + return(goto_eval); } break; @@ -80389,7 +82102,7 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f) else set_optimize_op(code, OP_C_FX); annotate_args(sc, cdr(code), sc->envir); set_c_function(code, f); - return(goto_EVAL); + return(goto_eval); case T_CLOSURE: if ((!has_methods(f)) && @@ -80408,7 +82121,7 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f) } else set_optimize_op(code, hop + OP_CLOSURE_FX); set_opt1_lambda(code, f); - return(goto_EVAL); + return(goto_eval); } break; @@ -80475,7 +82188,7 @@ static goto_t op_dynamic_wind(s7_scheme *sc) push_stack(sc, OP_DYNAMIC_WIND, sc->nil, sc->code); sc->code = dynamic_wind_body(sc->code); sc->args = sc->nil; - return(goto_APPLY); + return(goto_apply); } if (dynamic_wind_state(sc->code) == DWIND_BODY) { @@ -80485,16 +82198,16 @@ static goto_t op_dynamic_wind(s7_scheme *sc) push_stack(sc, OP_DYNAMIC_WIND, sc->value, sc->code); sc->code = dynamic_wind_out(sc->code); sc->args = sc->nil; - return(goto_APPLY); + return(goto_apply); } if (is_multiple_value(sc->value)) sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(goto_START); + return(goto_start); } if (is_multiple_value(sc->args)) /* (+ 1 (dynamic-wind (lambda () #f) (lambda () (values 2 3 4)) (lambda () #f)) 5) */ sc->value = splice_in_values(sc, multiple_value(sc->args)); else sc->value = sc->args; /* value saved above */ - return(goto_START); + return(goto_start); } static goto_t op_read_s(s7_scheme *sc) @@ -80508,7 +82221,7 @@ static goto_t op_read_s(s7_scheme *sc) if (!is_input_port(port)) /* was also not stdin */ { sc->value = g_read(sc, list_1(sc, port)); - return(goto_START); + return(goto_start); } /* I guess this port_is_closed check is needed because we're going down a level below */ if (port_is_closed(port)) @@ -80528,7 +82241,7 @@ static goto_t op_read_s(s7_scheme *sc) sc->tok = token(sc); switch (sc->tok) { - case TOKEN_EOF: return(goto_START); + case TOKEN_EOF: return(goto_start); case TOKEN_RIGHT_PAREN: read_error(sc, "unexpected close paren"); case TOKEN_COMMA: read_error(sc, "unexpected comma"); default: @@ -80539,7 +82252,7 @@ static goto_t op_read_s(s7_scheme *sc) } } /* equally read-done and read-list here */ - return(goto_START); + return(goto_start); } static goto_t op_string_a(s7_scheme *sc) @@ -80558,17 +82271,17 @@ static goto_t op_string_a(s7_scheme *sc) if (!s7_is_integer(x)) { sc->value = string_ref_1(sc, s, set_plist_1(sc, x)); - return(goto_START); + return(goto_start); } index = s7_integer(x); if ((index < string_length(s)) && (index >= 0)) { sc->value = s7_make_character(sc, ((uint8_t *)string_value(s))[index]); - return(goto_START); + return(goto_start); } sc->value = string_ref_1(sc, s, x); - return(goto_START); + return(goto_start); } static goto_t op_vector_a(s7_scheme *sc) @@ -80594,11 +82307,11 @@ static goto_t op_vector_a(s7_scheme *sc) if (is_float_vector(v)) sc->value = make_real(sc, float_vector(v, index)); else sc->value = vector_getter(v)(sc, v, index); - return(goto_START); + return(goto_start); } } sc->value = vector_ref_1(sc, v, set_plist_1(sc, x)); - return(goto_START); + return(goto_start); } static goto_t op_vector_aa(s7_scheme *sc) @@ -80630,11 +82343,11 @@ static goto_t op_vector_aa(s7_scheme *sc) s7_int index; index = (ix * vector_offset(v, 0)) + iy; sc->value = vector_getter(v)(sc, v, index); - return(goto_START); + return(goto_start); } } sc->value = vector_ref_1(sc, v, set_plist_2(sc, x, y)); - return(goto_START); + return(goto_start); } static bool op_vector_set_3(s7_scheme *sc) @@ -80677,85 +82390,85 @@ static bool op_vector_set_4(s7_scheme *sc) return(false); } -static void op_increment_by_1(s7_scheme *sc) +static void op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) */ { - /* ([set!] ctr (+ ctr 1)) */ s7_pointer val, y; y = symbol_to_slot(sc, cadr(sc->code)); if (!is_slot(y)) eval_error_no_return(sc, sc->wrong_type_arg_symbol, "set! ~A: unbound variable", 25, cadr(sc->code)); - val = slot_value(y); - switch (type(val)) + if (is_t_integer(val)) + sc->value = make_integer(sc, integer(val) + 1); + else { - case T_INTEGER: - sc->value = make_integer(sc, integer(val) + 1); /* this can't be optimized to treat y's value as a mutable integer */ - break; - - case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) + denominator(val); - denominator(sc->value) = denominator(val); - break; - - case T_REAL: - sc->value = make_real(sc, real(val) + 1.0); - break; - - case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) + 1.0); - set_imag_part(sc->value, imag_part(val)); - break; - - default: - sc->value = g_add(sc, set_plist_2(sc, val, small_int(1))); - break; + switch (type(val)) + { + case T_RATIO: + new_cell(sc, sc->value, T_RATIO); + numerator(sc->value) = numerator(val) + denominator(val); + denominator(sc->value) = denominator(val); + break; + + case T_REAL: + sc->value = make_real(sc, real(val) + 1.0); + break; + + case T_COMPLEX: + new_cell(sc, sc->value, T_COMPLEX); + set_real_part(sc->value, real_part(val) + 1.0); + set_imag_part(sc->value, imag_part(val)); + break; + + default: + sc->value = g_add(sc, set_plist_2(sc, val, small_int(1))); + break; + } } slot_set_value(y, sc->value); } -static void op_decrement_by_1(s7_scheme *sc) +static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ { - /* ([set!] ctr (- ctr 1)) */ s7_pointer val, y; + y = symbol_to_slot(sc, cadr(sc->code)); if (!is_slot(y)) eval_error_no_return(sc, sc->wrong_type_arg_symbol, "set! ~A: unbound variable", 25, cadr(sc->code)); val = slot_value(y); - switch (type(val)) + if (is_t_integer(val)) + sc->value = make_integer(sc, integer(val) - 1); /* increment (set!) returns the new value in sc->value */ + else { - case T_INTEGER: - sc->value = make_integer(sc, integer(val) - 1); - break; - - case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) - denominator(val); - denominator(sc->value) = denominator(val); - break; - - case T_REAL: - sc->value = make_real(sc, real(val) - 1.0); - break; - - case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) - 1.0); - set_imag_part(sc->value, imag_part(val)); - break; - - default: - sc->value = g_subtract(sc, set_plist_2(sc, val, small_int(1))); - break; + switch (type(val)) + { + case T_RATIO: + new_cell(sc, sc->value, T_RATIO); + numerator(sc->value) = numerator(val) - denominator(val); + denominator(sc->value) = denominator(val); + break; + + case T_REAL: + sc->value = make_real(sc, real(val) - 1.0); + break; + + case T_COMPLEX: + new_cell(sc, sc->value, T_COMPLEX); + set_real_part(sc->value, real_part(val) - 1.0); + set_imag_part(sc->value, imag_part(val)); + break; + + default: + sc->value = g_subtract(sc, set_plist_2(sc, val, small_int(1))); + break; + } } slot_set_value(y, sc->value); } static void op_set_pws(s7_scheme *sc) { - /* ([set!] (save-dir) "/home/bil/zap/snd") */ + /* this is (set! (getter) val) where getter is a global c_function (a built-in pws) and val is not a pair: (set! (mus-clipping) #f) */ s7_pointer obj; sc->code = cdr(sc->code); obj = caar(sc->code); @@ -81010,6 +82723,20 @@ static void apply_lambda(s7_scheme *sc) /* -------- n /* lambda* */ +static void op_lambda_star(s7_scheme *sc) +{ + set_current_code(sc, sc->code); + check_lambda_star(sc); + sc->value = make_closure(sc, car(sc->code), cdr(sc->code), (!is_pair(car(sc->code))) ? T_CLOSURE : T_CLOSURE_STAR, CLOSURE_ARITY_NOT_SET); +} + +static void op_lambda_star_unchecked(s7_scheme *sc) +{ + set_current_code(sc, sc->code); + sc->code = cdr(sc->code); + sc->value = make_closure(sc, car(sc->code), cdr(sc->code), (!is_pair(car(sc->code))) ? T_CLOSURE : T_CLOSURE_STAR, CLOSURE_ARITY_NOT_SET); +} + static s7_pointer star_set(s7_scheme *sc, s7_pointer slot, s7_pointer val, bool check_rest) { if (is_checked_slot(slot)) @@ -81221,7 +82948,7 @@ static inline goto_t lambda_star_default(s7_scheme *sc) { push_stack(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code); sc->code = val; - return(goto_EVAL); + return(goto_eval); } } else slot_set_value(z, val); @@ -81237,6 +82964,19 @@ static inline goto_t lambda_star_default(s7_scheme *sc) return(fall_through); } +static bool op_lambda_star_default(s7_scheme *sc) +{ + /* sc->args is the current let slots position, sc->value is the default expression's value */ + if (is_multiple_value(sc->value)) + eval_error(sc, "lambda*: argument default value can't be ~S", 43, cons(sc, sc->values_symbol, sc->value)); + slot_set_value(sc->args, sc->value); + sc->args = next_slot(sc->args); + if (lambda_star_default(sc) == goto_eval) return(true); + pop_stack_no_op(sc); + sc->code = T_Pair(closure_body(sc->code)); + return(false); +} + static goto_t apply_lambda_star(s7_scheme *sc) /* -------- define* (lambda*) -------- */ { s7_pointer z, car_z, val, top; @@ -81260,7 +83000,7 @@ static goto_t apply_lambda_star(s7_scheme *sc) /* -------- de s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, closure_name(sc, sc->code), sc->args)); /* what about (define* (f :allow-other-keys) 0) (f :a-key 21) */ sc->code = closure_body(sc->code); - return(goto_BEGIN); + return(goto_begin); } top = sc->nil; @@ -81308,12 +83048,12 @@ static goto_t apply_lambda_star(s7_scheme *sc) /* -------- de { /* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */ push_stack(sc, OP_GC_PROTECT, sc->args, sc->code); - if (lambda_star_default(sc) == goto_EVAL) return(goto_EVAL); + if (lambda_star_default(sc) == goto_eval) return(goto_eval); pop_stack_no_op(sc); /* get original args and code back */ } sc->code = closure_body(sc->code); - return(goto_BEGIN); + return(goto_begin); } static void safe_closure_star_a(s7_scheme *sc, s7_pointer code) @@ -81532,7 +83272,7 @@ static goto_t op_define1(s7_scheme *sc) { sc->value = bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER, sc->code, sc->value); if (sc->value == sc->no_value) - return(goto_APPLY); + return(goto_apply); /* if all goes well, OP_DEFINE_WITH_SETTER will jump to DEFINE2 */ } } @@ -81765,6 +83505,67 @@ static s7_pointer check_for_cyclic_code(s7_scheme *sc, s7_pointer code) /* #define closure_goto(sc) sc->code = car(closure_body(sc->code)) */ +static void op_thunk(s7_scheme *sc) +{ + check_stack_size(sc); + /* this recursion check is consistent with the other unsafe closure calls, but we're probably in big trouble: + * (letrec ((a (lambda () (cons 1 (b)))) (b (lambda () (a)))) (b)) + */ + sc->code = opt1_lambda(sc->code); + new_frame(sc, closure_let(sc->code), sc->envir); + closure_push(sc); +} + +static void op_thunk_p(s7_scheme *sc) +{ + sc->code = opt1_lambda(sc->code); + new_frame(sc, closure_let(sc->code), sc->envir); + sc->code = car(closure_body(sc->code)); +} + +static void op_thunk_nil(s7_scheme *sc) +{ + sc->code = opt1_lambda(sc->code); + new_frame_with_slot(sc, closure_let(sc->code), sc->envir, closure_args(sc->code), sc->nil); + sc->code = closure_body(sc->code); +} + +static void op_safe_thunk(s7_scheme *sc) /* no frame needed */ +{ + sc->code = opt1_lambda(sc->code); + sc->envir = closure_let(sc->code); + closure_push(sc); +} + +static void op_safe_thunk_p(s7_scheme *sc) +{ + sc->code = opt1_lambda(sc->code); + sc->envir = closure_let(sc->code); + sc->code = car(closure_body(sc->code)); +} + +static void op_closure_c(s7_scheme *sc) +{ + check_stack_size(sc); + sc->value = cadr(sc->code); + sc->code = opt1_lambda(sc->code); + new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value); + closure_push(sc); +} + +static void op_closure_c_p(s7_scheme *sc) +{ + sc->value = cadr(sc->code); + check_stack_size(sc); + sc->code = opt1_lambda(sc->code); + new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value); + sc->code = car(closure_body(sc->code)); +} + +#if WITH_GCC +static inline void op_closure_a(s7_scheme *sc) __attribute__((always_inline)); +#endif + static inline void op_closure_a(s7_scheme *sc) { s7_pointer code; @@ -81775,25 +83576,18 @@ static inline void op_closure_a(s7_scheme *sc) new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value); } -static void op_closure_sub_p(s7_scheme *sc) +static void op_safe_closure_3s(s7_scheme *sc) { - s7_pointer arg; - check_stack_size(sc); - arg = opt2_pair(sc->code); /* cdadr(sc->code); */ - sc->value = lookup(sc, car(arg)); - if (is_t_integer(sc->value)) - sc->value = make_integer(sc, integer(sc->value) - integer(cadr(arg))); - else sc->value = subtract_p_pp(sc, sc->value, cadr(arg)); - sc->code = opt1_lambda(sc->code); - new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value); + s7_pointer args, f; + f = opt1_lambda(sc->code); + args = cddr(sc->code); + sc->envir = old_frame_with_three_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, car(args)), lookup(sc, cadr(args))); + sc->code = T_Pair(closure_body(f)); } static void op_safe_closure_saa(s7_scheme *sc) { s7_pointer args, z, f; -#if S7_DEBUGGING - if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__); -#endif f = opt1_lambda(sc->code); args = cddr(sc->code); gc_protect_direct(sc, fx_call(sc, args)); @@ -81804,42 +83598,54 @@ static void op_safe_closure_saa(s7_scheme *sc) sc->code = T_Pair(closure_body(f)); } -static void op_safe_closure_a(s7_scheme *sc) +static void op_closure_p_mv(s7_scheme *sc) { - s7_pointer code; - code = sc->code; - sc->value = fx_call(sc, cdr(sc->code)); - sc->code = opt1_lambda(code); + sc->code = opt1_lambda(sc->code); + sc->args = copy_list(sc, sc->value); +} + +static void op_safe_closure_c(s7_scheme *sc) +{ + sc->value = cadr(sc->code); + sc->code = opt1_lambda(sc->code); sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); closure_push(sc); } -static void op_safe_closure_a_p(s7_scheme *sc) +static void op_safe_closure_c_a(s7_scheme *sc) { - s7_pointer code; - code = sc->code; - sc->value = fx_call(sc, cdr(sc->code)); - sc->code = opt1_lambda(code); + sc->value = cadr(sc->code); + sc->code = opt1_lambda(sc->code); sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); - sc->code = car(closure_body(sc->code)); + sc->value = fx_call(sc, closure_body(sc->code)); } -static void op_safe_closure_s_a(s7_scheme *sc) +static void op_safe_closure_c_p(s7_scheme *sc) { - sc->value = lookup(sc, opt2_sym(sc->code)); + sc->value = cadr(sc->code); sc->code = opt1_lambda(sc->code); sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); - sc->value = fx_call(sc, closure_body(sc->code)); + sc->code = car(closure_body(sc->code)); } -static void op_safe_closure_a_a(s7_scheme *sc) +static void op_safe_closure_a(s7_scheme *sc) { s7_pointer code; code = sc->code; sc->value = fx_call(sc, cdr(sc->code)); sc->code = opt1_lambda(code); sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); - sc->value = fx_call(sc, closure_body(sc->code)); + closure_push(sc); +} + +static void op_safe_closure_a_p(s7_scheme *sc) +{ + s7_pointer code; + code = sc->code; + sc->value = fx_call(sc, cdr(sc->code)); + sc->code = opt1_lambda(code); + sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); + sc->code = car(closure_body(sc->code)); } static void op_closure_ap(s7_scheme *sc) @@ -81889,7 +83695,7 @@ static void op_closure_pa_1(s7_scheme *sc) static void op_closure_pa_mv(s7_scheme *sc) { sc->code = opt1_lambda(sc->code); - sc->args = s7_append(sc, copy_list(sc, sc->value), cons(sc, sc->args, sc->nil)); + sc->args = s7_append(sc, sc->value, cons(sc, sc->args, sc->nil)); /* copy_list until 8-Aug-19 */ } static void op_safe_closure_ap(s7_scheme *sc) @@ -81948,15 +83754,6 @@ static void op_safe_closure_ss_p(s7_scheme *sc) sc->code = car(closure_body(sc->code)); } -static void op_safe_closure_ss_a(s7_scheme *sc) -{ - sc->temp5 = lookup(sc, opt2_sym(sc->code)); - sc->value = lookup(sc, cadr(sc->code)); - sc->code = opt1_lambda(sc->code); - sc->envir = old_frame_with_two_slots(sc, closure_let(sc->code), sc->value, sc->temp5); - sc->value = fx_call(sc, closure_body(sc->code)); -} - static void op_closure_ss(s7_scheme *sc) { sc->temp5 = lookup(sc, opt2_sym(sc->code)); @@ -82034,7 +83831,7 @@ static void op_closure_cs(s7_scheme *sc) sc->code = T_Pair(closure_body(sc->code)); } -static inline void op_closure_3s(s7_scheme *sc) +static void op_closure_3s(s7_scheme *sc) { s7_pointer e, p, args, last_slot; s7_int id; @@ -82057,7 +83854,7 @@ static inline void op_closure_3s(s7_scheme *sc) sc->z = sc->nil; } -static inline void op_closure_4s(s7_scheme *sc) +static void op_closure_4s(s7_scheme *sc) { s7_pointer e, p, args, last_slot; s7_int id; @@ -82105,17 +83902,6 @@ static void op_safe_closure_aa_p(s7_scheme *sc) sc->code = car(closure_body(sc->code)); } -static void op_safe_closure_aa_a(s7_scheme *sc) -{ - s7_pointer p; - p = cdr(sc->code); - sc->temp5 = fx_call(sc, cdr(p)); - sc->value = fx_call(sc, p); - sc->code = opt1_lambda(sc->code); - sc->envir = old_frame_with_two_slots(sc, closure_let(sc->code), sc->value, sc->temp5); - sc->value = fx_call(sc, closure_body(sc->code)); -} - static void op_closure_aa(s7_scheme *sc) { s7_pointer p; @@ -82154,6 +83940,30 @@ static void op_closure_fa(s7_scheme *sc) sc->code = car(closure_body(func)); } +static void op_safe_closure_all_s(s7_scheme *sc) +{ + s7_pointer args, env, x; + uint64_t id; + + args = cdr(sc->code); + sc->code = opt1_lambda(sc->code); + id = ++sc->let_number; + env = closure_let(sc->code); + let_id(env) = id; + + for (x = let_slots(env); tis_slot(x); x = next_slot(x), args = cdr(args)) + { + slot_set_value(x, lookup(sc, car(args))); + symbol_set_local(slot_symbol(x), id, x); + } + + sc->envir = env; + sc->code = closure_body(sc->code); + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); +} + static void op_safe_closure_fx(s7_scheme *sc) { s7_pointer args, p, env, x, z; @@ -82184,7 +83994,7 @@ static void op_safe_closure_fx(s7_scheme *sc) sc->code = car(sc->code); } -static void op_closure_all_s(s7_scheme *sc) +static inline void op_closure_all_s(s7_scheme *sc) { s7_pointer args, p, e, last_slot; s7_int id; @@ -82662,6 +84472,7 @@ static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg) static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) { s7_pointer if_test, if_true, la, laa, la_slot, laa_slot; + s7_function tf; if_test = cdr(code); if_true = cdr(if_test); la = cdadr(if_true); @@ -82699,10 +84510,9 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) fb = o->v[0].fb; fi1 = o1->v[0].fi; fi2 = o2->v[0].fi; - while (true) + while (!fb(o)) { s7_int i1; - if (fb(o)) break; i1 = fi1(o1); integer(val2) = fi2(o2); integer(val1) = i1; @@ -82716,10 +84526,9 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) fb = o->v[0].fb; fd1 = o1->v[0].fd; fd2 = o2->v[0].fd; - while (true) + while (!fb(o)) { s7_double x1; - if (fb(o)) break; x1 = fd1(o1); real(val2) = fd2(o2); real(val1) = x1; @@ -82774,11 +84583,11 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code) } else set_no_bool_opt(code); } - - while (true) + tf = c_callee(if_test); + if_test = car(if_test); + while (tf(sc, if_test) == sc->F) { s7_pointer a1; - if (fx_call(sc, if_test) != sc->F) break; a1 = fx_call(sc, la); sc->w = a1; slot_set_value(laa_slot, fx_call(sc, laa)); @@ -83285,7 +85094,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) slots = let_slots(outer_env); /* in the named let no-var case slots may contain the let name (it's the funclet) */ - if (integer(opt3_arglen(code)) == 0) + if (integer(opt3_arglen(code)) == 0) /* (loop) etc -- no args */ { while (true) { @@ -83418,7 +85227,6 @@ static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg) static void recur_resize(s7_scheme *sc) { - s7_int i; s7_pointer stack; block_t *ob, *nb; @@ -83428,9 +85236,7 @@ static void recur_resize(s7_scheme *sc) nb = reallocate(sc, ob, vector_length(stack) * sizeof(s7_pointer)); block_info(nb) = NULL; vector_block(stack) = nb; - vector_elements(stack) = (s7_pointer *)block_data(nb); - for (i = sc->rec_len; i < vector_length(stack); i++) - vector_element(stack, i) = sc->F; /* GC will look at all elements */ + vector_elements(stack) = (s7_pointer *)block_data(nb); /* GC looks only at elements within sc->rec_loc */ sc->rec_len = vector_length(stack); } @@ -83475,12 +85281,13 @@ static s7_pointer recur_swap(s7_scheme *sc, s7_pointer value) static s7_pointer recur_make_stack(s7_scheme *sc) { - s7_pointer v; - v = make_simple_vector(sc, RECUR_INITIAL_STACK_SIZE); - s7_vector_fill(sc, v, sc->F); + if (!sc->rec_stack) + { + sc->rec_stack = make_simple_vector(sc, RECUR_INITIAL_STACK_SIZE); + sc->rec_len = RECUR_INITIAL_STACK_SIZE; + } sc->rec_loc = 0; - sc->rec_len = RECUR_INITIAL_STACK_SIZE; - return(v); + return(sc->rec_stack); } static void rec_set_test(s7_scheme *sc, s7_pointer p) @@ -83540,109 +85347,6 @@ static void rec_set_f6(s7_scheme *sc, s7_pointer p) } -/* int stack */ -static void recur_i_resize(s7_scheme *sc) -{ - s7_int i; - s7_pointer stack; - block_t *ob, *nb; - stack = sc->rec_stack; - vector_length(stack) = sc->rec_len * 2; - ob = vector_block(stack); - nb = reallocate(sc, ob, vector_length(stack) * sizeof(s7_int)); - block_info(nb) = NULL; - vector_block(stack) = nb; - int_vector_ints(stack) = (s7_int *)block_data(nb); - for (i = sc->rec_len; i < vector_length(stack); i++) - int_vector_ints(stack)[i] = 0; - sc->rec_len = vector_length(stack); -} - -static inline void recur_i_push(s7_scheme *sc, s7_int value) -{ - if (sc->rec_loc == sc->rec_len) - recur_i_resize(sc); - int_vector_ints(sc->rec_stack)[sc->rec_loc] = value; - sc->rec_loc++; -} - -static s7_int recur_i_pop(s7_scheme *sc) -{ - sc->rec_loc--; - return(int_vector_ints(sc->rec_stack)[sc->rec_loc]); -} - -static s7_int recur_i_swap(s7_scheme *sc, s7_int value) -{ - s7_int res; - res = int_vector_ints(sc->rec_stack)[sc->rec_loc - 1]; - int_vector_ints(sc->rec_stack)[sc->rec_loc - 1] = value; - return(res); -} - -static s7_pointer recur_make_i_stack(s7_scheme *sc) -{ - s7_pointer v; - v = make_simple_int_vector(sc, RECUR_INITIAL_STACK_SIZE); - int_vector_fill(sc, v, 0); - sc->rec_loc = 0; - sc->rec_len = RECUR_INITIAL_STACK_SIZE; - return(v); -} - - -/* float stack */ -static void recur_d_resize(s7_scheme *sc) -{ - s7_int i; - s7_pointer stack; - block_t *ob, *nb; - - stack = sc->rec_stack; - vector_length(stack) = sc->rec_len * 2; - ob = vector_block(stack); - nb = reallocate(sc, ob, vector_length(stack) * sizeof(s7_double)); - block_info(nb) = NULL; - vector_block(stack) = nb; - float_vector_floats(stack) = (s7_double *)block_data(nb); - for (i = sc->rec_len; i < vector_length(stack); i++) - float_vector_floats(stack)[i] = 0.0; - sc->rec_len = vector_length(stack); -} - -static inline void recur_d_push(s7_scheme *sc, s7_double value) -{ - if (sc->rec_loc == sc->rec_len) - recur_d_resize(sc); - float_vector_floats(sc->rec_stack)[sc->rec_loc] = value; - sc->rec_loc++; -} - -static s7_double recur_d_pop(s7_scheme *sc) -{ - sc->rec_loc--; - return(float_vector_floats(sc->rec_stack)[sc->rec_loc]); -} - -static s7_double recur_d_swap(s7_scheme *sc, s7_double value) -{ - s7_double res; - res = float_vector_floats(sc->rec_stack)[sc->rec_loc - 1]; - float_vector_floats(sc->rec_stack)[sc->rec_loc - 1] = value; - return(res); -} - -static s7_pointer recur_make_d_stack(s7_scheme *sc) -{ - s7_pointer v; - v = make_simple_float_vector(sc, RECUR_INITIAL_STACK_SIZE); - float_vector_fill(sc, v, 0.0); - sc->rec_loc = 0; - sc->rec_len = RECUR_INITIAL_STACK_SIZE; - return(v); -} - - /* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */ static void opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, s7_pointer code) { @@ -83697,10 +85401,9 @@ static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_RECUR_IF_A_A_opA_LAq]++; #endif sc->rec_stack = recur_make_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); opinit_if_a_a_opa_laq(sc, true, arg); sc->value = oprec_if_a_a_opa_laq(sc); - unstack(sc); + sc->rec_loc = 0; return(sc->value); } @@ -83710,10 +85413,9 @@ static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_RECUR_IF_A_opA_LAq_A]++; #endif sc->rec_stack = recur_make_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); opinit_if_a_a_opa_laq(sc, false, arg); sc->value = oprec_if_a_opa_laq_a(sc); - unstack(sc); + sc->rec_loc = 0; return(sc->value); } @@ -83899,6 +85601,7 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc) { + s7_int i1, i2; sc->pc = 0; if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) /* if_(A) */ { @@ -83906,25 +85609,39 @@ static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */ } sc->pc = sc->rec_pc1; - recur_i_push(sc, sc->rec_a1_o->v[0].fi(sc->rec_a1_o)); /* save a1 */ + i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */ sc->pc++; integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); /* slot1 = a2 */ - integer(sc->rec_val1) = recur_i_swap(sc, oprec_i_if_a_a_opla_laq(sc)); /* slot1 = a1, save la2 */ - return(sc->rec_i_cf(oprec_i_if_a_a_opla_laq(sc), recur_i_pop(sc))); /* call op(la1, la2) */ + i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */ + integer(sc->rec_val1) = i1; /* slot1 = a1 */ + return(sc->rec_i_cf(oprec_i_if_a_a_opla_laq(sc), i2)); /* call op(la1, la2) */ } static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme *sc) { + s7_int i1, i2; if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); - recur_i_push(sc, sc->rec_fi2(sc->rec_a1_o)); + i1 = sc->rec_fi2(sc->rec_a1_o); integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - integer(sc->rec_val1) = recur_i_swap(sc, oprec_i_if_a_a_opla_laq_0(sc)); - return(sc->rec_i_cf(oprec_i_if_a_a_opla_laq_0(sc), recur_i_pop(sc))); + if (sc->rec_fb1(sc->rec_test_o)) + i2 = sc->rec_fi1(sc->rec_result_o); + else + { + s7_int i3; + i2 = sc->rec_fi2(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + i3 = oprec_i_if_a_a_opla_laq_0(sc); + integer(sc->rec_val1) = i2; + i2 = sc->rec_i_cf(oprec_i_if_a_a_opla_laq_0(sc), i3); + } + integer(sc->rec_val1) = i1; + return(sc->rec_i_cf(oprec_i_if_a_a_opla_laq_0(sc), i2)); } static s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc) { + s7_double x1, x2; sc->pc = 0; if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) { @@ -83932,10 +85649,11 @@ static s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc) return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); } sc->pc = sc->rec_pc1; - recur_d_push(sc, sc->rec_a1_o->v[0].fd(sc->rec_a1_o)); + x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); - real(sc->rec_val1) = recur_d_swap(sc, oprec_d_if_a_a_opla_laq(sc)); - return(sc->rec_d_cf(oprec_d_if_a_a_opla_laq(sc), recur_d_pop(sc))); + x2 = oprec_d_if_a_a_opla_laq(sc); + real(sc->rec_val1) = x1; + return(sc->rec_d_cf(oprec_d_if_a_a_opla_laq(sc), x2)); } static s7_pointer oprec_if_a_a_opla_laq(s7_scheme *sc) @@ -83952,6 +85670,7 @@ static s7_pointer oprec_if_a_a_opla_laq(s7_scheme *sc) static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc) { + s7_int i1, i2; sc->pc = 0; if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) { @@ -83959,25 +85678,39 @@ static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); } sc->pc = sc->rec_pc1; - recur_i_push(sc, sc->rec_a1_o->v[0].fi(sc->rec_a1_o)); + i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); sc->pc++; integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - integer(sc->rec_val1) = recur_i_swap(sc, oprec_i_if_a_opla_laq_a(sc)); - return(sc->rec_i_cf(oprec_i_if_a_opla_laq_a(sc), recur_i_pop(sc))); + i2 = oprec_i_if_a_opla_laq_a(sc); + integer(sc->rec_val1) = i1; + return(sc->rec_i_cf(oprec_i_if_a_opla_laq_a(sc), i2)); } static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme *sc) { - if (!(sc->rec_fb1(sc->rec_test_o))) + s7_int i1, i2; + if (!sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); - recur_i_push(sc, sc->rec_fi2(sc->rec_a1_o)); + i1 = sc->rec_fi2(sc->rec_a1_o); integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - integer(sc->rec_val1) = recur_i_swap(sc, oprec_i_if_a_opla_laq_a_0(sc)); - return(sc->rec_i_cf(oprec_i_if_a_opla_laq_a_0(sc), recur_i_pop(sc))); + if (!sc->rec_fb1(sc->rec_test_o)) + i2 = sc->rec_fi1(sc->rec_result_o); + else + { + s7_int i3; + i2 = sc->rec_fi2(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + i3 = oprec_i_if_a_opla_laq_a_0(sc); + integer(sc->rec_val1) = i2; + i2 = sc->rec_i_cf(oprec_i_if_a_opla_laq_a_0(sc), i3); + } + integer(sc->rec_val1) = i1; + return(sc->rec_i_cf(oprec_i_if_a_opla_laq_a_0(sc), i2)); } static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc) { + s7_double x1, x2; sc->pc = 0; if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) { @@ -83985,11 +85718,12 @@ static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc) return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); } sc->pc = sc->rec_pc1; - recur_d_push(sc, sc->rec_a1_o->v[0].fd(sc->rec_a1_o)); + x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); sc->pc++; real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); - real(sc->rec_val1) = recur_d_swap(sc, oprec_d_if_a_opla_laq_a(sc)); - return(sc->rec_d_cf(oprec_d_if_a_opla_laq_a(sc), recur_d_pop(sc))); + x2 = oprec_d_if_a_opla_laq_a(sc); + real(sc->rec_val1) = x1; + return(sc->rec_d_cf(oprec_d_if_a_opla_laq_a(sc), x2)); } static s7_pointer oprec_if_a_opla_laq_a(s7_scheme *sc) @@ -84007,11 +85741,10 @@ static s7_pointer oprec_if_a_opla_laq_a(s7_scheme *sc) static void wrap_recur_if_a_a_opla_laq(s7_scheme *sc, bool a_op) { opt_pid_t choice; + tick_tc_rec(sc); choice = opinit_if_a_a_opla_laq(sc, a_op); if ((choice == OPT_INT) || (choice == OPT_INT_0)) { - sc->rec_stack = recur_make_i_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); if (choice == OPT_INT_0) sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq_0(sc) : oprec_i_if_a_opla_laq_a_0(sc)); else sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq(sc) : oprec_i_if_a_opla_laq_a(sc)); @@ -84021,17 +85754,11 @@ static void wrap_recur_if_a_a_opla_laq(s7_scheme *sc, bool a_op) if (choice == OPT_PTR) { sc->rec_stack = recur_make_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); sc->value = (a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc); + sc->rec_loc = 0; } - else - { - sc->rec_stack = recur_make_d_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); - sc->value = make_real(sc, (a_op) ? oprec_d_if_a_a_opla_laq(sc) : oprec_d_if_a_opla_laq_a(sc)); - } + else sc->value = make_real(sc, (a_op) ? oprec_d_if_a_a_opla_laq(sc) : oprec_d_if_a_opla_laq_a(sc)); } - unstack(sc); } @@ -84129,7 +85856,7 @@ static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme *sc) * esteemed reader, please ignore this nonsense! * The opt_info version was not a lot faster -- ~/old/tak-st.c: say 10% faster. The current fx-based * version has immediate lookups, and since the data is (ahem) simple, the GC is not a factor. - * The opt version has its own overheads, and has to do the same amount of i-stack manipulations. + * The opt version has its own overheads, and has to do the same amount of stack manipulations. */ static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) { @@ -84262,10 +85989,9 @@ static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer arg) #endif /* sc->envir is set already and will be restored by the caller */ sc->rec_stack = recur_make_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); opinit_if_a_a_and_a_laa_laa(sc, arg); sc->value = oprec_if_a_a_and_a_laa_laa(sc); - unstack(sc); + sc->rec_loc = 0; return(sc->value); } @@ -84310,10 +86036,9 @@ static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer arg) tc_rec_calls[OP_RECUR_COND_A_A_A_A_opLA_LAq]++; #endif sc->rec_stack = recur_make_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); opinit_cond_a_a_a_a_opla_laq(sc, arg); sc->value = oprec_cond_a_a_a_a_opla_laq(sc); - unstack(sc); + sc->rec_loc = 0; return(sc->value); } @@ -84557,6 +86282,7 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) { + s7_int i1, i2; sc->pc = 0; if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) { @@ -84566,41 +86292,42 @@ static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) sc->pc = sc->rec_pc1; if (sc->rec_a1_o->v[0].fb(sc->rec_a1_o)) { - recur_i_push(sc, sc->rec_a2_o->v[0].fi(sc->rec_a2_o)); + i1 = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); sc->pc++; integer(sc->rec_val2) = sc->rec_a3_o->v[0].fi(sc->rec_a3_o); - integer(sc->rec_val1) = recur_i_pop(sc); + integer(sc->rec_val1) = i1; return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); } sc->pc = sc->rec_pc2; - recur_i_push(sc, sc->rec_a4_o->v[0].fi(sc->rec_a4_o)); + i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o); sc->pc++; - recur_i_push(sc, sc->rec_a5_o->v[0].fi(sc->rec_a5_o)); + i2 = sc->rec_a5_o->v[0].fi(sc->rec_a5_o); sc->pc++; integer(sc->rec_val2) = sc->rec_a6_o->v[0].fi(sc->rec_a6_o); - integer(sc->rec_val1) = recur_i_pop(sc); + integer(sc->rec_val1) = i2; integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq(sc); - integer(sc->rec_val1) = recur_i_pop(sc); + integer(sc->rec_val1) = i1; return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); } static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq_0(s7_scheme *sc) { + s7_int i1, i2; if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); if (sc->rec_fb2(sc->rec_a1_o)) { - recur_i_push(sc, sc->rec_fi2(sc->rec_a2_o)); + i1 = sc->rec_fi2(sc->rec_a2_o); integer(sc->rec_val2) = sc->rec_fi3(sc->rec_a3_o); - integer(sc->rec_val1) = recur_i_pop(sc); + integer(sc->rec_val1) = i1; return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); } - recur_i_push(sc, sc->rec_fi4(sc->rec_a4_o)); - recur_i_push(sc, sc->rec_fi5(sc->rec_a5_o)); + i1 = sc->rec_fi4(sc->rec_a4_o); + i2 = sc->rec_fi5(sc->rec_a5_o); integer(sc->rec_val2) = sc->rec_fi6(sc->rec_a6_o); - integer(sc->rec_val1) = recur_i_pop(sc); + integer(sc->rec_val1) = i2; integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc); - integer(sc->rec_val1) = recur_i_pop(sc); + integer(sc->rec_val1) = i1; return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); } @@ -84627,43 +86354,29 @@ static s7_pointer oprec_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) { opt_pid_t choice; + tick_tc_rec(sc); choice = opinit_cond_a_a_a_laa_lopa_laaq(sc); if (choice != OPT_PTR) - { - sc->rec_stack = recur_make_i_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); - sc->value = make_integer(sc, (choice == OPT_INT) ? oprec_i_cond_a_a_a_laa_lopa_laaq(sc) : oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); - } + sc->value = make_integer(sc, (choice == OPT_INT) ? oprec_i_cond_a_a_a_laa_lopa_laaq(sc) : oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); else { sc->rec_stack = recur_make_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); sc->value = oprec_cond_a_a_a_laa_lopa_laaq(sc); + sc->rec_loc = 0; } - unstack(sc); - } static void wrap_recur(s7_scheme *sc, s7_pointer (*recur)(s7_scheme *sc)) { + tick_tc_rec(sc); sc->rec_stack = recur_make_stack(sc); - push_stack_no_code(sc, OP_GC_PROTECT, sc->rec_stack); sc->value = recur(sc); - unstack(sc); + sc->rec_loc = 0; } /* -------------------------------- */ -static void op_safe_c_cs(s7_scheme *sc) -{ - s7_pointer args; - args = cdr(sc->code); - set_car(sc->t2_2, lookup(sc, cadr(args))); - set_car(sc->t2_1, opt1_con(args)); /* car(args) or cadar */ - sc->value = c_call(sc->code)(sc, sc->t2_1); -} - static void op_safe_c_ssp(s7_scheme *sc) { check_stack_size(sc); @@ -84731,7 +86444,7 @@ static s7_pointer op_s_c(s7_scheme *sc) return(NULL); } -static bool op_s_s(s7_scheme *sc) +static inline bool op_s_s(s7_scheme *sc) { s7_pointer code; code = sc->code; @@ -84796,6 +86509,20 @@ static void op_safe_c_star_fx(s7_scheme *sc) sc->args = sc->nil; } +static void op_safe_c_star(s7_scheme *sc) +{ + sc->code = opt1_cfunc(sc->code); + apply_c_function_star_fill_defaults(sc, 0); +} + +static void op_safe_c_star_a(s7_scheme *sc) +{ + sc->args = list_1(sc, fx_call(sc, cdr(sc->code))); + sc->code = opt1_cfunc(sc->code); + /* one arg, so it's not a keyword; all we need to do is fill in defaults */ + apply_c_function_star_fill_defaults(sc, 1); +} + static void op_safe_c_star_aa(s7_scheme *sc) { s7_pointer val; @@ -84807,31 +86534,50 @@ static void op_safe_c_star_aa(s7_scheme *sc) apply_c_function_star(sc); } -static void op_safe_c_css(s7_scheme *sc) +static void op_safe_c_ps_mv(s7_scheme *sc) /* (define (hi a) (+ (values 1 2) a)) */ { - s7_pointer val1, args; - args = cdr(sc->code); - val1 = lookup(sc, opt2_sym(args)); - set_car(sc->t3_2, lookup(sc, opt1_sym(args))); - set_car(sc->t3_3, val1); - set_car(sc->t3_1, car(args)); - sc->value = c_call(sc->code)(sc, sc->t3_1); + sc->args = s7_append(sc, sc->value, list_1(sc, lookup(sc, caddr(sc->code)))); + sc->code = c_function_base(opt1_cfunc(sc->code)); } -static void op_safe_c_sc(s7_scheme *sc) +static void op_safe_c_pc(s7_scheme *sc) { - set_car(sc->t2_1, lookup(sc, cadr(sc->code))); - set_car(sc->t2_2, opt2_con(cdr(sc->code))); + check_stack_size(sc); + push_stack(sc, OP_SAFE_C_PC_1, opt2_con(cdr(sc->code)), sc->code); + sc->code = cadr(sc->code); +} + +static void op_safe_c_pc_mv(s7_scheme *sc) +{ + sc->args = s7_append(sc, sc->value, list_1(sc, sc->args)); /* not plist! */ + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_c_pc_1(s7_scheme *sc) +{ + set_car(sc->t2_1, sc->value); + set_car(sc->t2_2, sc->args); sc->value = c_call(sc->code)(sc, sc->t2_1); } -static void op_safe_c_opsq(s7_scheme *sc) +static void op_safe_c_cp(s7_scheme *sc) { - s7_pointer args; - args = cadr(sc->code); - set_car(sc->t1_1, lookup(sc, cadr(args))); - set_car(sc->t1_1, c_call(args)(sc, sc->t1_1)); - sc->value = c_call(sc->code)(sc, sc->t1_1); + /* it's possible in a case like this to overflow the stack -- s7test has a deeply + * nested expression involving (+ c (+ c (+ ... ))) all opt'd as safe_c_cp -- if we're close + * to the stack end at the start, it runs off the end. Normally the stack increase in + * the reader protects us, but a call/cc can replace the original stack with a much smaller one. + * How to minimize the cost of this check? + */ + check_stack_size(sc); + push_stack(sc, (opcode_t)opt1_any(cdr(sc->code)), opt3_any(cdr(sc->code)), sc->code); /* to safe_add_sp_1 for example */ + sc->code = caddr(sc->code); +} + +static void op_safe_c_sc(s7_scheme *sc) +{ + set_car(sc->t2_1, lookup(sc, cadr(sc->code))); + set_car(sc->t2_2, opt2_con(cdr(sc->code))); + sc->value = c_call(sc->code)(sc, sc->t2_1); } static void op_safe_c_ap(s7_scheme *sc) @@ -84844,16 +86590,69 @@ static void op_safe_c_ap(s7_scheme *sc) sc->code = caddr(code); } +static void op_safe_c_sp_mv(s7_scheme *sc) +{ + sc->args = cons(sc, sc->args, sc->value); /* don't use u2_1 or some permanent list here: immutable=copied later */ + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_c_pp_1(s7_scheme *sc) +{ + /* unless multiple values from last call (first arg) we get here only from OP_SAFE_C_PP. + * splice_in_values changes the operator so if we get here, sc->value is the result of the first arg + * safe_c_pp -> 1, but if mv, -> 3 + * 1: -> 2, if mv -> 4 + * 2: done (both normal) + * 3: -> 5, but if mv, -> 6 + * 4: done (1 normal, 2 mv) + * 5: done (1 mv, 2 normal) + * 6: done (both mv) + * I think safe_c_ppp would require 18 branches (or maybe just collect the args and concatenate at the end?) + */ + push_stack(sc, (opcode_t)opt1_any(cdr(sc->code)), sc->value, sc->code); /* mv -> 3, opt1 is OP_SAFE_CONS_SP_1 et al which assume no mv */ + sc->code = caddr(sc->code); +} + +static void op_safe_c_pp_3_mv(s7_scheme *sc) +{ + /* we get here if the first arg returned multiple values */ + push_stack(sc, OP_SAFE_C_PP_5, copy_list(sc, sc->value), sc->code); /* copy is needed here */ + sc->code = caddr(sc->code); +} + +static void op_safe_c_pp_5(s7_scheme *sc) +{ + /* 1 mv, 2, normal */ + sc->args = s7_append(sc, sc->args, list_1(sc, sc->value)); + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_c_pp_6_mv(s7_scheme *sc) +{ + sc->args = s7_append(sc, sc->args, sc->value); + /* + * c_callee(sc->code) here is g_add_2, but we have any number of args from a values call + * the original (unoptimized) function is (hopefully) c_function_base(opt1_cfunc(sc->code))? + * (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (ho 2))) (hi)) -> 7 + * (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) (hi)) -> 10 + * (let () (define (ho a) (+ a 2)) (define (hi) (+ (values 3 4) (ho 1))) (hi)) -> 10 + * (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10 + */ + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +#if WITH_GCC +static inline bool collect_fp_args(s7_scheme *sc, opcode_t op, s7_pointer args) __attribute__((always_inline)); +#endif + static inline bool collect_fp_args(s7_scheme *sc, opcode_t op, s7_pointer args) { s7_pointer p; + sc->args = args; - p = sc->code; - while ((is_pair(p)) && (has_fx(p))) - { - sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_SAFE_C_FP_1 */ - p = cdr(p); - } + for (p = sc->code; (is_pair(p)) && (has_fx(p)); p = cdr(p)) + sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_SAFE_C_FP_1 */ + if (is_pair(p)) { push_stack(sc, op, sc->args, cdr(p)); @@ -84863,42 +86662,97 @@ static inline bool collect_fp_args(s7_scheme *sc, opcode_t op, s7_pointer args) return(false); } +static void op_safe_c_fp(s7_scheme *sc) /* code: (func . args) where at least one arg is not fxable */ +{ + s7_pointer p; + check_stack_size(sc); + sc->args = list_1(sc, sc->code); + sc->code = cdr(sc->code); /* args pre-eval */ + for (p = sc->code; (is_pair(p)) && (has_fx(p)); p = cdr(p)) + sc->args = cons(sc, fx_call(sc, p), sc->args); /* reversed before apply in OP_SAFE_C_FP_1 */ + /* there's always at least one non-fx arg (the "p" in "fp"), also lots of recurs here */ +#if S7_DEBUGGING + if (!is_pair(p)) fprintf(stderr, "%s: all fxable: %s\n", __func__, DISPLAY(sc->code)); +#endif + push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_SAFE_C_FP_1 : OP_SAFE_C_FP_2)), sc->args, cdr(p)); + sc->code = T_Pair(car(p)); +} + +static bool op_safe_c_fp_mv_1(s7_scheme *sc) +{ + /* s7_append copies its first argument, as does s7_reverse, so use append_uncopied */ + if (collect_fp_args(sc, OP_SAFE_C_FP_MV_1, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args))) + return(true); + sc->args = safe_reverse_in_place(sc, sc->args); + sc->code = c_function_base(opt1_cfunc(car(sc->args))); + sc->args = cdr(sc->args); + return(false); +} + static void op_safe_closure_fp(s7_scheme *sc) { + s7_pointer p; + check_stack_size(sc); + sc->args = list_1(sc, sc->code); + sc->code = cdr(sc->code); + for (p = sc->code; (is_pair(p)) && (has_fx(p)); p = cdr(p)) + sc->args = cons(sc, fx_call(sc, p), sc->args); + push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_SAFE_CLOSURE_FP_1 : OP_SAFE_CLOSURE_FP_2)), sc->args, cdr(p)); + sc->code = T_Pair(car(p)); +} + +static void op_safe_closure_fp_1(s7_scheme *sc) +{ + /* in-coming sc->value has the current arg value, sc->args is all previous args */ uint64_t id; - s7_pointer x, env, z; + s7_pointer x, z; sc->args = safe_reverse_in_place(sc, sc->args); sc->code = opt1_lambda(car(sc->args)); sc->args = cdr(sc->args); id = ++sc->let_number; - env = closure_let(sc->code); - let_id(env) = id; + sc->envir = closure_let(sc->code); + let_id(sc->envir) = id; - for (x = let_slots(env), z = sc->args; tis_slot(x); x = next_slot(x), z = cdr(z)) + for (x = let_slots(sc->envir), z = sc->args; tis_slot(x); x = next_slot(x), z = cdr(z)) { slot_set_value(x, car(z)); symbol_set_local(slot_symbol(x), id, x); } - if (is_pair(z)) + if (is_pair(z)) /* these checks are needed because multiple-values might evade earlier arg num checks */ s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); if (tis_slot(x)) s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); - sc->envir = env; sc->code = closure_body(sc->code); if (is_pair(cdr(sc->code))) push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); sc->code = car(sc->code); } +static void op_safe_c_pa(s7_scheme *sc) +{ + check_stack_size(sc); + push_stack(sc, OP_SAFE_C_PA_1, sc->nil, sc->code); + sc->code = cadr(sc->code); +} + +static void op_safe_c_pa_1(s7_scheme *sc) +{ + s7_pointer val; + val = sc->value; + set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t2_1, val); + sc->value = c_call(sc->code)(sc, sc->t2_1); +} + static void op_safe_c_pa_mv(s7_scheme *sc) { s7_pointer val, code; code = sc->code; val = sc->value; /* this is necessary since the c_call below can clobber sc->value */ - sc->args = s7_append(sc, val, set_plist_1(sc, fx_call(sc, cddr(code)))); + sc->args = s7_append(sc, val, list_1(sc, fx_call(sc, cddr(code)))); /* not plist here! s7_append does not copy it */ sc->code = c_function_base(opt1_cfunc(code)); } @@ -84929,12 +86783,63 @@ static void op_c_fx(s7_scheme *sc) sc->value = c_call(sc->code)(sc, new_args); } +static void op_c_p_mv(s7_scheme *sc) /* op_c_p_1 -> mv case: (define (hi) (format (values #f "~A ~D" 1 2))) */ +{ + sc->code = c_function_base(opt1_cfunc(sc->code)); /* see comment above */ + sc->args = copy_list(sc, sc->value); +} + static void op_c_a(s7_scheme *sc) { sc->args = list_1(sc, fx_call(sc, cdr(sc->code))); sc->value = c_call(sc->code)(sc, sc->args); } +static void op_c_ap(s7_scheme *sc) +{ + s7_pointer val; + val = fx_call(sc, cdr(sc->code)); + push_stack(sc, OP_C_AP_1, val, sc->code); /* op_c_ap_1 sends us to apply which calls check_stack_size I think */ + sc->code = caddr(sc->code); +} + +static void op_c_ap_mv(s7_scheme *sc) +{ + clear_multiple_value(sc->value); + sc->args = cons(sc, sc->args, sc->value); + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_c_fa(s7_scheme *sc) +{ + s7_pointer f, code; + code = sc->code; + sc->code = cdadr(code); + make_closure_with_let(sc, f, car(sc->code), cdr(sc->code), sc->envir, CLOSURE_ARITY_NOT_SET); + sc->w = f; /* f=new closure cell, car=args, cdr=body, can't use sc->value here because c_call below may clobber it */ + sc->args = list_2(sc, f, fx_call(sc, cddr(code))); + sc->value = c_call(code)(sc, sc->args); +} + +static inline void op_c_fa_1(s7_scheme *sc) +{ + s7_pointer f, code; + code = sc->code; + f = cddr(code); + sc->value = fx_call(sc, f); + if (is_null(sc->value)) + { + if (c_callee(code)) + sc->value = sc->unspecified; + return; + } + sc->code = opt3_pair(code); /* cdadr(code); */ + make_closure_with_let(sc, f, car(sc->code), cdr(sc->code), sc->envir, 1); + if (c_callee(code)) + sc->value = g_for_each_closure(sc, f, sc->value); + else sc->value = g_map_closure(sc, f, sc->value); +} + static void op_c_aa(s7_scheme *sc) { s7_pointer code; @@ -84960,6 +86865,50 @@ static inline void op_eval_args1(s7_scheme *sc) /* inline is needed here */ sc->args = x; } +static void op_safe_ifa_ss_a(s7_scheme *sc) /* ((if fx s s) fx) I think */ +{ + s7_function f; + f = c_function_call((is_true(sc, fx_call(sc, cdar(sc->code)))) ? opt1_con(sc->code) : opt2_con(sc->code)); + sc->value = f(sc, set_plist_1(sc, fx_call(sc, cdr(sc->code)))); +} + +#if WITH_GCC +static inline void op_apply_ss(s7_scheme *sc) __attribute__((always_inline)); +#endif + +static inline void op_apply_ss(s7_scheme *sc) +{ + /* these used to check sc->code (i.e. "apply") if not h_optimized, but that still assumed we'd apply cadr to cddr. + * should we check that apply has not been set!? + */ + sc->args = lookup(sc, opt2_sym(sc->code)); /* is this right if code=macro? */ + sc->code = lookup(sc, cadr(sc->code)); /* global search here was slower (e.g. tauto) */ + if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ + apply_list_error(sc, sc->args); + if (needs_copied_args(sc->code)) + sc->args = copy_list(sc, sc->args); +} + +static void op_apply_sa(s7_scheme *sc) +{ + s7_pointer p; + p = cdr(sc->code); + sc->args = fx_call(sc, cdr(p)); + sc->code = lookup_global(sc, car(p)); + if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ + apply_list_error(sc, sc->args); + if (needs_copied_args(sc->code)) + sc->args = copy_list(sc, sc->args); +} + +static void op_apply_sl(s7_scheme *sc) +{ + s7_pointer p; + p = cdr(sc->code); + sc->args = fx_call(sc, cdr(p)); + sc->code = lookup_global(sc, car(p)); +} + static void op_eval_args2(s7_scheme *sc) { s7_pointer x; @@ -85133,7 +87082,7 @@ static goto_t op_read_dot(s7_scheme *sc) for (p = sc->value; is_pair(p); p = cdr(p)) sc->args = cons(sc, car(p), sc->args); sc->tok = c; - return(goto_READ_TOK); + return(goto_read_tok); } back_up_stack(sc); read_error(sc, "stray dot?"); /* (+ 1 . 2 3) or (list . ) */ @@ -85148,8 +87097,8 @@ static goto_t op_read_dot(s7_scheme *sc) */ sc->value = reverse_in_place(sc, sc->value, sc->args); pair_set_dotted(sc->value); - if (main_stack_op(sc) == OP_READ_LIST) return(goto_POP_READ_LIST); - return(goto_START); + if (main_stack_op(sc) == OP_READ_LIST) return(goto_pop_read_list); + return(goto_start); } static bool op_read_quote(s7_scheme *sc) @@ -85224,7 +87173,7 @@ static bool op_read_byte_vector(s7_scheme *sc) return(main_stack_op(sc) != OP_READ_LIST); } -static void op_eval_macro(s7_scheme *sc) +static void op_eval_macro(s7_scheme *sc) /* after (scheme-side) macroexpansion, evaluate the resulting expression */ { /* (define-macro (hi a) `(+ ,a 1)) * (hi 2) @@ -85260,8 +87209,193 @@ static bool op_eval_macro_mv(s7_scheme *sc) return(false); } +static void op_finish_expansion(s7_scheme *sc) +{ + /* after the expander has finished, if a list was returned, we need to add some annotations. + * if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*). + */ + if (sc->value == sc->no_value) + sc->stack_end[-1] = (s7_pointer)OP_READ_NEXT; + else + { + if (is_pair(sc->value)) + sc->value = copy_body(sc, sc->value); + } +} + +static void macroexpand_c_macro(s7_scheme *sc) +{ + s7_int len; + len = safe_list_length(sc->args); + if (len < c_macro_required_args(sc->code)) + s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); + if (c_macro_all_args(sc->code) < len) + s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); + sc->value = c_macro_call(sc->code)(sc, sc->args); +} + +static void eval_last_arg(s7_scheme *sc, s7_pointer car_code) +{ + /* here we've reached the last arg (sc->code == nil), it is not a pair */ + s7_pointer x, val; + + if (!is_null(cdr(sc->code))) + improper_arglist_error(sc); + + sc->code = pop_op_stack(sc); + if (is_symbol(car_code)) + val = lookup_checked(sc, car_code); /* this has to precede the set_type below */ + else val = car_code; + sc->temp4 = val; + new_cell(sc, x, T_PAIR); + set_car(x, val); + set_cdr(x, sc->args); + + if (!is_null(sc->args)) + sc->args = safe_reverse_in_place(sc, x); + else sc->args = x; +} + +static bool eval_car_pair(s7_scheme *sc) +{ + s7_pointer code, carc; + 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 + */ + if (sc->stack_end >= sc->stack_resize_trigger) + check_for_cyclic_code(sc, code); + push_stack(sc, OP_EVAL_ARGS, sc->nil, code); + + if (is_syntactic_symbol(car(carc))) + /* was checking for is_syntactic here but that can be confused by successive optimizer passes: + * (define (hi) (((lambda () list)) 1 2 3)) etc + */ + { + if ((car(carc) == sc->quote_symbol) && /* ('and #f) */ + ((!is_pair(cdr(carc))) || /* ((quote . #\h) (2 . #\i)) ! */ + (is_syntactic(cadr(carc))))) + apply_error(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc, cdr(code)); + + sc->code = carc; + sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); + pair_set_syntax_op(sc->code, sc->cur_op); + return(true); + } + set_optimize_op(code, OP_PAIR_PAIR); + push_stack(sc, OP_EVAL_ARGS, sc->nil, carc); + sc->code = car(carc); + return(false); +} + +static void op_pair_pair(s7_scheme *sc) +{ + if (sc->stack_end >= sc->stack_resize_trigger) + check_for_cyclic_code(sc, sc->code); + push_stack(sc, OP_EVAL_ARGS, sc->nil, sc->code); + push_stack(sc, OP_EVAL_ARGS, sc->nil, car(sc->code)); + sc->code = caar(sc->code); +} + + #define UNOPT_PRINT 0 +static goto_t trailers(s7_scheme *sc) +{ + s7_pointer code; + code = sc->code; + if (is_pair(code)) + { + s7_pointer carc; + carc = car(code); + if (is_syntactic_symbol(carc)) /* carc can also be syntactic */ + { + sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); + pair_set_syntax_op(code, sc->cur_op); +#if UNOPT_PRINT && (0) + fprintf(stderr, " syntax (1): %s\n", DISPLAY_80(sc->code)); +#endif + return(goto_top_no_pop); + } + + if (is_symbol(carc)) + { + /* car is a symbol, sc->code a list */ + if (is_syntactic_symbol(carc)) + { + sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); + pair_set_syntax_op(sc->code, sc->cur_op); +#if UNOPT_PRINT + fprintf(stderr, " syntax (2): %s\n", DISPLAY_80(sc->code)); +#endif + return(goto_top_no_pop); + } + sc->value = lookup_global(sc, carc); + set_optimize_op(code, OP_PAIR_SYM); +#if UNOPT_PRINT + fprintf(stderr, " pair_sym: %s\n", DISPLAY_80(code)); +#endif + /* pair_sym -> unknown* check seems to make no difference? maybe split pair_sym? */ + return(goto_eval_args_top); + } + if (is_pair(carc)) /* very uncommon case: car is either itself a pair or some non-symbol */ + { + if (eval_car_pair(sc)) return(goto_top_no_pop); + return(goto_eval); + } + /* here we can get syntax objects like quote */ + if (is_syntax(carc)) + { + sc->cur_op = (opcode_t)syntax_opcode(carc); + pair_set_syntax_op(sc->code, sc->cur_op); +#if UNOPT_PRINT + fprintf(stderr, " syntax (4): %s\n", DISPLAY_80(sc->code)); +#endif + return(goto_top_no_pop); + } + /* car must be the function to be applied, or (for example) a syntax variable like quote that has been used locally */ + set_optimize_op(code, OP_PAIR_ANY); +#if UNOPT_PRINT + fprintf(stderr, " pair_any: %s\n", DISPLAY_80(sc->code)); +#endif + sc->value = T_Pos(carc); + return(goto_eval_args_top); + } + if (is_symbol(code)) + { + sc->value = lookup_checked(sc, code); + set_optimize_op(code, (is_keyword(code)) ? OP_CON : ((is_global(code)) ? OP_GLOBAL_SYM : OP_SYM)); + /* set_optimize_op(code, (is_keyword(code)) ? OP_CON : OP_SYM); */ +#if UNOPT_PRINT + fprintf(stderr, " con/sym: %s\n", DISPLAY_80(sc->code)); +#endif + } + else + { + sc->value = T_Pos(code); + set_optimize_op(code, OP_CON); +#if UNOPT_PRINT + fprintf(stderr, " con: %s\n", DISPLAY_80(sc->code)); +#endif + } + return(goto_start); +} + +#if WITH_GCC +static inline void op_map_gather(s7_scheme *sc) __attribute__((always_inline)); +#endif + +static inline void op_map_gather(s7_scheme *sc) +{ + if (sc->value != sc->no_value) + { + if (is_multiple_value(sc->value)) + counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args))); + else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args))); + } +} + static s7_pointer eval(s7_scheme *sc, opcode_t first_op) { #if SHOW_EVAL_OPS @@ -85270,9 +87404,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->cur_op = first_op; goto TOP_NO_POP; - while (true) + while (true) /* "continue" in this procedure refers to this loop */ { - START: pop_stack(sc); goto TOP_NO_POP; @@ -85300,33 +87433,20 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) */ switch (sc->cur_op) { - case OP_SAFE_C_D: - if (!c_function_is_ok(sc, sc->code)) - { - if (is_proper_list_1(sc, cdr(sc->code))) /* code here can be (values) for example, if values is a method in lt and we're in (with-let lt ...) */ - { - set_optimize_op(sc->code, OP_S_C); - goto EVAL; - } - break; - } - /* break = fall into the "trailers" section where optimizations are cleared */ - case HOP_SAFE_C_D: - sc->value = d_call(sc, sc->code); - goto START; - - case OP_X: - case HOP_X: - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */ - sc->value = fx_call(sc, sc->code); - goto START; + case OP_SAFE_C_D: if (!c_function_is_ok(sc, sc->code)) break; /* break refers to the switch statement */ + case HOP_SAFE_C_D: sc->value = d_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */ case OP_SAFE_C_S: /* hop_safe_c_t (if set in fx_tree) is uncommon: ca 20 hits in t103.scm */ - if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_S); goto EVAL;} + if (!c_function_is_ok(sc, sc->code)) /* {set_optimize_op(sc->code, OP_S_S); goto EVAL;} */ + { + if (op_unknown_g(sc, lookup(sc, car(sc->code))) != goto_eval) + set_optimize_op(sc->code, OP_S_S); + goto EVAL; + } case HOP_SAFE_C_S: set_car(sc->t1_1, lookup(sc, cadr(sc->code))); sc->value = c_call(sc->code)(sc, sc->t1_1); - goto START; + continue; case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break; @@ -85334,19 +87454,19 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) set_car(sc->t2_1, lookup(sc, cadr(sc->code))); set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(sc->code)))); sc->value = c_call(sc->code)(sc, sc->t2_1); - goto START; + continue; case OP_SAFE_C_ALL_S: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_ALL_S: sc->value = fx_c_all_s(sc, sc->code); goto START; + case HOP_SAFE_C_ALL_S: sc->value = fx_c_all_s(sc, sc->code); continue; case OP_SAFE_C_SC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SC: op_safe_c_sc(sc); goto START; + case HOP_SAFE_C_SC: op_safe_c_sc(sc); continue; case OP_SAFE_C_CS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CS: op_safe_c_cs(sc); goto START; + case HOP_SAFE_C_CS: sc->value = fx_c_cs(sc, sc->code); continue; case OP_SAFE_C_CQ: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CQ: sc->value = fx_c_cq(sc, sc->code); goto START; + case HOP_SAFE_C_CQ: sc->value = fx_c_cq(sc, sc->code); continue; case OP_SAFE_C_P: if (!c_function_is_ok(sc, sc->code)) break; @@ -85359,7 +87479,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SAFE_C_P_1: set_car(sc->t1_1, sc->value); sc->value = c_call(sc->code)(sc, sc->t1_1); - goto START; + continue; case OP_NOT_P: if (!c_function_is_ok(sc, sc->code)) break; @@ -85368,145 +87488,135 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->code = T_Pair(cadr(sc->code)); goto EVAL; - case OP_NOT_P_1: - sc->value = ((sc->value == sc->F) ? sc->T : sc->F); - goto START; + case OP_NOT_P_1: sc->value = ((sc->value == sc->F) ? sc->T : sc->F); continue; - - case OP_SAFE_C_FP: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_FP: - check_stack_size(sc); - sc->args = list_1(sc, sc->code); - sc->code = cdr(sc->code); - collect_fp_args(sc, OP_SAFE_C_FP_1, sc->args); - goto EVAL; + case OP_SAFE_C_FP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_FP: op_safe_c_fp(sc); goto EVAL; case OP_SAFE_C_FP_1: /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is the next arg if any */ if (collect_fp_args(sc, OP_SAFE_C_FP_1, cons(sc, sc->value, sc->args))) goto EVAL; sc->args = safe_reverse_in_place(sc, sc->args); sc->value = c_call(car(sc->args))(sc, cdr(sc->args)); - goto START; + continue; - case OP_SAFE_C_FP_MV_1: - if (collect_fp_args(sc, OP_SAFE_C_FP_MV_1, (is_multiple_value(sc->value)) ? s7_append(sc, s7_reverse(sc, sc->value), sc->args) : cons(sc, sc->value, sc->args))) - goto EVAL; - sc->args = safe_reverse_in_place(sc, sc->args); - sc->code = c_function_base(opt1_cfunc(car(sc->args))); - sc->args = cdr(sc->args); - goto APPLY; + case OP_SAFE_C_FP_2: + sc->args = safe_reverse_in_place(sc, sc->args = cons(sc, sc->value, sc->args)); + sc->value = c_call(car(sc->args))(sc, cdr(sc->args)); + continue; + case OP_SAFE_C_FP_MV_1: if (op_safe_c_fp_mv_1(sc)) goto EVAL; goto APPLY; case OP_SAFE_C_SSP: if (!c_function_is_ok(sc, sc->code)) break; case HOP_SAFE_C_SSP: op_safe_c_ssp(sc); goto EVAL; - case OP_SAFE_C_SSP_1: op_safe_c_ssp_1(sc); goto START; + case OP_SAFE_C_SSP_1: op_safe_c_ssp_1(sc); continue; case OP_SAFE_C_SSP_MV_1: op_safe_c_ssp_mv_1(sc); goto APPLY; - case OP_SAFE_C_A: if (!c_function_is_ok(sc, sc->code)) { - if (op_unknown_a(sc, lookup_checked(sc, car(sc->code))) == goto_EVAL) /* for lt?? */ + if (op_unknown_a(sc, lookup_checked(sc, car(sc->code))) == goto_eval) /* for lt?? (matters at least in lt: 12!) */ { if (op_no_hop(sc->code) == OP_SAFE_C_A) { set_car(sc->t1_1, c_call(cdr(sc->code))(sc, cadr(sc->code))); sc->value = c_call(sc->code)(sc, sc->t1_1); - goto START; + continue; } } else set_optimize_op(sc->code, OP_S_A); goto EVAL; } - case HOP_SAFE_C_A: sc->value = fx_c_a(sc, sc->code); goto START; + case HOP_SAFE_C_A: sc->value = fx_c_a(sc, sc->code); continue; case OP_SAFE_C_opAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAq: sc->value = fx_c_opaq(sc, sc->code); goto START; + case HOP_SAFE_C_opAq: sc->value = fx_c_opaq(sc, sc->code); continue; case OP_SAFE_C_opAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAAq: sc->value = fx_c_opaaq(sc, sc->code); goto START; + case HOP_SAFE_C_opAAq: sc->value = fx_c_opaaq(sc, sc->code); continue; case OP_SAFE_C_opAAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAAAq: sc->value = fx_c_opaaaq(sc, sc->code); goto START; + case HOP_SAFE_C_opAAAq: sc->value = fx_c_opaaaq(sc, sc->code); continue; case OP_SAFE_C_S_opAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_opAq: sc->value = fx_c_s_opaq(sc, sc->code); goto START; + case HOP_SAFE_C_S_opAq: sc->value = fx_c_s_opaq(sc, sc->code); continue; case OP_SAFE_C_opAq_S: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAq_S: sc->value = fx_c_opaq_s(sc, sc->code); goto START; + case HOP_SAFE_C_opAq_S: sc->value = fx_c_opaq_s(sc, sc->code); continue; case OP_SAFE_C_S_opAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_opAAq: sc->value = fx_c_s_opaaq(sc, sc->code); goto START; + case HOP_SAFE_C_S_opAAq: sc->value = fx_c_s_opaaq(sc, sc->code); continue; 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); goto START; + 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 HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); goto START; + case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue; case OP_SAFE_C_AAA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AAA: sc->value = fx_c_aaa(sc, sc->code); goto START; + case HOP_SAFE_C_AAA: sc->value = fx_c_aaa(sc, sc->code); continue; case OP_SAFE_C_SSA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSA: sc->value = fx_c_ssa(sc, sc->code); goto START; + case HOP_SAFE_C_SSA: sc->value = fx_c_ssa(sc, sc->code); continue; + case OP_SSA_DIRECT: sc->value = fx_c_ssa_direct(sc, sc->code); continue; case OP_SAFE_C_SAS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SAS: sc->value = fx_c_sas(sc, sc->code); goto START; + case HOP_SAFE_C_SAS: sc->value = fx_c_sas(sc, sc->code); continue; case OP_SAFE_C_CAC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CAC: sc->value = fx_c_cac(sc, sc->code); goto START; + case HOP_SAFE_C_CAC: sc->value = fx_c_cac(sc, sc->code); continue; case OP_SAFE_C_CSA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSA: sc->value = fx_c_csa(sc, sc->code); goto START; + case HOP_SAFE_C_CSA: sc->value = fx_c_csa(sc, sc->code); continue; case OP_SAFE_C_SCA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCA: sc->value = fx_c_sca(sc, sc->code); goto START; + case HOP_SAFE_C_SCA: sc->value = fx_c_sca(sc, sc->code); continue; case OP_SAFE_C_SSSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSSC: sc->value = fx_c_sssc(sc, sc->code); goto START; + case HOP_SAFE_C_SSSC: sc->value = fx_c_sssc(sc, sc->code); continue; case OP_SAFE_C_4A: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_4A: sc->value = fx_c_4a(sc, sc->code); goto START; + case HOP_SAFE_C_4A: sc->value = fx_c_4a(sc, sc->code); continue; case OP_SAFE_C_FX: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_FX: sc->value = fx_c_fx(sc, sc->code); goto START; + case HOP_SAFE_C_FX: sc->value = fx_c_fx(sc, sc->code); continue; case OP_SAFE_C_ALL_CA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_ALL_CA: sc->value = fx_c_all_ca(sc, sc->code); goto START; + case HOP_SAFE_C_ALL_CA: sc->value = fx_c_all_ca(sc, sc->code); continue; case OP_SAFE_C_SCS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCS: sc->value = fx_c_scs(sc, sc->code); goto START; + case HOP_SAFE_C_SCS: sc->value = fx_c_scs(sc, sc->code); continue; case OP_SAFE_C_SSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSC: sc->value = fx_c_ssc(sc, sc->code); goto START; + case HOP_SAFE_C_SSC: sc->value = fx_c_ssc(sc, sc->code); continue; case OP_SAFE_C_SCC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCC: sc->value = fx_c_scc(sc, sc->code); goto START; + case HOP_SAFE_C_SCC: sc->value = fx_c_scc(sc, sc->code); continue; case OP_SAFE_C_CSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSC: sc->value = fx_c_csc(sc, sc->code); goto START; + case HOP_SAFE_C_CSC: sc->value = fx_c_csc(sc, sc->code); continue; case OP_SAFE_C_CSS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSS: op_safe_c_css(sc); goto START; + case HOP_SAFE_C_CSS: sc->value = fx_c_css(sc, sc->code); continue; case OP_SAFE_C_SSS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSS: sc->value = fx_c_sss(sc, sc->code); goto START; + case HOP_SAFE_C_SSS: sc->value = fx_c_sss(sc, sc->code); continue; + case OP_SAFE_C_TUS: sc->value = fx_c_tus(sc, sc->code); continue; case OP_SAFE_C_opDq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opDq: sc->value = fx_c_opdq(sc, sc->code); goto START; + case HOP_SAFE_C_opDq: sc->value = fx_c_opdq(sc, sc->code); continue; case OP_SAFE_C_opSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq: op_safe_c_opsq(sc); goto START; + case HOP_SAFE_C_opSq: sc->value = fx_c_opsq(sc, sc->code); continue; case OP_SAFE_C_op_opSq_q: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSq_q: sc->value = fx_c_op_opsq_q(sc, sc->code); goto START; + case HOP_SAFE_C_op_opSq_q: sc->value = fx_c_op_opsq_q(sc, sc->code); continue; case OP_SAFE_C_op_S_opSq_q: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, caddr(cadr(sc->code))))) break; - case HOP_SAFE_C_op_S_opSq_q: sc->value = fx_c_op_s_opsq_q(sc, sc->code); goto START; + case HOP_SAFE_C_op_S_opSq_q: sc->value = fx_c_op_s_opsq_q(sc, sc->code); continue; case OP_SAFE_C_op_opSq_S_q: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSq_S_q: sc->value = fx_c_op_opsq_s_q(sc, sc->code); goto START; + case HOP_SAFE_C_op_opSq_S_q: sc->value = fx_c_op_opsq_s_q(sc, sc->code); continue; case OP_SAFE_C_PS: if (!c_function_is_ok(sc, sc->code)) break; @@ -85522,34 +87632,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) */ set_car(sc->t2_1, sc->value); sc->value = c_call(sc->code)(sc, sc->t2_1); - goto START; - - case OP_SAFE_C_PS_MV: /* (define (hi a) (+ (values 1 2) a)) */ - sc->args = s7_append(sc, sc->value, set_plist_1(sc, lookup(sc, caddr(sc->code)))); - sc->code = c_function_base(opt1_cfunc(sc->code)); - goto APPLY; - - - case OP_SAFE_C_PC: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PC: - /* if (optimize_op(cadr(sc->code)) == HOP_SAFE_CLOSURE_S_A) fprintf(stderr, "%s\n", DISPLAY_80(sc->code)); */ - check_stack_size(sc); - push_stack(sc, OP_SAFE_C_PC_1, opt2_con(cdr(sc->code)), sc->code); - sc->code = cadr(sc->code); - goto EVAL; - - case OP_SAFE_C_PC_1: - set_car(sc->t2_1, sc->value); - set_car(sc->t2_2, sc->args); - sc->value = c_call(sc->code)(sc, sc->t2_1); - goto START; + continue; - case OP_SAFE_C_PC_MV: - sc->args = s7_append(sc, sc->value, set_plist_1(sc, sc->args)); - sc->code = c_function_base(opt1_cfunc(sc->code)); - goto APPLY; + case OP_SAFE_C_PS_MV: op_safe_c_ps_mv(sc); goto APPLY; + case OP_SAFE_C_PC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_PC: op_safe_c_pc(sc); goto EVAL; + case OP_SAFE_C_PC_1: op_safe_c_pc_1(sc); continue; + case OP_SAFE_C_PC_MV: op_safe_c_pc_mv(sc); goto APPLY; case OP_SAFE_C_SP: if (!c_function_is_ok(sc, sc->code)) break; @@ -85563,11 +87653,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) set_car(sc->t2_1, sc->args); set_car(sc->t2_2, sc->value); sc->value = c_call(sc->code)(sc, sc->t2_1); - goto START; + continue; - case OP_SAFE_CONS_SP_1: - sc->value = cons(sc, sc->args, sc->value); - goto START; + case OP_SAFE_CONS_SP_1: sc->value = cons(sc, sc->args, sc->value); continue; #if (!WITH_GMP) case OP_SAFE_ADD_SP_1: @@ -85583,17 +87671,17 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->value = make_integer(sc, integer(sc->args) + integer(sc->value)); #endif else sc->value = add_p_pp(sc, sc->args, sc->value); - goto START; + continue; case OP_SAFE_SUBTRACT_SP_1: sc->value = subtract_p_pp(sc, sc->args, sc->value); - goto START; + continue; case OP_SAFE_MULTIPLY_SP_1: if ((is_t_real(sc->args)) && (is_t_real(sc->value))) sc->value = make_real(sc, real(sc->args) * real(sc->value)); else sc->value = multiply_p_pp(sc, sc->args, sc->value); - goto START; + continue; #endif case OP_SAFE_MEMQ_SP_1: @@ -85605,56 +87693,20 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->value = sc->F; else sc->value = method_or_bust_with_type(sc, sc->value, sc->memq_symbol, list_2(sc, sc->args, sc->value), a_list_string, 2); } - goto START; - - case OP_SAFE_C_SP_MV: - sc->args = cons(sc, sc->args, sc->value); /* don't use u2_1 or some permanent list here: immutable=copied later */ - sc->code = c_function_base(opt1_cfunc(sc->code)); - goto APPLY; - - - case OP_SAFE_C_AP: - if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code)))) break; - case HOP_SAFE_C_AP: - op_safe_c_ap(sc); - goto EVAL; + continue; - case OP_SAFE_C_PA: - if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code)))) break; - case HOP_SAFE_C_PA: - check_stack_size(sc); - push_stack(sc, OP_SAFE_C_PA_1, sc->nil, sc->code); - sc->code = cadr(sc->code); - goto EVAL; + case OP_SAFE_C_SP_MV: op_safe_c_sp_mv(sc); goto APPLY; - case OP_SAFE_C_PA_1: - { - s7_pointer val, code; - code = sc->code; - val = sc->value; - set_car(sc->t2_2, fx_call(sc, cddr(code))); - set_car(sc->t2_1, val); - sc->value = c_call(code)(sc, sc->t2_1); - goto START; - } + case OP_SAFE_C_AP: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code)))) break; + case HOP_SAFE_C_AP: op_safe_c_ap(sc); goto EVAL; - case OP_SAFE_C_PA_MV: - op_safe_c_pa_mv(sc); - goto APPLY; + case OP_SAFE_C_PA: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code)))) break; + case HOP_SAFE_C_PA: op_safe_c_pa(sc); goto EVAL; + case OP_SAFE_C_PA_1: op_safe_c_pa_1(sc); continue; + case OP_SAFE_C_PA_MV: op_safe_c_pa_mv(sc); goto APPLY; - case OP_SAFE_C_CP: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CP: - /* it's possible in a case like this to overflow the stack -- s7test has a deeply - * nested expression involving (+ c (+ c (+ ... ))) all opt'd as safe_c_cz -- if we're close - * to the stack end at the start, it runs off the end. Normally the stack increase in - * the reader protects us, but a call/cc can replace the original stack with a much smaller one. - * How to minimize the cost of this check? - */ - check_stack_size(sc); - push_stack(sc, (opcode_t)opt1_any(cdr(sc->code)), opt3_any(cdr(sc->code)), sc->code); - sc->code = caddr(sc->code); - goto EVAL; + case OP_SAFE_C_CP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CP: op_safe_c_cp(sc); goto EVAL; case OP_SAFE_C_PP: if (!c_function_is_ok(sc, sc->code)) break; @@ -85664,184 +87716,131 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->code = cadr(sc->code); goto EVAL; - case OP_SAFE_C_PP_1: - /* unless multiple values from last call (first arg) we get here only from OP_SAFE_C_PP. - * splice_in_values changes the operator so if we get here, sc->value is the result of the first arg - * safe_c_pp -> 1, but if mv, -> 3 - * 1: -> 2, if mv -> 4 - * 2: done (both normal) - * 3: -> 5, but if mv, -> 6 - * 4: done (1 normal, 2 mv) - * 5: done (1 mv, 2 normal) - * 6: done (both mv) - * I think safe_c_ppp would require 18 branches (or maybe just collect the args and concatenate at the end?) - */ - push_stack(sc, (opcode_t)opt1_any(cdr(sc->code)), sc->value, sc->code); /* mv -> 3, opt1 is OP_SAFE_CONS_SP_1 et al which assume no mv */ - sc->code = caddr(sc->code); - goto EVAL; - - case OP_SAFE_C_PP_3_MV: /* we get here if the first arg returned multiple values */ - push_stack(sc, OP_SAFE_C_PP_5, copy_list(sc, sc->value), sc->code); /* copy is needed here */ - sc->code = caddr(sc->code); - goto EVAL; - - case OP_SAFE_C_PP_5: - /* 1 mv, 2, normal */ - sc->args = s7_append(sc, sc->args, list_1(sc, sc->value)); - sc->code = c_function_base(opt1_cfunc(sc->code)); - goto APPLY; - - case OP_SAFE_C_PP_6_MV: /* both mv */ - sc->args = s7_append(sc, sc->args, sc->value); - /* - * c_callee(sc->code) here is g_add_2, but we have any number of args from a values call - * the original (unoptimized) function is (hopefully) c_function_base(opt1_cfunc(sc->code))? - * (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (ho 2))) (hi)) -> 7 - * (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) (hi)) -> 10 - * (let () (define (ho a) (+ a 2)) (define (hi) (+ (values 3 4) (ho 1))) (hi)) -> 10 - * (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10 - */ - sc->code = c_function_base(opt1_cfunc(sc->code)); - goto APPLY; + case OP_SAFE_C_PP_1: op_safe_c_pp_1(sc); goto EVAL; + case OP_SAFE_C_PP_3_MV: op_safe_c_pp_3_mv(sc); goto EVAL; + case OP_SAFE_C_PP_5: op_safe_c_pp_5(sc); goto APPLY; + case OP_SAFE_C_PP_6_MV: op_safe_c_pp_6_mv(sc); goto APPLY; case OP_SAFE_C_opSSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq: sc->value = fx_c_opssq(sc, sc->code); goto START; + case HOP_SAFE_C_opSSq: sc->value = fx_c_opssq(sc, sc->code); continue; case OP_SAFE_C_opSCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSCq: sc->value = fx_c_opscq(sc, sc->code); goto START; + case HOP_SAFE_C_opSCq: sc->value = fx_c_opscq(sc, sc->code); continue; case OP_SAFE_C_opCSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq: sc->value = fx_c_opcsq(sc, sc->code); goto START; + case HOP_SAFE_C_opCSq: sc->value = fx_c_opcsq(sc, sc->code); continue; case OP_SAFE_C_S_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSq: sc->value = fx_c_s_opsq(sc, sc->code); goto START; + case HOP_SAFE_C_S_opSq: sc->value = fx_c_s_opsq(sc, sc->code); continue; case OP_SAFE_C_S_opDq: if (!c_function_is_ok_caddr(sc, sc->code))break; - case HOP_SAFE_C_S_opDq: sc->value = fx_c_s_opdq(sc, sc->code); goto START; + case HOP_SAFE_C_S_opDq: sc->value = fx_c_s_opdq(sc, sc->code); continue; case OP_SAFE_C_C_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSq: sc->value = fx_c_c_opsq(sc, sc->code); goto START; + case HOP_SAFE_C_C_opSq: sc->value = fx_c_c_opsq(sc, sc->code); continue; case OP_SAFE_C_C_opDq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opDq: sc->value = fx_c_c_opdq(sc, sc->code); goto START; + case HOP_SAFE_C_C_opDq: sc->value = fx_c_c_opdq(sc, sc->code); continue; case OP_SAFE_C_C_opCSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opCSq: sc->value = fx_c_c_opcsq(sc, sc->code); goto START; + case HOP_SAFE_C_C_opCSq: sc->value = fx_c_c_opcsq(sc, sc->code); continue; case OP_SAFE_C_C_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSSq: sc->value = fx_c_c_opssq(sc, sc->code); goto START; + case HOP_SAFE_C_C_opSSq: sc->value = fx_c_c_opssq(sc, sc->code); continue; case OP_SAFE_C_opCSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq_C: sc->value = fx_c_opcsq_c(sc, sc->code); goto START; + case HOP_SAFE_C_opCSq_C: sc->value = fx_c_opcsq_c(sc, sc->code); continue; case OP_SAFE_C_opSSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_C: sc->value = fx_c_opssq_c(sc, sc->code); goto START; + case HOP_SAFE_C_opSSq_C: sc->value = fx_c_opssq_c(sc, sc->code); continue; case OP_SAFE_C_opSSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_S: sc->value = fx_c_opssq_s(sc, sc->code); goto START; + case HOP_SAFE_C_opSSq_S: sc->value = fx_c_opssq_s(sc, sc->code); continue; case OP_SAFE_C_op_opSSq_q_C: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSSq_q_C: sc->value = fx_c_op_opssq_q_c(sc, sc->code); goto START; + case HOP_SAFE_C_op_opSSq_q_C: sc->value = fx_c_op_opssq_q_c(sc, sc->code); continue; case OP_SAFE_C_op_opSSq_q_S: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSSq_q_S: sc->value = fx_c_op_opssq_q_s(sc, sc->code); goto START; + case HOP_SAFE_C_op_opSSq_q_S: sc->value = fx_c_op_opssq_q_s(sc, sc->code); continue; case OP_SAFE_C_op_opSSq_Sq_S: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSSq_Sq_S: sc->value = fx_c_op_opssq_sq_s(sc, sc->code); goto START; + case HOP_SAFE_C_op_opSSq_Sq_S: sc->value = fx_c_op_opssq_sq_s(sc, sc->code); continue; case OP_SAFE_C_op_opSq_q_C: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, cadadr(sc->code)))) break; - case HOP_SAFE_C_op_opSq_q_C: sc->value = fx_c_op_opsq_q_c(sc, sc->code); goto START; + case HOP_SAFE_C_op_opSq_q_C: sc->value = fx_c_op_opsq_q_c(sc, sc->code); continue; case OP_SAFE_C_S_op_opSq_Cq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, cadr(caddr(sc->code))))) break; - case HOP_SAFE_C_S_op_opSq_Cq: sc->value = fx_c_s_op_opsq_cq(sc, sc->code); goto START; + case HOP_SAFE_C_S_op_opSq_Cq: sc->value = fx_c_s_op_opsq_cq(sc, sc->code); continue; case OP_SAFE_C_S_op_S_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, caddr(caddr(sc->code))))) break; - case HOP_SAFE_C_S_op_S_opSqq: sc->value = fx_c_s_op_s_opsqq(sc, sc->code); goto START; + case HOP_SAFE_C_S_op_S_opSqq: sc->value = fx_c_s_op_s_opsqq(sc, sc->code); continue; case OP_SAFE_C_S_op_S_opSSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, caddr(sc->code))) || (!c_function_is_ok(sc, caddr(caddr(sc->code))))) break; - case HOP_SAFE_C_S_op_S_opSSqq: sc->value = fx_c_s_op_s_opssqq(sc, sc->code); goto START; + case HOP_SAFE_C_S_op_S_opSSqq: sc->value = fx_c_s_op_s_opssqq(sc, sc->code); continue; case OP_SAFE_C_S_op_opSSq_opSSqq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_op_opSSq_opSSqq: sc->value = fx_c_s_op_opssq_opssqq(sc, sc->code); goto START; + case HOP_SAFE_C_S_op_opSSq_opSSqq: sc->value = fx_c_s_op_opssq_opssqq(sc, sc->code); continue; case OP_SAFE_C_opSCq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSCq_C: sc->value = fx_c_opscq_c(sc, sc->code); goto START; + case HOP_SAFE_C_opSCq_C: sc->value = fx_c_opscq_c(sc, sc->code); continue; case OP_SAFE_C_opCSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq_S: sc->value = fx_c_opcsq_s(sc, sc->code); goto START; + case HOP_SAFE_C_opCSq_S: sc->value = fx_c_opcsq_s(sc, sc->code); continue; case OP_SAFE_C_S_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSCq: sc->value = fx_c_s_opscq(sc, sc->code); goto START; + case HOP_SAFE_C_S_opSCq: sc->value = fx_c_s_opscq(sc, sc->code); continue; case OP_SAFE_C_C_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSCq: sc->value = fx_c_c_opscq(sc, sc->code); goto START; + case HOP_SAFE_C_C_opSCq: sc->value = fx_c_c_opscq(sc, sc->code); continue; case OP_SAFE_C_S_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSSq: sc->value = fx_c_s_opssq(sc, sc->code); goto START; + case HOP_SAFE_C_S_opSSq: sc->value = fx_c_s_opssq(sc, sc->code); continue; case OP_SAFE_C_S_opCSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opCSq: sc->value = fx_c_s_opcsq(sc, sc->code); goto START; + case HOP_SAFE_C_S_opCSq: sc->value = fx_c_s_opcsq(sc, sc->code); continue; case OP_SAFE_C_opSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_S: sc->value = fx_c_opsq_s(sc, sc->code); goto START; + case HOP_SAFE_C_opSq_S: sc->value = fx_c_opsq_s(sc, sc->code); continue; case OP_SAFE_C_opSq_P: if (!c_function_is_ok_cadr(sc, sc->code)) break; case HOP_SAFE_C_opSq_P: op_safe_c_opsq_p(sc); goto EVAL; case OP_SAFE_C_opSq_CS: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_CS: sc->value = fx_c_opsq_cs(sc, sc->code); goto START; + case HOP_SAFE_C_opSq_CS: sc->value = fx_c_opsq_cs(sc, sc->code); continue; case OP_SAFE_C_opDq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opDq_S: sc->value = fx_c_opdq_s(sc, sc->code); goto START; + case HOP_SAFE_C_opDq_S: sc->value = fx_c_opdq_s(sc, sc->code); continue; case OP_SAFE_C_opDq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opDq_C: sc->value = fx_c_opdq_c(sc, sc->code); goto START; + case HOP_SAFE_C_opDq_C: sc->value = fx_c_opdq_c(sc, sc->code); continue; case OP_SAFE_C_opSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_C: sc->value = fx_c_opsq_c(sc, sc->code); goto START; + case HOP_SAFE_C_opSq_C: sc->value = fx_c_opsq_c(sc, sc->code); continue; case OP_SAFE_C_opSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_opSq: sc->value = fx_c_opsq_opsq(sc, sc->code); goto START; + case HOP_SAFE_C_opSq_opSq: sc->value = fx_c_opsq_opsq(sc, sc->code); continue; case OP_SAFE_C_opDq_opDq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opDq_opDq: sc->value = fx_c_opdq_opdq(sc, sc->code); goto START; + case HOP_SAFE_C_opDq_opDq: sc->value = fx_c_opdq_opdq(sc, sc->code); continue; case OP_SAFE_C_opSSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_opSSq: sc->value = fx_c_opssq_opssq(sc, sc->code); goto START; + case HOP_SAFE_C_opSSq_opSSq: sc->value = fx_c_opssq_opssq(sc, sc->code); continue; case OP_SAFE_C_opSSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_opSq: sc->value = fx_c_opssq_opsq(sc, sc->code); goto START; + case HOP_SAFE_C_opSSq_opSq: sc->value = fx_c_opssq_opsq(sc, sc->code); continue; case OP_SAFE_C_opSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_opSSq: sc->value = fx_c_opsq_opssq(sc, sc->code); goto START; - - case OP_SAFE_IFA_SS_A: /* ((if fx s s) fx) I think */ - case HOP_SAFE_IFA_SS_A: - { - s7_function f; - f = c_function_call((is_true(sc, fx_call(sc, cdar(sc->code)))) ? opt1_con(sc->code) : opt2_con(sc->code)); - sc->value = f(sc, set_plist_1(sc, fx_call(sc, cdr(sc->code)))); - goto START; - } + case HOP_SAFE_C_opSq_opSSq: sc->value = fx_c_opsq_opssq(sc, sc->code); continue; /* -------------------------------------------------------------------------------- */ - case OP_C_S: - if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_S); goto EVAL;} - case HOP_C_S: - op_c_s(sc); - goto START; - - case OP_READ_S: - if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_S); goto EVAL;} - case HOP_READ_S: - op_read_s(sc); - goto START; - - case OP_C_A: - if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} - case HOP_C_A: - op_c_a(sc); - goto START; + case OP_C_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_S); goto EVAL;} + case HOP_C_S: op_c_s(sc); continue; + + case OP_READ_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_S); goto EVAL;} + case HOP_READ_S: op_read_s(sc); continue; + + case OP_C_A: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} + case HOP_C_A: op_c_a(sc); continue; case OP_C_P: if (!c_function_is_ok(sc, sc->code)) break; @@ -85850,171 +87849,63 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->code = T_Pair(cadr(sc->code)); goto EVAL; - case OP_C_P_1: - sc->value = c_call(sc->code)(sc, list_1(sc, sc->value)); - goto START; - - case OP_C_P_MV: - /* op_c_p_1 -> mv case: (define (hi) (format (values #f "~A ~D" 1 2))) */ - sc->code = c_function_base(opt1_cfunc(sc->code)); /* see comment above */ - sc->args = copy_list(sc, sc->value); - goto APPLY; + case OP_C_P_1: sc->value = c_call(sc->code)(sc, list_1(sc, sc->value)); continue; + case OP_C_P_MV: op_c_p_mv(sc); goto APPLY; case OP_C_SS: if (!c_function_is_ok(sc, sc->code)) break; case HOP_C_SS: sc->args = list_2(sc, lookup(sc, cadr(sc->code)), lookup(sc, caddr(sc->code))); sc->value = c_call(sc->code)(sc, sc->args); - goto START; - - case OP_C_AP: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_AP: - { - s7_pointer val; - val = fx_call(sc, cdr(sc->code)); - push_stack(sc, OP_C_AP_1, val, sc->code); /* op_c_ap_1 sends us to apply which calls check_stack_size I think */ - sc->code = caddr(sc->code); - goto EVAL; - } - - case OP_C_AP_1: /* goes to c_ap_mv if multiple values */ - sc->value = c_call(sc->code)(sc, sc->args = list_2(sc, sc->args, sc->value)); - goto START; - - case OP_C_AP_MV: - clear_multiple_value(sc->value); - sc->args = cons(sc, sc->args, sc->value); - sc->code = c_function_base(opt1_cfunc(sc->code)); - goto APPLY; - - case OP_C_FA: /* op_c_fs was not faster if fx_s below */ - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_FA: - { - s7_pointer f, code; - code = sc->code; - sc->code = cdadr(code); - make_closure_with_let(sc, f, car(sc->code), cdr(sc->code), sc->envir, CLOSURE_ARITY_NOT_SET); - sc->w = f; /* f=new closure cell, car=args, cdr=body, can't use sc->value here because c_call below may clobber it */ - sc->args = list_2(sc, f, fx_call(sc, cddr(code))); - sc->value = c_call(code)(sc, sc->args); - goto START; - } - - case OP_C_FA_1: /* here only if for-each or map */ - { - s7_pointer f, code; - code = sc->code; - f = cddr(code); - sc->value = fx_call(sc, f); - if (is_null(sc->value)) - { - if (c_callee(code)) - sc->value = sc->unspecified; - goto START; - } - sc->code = opt3_pair(code); /* cdadr(code); */ - make_closure_with_let(sc, f, car(sc->code), cdr(sc->code), sc->envir, 1); - if (c_callee(code)) - sc->value = g_for_each_closure(sc, f, sc->value); - else sc->value = g_map_closure(sc, f, sc->value); - goto START; - } + continue; - case OP_C_AA: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_AA: - op_c_aa(sc); - goto START; + case OP_C_AP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_AP: op_c_ap(sc); goto EVAL; + case OP_C_AP_1: sc->value = c_call(sc->code)(sc, sc->args = list_2(sc, sc->args, sc->value)); continue; + case OP_C_AP_MV: op_c_ap_mv(sc); goto APPLY; - case OP_APPLY_SS: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_APPLY_SS: - sc->args = lookup(sc, opt2_sym(sc->code)); /* is this right if code=macro? */ - sc->code = lookup(sc, cadr(sc->code)); /* global search here was slower */ - if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ - apply_list_error(sc, sc->args); - if (needs_copied_args(sc->code)) - sc->args = copy_list(sc, sc->args); - goto APPLY; + case OP_C_FA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_FA: op_c_fa(sc); continue; /* op_c_fs was not faster if fx_s below */ + case OP_C_FA_1: op_c_fa_1(sc); continue; /* here only if for-each or map */ - case OP_APPLY_SA: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_APPLY_SA: - { - s7_pointer p; - p = cdr(sc->code); - sc->args = fx_call(sc, cdr(p)); - sc->code = lookup(sc, car(p)); - if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ - apply_list_error(sc, sc->args); - if (needs_copied_args(sc->code)) - sc->args = copy_list(sc, sc->args); - goto APPLY; - } - - case OP_APPLY_SL: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_APPLY_SL: - { - s7_pointer p; - p = cdr(sc->code); - sc->args = fx_call(sc, cdr(p)); - sc->code = lookup(sc, car(p)); - goto APPLY; - } + case OP_C_AA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_AA: op_c_aa(sc); continue; case OP_C_S_opSq: if ((!c_function_is_ok(sc, sc->code)) || (!indirect_c_function_is_ok(sc, caddr(sc->code)))) break; - case HOP_C_S_opSq: sc->value = op_c_s_opsq(sc); goto START; + case HOP_C_S_opSq: sc->value = op_c_s_opsq(sc); continue; case OP_C_S_opDq: if ((!c_function_is_ok(sc, sc->code)) || (!indirect_c_function_is_ok(sc, caddr(sc->code)))) break; - case HOP_C_S_opDq: sc->value = op_c_s_opdq(sc); goto START; + case HOP_C_S_opDq: sc->value = op_c_s_opdq(sc); continue; case OP_C_SCS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_SCS: sc->value = op_c_scs(sc); goto START; + case HOP_C_SCS: sc->value = op_c_scs(sc); continue; case OP_C_FX: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_FX: op_c_fx(sc); goto START; + case HOP_C_FX: op_c_fx(sc); continue; - case OP_CALL_WITH_EXIT: - if (!c_function_is_ok(sc, sc->code)) break; - check_lambda_args(sc, cadadr(sc->code), NULL); - case HOP_CALL_WITH_EXIT: - op_call_with_exit(sc); - goto BEGIN; + case OP_SAFE_IFA_SS_A: op_safe_ifa_ss_a(sc); continue; - case OP_CALL_WITH_EXIT_P: - if (!c_function_is_ok(sc, sc->code)) break; - check_lambda_args(sc, cadadr(sc->code), NULL); - case HOP_CALL_WITH_EXIT_P: - op_call_with_exit_p(sc); - goto EVAL; + case OP_APPLY_SS: op_apply_ss(sc); goto APPLY; + case OP_APPLY_SA: op_apply_sa(sc); goto APPLY; + case OP_APPLY_SL: op_apply_sl(sc); goto APPLY; - case OP_C_CATCH: - if (!c_function_is_ok(sc, sc->code)) break; - check_lambda_args(sc, cadr(cadddr(sc->code)), NULL); - case HOP_C_CATCH: - op_c_catch(sc); - goto BEGIN; + case OP_CALL_WITH_EXIT: if (!c_function_is_ok(sc, sc->code)) break; check_lambda_args(sc, cadadr(sc->code), NULL); + case HOP_CALL_WITH_EXIT: op_call_with_exit(sc); goto BEGIN; - case OP_C_CATCH_ALL: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_CATCH_ALL: /* (catch #t (lambda () ...) (lambda args #f) */ - op_c_catch_all(sc); - goto BEGIN; + case OP_CALL_WITH_EXIT_P: if (!c_function_is_ok(sc, sc->code)) break; check_lambda_args(sc, cadadr(sc->code), NULL); + case HOP_CALL_WITH_EXIT_P: op_call_with_exit_p(sc); goto EVAL; - case OP_C_CATCH_ALL_P: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_CATCH_ALL_P: - op_c_catch_all_p(sc); - goto EVAL; + case OP_C_CATCH: if (!c_function_is_ok(sc, sc->code)) break; check_lambda_args(sc, cadr(cadddr(sc->code)), NULL); + case HOP_C_CATCH: op_c_catch(sc); goto BEGIN; - case OP_C_CATCH_ALL_FX: - if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_CATCH_ALL_FX: - op_c_catch_all_fx(sc); - goto START; + case OP_C_CATCH_ALL: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_CATCH_ALL: op_c_catch_all(sc); goto BEGIN; + + case OP_C_CATCH_ALL_P: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_CATCH_ALL_P: op_c_catch_all_p(sc); goto EVAL; + + case OP_C_CATCH_ALL_FX: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_CATCH_ALL_FX: op_c_catch_all_fx(sc); continue; /* -------------------------------------------------------------------------------- */ /* unknown* fallback on these */ @@ -86026,78 +87917,43 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) goto APPLY; case OP_S_C: op_s_c(sc); goto APPLY; - case OP_S_S: if (op_s_s(sc)) goto START; goto APPLY; + case OP_S_S: if (op_s_s(sc)) continue; goto APPLY; case OP_S_A: op_s_a(sc); goto APPLY; case OP_S_AA: op_s_aa(sc); goto APPLY; case OP_SAFE_C_STAR: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR: - sc->code = opt1_cfunc(sc->code); - apply_c_function_star_fill_defaults(sc, 0); - goto START; + case HOP_SAFE_C_STAR: op_safe_c_star(sc); continue; case OP_SAFE_C_STAR_A: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_A: - sc->args = list_1(sc, fx_call(sc, cdr(sc->code))); - sc->code = opt1_cfunc(sc->code); - /* one arg, so it's not a keyword; all we need to do is fill in defaults */ - apply_c_function_star_fill_defaults(sc, 1); - goto START; + case HOP_SAFE_C_STAR_A: op_safe_c_star_a(sc); continue; case OP_SAFE_C_STAR_AA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_AA: - op_safe_c_star_aa(sc); - goto START; + case HOP_SAFE_C_STAR_AA: op_safe_c_star_aa(sc); continue; case OP_SAFE_C_STAR_FX: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_FX: - op_safe_c_star_fx(sc); - goto START; + case HOP_SAFE_C_STAR_FX: op_safe_c_star_fx(sc); continue; /* -------------------------------------------------------------------------------- */ - case OP_THUNK: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 0)) {if (op_unknown(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_THUNK: - check_stack_size(sc); - /* this recursion check is consistent with the other unsafe closure calls, but we're probably in big trouble: - * (letrec ((a (lambda () (cons 1 (b)))) (b (lambda () (a)))) (b)) - */ - sc->code = opt1_lambda(sc->code); - new_frame(sc, closure_let(sc->code), sc->envir); - closure_push_and_goto_eval(sc); + case OP_THUNK: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_THUNK: op_thunk(sc); goto EVAL; - case OP_THUNK_P: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 0)) {if (op_unknown(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_THUNK_P: - sc->code = opt1_lambda(sc->code); - new_frame(sc, closure_let(sc->code), sc->envir); - closure_goto_eval(sc); + case OP_THUNK_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_THUNK_P: op_thunk_p(sc); goto EVAL; - case OP_SAFE_THUNK: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_M, 0)) {if (op_unknown(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_THUNK: /* no frame needed */ - sc->code = opt1_lambda(sc->code); - sc->envir = closure_let(sc->code); - closure_push_and_goto_eval(sc); + case OP_SAFE_THUNK: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_THUNK: op_safe_thunk(sc); goto EVAL; - case OP_SAFE_THUNK_A: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_A, 0)) {if (op_unknown(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_THUNK_A: - sc->code = opt1_lambda(sc->code); - sc->envir = closure_let(sc->code); - sc->value = fx_call(sc, closure_body(sc->code)); - goto START; + case OP_THUNK_NIL: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break; + case HOP_THUNK_NIL: op_thunk_nil(sc); goto BEGIN; - case OP_SAFE_THUNK_P: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_P, 0)) {if (op_unknown(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_THUNK_P: - sc->code = opt1_lambda(sc->code); - sc->envir = closure_let(sc->code); - closure_goto_eval(sc); + case OP_SAFE_THUNK_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_THUNK_A: sc->value = fx_thunk_a(sc, sc->code); continue; + case OP_SAFE_THUNK_P: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_THUNK_P: op_safe_thunk_p(sc); goto EVAL; case OP_CLOSURE_S: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_S: sc->value = lookup(sc, opt2_sym(sc->code)); check_stack_size(sc); @@ -86106,7 +87962,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) closure_push_and_goto_eval(sc); case OP_CLOSURE_S_P: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_S_P: sc->value = lookup(sc, opt2_sym(sc->code)); check_stack_size(sc); @@ -86115,7 +87971,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) closure_goto_eval(sc); case OP_SAFE_CLOSURE_S: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_S: sc->value = lookup(sc, opt2_sym(sc->code)); sc->code = opt1_lambda(sc->code); @@ -86123,66 +87979,36 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) closure_push_and_goto_eval(sc); case OP_SAFE_CLOSURE_S_P: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_S_P: sc->value = lookup(sc, opt2_sym(sc->code)); sc->code = opt1_lambda(sc->code); sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); closure_goto_eval(sc); - case OP_SAFE_CLOSURE_S_A: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_A, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_S_A: - op_safe_closure_s_a(sc); - goto START; + case OP_SAFE_CLOSURE_S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_S_A: sc->value = fx_safe_closure_s_a(sc, sc->code); continue; + case OP_SAFE_CLOSURE_S_TO_S: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_S_TO_S: sc->value = fx_safe_closure_s_to_s(sc, sc->code); continue; - case OP_CLOSURE_C: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_CLOSURE_C: - check_stack_size(sc); - sc->value = cadr(sc->code); - sc->code = opt1_lambda(sc->code); - new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value); - closure_push_and_goto_eval(sc); + case OP_CLOSURE_C: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_CLOSURE_C: op_closure_c(sc); goto EVAL; - case OP_CLOSURE_C_P: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_CLOSURE_C_P: - sc->value = cadr(sc->code); - check_stack_size(sc); - sc->code = opt1_lambda(sc->code); - new_frame_with_slot(sc, closure_let(sc->code), sc->envir, car(closure_args(sc->code)), sc->value); - closure_goto_eval(sc); + case OP_CLOSURE_C_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_CLOSURE_C_P: op_closure_c_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_C: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_C: - sc->value = cadr(sc->code); - sc->code = opt1_lambda(sc->code); - sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); - closure_push_and_goto_eval(sc); - - case OP_SAFE_CLOSURE_C_P: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_C_P: - sc->value = cadr(sc->code); - sc->code = opt1_lambda(sc->code); - sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); - closure_goto_eval(sc); + case OP_SAFE_CLOSURE_C: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_C: op_safe_closure_c(sc); goto EVAL; - case OP_SAFE_CLOSURE_C_A: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_A, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_C_A: - sc->value = cadr(sc->code); - sc->code = opt1_lambda(sc->code); - sc->envir = old_frame_with_slot(sc, closure_let(sc->code), sc->value); - sc->value = fx_call(sc, closure_body(sc->code)); - goto START; + case OP_SAFE_CLOSURE_C_P: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_C_P: op_safe_closure_c_p(sc); goto EVAL; + case OP_SAFE_CLOSURE_C_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_C_A: op_safe_closure_c_a(sc); continue; case OP_CLOSURE_P: - if (!closure_is_fine(sc, sc->code, MATCH_UNSAFE_CLOSURE, 1)) break; + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break; case HOP_CLOSURE_P: push_stack(sc, OP_CLOSURE_P_1, sc->args, sc->code); sc->code = cadr(sc->code); @@ -86195,13 +88021,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->code = T_Pair(closure_body(sc->code)); goto BEGIN; - case OP_CLOSURE_P_MV: - sc->code = opt1_lambda(sc->code); - sc->args = copy_list(sc, sc->value); - goto APPLY; + case OP_CLOSURE_P_MV: op_closure_p_mv(sc); goto APPLY; case OP_SAFE_CLOSURE_P: - if (!closure_is_fine(sc, sc->code, MATCH_SAFE_CLOSURE, 1)) break; + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break; case HOP_SAFE_CLOSURE_P: push_stack(sc, OP_SAFE_CLOSURE_P_1, sc->args, sc->code); sc->code = cadr(sc->code); @@ -86212,141 +88035,138 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->code = T_Pair(closure_body(opt1_lambda(sc->code))); goto BEGIN; + case OP_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_CLOSURE_A: op_closure_a(sc); closure_push_and_goto_eval(sc); - case OP_CLOSURE_A: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_CLOSURE_A: - op_closure_a(sc); - closure_push_and_goto_eval(sc); - - case OP_CLOSURE_A_P: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_CLOSURE_A_P: - op_closure_a(sc); - closure_goto_eval(sc); - - case OP_CLOSURE_SUB_P: - if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_CLOSURE_SUB_P: - op_closure_sub_p(sc); - closure_goto_eval(sc); + case OP_CLOSURE_A_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_CLOSURE_A_P: op_closure_a(sc); closure_goto_eval(sc); - case OP_SAFE_CLOSURE_A: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_A: - op_safe_closure_a(sc); - goto EVAL; - - case OP_SAFE_CLOSURE_A_P: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_A_P: - op_safe_closure_a_p(sc); - goto EVAL; + case OP_SAFE_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_A: op_safe_closure_a(sc); goto EVAL; - case OP_SAFE_CLOSURE_A_A: - if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_A, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_A_A: - op_safe_closure_a_a(sc); - goto START; + case OP_SAFE_CLOSURE_A_P: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_A_P: op_safe_closure_a_p(sc); goto EVAL; + case OP_SAFE_CLOSURE_A_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_A_A: sc->value = fx_safe_closure_a_a(sc, sc->code); continue; - case OP_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, MATCH_UNSAFE_CLOSURE, 2)) break; + case OP_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; case HOP_CLOSURE_AP: op_closure_ap(sc); goto EVAL; case OP_CLOSURE_AP_1: op_closure_ap_1(sc); goto BEGIN; case OP_CLOSURE_AP_MV: op_closure_ap_mv(sc); goto APPLY; - case OP_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, MATCH_UNSAFE_CLOSURE, 2)) break; + case OP_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; case HOP_CLOSURE_PA: op_closure_pa(sc); goto EVAL; case OP_CLOSURE_PA_1: op_closure_pa_1(sc); goto BEGIN; case OP_CLOSURE_PA_MV: op_closure_pa_mv(sc); goto APPLY; - case OP_SAFE_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, MATCH_SAFE_CLOSURE, 2)) break; + case OP_SAFE_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) break; case HOP_SAFE_CLOSURE_AP: op_safe_closure_ap(sc); goto EVAL; case OP_SAFE_CLOSURE_AP_1: op_safe_closure_ap_1(sc); goto BEGIN; - case OP_SAFE_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, MATCH_SAFE_CLOSURE, 2)) break; + case OP_SAFE_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) break; case HOP_SAFE_CLOSURE_PA: op_safe_closure_pa(sc); goto EVAL; case OP_SAFE_CLOSURE_PA_1: op_safe_closure_pa_1(sc); goto BEGIN; - case OP_CLOSURE_FA: if (!closure_is_fine(sc, sc->code, MATCH_UNSAFE_CLOSURE, 2)) break; + case OP_CLOSURE_FA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; case HOP_CLOSURE_FA: op_closure_fa(sc); goto EVAL; - case OP_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_SS: op_closure_ss(sc); goto EVAL; - case OP_CLOSURE_SS_P: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_SS_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_SS_P: op_closure_ss_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_SAFE_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_SS: op_safe_closure_ss(sc); goto EVAL; - case OP_SAFE_CLOSURE_SS_P: if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_SAFE_CLOSURE_SS_P: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_SS_P: op_safe_closure_ss_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_SS_A: if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_A, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_SS_A: op_safe_closure_ss_a(sc); goto START; + case OP_SAFE_CLOSURE_SS_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_SS_A: sc->value = fx_safe_closure_ss_a(sc, sc->code); continue; - case OP_CLOSURE_3S: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_3S: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_3S: op_closure_3s(sc); closure_push(sc); goto EVAL; - case OP_CLOSURE_3S_P: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_3S_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_3S_P: op_closure_3s(sc); sc->code = car(closure_body(sc->code)); goto EVAL; - case OP_CLOSURE_4S: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 4)) {if (op_unknown_all_s(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + /* an experiment -- if closure through unknown_all_s M/P case may change on every call */ + case OP_CLOSURE_3S_B: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_CLOSURE_3S_B: op_closure_3s(sc); + sc->code = T_Pair(closure_body(sc->code)); + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + goto EVAL; + + case OP_CLOSURE_4S: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 4)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_4S: op_closure_4s(sc); closure_push(sc); goto EVAL; - case OP_CLOSURE_4S_P: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 4)) {if (op_unknown_all_s(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_4S_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 4)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_4S_P: op_closure_4s(sc); sc->code = car(closure_body(sc->code)); goto EVAL; - case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_4S_B: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_CLOSURE_4S_B: op_closure_4s(sc); + sc->code = T_Pair(closure_body(sc->code)); + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + goto EVAL; + + case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_SC: op_closure_sc(sc); goto EVAL; - case OP_CLOSURE_SC_P: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_SC_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_SC_P: op_closure_sc_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_SAFE_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_SC: op_safe_closure_sc(sc); goto EVAL; - case OP_SAFE_CLOSURE_SC_P: if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_SAFE_CLOSURE_SC_P: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_SC_P: op_safe_closure_sc_p(sc); goto EVAL; - - case OP_CLOSURE_CS: if (!closure_is_fine(sc, sc->code, MATCH_UNSAFE_CLOSURE, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_CS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_CS: op_closure_cs(sc); goto BEGIN; - case OP_SAFE_CLOSURE_CS: if (!closure_is_fine(sc, sc->code, MATCH_SAFE_CLOSURE, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_SAFE_CLOSURE_CS: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_gg(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_CS: op_safe_closure_cs(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_SA: if (!closure_is_fine(sc, sc->code, MATCH_SAFE_CLOSURE, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_SAFE_CLOSURE_SA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_SA: op_safe_closure_sa(sc); goto BEGIN; - case OP_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_AA: op_closure_aa(sc); goto EVAL; - case OP_CLOSURE_AA_P: if (!closure_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_CLOSURE_AA_P: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_AA_P: op_closure_aa_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_SAFE_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_AA: op_safe_closure_aa(sc); goto EVAL; - case OP_SAFE_CLOSURE_AA_P: if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + case OP_SAFE_CLOSURE_AA_P: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_AA_P: op_safe_closure_aa_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_AA_A: if (!closure_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_A, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_AA_A: op_safe_closure_aa_a(sc); goto START; + case OP_SAFE_CLOSURE_AA_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_aa(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_AA_A: sc->value = fx_safe_closure_aa_a(sc, sc->code); continue; - /* safe_closure_3s was not a win: fx_s overhead -5, three_slot overhead +2 */ - case OP_SAFE_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, MATCH_SAFE_CLOSURE, 3)) break; + case OP_SAFE_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) break; case HOP_SAFE_CLOSURE_SAA: op_safe_closure_saa(sc); goto BEGIN; - case OP_SAFE_CLOSURE_FX: if (!closure_is_fine(sc, sc->code, MATCH_SAFE_CLOSURE, integer(opt3_arglen(sc->code)))) break; + case OP_SAFE_CLOSURE_ALL_S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, integer(opt3_arglen(sc->code)))) break; + case HOP_SAFE_CLOSURE_ALL_S: op_safe_closure_all_s(sc); goto EVAL; + + case OP_SAFE_CLOSURE_FX: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, integer(opt3_arglen(sc->code)))) break; case HOP_SAFE_CLOSURE_FX: op_safe_closure_fx(sc); goto EVAL; + case OP_SAFE_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) break; + case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto BEGIN; + case OP_CLOSURE_ALL_S: - if (!closure_is_fine(sc, sc->code, MATCH_UNSAFE_CLOSURE, integer(opt3_arglen(sc->code)))) + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, integer(opt3_arglen(sc->code)))) { - if (op_unknown_all_s(sc, sc->last_function) == goto_EVAL) + if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break; } @@ -86355,9 +88175,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) goto EVAL; case OP_CLOSURE_FX: - if (!closure_is_fine(sc, sc->code, MATCH_UNSAFE_CLOSURE, integer(opt3_arglen(sc->code)))) + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, integer(opt3_arglen(sc->code)))) { - if (op_unknown_fx(sc, sc->last_function) == goto_EVAL) + if (op_unknown_fx(sc, sc->last_function) == goto_eval) goto EVAL; break; } @@ -86365,283 +88185,216 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) op_closure_fx(sc); goto EVAL; - case OP_CLOSURE_ANY_FX: if (!closure_is_fine(sc, sc->code, MATCH_UNSAFE_CLOSURE, -1)) break; + case OP_CLOSURE_ANY_FX: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, -1)) break; case HOP_CLOSURE_ANY_FX: op_closure_any_fx(sc); goto BEGIN; + case OP_SAFE_CLOSURE_FP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, integer(opt3_arglen(sc->code)))) break; + case HOP_SAFE_CLOSURE_FP: op_safe_closure_fp(sc); goto EVAL; - case OP_SAFE_CLOSURE_FP: - if (!closure_is_fine(sc, sc->code, MATCH_SAFE_CLOSURE, integer(opt3_arglen(sc->code)))) break; - case HOP_SAFE_CLOSURE_FP: - check_stack_size(sc); - sc->args = list_1(sc, sc->code); - sc->code = cdr(sc->code); - collect_fp_args(sc, OP_SAFE_CLOSURE_FP_1, sc->args); + case OP_SAFE_CLOSURE_FP_1: + if (!(collect_fp_args(sc, OP_SAFE_CLOSURE_FP_1, cons(sc, sc->value, sc->args)))) + op_safe_closure_fp_1(sc); goto EVAL; - case OP_SAFE_CLOSURE_FP_1: /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is the next arg if any */ - if (!(collect_fp_args(sc, OP_SAFE_CLOSURE_FP_1, cons(sc, sc->value, sc->args)))) - op_safe_closure_fp(sc); + case OP_SAFE_CLOSURE_FP_2: + sc->args = cons(sc, sc->value, sc->args); + op_safe_closure_fp_1(sc); goto EVAL; case OP_SAFE_CLOSURE_FP_MV_1: - if (!(collect_fp_args(sc, OP_SAFE_CLOSURE_FP_MV_1, - (is_multiple_value(sc->value)) ? s7_append(sc, s7_reverse(sc, sc->value), sc->args) : cons(sc, sc->value, sc->args)))) - op_safe_closure_fp(sc); + if (!(collect_fp_args(sc, OP_SAFE_CLOSURE_FP_MV_1, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args)))) + op_safe_closure_fp_1(sc); goto EVAL; /* -------------------------------------------------------------------------------- */ - case OP_TC_AND_A_OR_A_LA: tick_tc_rec(sc); op_tc_and_a_or_a_la(sc, sc->code); goto START; - case OP_TC_OR_A_AND_A_LA: tick_tc_rec(sc); op_tc_or_a_and_a_la(sc, sc->code); goto START; - case OP_TC_AND_A_OR_A_LAA: tick_tc_rec(sc); op_tc_and_a_or_a_laa(sc, sc->code); goto START; - case OP_TC_OR_A_AND_A_LAA: tick_tc_rec(sc); op_tc_or_a_and_a_laa(sc, sc->code); goto START; - case OP_TC_OR_A_A_AND_A_A_LA: tick_tc_rec(sc); op_tc_or_a_a_and_a_a_la(sc, sc->code); goto START; - case OP_TC_OR_A_AND_A_A_L3A: tick_tc_rec(sc); op_tc_or_a_and_a_a_l3a(sc, true, sc->code); goto START; - - case OP_TC_LET_WHEN_LAA: tick_tc_rec(sc); op_tc_let_when_laa(sc, true, sc->code); goto START; - case OP_TC_LET_UNLESS_LAA: tick_tc_rec(sc); op_tc_let_when_laa(sc, false, sc->code); goto START; - - case OP_TC_COND_A_Z_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code)) goto START; goto EVAL; - case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc_rec(sc); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) goto START; goto EVAL; - case OP_TC_LET_COND: tick_tc_rec(sc); if (op_tc_let_cond(sc, sc->code)) goto START; goto EVAL; - - case OP_TC_IF_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_la(sc, sc->code)) goto START; goto EVAL; - case OP_TC_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_laa(sc, sc->code)) goto START; goto EVAL; - case OP_TC_IF_A_LA_Z: tick_tc_rec(sc); if (op_tc_if_a_la_z(sc, sc->code)) goto START; goto EVAL; - case OP_TC_IF_A_LAA_Z: tick_tc_rec(sc); if (op_tc_if_a_laa_z(sc, sc->code)) goto START; goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_la(sc, sc->code)) goto START; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_la_z(sc, sc->code)) goto START; goto EVAL; - case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) goto START; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LAA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_laa_z(sc, sc->code)) goto START; goto EVAL; - case OP_TC_IF_A_T_AND_A_A_L3A: tick_tc_rec(sc); op_tc_or_a_and_a_a_l3a(sc, false, sc->code); goto START; - - case OP_TC_LET_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_let_if_a_z_laa(sc, sc->code)) goto START; goto EVAL; - case OP_TC_CASE_LA: tick_tc_rec(sc); if (op_tc_case_la(sc, sc->code)) goto START; goto BEGIN; - - case OP_RECUR_IF_A_A_opA_LAq: - case OP_RECUR_IF_A_opA_LAq_A: - tick_tc_rec(sc); - wrap_recur(sc, (sc->cur_op == OP_RECUR_IF_A_A_opA_LAq) ? op_recur_if_a_a_opa_laq : op_recur_if_a_opa_laq_a); - goto START; - - case OP_RECUR_IF_A_A_opA_LAAq: - case OP_RECUR_IF_A_opA_LAAq_A: - tick_tc_rec(sc); - wrap_recur(sc, (sc->cur_op == OP_RECUR_IF_A_A_opA_LAAq) ? op_recur_if_a_a_opa_laaq : op_recur_if_a_opa_laaq_a); - goto START; - - case OP_RECUR_IF_A_A_opLA_LAq: - case OP_RECUR_IF_A_opLA_LAq_A: - tick_tc_rec(sc); - wrap_recur_if_a_a_opla_laq(sc, sc->cur_op == OP_RECUR_IF_A_A_opLA_LAq); - goto START; - - case OP_RECUR_IF_A_A_opA_LA_LAq: - case OP_RECUR_IF_A_opA_LA_LAq_A: - tick_tc_rec(sc); - wrap_recur(sc, (sc->cur_op == OP_RECUR_IF_A_A_opA_LA_LAq) ? op_recur_if_a_a_opa_la_laq : op_recur_if_a_opa_la_laq_a); - goto START; - - case OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_if_a_a_lopl3a_l3a_l3aq); - goto START; - - case OP_RECUR_IF_A_A_AND_A_LAA_LAA: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_if_a_a_and_a_laa_laa); - goto START; - - case OP_RECUR_IF_A_A_opLA_LA_LAq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_if_a_a_opla_la_laq); - goto START; - - case OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_if_a_a_if_a_laa_opa_laaq); - goto START; - - case OP_RECUR_COND_A_A_opA_LAq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_cond_a_a_opa_laq); - goto START; - - case OP_RECUR_COND_A_A_opA_LAAq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_cond_a_a_opa_laaq); - goto START; - - case OP_RECUR_COND_A_A_A_A_opLA_LAq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_cond_a_a_a_a_opla_laq); - goto START; - - case OP_RECUR_COND_A_A_A_A_opA_LAAq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_cond_a_a_a_a_opa_laaq); - goto START; - - case OP_RECUR_COND_A_A_A_A_opLAA_LAAq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq); - goto START; - - case OP_RECUR_COND_A_A_A_LAA_opA_LAAq: - tick_tc_rec(sc); - wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq); - goto START; - - case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: - tick_tc_rec(sc); - wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); - goto START; + case OP_TC_AND_A_OR_A_LA: tick_tc_rec(sc); op_tc_and_a_or_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LA: tick_tc_rec(sc); op_tc_or_a_and_a_la(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_LAA: tick_tc_rec(sc); op_tc_and_a_or_a_laa(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LAA: tick_tc_rec(sc); op_tc_or_a_and_a_laa(sc, sc->code); continue; + case OP_TC_OR_A_A_AND_A_A_LA: tick_tc_rec(sc); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_L3A: tick_tc_rec(sc); op_tc_or_a_and_a_a_l3a(sc, true, sc->code); continue; + + case OP_TC_LET_WHEN_LAA: tick_tc_rec(sc); op_tc_let_when_laa(sc, true, sc->code); continue; + case OP_TC_LET_UNLESS_LAA: tick_tc_rec(sc); op_tc_let_when_laa(sc, false, sc->code); continue; + + case OP_TC_COND_A_Z_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc_rec(sc); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_COND: tick_tc_rec(sc); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; + + case OP_TC_IF_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_LA_Z: tick_tc_rec(sc); if (op_tc_if_a_la_z(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_LAA_Z: tick_tc_rec(sc); if (op_tc_if_a_laa_z(sc, sc->code)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_la_z(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LAA_Z: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_laa_z(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_T_AND_A_A_L3A: tick_tc_rec(sc); op_tc_or_a_and_a_a_l3a(sc, false, sc->code); continue; + + case OP_TC_LET_IF_A_Z_LAA: tick_tc_rec(sc); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_CASE_LA: tick_tc_rec(sc); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; + + case OP_RECUR_IF_A_A_opA_LAq: wrap_recur(sc, op_recur_if_a_a_opa_laq); continue; + case OP_RECUR_IF_A_opA_LAq_A: wrap_recur(sc, op_recur_if_a_opa_laq_a); continue; + case OP_RECUR_IF_A_A_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_opa_laaq); continue; + case OP_RECUR_IF_A_opA_LAAq_A: wrap_recur(sc, op_recur_if_a_opa_laaq_a); continue; + case OP_RECUR_IF_A_A_opLA_LAq: wrap_recur_if_a_a_opla_laq(sc, true); continue; + case OP_RECUR_IF_A_opLA_LAq_A: wrap_recur_if_a_a_opla_laq(sc, false); continue; + case OP_RECUR_IF_A_A_opA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opa_la_laq); continue; + case OP_RECUR_IF_A_opA_LA_LAq_A: wrap_recur(sc, op_recur_if_a_opa_la_laq_a); continue; + + case OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq: wrap_recur(sc, op_recur_if_a_a_lopl3a_l3a_l3aq); continue; + case OP_RECUR_IF_A_A_AND_A_LAA_LAA: wrap_recur(sc, op_recur_if_a_a_and_a_laa_laa); continue; + case OP_RECUR_IF_A_A_opLA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opla_la_laq); continue; + case OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_laa_opa_laaq); continue; + case OP_RECUR_COND_A_A_opA_LAq: wrap_recur(sc, op_recur_cond_a_a_opa_laq); continue; + case OP_RECUR_COND_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_opa_laaq); continue; + case OP_RECUR_COND_A_A_A_A_opLA_LAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opla_laq); continue; + case OP_RECUR_COND_A_A_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opa_laaq); continue; + case OP_RECUR_COND_A_A_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq); continue; + case OP_RECUR_COND_A_A_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq); continue; + case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); continue; /* -------------------------------------------------------------------------------- */ - case OP_SAFE_CLOSURE_STAR_A: - if (!closure_star_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} - case HOP_SAFE_CLOSURE_STAR_A: - safe_closure_star_a(sc, sc->code); - goto BEGIN; + case OP_SAFE_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} + case HOP_SAFE_CLOSURE_STAR_A: safe_closure_star_a(sc, sc->code); goto BEGIN; - case OP_SAFE_CLOSURE_STAR_AA: - if (!closure_star_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_STAR, 2)) break; - case HOP_SAFE_CLOSURE_STAR_AA: - safe_closure_star_aa(sc, sc->code); - goto BEGIN; + case OP_SAFE_CLOSURE_STAR_AA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) break; + case HOP_SAFE_CLOSURE_STAR_AA: safe_closure_star_aa(sc, sc->code); goto BEGIN; case OP_SAFE_CLOSURE_STAR_FX: - if (!closure_star_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? integer(opt3_arglen(sc->code)) : 0)) + if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? integer(opt3_arglen(sc->code)) : 0)) { - if (op_unknown_fx(sc, sc->last_function) == goto_EVAL) + if (op_unknown_fx(sc, sc->last_function) == goto_eval) goto EVAL; break; } case HOP_SAFE_CLOSURE_STAR_FX: - if (safe_closure_star_fx(sc, sc->code) == goto_EVAL) goto EVAL; + if (safe_closure_star_fx(sc, sc->code) == goto_eval) goto EVAL; goto BEGIN; case OP_SAFE_CLOSURE_STAR_FX_0: - if (!closure_star_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_STAR, 0)) {if (op_unknown(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 0)) {if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_STAR_FX_0: - if (safe_closure_star_fx_0(sc, sc->code) == goto_EVAL) goto EVAL; + if (safe_closure_star_fx_0(sc, sc->code) == goto_eval) goto EVAL; goto BEGIN; case OP_SAFE_CLOSURE_STAR_FX_1: - if (!closure_star_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_STAR_FX_1: - if (safe_closure_star_fx_1(sc, sc->code) == goto_EVAL) goto EVAL; + if (safe_closure_star_fx_1(sc, sc->code) == goto_eval) goto EVAL; goto BEGIN; case OP_SAFE_CLOSURE_STAR_FX_2: - if (!closure_star_is_ok(sc, sc->code, MATCH_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_SAFE_CLOSURE_STAR_FX_2: - if (safe_closure_star_fx_2(sc, sc->code) == goto_EVAL) goto EVAL; + if (safe_closure_star_fx_2(sc, sc->code) == goto_eval) goto EVAL; goto BEGIN; /* -------------------------------------------------------------------------------- */ case OP_CLOSURE_STAR_A: - if (!closure_star_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; break;} + if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;} case HOP_CLOSURE_STAR_A: closure_star_a(sc, sc->code); goto BEGIN; case OP_CLOSURE_STAR_FX: - if (!closure_star_is_ok(sc, sc->code, MATCH_UNSAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? integer(opt3_arglen(sc->code)) : 0)) + if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? integer(opt3_arglen(sc->code)) : 0)) { - if (op_unknown_fx(sc, sc->last_function) == goto_EVAL) + if (op_unknown_fx(sc, sc->last_function) == goto_eval) goto EVAL; break; } case HOP_CLOSURE_STAR_FX: check_stack_size(sc); closure_star_fx(sc, sc->code); - if (apply_lambda_star(sc) == goto_EVAL) goto EVAL; + if (apply_lambda_star(sc) == goto_eval) goto EVAL; goto BEGIN; /* -------------------------------------------------------------------------------- */ - case OP_UNKNOWN: if (op_unknown(sc, lookup_checked(sc, car(sc->code))) == goto_EVAL) goto EVAL; break; - case OP_UNKNOWN_G: if (op_unknown_g(sc, lookup_checked(sc, car(sc->code))) == goto_EVAL) goto EVAL; break; - case OP_UNKNOWN_GG: if (op_unknown_gg(sc, lookup_checked(sc, car(sc->code))) == goto_EVAL) goto EVAL; break; - case OP_UNKNOWN_ALL_S: if (op_unknown_all_s(sc, lookup_checked(sc, car(sc->code))) == goto_EVAL) goto EVAL; break; - case OP_UNKNOWN_A: if (op_unknown_a(sc, lookup_checked(sc, car(sc->code))) == goto_EVAL) goto EVAL; break; - case OP_UNKNOWN_AA: if (op_unknown_aa(sc, lookup_checked(sc, car(sc->code))) == goto_EVAL) goto EVAL; break; - case OP_UNKNOWN_FX: if (op_unknown_fx(sc, lookup_checked(sc, car(sc->code))) == goto_EVAL) goto EVAL; break; + case OP_UNKNOWN: if (op_unknown(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break; + case OP_UNKNOWN_G: if (op_unknown_g(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break; + case OP_UNKNOWN_GG: if (op_unknown_gg(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break; + case OP_UNKNOWN_ALL_S: if (op_unknown_all_s(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break; + case OP_UNKNOWN_A: if (op_unknown_a(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break; + case OP_UNKNOWN_AA: if (op_unknown_aa(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break; + case OP_UNKNOWN_FX: if (op_unknown_fx(sc, lookup_checked(sc, car(sc->code))) == goto_eval) goto EVAL; break; /* -------------------------------------------------------------------------------- */ case OP_IMPLICIT_VECTOR_REF_A: - if (op_vector_a(sc) == goto_START) goto START; - if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_vector_a(sc) == goto_start) continue; + if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_VECTOR_REF_AA: - if (op_vector_aa(sc) == goto_START) goto START; - if (op_unknown_aa(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_vector_aa(sc) == goto_start) continue; + if (op_unknown_aa(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_STRING_REF_A: - if (op_string_a(sc) == goto_START) goto START; - if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_string_a(sc) == goto_start) continue; + if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_HASH_TABLE_REF_A: - if (op_hash_table_a(sc)) goto START; - if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_hash_table_a(sc)) continue; + if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_CONTINUATION_A: - if (op_continuation_a(sc)) goto START; - if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_continuation_a(sc)) continue; + if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_ITERATE: - if (op_iterate(sc)) goto START; - if (op_unknown(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_iterate(sc)) continue; + if (op_unknown(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_S7_LET_REF: sc->value = g_s7_let_ref_fallback(sc, set_plist_2(sc, sc->s7_let, (is_keyword(cadr(sc->code))) ? keyword_symbol(cadr(sc->code)) : cadadr(sc->code))); - goto START; + continue; case OP_IMPLICIT_LET_REF_C: - if (op_environment_c(sc)) goto START; - if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc, sc->last_function) == goto_EVAL)) goto EVAL; + if (op_environment_c(sc)) continue; + if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc, sc->last_function) == goto_eval)) goto EVAL; break; case OP_IMPLICIT_LET_REF_A: - if (op_environment_a(sc)) goto START; - if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_environment_a(sc)) continue; + if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_PAIR_REF_A: - if (op_pair_a(sc)) goto START; - if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_pair_a(sc)) continue; + if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_C_OBJECT_REF_A: - if (op_c_object_a(sc)) goto START; - if (op_unknown_a(sc, sc->last_function) == goto_EVAL) goto EVAL; + if (op_c_object_a(sc)) continue; + if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break; case OP_IMPLICIT_GOTO: - if (op_goto(sc)) goto START; - if (op_unknown(sc, opt1_goto(sc->code)) == goto_EVAL) goto EVAL; + if (op_goto(sc)) continue; + if (op_unknown(sc, opt1_goto(sc->code)) == goto_eval) goto EVAL; break; case OP_IMPLICIT_GOTO_A: - if (op_goto_a(sc)) goto START; - if (op_unknown_a(sc, opt1_goto(sc->code)) == goto_EVAL) goto EVAL; + if (op_goto_a(sc)) continue; + if (op_unknown_a(sc, opt1_goto(sc->code)) == goto_eval) goto EVAL; break; case OP_IMPLICIT_VECTOR_SET_3: /* (set! (v i) x) */ if (op_vector_set_3(sc)) goto EVAL; - goto START; + continue; case OP_IMPLICIT_VECTOR_SET_4: /* (set! (v i j) x) */ if (op_vector_set_4(sc)) goto EVAL; - goto START; + continue; case OP_UNOPT: #if UNOPT_PRINT @@ -86649,54 +88402,44 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) #endif goto UNOPT; - case OP_SYM: - sc->value = lookup_checked(sc, sc->code); - goto START; + case OP_SYM: sc->value = lookup_checked(sc, sc->code); continue; - case OP_CON: - sc->value = sc->code; - goto START; + case OP_GLOBAL_SYM: +#if S7_DEBUGGING && (0) + if (lookup_global(sc, sc->code) != lookup_checked(sc, sc->code)) + fprintf(stderr, "global?? %s %d: %s %s\n", + DISPLAY(sc->code), is_global(sc->code), + DISPLAY(lookup_global(sc, sc->code)), + DISPLAY(lookup_checked(sc, sc->code))); + if (!is_global(sc->code)) fprintf(stderr, "%s is no longer global\n", DISPLAY(sc->code)); +#endif + sc->value = lookup_global(sc, sc->code); + continue; - case OP_PAIR_PAIR: - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, sc->code); - push_stack(sc, OP_EVAL_ARGS, sc->nil, sc->code); - push_stack(sc, OP_EVAL_ARGS, sc->nil, car(sc->code)); - sc->code = caar(sc->code); - goto EVAL; + case OP_CON: sc->value = sc->code; continue; + case OP_PAIR_PAIR: op_pair_pair(sc); goto EVAL; /* car is pair ((if x car cadr) ...) */ + case OP_PAIR_ANY: sc->value = car(sc->code); goto EVAL_ARGS_TOP; case OP_PAIR_SYM: +#if 0 + if (!tree_is_cyclic(sc, sc->code)) + fprintf(stderr, "op_pair_sym: %s\n", DISPLAY_80(sc->code)); + else fprintf(stderr, "cyclic op_pair_sym: (%s ...)\n", DISPLAY(car(sc->code))); +#endif /* car is a non-syntax symbol, sc->code a list */ - /* fprintf(stderr, "%s\n", DISPLAY_80(sc->code)); */ - sc->value = find_global_symbol_checked(sc, car(sc->code)); - goto EVAL_ARGS_TOP; - - case OP_PAIR_ANY: - sc->value = car(sc->code); + /* op_c_sym? op_c_sym_1? op_pair_closure_... */ + sc->value = lookup_global(sc, car(sc->code)); + /* sc->value = lookup_checked(sc, car(sc->code)); */ goto EVAL_ARGS_TOP; /* sc->value is car=something applicable, sc->code = rest of expression * sc->args is nil (set by the drop-through cases above -- perhaps clearer to bring that down?) */ - case OP_EVAL_ARGS5: - op_eval_args5(sc); - goto APPLY; - - case OP_EVAL_ARGS2: /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2] */ - op_eval_args2(sc); - goto APPLY; - - case OP_EVAL_ARGS3: /* sc->value is the next-to-last arg, and we know the last arg is not a list (so values can't mess us up!) */ - op_eval_args3(sc); - goto APPLY; - - case OP_EVAL_ARGS4: /* sc->code is a pair, and either cdr(sc->code) is not null or car(sc->code) is a pair */ - op_eval_args4(sc); - goto EVAL_ARGS_PAIR; - - case OP_EVAL_ARGS1: - op_eval_args1(sc); - goto EVAL_ARGS; + case OP_EVAL_ARGS5: op_eval_args5(sc); goto APPLY; + case OP_EVAL_ARGS2: op_eval_args2(sc); goto APPLY; /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2] */ + case OP_EVAL_ARGS3: op_eval_args3(sc); goto APPLY; /* sc->value is the next-to-last arg, and we know the last arg is not a list (so values can't mess us up!) */ + case OP_EVAL_ARGS4: op_eval_args4(sc); goto EVAL_ARGS_PAIR; /* sc->code is a pair, and either cdr(sc->code) is not null or car(sc->code) is a pair */ + case OP_EVAL_ARGS1: op_eval_args1(sc); goto EVAL_ARGS; EVAL_ARGS_TOP: case OP_EVAL_ARGS: @@ -86704,10 +88447,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) { if (is_any_macro(sc->value)) { - /* macro expansion */ - sc->args = copy_list_with_arglist_error(sc, cdr(sc->code)); - sc->code = sc->value; - goto APPLY; /* not UNSAFE_CLOSURE because it might be a bacro */ + eval_args_expand_macro(sc); + goto APPLY; } /* (define progn begin) (progn (display "hi") (+ 1 23)) */ if (is_syntactic_pair(sc->code)) @@ -86735,7 +88476,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) resize_op_stack(sc); sc->args = sc->nil; - /* goto EVAL_ARGS; */ + /* fall through */ EVAL_ARGS: /* first time, value = op, args = nil, code is args */ if (is_pair(sc->code)) /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */ @@ -86823,28 +88564,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) goto EVAL_ARGS_PAIR; } } - else - { - /* here we've reached the last arg (sc->code == nil), it is not a pair */ - s7_pointer x, val; - - if (!is_null(cdr(sc->code))) - improper_arglist_error(sc); - - sc->code = pop_op_stack(sc); - if (is_symbol(car_code)) - val = lookup_checked(sc, car_code); /* this has to precede the set_type below */ - else val = car_code; - sc->temp4 = val; - new_cell(sc, x, T_PAIR); - set_car(x, val); - set_cdr(x, sc->args); - - if (!is_null(sc->args)) - sc->args = safe_reverse_in_place(sc, x); - else sc->args = x; - /* drop into APPLY */ - } + else eval_last_arg(sc, car_code); + /* drop into APPLY */ } else /* got all args -- go to apply */ { @@ -86873,25 +88594,25 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) #endif switch (type(sc->code)) { - case T_C_FUNCTION: apply_c_function(sc); goto START; - case T_C_ANY_ARGS_FUNCTION: apply_c_any_args_function(sc); goto START; - case T_C_FUNCTION_STAR: apply_c_function_star(sc); goto START; - case T_C_OPT_ARGS_FUNCTION: apply_c_opt_args_function(sc); goto START; - case T_C_RST_ARGS_FUNCTION: apply_c_rst_args_function(sc); goto START; + case T_C_FUNCTION: apply_c_function(sc); continue; + case T_C_ANY_ARGS_FUNCTION: apply_c_any_args_function(sc); continue; + case T_C_FUNCTION_STAR: apply_c_function_star(sc); continue; + case T_C_OPT_ARGS_FUNCTION: apply_c_opt_args_function(sc); continue; + case T_C_RST_ARGS_FUNCTION: apply_c_rst_args_function(sc); continue; case T_C_MACRO: apply_c_macro(sc); goto EVAL; - case T_CONTINUATION: apply_continuation(sc); goto START; - case T_GOTO: call_with_exit(sc); goto START; - case T_C_OBJECT: apply_c_object(sc); goto START; + case T_CONTINUATION: apply_continuation(sc); continue; + case T_GOTO: call_with_exit(sc); continue; + case T_C_OBJECT: apply_c_object(sc); continue; case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: - case T_VECTOR: apply_vector(sc); goto START; - case T_STRING: apply_string(sc); goto START; - case T_HASH_TABLE: apply_hash_table(sc); goto START; - case T_ITERATOR: apply_iterator(sc); goto START; - case T_LET: apply_let(sc); goto START; + case T_VECTOR: apply_vector(sc); continue; + case T_STRING: apply_string(sc); continue; + case T_HASH_TABLE: apply_hash_table(sc); continue; + case T_ITERATOR: apply_iterator(sc); continue; + case T_LET: apply_let(sc); continue; case T_SYNTAX: apply_syntax(sc); goto TOP_NO_POP; - case T_PAIR: if (apply_pair(sc)) goto START; goto APPLY; + case T_PAIR: if (apply_pair(sc)) continue; goto APPLY; case T_MACRO: /* this is not from the reader, so treat expansions here as normal macros */ @@ -86913,39 +88634,36 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case T_MACRO_STAR: push_stack_op_let(sc, OP_EVAL_MACRO); new_frame(sc, closure_let(sc->code), sc->envir); - if (apply_lambda_star(sc) == goto_EVAL) goto EVAL; + if (apply_lambda_star(sc) == goto_eval) goto EVAL; goto BEGIN; case T_BACRO_STAR: push_stack_op_let(sc, OP_EVAL_MACRO); new_frame(sc, sc->envir, sc->envir); - if (apply_lambda_star(sc) == goto_EVAL) goto EVAL; + if (apply_lambda_star(sc) == goto_eval) goto EVAL; goto BEGIN; case T_CLOSURE_STAR: check_stack_size(sc); sc->envir = new_frame_in_env(sc, closure_let(sc->code)); - if (apply_lambda_star(sc) == goto_EVAL) goto EVAL; + if (apply_lambda_star(sc) == goto_eval) goto EVAL; goto BEGIN; default: apply_error(sc, sc->code, sc->args); } + case OP_MACRO_D: + if (op_macro_d(sc)) goto EVAL_ARGS_TOP; + /* fall through */ + APPLY_LAMBDA: case OP_APPLY_LAMBDA: apply_lambda(sc); goto BEGIN; case OP_LAMBDA_STAR_DEFAULT: - /* sc->args is the current let slots position, sc->value is the default expression's value */ - if (is_multiple_value(sc->value)) - eval_error(sc, "lambda*: argument default value can't be ~S", 43, cons(sc, sc->values_symbol, sc->value)); - slot_set_value(sc->args, sc->value); - sc->args = next_slot(sc->args); - if (lambda_star_default(sc) == goto_EVAL) goto EVAL; - pop_stack_no_op(sc); - sc->code = T_Pair(closure_body(sc->code)); + if (op_lambda_star_default(sc)) goto EVAL; goto BEGIN; case OP_MACROEXPAND_1: @@ -86969,31 +88687,24 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case T_MACRO_STAR: new_frame(sc, closure_let(sc->code), sc->envir); - if (apply_lambda_star(sc) == goto_EVAL) goto EVAL; + if (apply_lambda_star(sc) == goto_eval) goto EVAL; goto BEGIN; case T_BACRO_STAR: new_frame(sc, sc->envir, sc->envir); - if (apply_lambda_star(sc) == goto_EVAL) goto EVAL; + if (apply_lambda_star(sc) == goto_eval) goto EVAL; goto BEGIN; - case T_C_MACRO: /* moving this out of eval makes callgrind behave foolishly */ - { - s7_int len; - len = safe_list_length(sc->args); - if (len < c_macro_required_args(sc->code)) - s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); - if (c_macro_all_args(sc->code) < len) - s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); - sc->value = c_macro_call(sc->code)(sc, sc->args); - goto START; - } + case T_C_MACRO: + macroexpand_c_macro(sc); + continue; } eval_error(sc, "macroexpand argument is not a macro call: ~A", 44, sc->args); + /* -------------------- sort! (heapsort, done directly so that call/cc in the sort function will work correctly) -------------------- */ HEAPSORT: - if (op_heapsort(sc)) goto START; + if (op_heapsort(sc)) continue; if (sc->value != sc->F) goto APPLY; case OP_SORT1: @@ -87001,304 +88712,149 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) goto APPLY; case OP_SORT2: - if (op_sort2(sc)) goto START; + if (op_sort2(sc)) continue; goto HEAPSORT; case OP_SORT: if (!op_sort(sc)) goto HEAPSORT; case OP_SORT3: - if (op_sort3(sc)) goto START; + if (op_sort3(sc)) continue; goto HEAPSORT; case OP_SORT_PAIR_END: /* sc->value is the sort vector which needs to be copied into the original list */ sc->value = vector_into_list(sc->value, car(sc->args)); free_cell(sc, sc->args); - goto START; + continue; case OP_SORT_VECTOR_END: /* sc->value is the sort (s7_pointer) vector which needs to be copied into the original (double/int) vector */ sc->value = vector_into_fi_vector(sc->value, car(sc->args)); free_cell(sc, sc->args); - goto START; + continue; case OP_SORT_STRING_END: sc->value = vector_into_string(sc->value, car(sc->args)); free_cell(sc, sc->args); - goto START; - - - case OP_MAP_GATHER_1: - if (sc->value != sc->no_value) - { - if (is_multiple_value(sc->value)) - counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args))); - else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args))); - } - - case OP_MAP_1: - if (op_map_1(sc)) goto START; - goto BEGIN; + continue; - case OP_MAP_GATHER: - if (sc->value != sc->no_value) /* (map (lambda (x) (values)) (list 1)) */ - { - if (is_multiple_value(sc->value)) /* (map (lambda (x) (if (odd? x) (values x (* x 20)) (values))) (list 1 2 3 4)) */ - counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args))); - /* not append_in_place here because sc->value has the multiple-values bit set */ - else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args))); - } + + /* -------------------------------- map, for-each -------------------------------- */ + case OP_MAP_GATHER: op_map_gather(sc); + case OP_MAP: if (op_map(sc)) continue; goto APPLY; - case OP_MAP: - if (op_map(sc)) goto START; - goto APPLY; + case OP_MAP_GATHER_1: op_map_gather(sc); + case OP_MAP_1: if (op_map_1(sc)) continue; goto BEGIN; case OP_MAP_GATHER_2: - case OP_MAP_GATHER_3: - if (sc->value != sc->no_value) - { - if (is_multiple_value(sc->value)) - counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args))); - else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args))); - } - case OP_MAP_2: - if (op_map_2(sc)) goto START; - goto EVAL; + case OP_MAP_GATHER_3: op_map_gather(sc); + case OP_MAP_2: if (op_map_2(sc)) continue; goto EVAL; + case OP_FOR_EACH: if (op_for_each(sc)) continue; goto APPLY; + case OP_FOR_EACH_1: if (op_for_each_1(sc)) continue; goto BEGIN; - case OP_FOR_EACH: - if (op_for_each(sc)) goto START; - goto APPLY; - - case OP_FOR_EACH_1: - if (op_for_each_1(sc)) goto START; - goto BEGIN; - - case OP_FOR_EACH_3: case OP_FOR_EACH_2: - if (op_for_each_2(sc)) goto START; - goto EVAL; - + 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)) goto START; - goto APPLY; + case OP_MEMBER_IF1: if (member_if(sc)) continue; goto APPLY; case OP_ASSOC_IF: - case OP_ASSOC_IF1: - if (assoc_if(sc)) goto START; - goto APPLY; + case OP_ASSOC_IF1: if (assoc_if(sc)) continue; goto APPLY; /* -------------------------------- do -------------------------------- */ - case OP_DO_NO_VARS: - if (op_do_no_vars(sc)) goto DO_END_CLAUSES; - goto BEGIN; - - case OP_DO_NO_VARS_NO_OPT: - set_current_code(sc, sc->code); - sc->code = cdr(sc->code); - new_frame(sc, sc->envir, sc->envir); - - case OP_DO_NO_VARS_NO_OPT_1: - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) + case OP_SAFE_DOTIMES: + SAFE_DOTIMES: /* check_do */ + switch (safe_dotimes_ex(sc)) { - sc->code = cdadr(sc->code); - goto DO_END_CLAUSES; + case goto_safe_do_end_clauses: if (is_null(sc->code)) continue; goto DO_END_CODE; + case goto_do_end_clauses: goto DO_END_CLAUSES; + case goto_eval: goto EVAL; + case goto_top_no_pop: goto TOP_NO_POP; + default: goto BEGIN; } - push_stack_no_args(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code); - sc->code = T_Pair(cddr(sc->code)); - goto BEGIN; - - case OP_SAFE_DOTIMES: - SAFE_DOTIMES: /* check_do */ - { - s7_pointer form; - goto_t choice; - - form = sc->code; - set_current_code(sc, form); - sc->code = cdr(sc->code); - choice = safe_dotimes_ex(sc); - - if (choice == goto_SAFE_DO_END_CLAUSES) goto SAFE_DO_END_CLAUSES; - if (choice == goto_BEGIN) goto BEGIN; - if (choice == goto_EVAL) goto EVAL; - if (choice == goto_TOP_NO_POP) goto TOP_NO_POP; - pair_set_syntax_op(form, OP_SIMPLE_DO); - sc->code = form; - goto SIMPLE_DO; - } - -#define do_stepper_end(sc) \ - do {s7_pointer arg; arg = slot_value(sc->args); numerator(arg)++; \ - if (numerator(arg) == denominator(arg)) {sc->value = sc->T; sc->code = cdadr(sc->code); goto DO_END_CLAUSES;}} while (0) - - case OP_SAFE_DOTIMES_STEP_P: - do_stepper_end(sc); - push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, sc->code); - sc->code = opt2_pair(sc->code); - goto EVAL; - - case OP_SAFE_DOTIMES_STEP_O: - do_stepper_end(sc); - push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, sc->code); - sc->code = T_Pair(opt2_pair(sc->code)); - goto EVAL; - - case OP_SAFE_DOTIMES_STEP: - do_stepper_end(sc); - push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, sc->code); - sc->code = opt2_pair(sc->code); /* here we know the body has more than one form */ - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; case OP_SAFE_DO: - SAFE_DO: /* from check_do */ - { - goto_t choice; - set_current_code(sc, sc->code); - choice = safe_do_ex(sc); - if (choice == goto_SAFE_DO_END_CLAUSES) goto SAFE_DO_END_CLAUSES; - if (choice == goto_DO_UNCHECKED) goto DO_UNCHECKED; - goto BEGIN; - } - - case OP_SAFE_DO_STEP: - if (op_safe_do_step(sc)) - goto BEGIN; - goto DO_END_CLAUSES; - - case OP_SIMPLE_DO: - SIMPLE_DO: /* from check_do safe_dotimes */ - if (op_simple_do(sc)) goto DO_END_CLAUSES; - goto BEGIN; + SAFE_DO: /* from check_do */ + switch (safe_do_ex(sc)) + { + case goto_safe_do_end_clauses: + if (is_null(sc->code)) /* I don't think multiple values (as test result) can happen here -- all safe do loops involve counters by 1 to some integer end */ + continue; + goto DO_END_CODE; - case OP_SIMPLE_DO_STEP: - if (op_simple_do_step(sc)) - goto BEGIN; - goto DO_END_CLAUSES; + case goto_do_unchecked: goto DO_UNCHECKED; + default: goto BEGIN; + } case OP_DOTIMES_P: - DOTIMES_P: /* from check_do */ - { - goto_t choice; - set_current_code(sc, sc->code); - choice = dotimes_p_ex(sc); - if (choice == goto_DO_END_CLAUSES) goto DO_END_CLAUSES; - if (choice == goto_DO_UNCHECKED) goto DO_UNCHECKED; - goto EVAL; - } - - case OP_DOTIMES_STEP_P: - if (op_dotimes_step_p(sc)) - goto EVAL; - goto DO_END_CLAUSES; + DOTIMES_P: /* from check_do */ + switch (dotimes_p_ex(sc)) + { + case goto_do_end_clauses: goto DO_END_CLAUSES; + case goto_do_unchecked: goto DO_UNCHECKED; + default: goto EVAL; + } case OP_DOX: - DOX: /* from check_do */ - { - goto_t choice; - s7_pointer form; - form = sc->code; - set_current_code(sc, sc->code); - sc->code = cdr(sc->code); - choice = dox_ex(sc); - if (choice == goto_DO_END_CLAUSES) goto DO_END_CLAUSES; - if (choice == goto_START) goto START; - if (choice == goto_TOP_NO_POP) goto TOP_NO_POP; - pair_set_syntax_op(form, OP_DOX_INIT); - push_stack_no_args(sc, OP_DOX_STEP, sc->code); - sc->code = T_Pair(cddr(sc->code)); - goto BEGIN; + DOX: /* from check_do */ + switch (dox_ex(sc)) + { + case goto_do_end_clauses: goto DO_END_CLAUSES; + case goto_start: continue; + case goto_top_no_pop: goto TOP_NO_POP; /* includes dox_step_p */ + default: goto BEGIN; } - case OP_DOX_INIT: - if (op_dox_init(sc)) goto DO_END_CLAUSES; - goto BEGIN; + case OP_DO_NO_VARS_NO_OPT: op_do_no_vars_no_opt(sc); /* fall through */ + case OP_DO_NO_VARS_NO_OPT_1: if (op_do_no_vars_no_opt_1(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_SAFE_DOTIMES_STEP_P: if (op_safe_dotimes_step_p(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_SAFE_DOTIMES_STEP: if (op_safe_dotimes_step(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_SAFE_DO_STEP: if (op_safe_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_SIMPLE_DO: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_SIMPLE_DO_STEP: if (op_simple_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_DOTIMES_STEP_P: if (op_dotimes_step_p(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_DOX_INIT: if (op_dox_init(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_DOX_STEP: if (op_dox_step(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_DOX_STEP_P: if (op_dox_step_p(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; + case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; - case OP_DOX_STEP: - { - s7_pointer slot; - for (slot = let_slots(sc->envir); tis_slot(slot); slot = next_slot(slot)) - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(sc->code); - goto DO_END_CLAUSES; - } - push_stack_no_args(sc, OP_DOX_STEP, sc->code); - sc->code = T_Pair(cddr(sc->code)); - goto BEGIN; - } + case OP_DO_INIT: + if (op_do_init(sc)) goto DO_END; + goto EVAL; - case OP_DOX_STEP_P: - { - s7_pointer slot; - for (slot = let_slots(sc->envir); tis_slot(slot); slot = next_slot(slot)) - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) + case OP_DO: + set_current_code(sc, sc->code); + if (is_null(check_do(sc))) + switch (optimize_op(sc->code)) { - sc->code = cdadr(sc->code); - goto DO_END_CLAUSES; - } - push_stack_no_args(sc, OP_DOX_STEP_P, sc->code); - sc->code = caddr(sc->code); - goto EVAL; - } + case OP_DOX: goto DOX; + case OP_SAFE_DOTIMES: goto SAFE_DOTIMES; + case OP_DOTIMES_P: goto DOTIMES_P; + case OP_SAFE_DO: goto SAFE_DO; - case OP_DOX_NO_BODY: - op_dox_no_body(sc); - goto START; + case OP_DO_NO_VARS: + if (op_do_no_vars(sc)) goto DO_END_CLAUSES; + goto BEGIN; - case OP_DOX_PENDING_NO_BODY: - op_dox_pending_no_body(sc); - goto DO_END_CLAUSES; + case OP_DOX_NO_BODY: + op_dox_no_body(sc); + continue; - case OP_DO_INIT: - if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ - eval_error_no_return(sc, sc->wrong_type_arg_symbol, "do: variable initial value can't be ~S", 38, cons(sc, sc->values_symbol, sc->value)); - if (do_init_ex(sc) == goto_EVAL) goto EVAL; - goto DO_END; + case OP_DOX_PENDING_NO_BODY: + op_dox_pending_no_body(sc); + goto DO_END_CLAUSES; - case OP_DO: - set_current_code(sc, sc->code); - if (is_null(check_do(sc))) - { - opcode_t op; - op = optimize_op(sc->code); - if (op == OP_DOX) goto DOX; - if (op == OP_SAFE_DOTIMES) goto SAFE_DOTIMES; - if (op == OP_DOTIMES_P) goto DOTIMES_P; - if (op == OP_SAFE_DO) goto SAFE_DO; - if (op == OP_DO_NO_VARS) - { - if (op_do_no_vars(sc)) goto DO_END_CLAUSES; - goto BEGIN; - } - if (op == OP_DOX_NO_BODY) - { - op_dox_no_body(sc); - goto START; - } - if (op == OP_DOX_PENDING_NO_BODY) - { - op_dox_pending_no_body(sc); - goto DO_END_CLAUSES; - } - goto SIMPLE_DO; - } + default: + if (op_simple_do(sc)) goto DO_END_CLAUSES; + goto BEGIN; + } case OP_DO_UNCHECKED: - set_current_code(sc, sc->code); - push_stack_no_code(sc, OP_GC_PROTECT, sc->code); - sc->code = cdr(sc->code); + op_do_unchecked(sc); + DO_UNCHECKED: /* fall through above, safe_do_ex, dotimes_p_ex */ if (is_null(car(sc->code))) /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */ { @@ -87311,19 +88867,22 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->args = sc->nil; /* the evaluated var-data */ sc->value = sc->code; /* protect it */ sc->code = car(sc->code); /* the vars */ - if (do_init_ex(sc) == goto_EVAL) goto EVAL; + if (do_init_ex(sc) == goto_eval) goto EVAL; DO_END: case OP_DO_END: /* car(sc->args) here is the var list used by do_end2 */ - if (!is_pair(cdr(sc->args))) goto DO_END2; - if (!has_fx(cdr(sc->args))) + if (is_pair(cdr(sc->args))) { - push_stack(sc, OP_DO_END1, sc->args, sc->code); - sc->code = cadr(sc->args); /* evaluate the end expr */ - goto EVAL; + if (!has_fx(cdr(sc->args))) + { + push_stack(sc, OP_DO_END1, sc->args, sc->code); + sc->code = cadr(sc->args); /* evaluate the end expr */ + goto EVAL; + } + sc->value = fx_call(sc, cdr(sc->args)); } - sc->value = fx_call(sc, cdr(sc->args)); + else sc->value = sc->F; /* goto "if (is_pair(sc->code))..." below */ case OP_DO_END1: if (is_true(sc, sc->value)) /* sc->value is the result of end-test evaluation */ @@ -87341,7 +88900,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) /* similarly, if the result is a multiple value: * (define (f) (+ 1 (do ((i 2 (+ i 1))) ((= i 3) (values i (+ i 1)))))) -> 8 */ - goto START; + continue; } /* might be => here as in cond and case */ if (is_null(cdr(sc->code))) @@ -87349,7 +88908,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) if (has_fx(sc->code)) { sc->value = fx_call(sc, sc->code); - goto START; + continue; } sc->code = car(sc->code); goto EVAL; @@ -87361,9 +88920,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->code = car(sc->code); goto EVAL; } - /* end test false so fall through */ - - DO_END2: if (is_pair(sc->code)) { if (is_null(car(sc->args))) @@ -87373,71 +88929,22 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) } if (is_null(car(sc->args))) /* no steppers */ goto DO_END; - /* fall through */ + /* else fall through */ case OP_DO_STEP: - /* increment all vars, return to endtest - * these are also updated in parallel at the end, so we gather all the incremented values first - * - * here we know car(sc->args) is not null, args is the list of steppable vars, - * any unstepped vars in the do var section are not in this list, so - * (do ((i 0 (+ i 1)) (j 2)) ...) arrives here with sc->args: '(slot<((+ i 1)=expr, 0=pending_value>)) - */ - push_stack(sc, OP_DO_END, sc->args, sc->code); - sc->args = car(sc->args); /* the var data lists */ - sc->code = sc->args; /* save the top of the list */ - - DO_STEP1: - { - s7_pointer code; - /* on each iteration, each arg incr expr is evaluated and the value placed in caddr while we cdr down args */ - if (is_null(sc->args)) - { - s7_pointer x; - for (x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ - { - slot_set_value(car(x), slot_pending_value(car(x))); - slot_clear_has_pending_value(car(x)); - } - pop_stack_no_op(sc); - goto DO_END; - } - code = slot_expression(car(sc->args)); - if (has_fx(code)) - { - sc->value = fx_call(sc, code); -#if S7_DEBUGGING - /* can values happen here even in error? */ - if (is_multiple_value(sc->value)) - fprintf(stderr, "got multiple values! %s\n", DISPLAY(sc->value)); -#endif - slot_set_pending_value(car(sc->args), sc->value); - sc->args = cdr(sc->args); /* go to next step var */ - goto DO_STEP1; - } - push_stack(sc, OP_DO_STEP2, sc->args, sc->code); - sc->code = car(code); - goto EVAL; - } + if (op_do_step(sc)) goto DO_END; + goto EVAL; case OP_DO_STEP2: - if (is_multiple_value(sc->value)) - eval_error(sc, "do: variable step value can't be ~S", 35, cons(sc, sc->values_symbol, sc->value)); - slot_set_pending_value(car(sc->args), sc->value); /* save current value */ - sc->args = cdr(sc->args); /* go to next step var */ - goto DO_STEP1; - - SAFE_DO_END_CLAUSES: - if (is_null(sc->code)) /* I don't think multiple values (as test result) can happen here -- all safe do loops involve counters by 1 to some integer end */ - goto START; - goto DO_END_CODE; + if (op_do_step2(sc)) goto DO_END; + goto EVAL; DO_END_CLAUSES: if (is_null(sc->code)) { if (is_multiple_value(sc->value)) sc->value = splice_in_values(sc, multiple_value(sc->value)); - goto START; + continue; } DO_END_CODE: @@ -87454,7 +88961,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) if (has_fx(sc->code)) { sc->value = fx_call(sc, sc->code); - goto START; + continue; } sc->code = T_Pair(car(sc->code)); goto EVAL; @@ -87467,58 +88974,35 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) goto BEGIN; case OP_BEGIN: - { - s7_pointer form; - form = sc->code; - set_current_code(sc, sc->code); - sc->code = cdr(sc->code); - if (!s7_is_proper_list(sc, sc->code)) /* proper list includes () */ - eval_error(sc, "unexpected dot? ~A", 18, form); - if (is_null(sc->code)) /* (begin) -> () */ - { - sc->value = sc->nil; - goto START; - } - pair_set_syntax_op(form, OP_BEGIN_UNCHECKED); - } - + if (op_begin(sc)) continue; + case OP_BEGIN0: if ((sc->begin_hook) && (call_begin_hook(sc))) return(sc->F); case OP_BEGIN1: goto BEGIN; - case OP_EVAL: + case OP_BEGIN_1_UNCHECKED: + sc->code = cadr(sc->code); goto EVAL; - case OP_QUOTE: - /* I think a quoted list in another list can be applied to a function, come here and - * be changed to unchecked, set-cdr! or something clobbers the argument so we get - * here on the next time around with the equivalent of (quote . 0) if unchecked - * so set-cdr! of constant -- if marked immutable, we could catch this case and clear. - */ - check_quote(sc, sc->code); - sc->value = cadr(sc->code); - goto START; + case OP_BEGIN_2_UNCHECKED: + push_stack_no_args(sc, OP_BEGIN_1, cddr(sc->code)); + sc->code = cadr(sc->code); + goto EVAL; - case OP_DEFINE_FUNCHECKED: - define_funchecked(sc); - goto START; + case OP_BEGIN_1: + sc->code = car(sc->code); - case OP_DEFINE_CONSTANT1: - if (is_pair(sc->code)) sc->code = car(sc->code); /* (define-constant (ex3 a)...) */ - if (is_symbol(sc->code)) - { - s7_pointer slot; - slot = symbol_to_slot(sc, sc->code); - set_possibly_constant(sc->code); - set_immutable(slot); - if (is_any_closure(slot_value(slot))) - set_immutable(slot_value(slot)); /* for the optimizer mainly */ - } - goto START; + case OP_EVAL: + goto EVAL; + + case OP_QUOTE: sc->value = check_quote(sc, sc->code); continue; + + case OP_DEFINE_FUNCHECKED: define_funchecked(sc); continue; + case OP_DEFINE_CONSTANT1: op_define_constant1(sc); continue; case OP_DEFINE_CONSTANT: - if (op_define_constant(sc)) goto START; + if (op_define_constant(sc)) continue; case OP_DEFINE_STAR: case OP_DEFINE: @@ -87532,116 +89016,65 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) if (op_define_unchecked(sc)) goto TOP_NO_POP; case OP_DEFINE1: - if (op_define1(sc) == goto_APPLY) goto APPLY; + if (op_define1(sc) == goto_apply) goto APPLY; - case OP_DEFINE_WITH_SETTER: - op_define_with_setter(sc); - goto START; + case OP_DEFINE_WITH_SETTER: + op_define_with_setter(sc); + continue; - case OP_EVAL_STRING: - op_eval_string(sc); - goto EVAL; + case OP_EVAL_STRING: op_eval_string(sc); goto EVAL; /* -------------------------------- set! -------------------------------- */ - case OP_SET_PAIR_P: - op_set_pair_p(sc); - goto EVAL; - - case OP_SET_PAIR_A: - op_set_pair_a(sc); - goto START; - case OP_SET_LET_S: /* (set! (*s7* 'print-length) i) */ sc->code = cdr(sc->code); if (set_pair_p_3(sc, symbol_to_slot(sc, caar(sc->code)), cadr(cadar(sc->code)), lookup(sc, cadr(sc->code)))) goto APPLY; - goto START; + continue; case OP_SET_LET_FX: /* (set! (hook 'result) 123) or (set! (H 'c) 32) */ sc->code = cdr(sc->code); if (set_pair_p_3(sc, symbol_to_slot(sc, caar(sc->code)), cadr(cadar(sc->code)), fx_call(sc, cdr(sc->code)))) goto APPLY; - goto START; + continue; case OP_SET_PAIR_ZA: /* unknown setter pair, but value is easy */ sc->code = cdr(sc->code); sc->value = fx_call(sc, cdr(sc->code)); /* fall through */ + case OP_SET_PAIR_P_1: if (op_set_pair_p_1(sc)) goto APPLY; continue; + case OP_SET_PAIR: if (op_set_pair(sc)) goto APPLY; continue; - case OP_SET_PAIR_P_1: - if (op_set_pair_p_1(sc)) goto APPLY; - goto START; - - case OP_SET_DILAMBDA_SA_A: - op_set_dilambda_sa_a(sc); - goto START; - - case OP_SET_DILAMBDA_P: - op_set_dilambda_p(sc); - goto EVAL; - - case OP_SET_DILAMBDA: /* ([set!] (dilambda-setter g) s) */ - op_set_dilambda(sc); - /* fall through */ + case OP_SET_PAIR_P: op_set_pair_p(sc); goto EVAL; + case OP_SET_PAIR_A: op_set_pair_a(sc); continue; + case OP_SET_PWS: op_set_pws(sc); continue; + case OP_SET_DILAMBDA_SA_A: op_set_dilambda_sa_a(sc); continue; + case OP_SET_DILAMBDA_P: op_set_dilambda_p(sc); goto EVAL; + case OP_SET_DILAMBDA: op_set_dilambda(sc); /* fall through */ case OP_SET_DILAMBDA_P_1: - { - s7_pointer obj, func, arg; - arg = cadar(sc->code); - if (is_symbol(arg)) - arg = lookup_checked(sc, arg); - else - { - if (is_pair(arg)) - arg = cadr(arg); /* can only be (quote ...) in this case */ - } - obj = symbol_to_slot(sc, caar(sc->code)); - func = slot_value(obj); - if ((is_closure(func)) && - (is_safe_closure(closure_setter(func)))) - { - s7_pointer setter; - setter = closure_setter(func); - if (is_pair(closure_args(setter))) - { - sc->envir = old_frame_with_two_slots(sc, closure_let(setter), arg, sc->value); - sc->code = T_Pair(closure_body(setter)); - goto BEGIN; - } - } - if (set_pair_p_3(sc, obj, arg, sc->value)) - goto APPLY; - } - goto START; - - case OP_SET_PAIR: - if (op_set_pair(sc)) goto APPLY; - goto START; - - /* this is (set! (getter) val) where getter is a global c_function (a built-in pws) and val is not a pair */ - case OP_SET_PWS: /* (set! (mus-clipping) #f) */ - op_set_pws(sc); - goto START; - - case OP_INCREMENT_1: op_increment_by_1(sc); goto START; - case OP_DECREMENT_1: op_decrement_by_1(sc); goto START; - case OP_INCREMENT_SS: op_increment_ss(sc); goto START; - case OP_INCREMENT_SA: op_increment_sa(sc); goto START; - case OP_INCREMENT_SSS: op_increment_sss(sc); goto START; - case OP_INCREMENT_SAA: op_increment_saa(sc); goto START; + switch (op_set_dilambda_p_1(sc)) + { + case goto_begin: goto BEGIN; + case goto_apply: goto APPLY; + default: continue; + } + + case OP_INCREMENT_1: op_increment_by_1(sc); continue; + case OP_DECREMENT_1: op_decrement_by_1(sc); continue; + case OP_INCREMENT_SS: op_increment_ss(sc); continue; + case OP_INCREMENT_SA: op_increment_sa(sc); continue; + case OP_INCREMENT_SAA: op_increment_saa(sc); continue; case OP_INCREMENT_SP: op_increment_sp(sc); goto EVAL; - case OP_INCREMENT_SP_1: op_increment_sp_1(sc); goto START; - case OP_INCREMENT_SP_MV: op_increment_sp_mv(sc); goto START; - - case OP_SET_SYMBOL_C: op_set_symbol_c(sc); goto START; - case OP_SET_SYMBOL_S: op_set_symbol_s(sc); goto START; - case OP_SET_SYMBOL_A: op_set_symbol_a(sc); goto START; - case OP_SET_SYMBOL_opSq: op_set_symbol_opsq(sc); goto START; - case OP_SET_SYMBOL_opSSq: op_set_symbol_opssq(sc); goto START; + case OP_INCREMENT_SP_1: op_increment_sp_1(sc); continue; + case OP_INCREMENT_SP_MV: op_increment_sp_mv(sc); continue; + + case OP_SET_SYMBOL_C: op_set_symbol_c(sc); continue; + case OP_SET_SYMBOL_S: op_set_symbol_s(sc); continue; + case OP_SET_SYMBOL_A: op_set_symbol_a(sc); continue; case OP_SET_SYMBOL_P: op_set_symbol_p(sc); goto EVAL; - case OP_SET_CONS: op_set_cons(sc); goto START; - case OP_SET_SAFE: op_set_safe(sc); goto START; + case OP_SET_CONS: op_set_cons(sc); continue; + case OP_SET_SAFE: op_set_safe(sc); continue; case OP_SET2: if (op_set2(sc)) goto EVAL; @@ -87652,233 +89085,123 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_SET_UNCHECKED: set_current_code(sc, sc->code); if (is_pair(cadr(sc->code))) /* has setter */ - { - goto_t choice; - choice = set_implicit(sc); - if (choice == goto_TOP_NO_POP) goto TOP_NO_POP; - if (choice == goto_START) goto START; - if (choice == goto_APPLY) goto APPLY; - goto EVAL_ARGS; - } + switch (set_implicit(sc)) + { + case goto_top_no_pop: goto TOP_NO_POP; + case goto_start: continue; + case goto_apply: goto APPLY; + default: goto EVAL_ARGS; + } case OP_SET_NORMAL: if (op_set_normal(sc)) goto EVAL; case OP_SET1: - if (op_set1(sc)) goto START; + if (op_set1(sc)) continue; goto APPLY; case OP_SET_WITH_SETTER: if (is_immutable(sc->code)) immutable_object_error(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sc->code)); slot_set_value(sc->code, sc->value); - goto START; + continue; case OP_SET_WITH_LET_1: if (op_set_with_let_1(sc)) goto TOP_NO_POP; goto SET_WITH_LET; case OP_SET_WITH_LET_2: - if (op_set_with_let_2(sc)) goto START; + if (op_set_with_let_2(sc)) continue; SET_WITH_LET: activate_let(sc, sc->value); /* this activates sc->value, so the set! will happen in that environment */ if (is_pair(cadr(sc->code))) - { - goto_t choice; - choice = set_implicit(sc); - if (choice == goto_TOP_NO_POP) goto TOP_NO_POP; - if (choice == goto_START) goto START; - if (choice == goto_APPLY) goto APPLY; - goto EVAL_ARGS; - } + switch (set_implicit(sc)) + { + case goto_top_no_pop: goto TOP_NO_POP; + case goto_start: continue; + case goto_apply: goto APPLY; + default: goto EVAL_ARGS; + } s7_error(sc, sc->error_symbol, set_elist_2(sc, wrap_string(sc, "can't set ~S", 12), sc->args)); /* -------------------------------- if -------------------------------- */ - case OP_IF: - set_current_code(sc, sc->code); - check_if(sc); - push_stack_no_args(sc, OP_IF1, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_IF_UNCHECKED: - set_current_code(sc, sc->code); - push_stack_no_args(sc, OP_IF1, cddr(sc->code)); - sc->code = cadr(sc->code); - goto EVAL; - - case OP_IF1: - if (is_true(sc, sc->value)) - sc->code = car(sc->code); - else sc->code = unchecked_car(cdr(sc->code)); /* even pre-optimization, (if #f #f) ==> #<unspecified> because unique_car(sc->nil) = sc->unspecified */ - if (is_pair(sc->code)) - goto EVAL; - if (is_symbol(sc->code)) - sc->value = lookup_checked(sc, sc->code); - else sc->value = sc->code; - goto START; + case OP_IF: op_if(sc); goto EVAL; + case OP_IF_UNCHECKED: op_if_unchecked(sc); goto EVAL; + case OP_IF1: if (op_if1(sc)) goto EVAL; continue; #define IF_CASE(Op, Code, Not_Code) \ - case Op ## _P: sc->code = cdr(sc->code); Code {sc->code = cadr(sc->code); goto EVAL;} sc->value = sc->unspecified; goto START; \ - case Op ## _R: sc->code = cdr(sc->code); Code {sc->value = sc->unspecified; goto START;} sc->code = cadr(sc->code); goto EVAL; \ - case Op ## _P_P: sc->code = cdr(sc->code); Code {sc->code = cadr(sc->code); goto EVAL;} sc->code = caddr(sc->code); goto EVAL; \ - case Op ## _N: sc->code = cdr(sc->code); Not_Code {sc->code = cadr(sc->code); goto EVAL;} sc->value = sc->unspecified; goto START; \ - case Op ## _N_N: sc->code = cdr(sc->code); Not_Code {sc->code = cadr(sc->code); goto EVAL;} sc->code = caddr(sc->code); goto EVAL; + case Op ## _P: Code {sc->code = caddr(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; \ + case Op ## _R: Code {sc->value = sc->unspecified; continue;} sc->code = caddr(sc->code); goto EVAL; \ + case Op ## _P_P: Code {sc->code = caddr(sc->code); goto EVAL;} sc->code = cadddr(sc->code); goto EVAL; \ + case Op ## _N: Not_Code {sc->code = caddr(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; \ + case Op ## _N_N: Not_Code {sc->code = caddr(sc->code); goto EVAL;} sc->code = cadddr(sc->code); goto EVAL; IF_CASE(OP_IF_S, - if (is_true(sc, lookup(sc, car(sc->code)))), - if (is_false(sc, lookup(sc, cadar(sc->code))))) + if (is_true(sc, lookup(sc, cadr(sc->code)))), + if (is_false(sc, lookup(sc, cadadr(sc->code))))) IF_CASE(OP_IF_A, - if (is_true(sc, fx_call(sc, sc->code))), - if (is_false(sc, fx_call(sc, cdar(sc->code))))) - - IF_CASE(OP_IF_D, - if (is_true(sc, c_call(car(sc->code))(sc, opt2_pair(sc->code)))), - if (is_false(sc, c_call(cadar(sc->code))(sc, opt2_pair(sc->code))))) + if (is_true(sc, fx_call(sc, cdr(sc->code)))), + if (is_false(sc, fx_call(sc, cdadr(sc->code))))) IF_CASE(OP_IF_IS_TYPE_S, - if (gen_type_match(sc, lookup(sc, opt2_sym(sc->code)), opt3_con(sc->code))), - if (!gen_type_match(sc, lookup(sc, opt2_sym(sc->code)), opt3_con(sc->code)))) - - IF_CASE(OP_IF_IS_TYPE_opSq, - set_car(sc->t1_1, lookup(sc, opt2_sym(sc->code))); \ - if (gen_type_match(sc, c_call(cadar(sc->code))(sc, sc->t1_1), opt3_con(sc->code))), - set_car(sc->t1_1, lookup(sc, opt2_sym(sc->code))); \ - if (!gen_type_match(sc, c_call(cadr(cadar(sc->code)))(sc, sc->t1_1), opt3_con(sc->code)))) - - IF_CASE(OP_IF_CS, - set_car(sc->t1_1, lookup(sc, opt2_sym(sc->code))); if (is_true(sc, c_call(car(sc->code))(sc, sc->t1_1))), - set_car(sc->t1_1, lookup(sc, opt2_sym(sc->code))); if (is_false(sc, c_call(cadar(sc->code))(sc, sc->t1_1)))) - - IF_CASE(OP_IF_CSS, - set_car(sc->t2_1, lookup(sc, opt3_sym(sc->code))); \ - set_car(sc->t2_2, lookup(sc, opt2_sym(sc->code))); - if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))), - set_car(sc->t2_1, lookup(sc, opt3_sym(sc->code))); \ - set_car(sc->t2_2, lookup(sc, opt2_sym(sc->code))); - if (is_false(sc, c_call(cadar(sc->code))(sc, sc->t2_1)))) - - IF_CASE(OP_IF_CSC, - set_car(sc->t2_1, lookup(sc, opt3_sym(sc->code))); \ - set_car(sc->t2_2, opt2_con(sc->code)); \ - if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))), - set_car(sc->t2_1, lookup(sc, opt3_sym(sc->code))); \ - set_car(sc->t2_2, opt2_con(sc->code)); \ - if (is_false(sc, c_call(cadar(sc->code))(sc, sc->t2_1)))) - - IF_CASE(OP_IF_S_opDq, - set_car(sc->t2_2, d_call(sc, opt2_pair(sc->code))); \ - set_car(sc->t2_1, lookup(sc, opt3_sym(sc->code))); \ - if (is_true(sc, c_call(car(sc->code))(sc, sc->t2_1))), - set_car(sc->t2_2, d_call(sc, opt2_pair(sc->code))); \ - set_car(sc->t2_1, lookup(sc, opt3_sym(sc->code))); \ - if (is_false(sc, c_call(cadar(sc->code))(sc, sc->t2_1)))) + if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))), + if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code))))) + + IF_CASE(OP_IF_opSq, + set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, c_call(cadr(sc->code))(sc, sc->t1_1))), + set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_false(sc, c_call(cadadr(sc->code))(sc, sc->t1_1)))) + /* lg: A: opCSq: 0, fx_gt_ss: 9, and_pair_closure_s: 11, is_pair_cdr_s: 0, and_3: 77 + */ IF_CASE(OP_IF_AND2, - if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) && \ - (is_true(sc, fx_call(sc, opt3_pair(sc->code))))), - if ((is_false(sc, fx_call(sc, opt2_pair(sc->code)))) || \ - (is_false(sc, fx_call(sc, opt3_pair(sc->code)))))) - - IF_CASE(OP_IF_AND3, - if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) && \ - (is_true(sc, fx_call(sc, opt3_pair(sc->code)))) && \ - (is_true(sc, fx_call(sc, cdr(opt3_pair(sc->code)))))), - if ((is_false(sc, fx_call(sc, opt2_pair(sc->code)))) || \ - (is_false(sc, fx_call(sc, opt3_pair(sc->code)))) || \ - (is_false(sc, fx_call(sc, cdr(opt3_pair(sc->code))))))) + if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))), + if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))))) IF_CASE(OP_IF_OR2, - if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) || \ - (is_true(sc, fx_call(sc, opt3_pair(sc->code))))), - if ((is_false(sc, fx_call(sc, opt2_pair(sc->code)))) && \ - (is_false(sc, fx_call(sc, opt3_pair(sc->code)))))) - - case OP_IF_P_P: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PP, opt2_any(sc->code)); sc->code = opt3_any(sc->code); goto EVAL; - case OP_IF_P_N: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PR, opt2_any(sc->code)); sc->code = opt3_any(sc->code); goto EVAL; - case OP_IF_P_R: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PR, opt2_any(sc->code)); sc->code = opt3_any(sc->code); goto EVAL; - case OP_IF_P_P_P: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PPP, opt2_any(sc->code)); sc->code = opt3_any(sc->code); goto EVAL; - case OP_IF_P_N_N: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PRR, opt2_any(sc->code)); sc->code = opt3_any(sc->code); goto EVAL; - - case OP_IF_ANDP_P: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PP, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto AND_P; - case OP_IF_ANDP_N: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PR, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto AND_P; - case OP_IF_ANDP_R: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PR, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto AND_P; - case OP_IF_ANDP_P_P: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PPP, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto AND_P; - case OP_IF_ANDP_N_N: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PRR, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto AND_P; - - case OP_IF_ORP_P: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PP, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto OR_P; - case OP_IF_ORP_N: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PR, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto OR_P; - case OP_IF_ORP_R: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PR, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto OR_P; - case OP_IF_ORP_P_P: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PPP, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto OR_P; - case OP_IF_ORP_N_N: sc->code = cdr(sc->code); push_stack_no_args(sc, OP_IF_PRR, opt2_any(sc->code)); sc->code = opt3_pair(sc->code); goto OR_P; - - case OP_IF_PP: - if (is_true(sc, sc->value)) - goto EVAL; - sc->value = sc->unspecified; - goto START; - - case OP_IF_PPP: - if (is_true(sc, sc->value)) - sc->code = car(sc->code); - else sc->code = cadr(sc->code); - goto EVAL; - - case OP_IF_PR: - if (is_false(sc, sc->value)) - goto EVAL; - sc->value = sc->unspecified; - goto START; - - case OP_IF_PRR: - if (is_false(sc, sc->value)) - sc->code = car(sc->code); - else sc->code = cadr(sc->code); - goto EVAL; - - case OP_COND_FEED: - /* (cond (expr => p)) where p is (lambda (s) ...) -- see check_cond */ - set_current_code(sc, sc->code); - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - push_stack_no_args(sc, OP_COND_FEED_1, sc->code); - sc->code = caar(sc->code); - goto EVAL; - } - - case OP_COND_FEED_1: - if (is_true(sc, sc->value)) - { - if (is_multiple_value(sc->value)) - sc->code = cons(sc, opt2_lambda(sc->code), multiple_value(sc->value)); - else - { - new_frame_with_slot(sc, sc->envir, sc->envir, caadr(opt2_lambda(sc->code)), sc->value); - sc->code = caddr(opt2_lambda(sc->code)); - } - goto EVAL; - } - sc->value = sc->unspecified; /* it's cond -- perhaps push as sc->args above; this was nil until 21-Feb-17! */ - goto START; + if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))), + if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))))) + + case OP_IF_P_P: push_stack_no_args(sc, OP_IF_PP, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL; + case OP_IF_P_N: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL; + case OP_IF_P_R: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL; + case OP_IF_P_P_P: push_stack_no_args(sc, OP_IF_PPP, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL; + case OP_IF_P_N_N: push_stack_no_args(sc, OP_IF_PRR, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code)); goto EVAL; + + case OP_IF_ANDP_P: push_stack_no_args(sc, OP_IF_PP, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P; + case OP_IF_ANDP_N: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P; + case OP_IF_ANDP_R: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P; + case OP_IF_ANDP_P_P: push_stack_no_args(sc, OP_IF_PPP, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P; + case OP_IF_ANDP_N_N: push_stack_no_args(sc, OP_IF_PRR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto AND_P; + + case OP_IF_ORP_P: push_stack_no_args(sc, OP_IF_PP, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P; + case OP_IF_ORP_N: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P; + case OP_IF_ORP_R: push_stack_no_args(sc, OP_IF_PR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P; + case OP_IF_ORP_P_P: push_stack_no_args(sc, OP_IF_PPP, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P; + case OP_IF_ORP_N_N: push_stack_no_args(sc, OP_IF_PRR, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code)); goto OR_P; + + case OP_IF_PP: if (sc->value != sc->F) goto EVAL; sc->value = sc->unspecified; continue; + case OP_IF_PPP: sc->code = (sc->value != sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; + case OP_IF_PR: if (sc->value == sc->F) goto EVAL; sc->value = sc->unspecified; continue; + case OP_IF_PRR: sc->code = (sc->value == sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; + + case OP_COND_FEED: if (op_cond_feed(sc)) goto EVAL; /* else fall through */ + case OP_COND_FEED_1: if (op_cond_feed_1(sc)) goto EVAL; continue; /* -------------------------------- when, unless -------------------------------- */ case OP_WHEN: check_when(sc); goto EVAL; - case OP_WHEN_S: if (op_when_s(sc)) goto START; goto EVAL; - case OP_WHEN_A: if (op_when_a(sc)) goto START; goto EVAL; + case OP_WHEN_S: if (op_when_s(sc)) continue; goto EVAL; + case OP_WHEN_A: if (op_when_a(sc)) continue; goto EVAL; case OP_WHEN_P: op_when_p(sc); goto EVAL; - case OP_WHEN_AND_AP: if (op_when_and_ap(sc)) goto START; goto EVAL; - case OP_WHEN_PP: if (op_when_pp(sc)) goto START; goto EVAL; + case OP_WHEN_AND_AP: if (op_when_and_ap(sc)) continue; goto EVAL; + case OP_WHEN_PP: if (op_when_pp(sc)) continue; goto EVAL; case OP_UNLESS: check_unless(sc); goto EVAL; - case OP_UNLESS_S: if (op_unless_s(sc)) goto START; goto EVAL; - case OP_UNLESS_A: if (op_unless_a(sc)) goto START; goto EVAL; + case OP_UNLESS_S: if (op_unless_s(sc)) continue; goto EVAL; + case OP_UNLESS_A: if (op_unless_a(sc)) continue; goto EVAL; case OP_UNLESS_P: op_unless_p(sc); goto EVAL; - case OP_UNLESS_PP: if (op_unless_pp(sc)) goto START; goto EVAL; + case OP_UNLESS_PP: if (op_unless_pp(sc)) continue; goto EVAL; /* -------------------------------- let -------------------------------- */ case OP_NAMED_LET_NO_VARS: op_named_let_no_vars(sc); goto BEGIN; @@ -87890,10 +89213,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_LET1: if (op_let1(sc)) goto BEGIN; goto EVAL; case OP_LET_NO_VARS: op_let_no_vars(sc); goto BEGIN; - case OP_LET_A_A_OLD: op_let_a_a_old(sc); goto START; - case OP_LET_A_A_NEW: op_let_a_a_new(sc); goto START; - case OP_LET_A_FX_OLD: op_let_a_fx_old(sc); goto START; - case OP_LET_A_FX_NEW: op_let_a_fx_new(sc); goto START; + case OP_LET_A_A_OLD: op_let_a_a_old(sc); continue; + case OP_LET_A_A_NEW: op_let_a_a_new(sc); continue; + case OP_LET_A_FX_OLD: op_let_a_fx_old(sc); continue; + case OP_LET_A_FX_NEW: op_let_a_fx_new(sc); continue; case OP_LET_FX_OLD: op_let_fx_old(sc); goto BEGIN; case OP_LET_FX_NEW: op_let_fx_new(sc); goto BEGIN; case OP_LET_FX_2_OLD: op_let_fx_2_old(sc); goto EVAL; @@ -87907,36 +89230,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_LET_A_OLD: op_let_a_old(sc); sc->code = cdr(sc->code); goto BEGIN; case OP_LET_A_NEW: op_let_a_new(sc); sc->code = cdr(sc->code); goto BEGIN; + case OP_LET_A_OLD_2: op_let_a_old(sc); push_stack_no_args(sc, OP_BEGIN_1, cddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; + case OP_LET_A_NEW_2: op_let_a_new(sc); push_stack_no_args(sc, OP_BEGIN_1, cddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; case OP_LET_A_P_OLD: op_let_a_old(sc); sc->code = cadr(sc->code); goto EVAL; case OP_LET_A_P_NEW: op_let_a_new(sc); sc->code = cadr(sc->code); goto EVAL; - - case OP_LET_ONE_NEW_1: - new_frame_with_slot(sc, sc->envir, sc->envir, sc->args, sc->value); - goto BEGIN; - - case OP_LET_ONE_P_NEW_1: - new_frame_with_slot(sc, sc->envir, sc->envir, sc->args, sc->value); - goto EVAL; - - case OP_LET_ONE_OLD_1: - { - s7_pointer frame; - frame = old_frame_with_slot(sc, opt3_let(sc->code), sc->value); - set_outlet(frame, sc->envir); - sc->envir = frame; - sc->code = cdr(sc->code); - goto BEGIN; - } - - case OP_LET_ONE_P_OLD_1: - { - s7_pointer frame; - frame = old_frame_with_slot(sc, opt3_let(sc->code), sc->value); - set_outlet(frame, sc->envir); - sc->envir = frame; - sc->code = cadr(sc->code); - goto EVAL; - } + case OP_LET_ONE_OLD_1: op_let_one_old_1(sc); goto BEGIN; + case OP_LET_ONE_P_OLD_1: op_let_one_p_old_1(sc); goto EVAL; + case OP_LET_ONE_NEW_1: new_frame_with_slot(sc, sc->envir, sc->envir, sc->args, sc->value); goto BEGIN; + case OP_LET_ONE_P_NEW_1: new_frame_with_slot(sc, sc->envir, sc->envir, sc->args, sc->value); goto EVAL; case OP_LET_opSSq_OLD: op_let_opssq_old(sc); goto BEGIN; case OP_LET_opSSq_NEW: op_let_opssq_new(sc); goto BEGIN; @@ -87949,8 +89250,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_LET_STAR_FX_OLD: op_let_star_fx_old(sc); goto BEGIN; case OP_LET_STAR_FX_NEW: op_let_star_fx_new(sc); goto BEGIN; - case OP_LET_STAR_FX_A_OLD: op_let_star_fx_a_old(sc); goto START; - case OP_LET_STAR_FX_A_NEW: op_let_star_fx_a_new(sc); goto START; + case OP_LET_STAR_FX_A_OLD: op_let_star_fx_a_old(sc); continue; + case OP_LET_STAR_FX_A_NEW: op_let_star_fx_a_new(sc); continue; case OP_NAMED_LET_STAR: op_named_let_star(sc); goto EVAL; case OP_LET_STAR2: op_let_star2(sc); goto EVAL; @@ -87979,82 +89280,42 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) if (op_let_temp_init1(sc)) goto EVAL; case OP_LET_TEMP_INIT2: - { - s7_pointer val; - val = op_let_temp_init2(sc); - if (!val) - { - sc->cur_op = OP_SET_UNCHECKED; - goto TOP_NO_POP; - } - if (val == sc->unused) goto BEGIN; - } + 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; + default: break; + } case OP_LET_TEMP_DONE: push_stack(sc, OP_GC_PROTECT, sc->args, sc->value); case OP_LET_TEMP_DONE1: - if (op_let_temp_done1(sc)) goto START; + if (op_let_temp_done1(sc)) continue; goto EVAL; - - case OP_LET_TEMP_S7: - op_let_temp_s7(sc); - goto BEGIN; - - case OP_LET_TEMP_FX: - op_let_temp_fx(sc); - goto BEGIN; + case OP_LET_TEMP_S7: op_let_temp_s7(sc); goto BEGIN; + case OP_LET_TEMP_FX: op_let_temp_fx(sc); goto BEGIN; + case OP_LET_TEMP_FX_1: op_let_temp_fx_1(sc); goto BEGIN; + case OP_LET_TEMP_SETTER: op_let_temp_setter(sc); goto BEGIN; case OP_LET_TEMP_UNWIND: op_let_temp_unwind(sc, sc->code, sc->args); if (is_multiple_value(sc->value)) sc->value = splice_in_values(sc, multiple_value(sc->value)); - goto START; + continue; case OP_LET_TEMP_S7_UNWIND: g_s7_let_set_fallback(sc, set_plist_3(sc, sc->s7_let, sc->code, sc->args)); if (is_multiple_value(sc->value)) sc->value = splice_in_values(sc, multiple_value(sc->value)); - goto START; - - - /* -------------------------------- => -------------------------------- */ - FEED_TO: - if (is_multiple_value(sc->value)) /* (cond ((values 1 2) => +)) */ - { - sc->args = multiple_value(sc->value); - clear_multiple_value(sc->args); - } - else - { - if (is_symbol(cadr(sc->code))) - { - s7_pointer func; - func = lookup_checked(sc, cadr(sc->code)); /* car is => */ - if ((is_c_function(func)) && - (is_safe_procedure(func))) - { - if ((c_function_required_args(func) <= 1) && - (c_function_all_args(func) >= 1)) - { - sc->value = c_function_call(func)(sc, set_plist_1(sc, sc->value)); - goto START; - } - } - sc->code = func; - sc->args = (needs_copied_args(func)) ? list_1(sc, sc->value) : set_plist_1(sc, sc->value); - goto APPLY; - } - sc->args = list_1(sc, sc->value); /* not plist here */ - } - push_stack(sc, OP_FEED_TO_1, sc->args, sc->code); - sc->code = cadr(sc->code); /* need to evaluate the target function */ - goto EVAL; + continue; - case OP_FEED_TO_1: - sc->code = sc->value; - goto APPLY; + case OP_LET_TEMP_SETTER_UNWIND: + slot_set_setter(sc->code, sc->args); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + continue; /* -------------------------------- cond -------------------------------- */ case OP_COND: @@ -88065,7 +89326,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_COND1: if (op_cond1(sc)) goto TOP_NO_POP; - goto FEED_TO; + /* fall through */ + + FEED_TO: + if (feed_to(sc)) goto APPLY; + goto EVAL; + + case OP_FEED_TO_1: + sc->code = sc->value; + goto APPLY; /* sc->args saved in feed_to via push_stack */ case OP_COND_SIMPLE: /* no => */ if (op_cond_simple(sc)) goto EVAL; @@ -88077,46 +89346,32 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_COND_SIMPLE_P: /* no =>, no null or multiform consequent */ if (op_cond_simple_p(sc)) goto EVAL; - case OP_COND1_SIMPLE_P: - if (op_cond1_simple_p(sc)) goto START; - goto EVAL; - - case OP_COND_FX: - if (op_cond_fx(sc)) goto START; - goto BEGIN; - - case OP_COND_FX_2: - if (op_cond_fx_2(sc)) goto START; - goto BEGIN; - - case OP_COND_FX_P: - if (op_cond_fx_p(sc)) goto START; - goto EVAL; - - case OP_COND_FX_1P_ELSE: - if (op_cond_fx_1p_else(sc)) goto START; + case OP_COND1_SIMPLE_P: + if (op_cond1_simple_p(sc)) continue; goto EVAL; - case OP_COND_FX_2P_ELSE: - if (op_cond_fx_2p_else(sc)) goto START; - goto EVAL; + case OP_COND_FX: if (op_cond_fx(sc)) continue; goto BEGIN; + case OP_COND_FX_2: if (op_cond_fx_2(sc)) continue; goto BEGIN; + case OP_COND_FX_P: if (op_cond_fx_p(sc)) continue; goto EVAL; + case OP_COND_FX_1P_ELSE: if (op_cond_fx_1p_else(sc)) continue; goto EVAL; + case OP_COND_FX_2P_ELSE: if (op_cond_fx_2p_else(sc)) continue; goto EVAL; /* -------------------------------- and -------------------------------- */ case OP_AND: set_current_code(sc, sc->code); - if (check_and(sc)) goto START; + if (check_and(sc)) continue; case OP_AND_P: sc->code = cdr(sc->code); AND_P: if (has_fx(sc->code)) /* all c_callee's are set via fx_choose which can return nil, but it is not cleared when type is */ - { /* so, if (c_callee(sc->code)) here and in OR_P is not safe */ + { /* so, if (c_callee(sc->code)) here and in OR_P is not safe */ sc->value = fx_call(sc, sc->code); if (is_false(sc, sc->value)) - goto START; + continue; sc->code = cdr(sc->code); if (is_null(sc->code)) - goto START; + continue; goto AND_P; } if (is_not_null(cdr(sc->code))) @@ -88127,59 +89382,31 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_AND_P1: if ((is_false(sc, sc->value)) || (is_null(sc->code))) - goto START; + continue; goto AND_P; - case OP_AND_SAFE_P1: /* sc->code: (and (func...) (fx...)...) */ - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_AND_SAFE_P_REST, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_AND_SAFE_P2: - sc->value = fx_call(sc, cdr(sc->code)); - if (is_false(sc, sc->value)) goto START; - sc->code = cddr(sc->code); - push_stack_no_args(sc, OP_AND_SAFE_P_REST, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_AND_SAFE_P3: - sc->value = fx_call(sc, cdr(sc->code)); - if (is_false(sc, sc->value)) goto START; - sc->code = cddr(sc->code); - sc->value = fx_call(sc, sc->code); - if (is_false(sc, sc->value)) goto START; - sc->code = cadr(sc->code); - goto EVAL; + case OP_AND_AP: if (op_and_ap(sc)) continue; goto EVAL; + case OP_AND_PAIR_P: if (op_and_pair_p(sc)) continue; goto EVAL; + case OP_AND_SAFE_AA: op_and_safe_aa(sc); continue; + case OP_AND_SAFE_P1: op_and_safe_p1(sc); goto EVAL; + case OP_AND_SAFE_P2: if (op_and_safe_p2(sc)) continue; goto EVAL; + case OP_AND_SAFE_P3: if (op_and_safe_p3(sc)) continue; goto EVAL; case OP_AND_SAFE_P_REST: /* cdr(sc->code) is known to be a pair (and was pushed => sc->code) */ if (is_false(sc, sc->value)) - goto START; + continue; op_and_safe_p(sc); - goto START; + continue; case OP_AND_SAFE_P: sc->code = cdr(sc->code); op_and_safe_p(sc); - goto START; - - case OP_AND_AP: - if (op_and_ap(sc)) goto START; - goto EVAL; - - case OP_AND_PAIR_P: - if (op_and_pair_p(sc)) goto START; - goto EVAL; - - case OP_AND_SAFE_AA: - op_and_safe_aa(sc); - goto START; + continue; /* -------------------------------- or -------------------------------- */ case OP_OR: set_current_code(sc, sc->code); - if (check_or(sc)) goto START; + if (check_or(sc)) continue; case OP_OR_P: sc->code = cdr(sc->code); @@ -88188,10 +89415,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) { sc->value = fx_call(sc, sc->code); if (is_true(sc, sc->value)) - goto START; + continue; sc->code = cdr(sc->code); if (is_null(sc->code)) - goto START; + continue; goto OR_P; } if (is_not_null(cdr(sc->code))) @@ -88202,229 +89429,72 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case OP_OR_P1: if ((is_true(sc, sc->value)) || (is_null(sc->code))) - goto START; + continue; goto OR_P; - case OP_OR_AP: - if (op_or_ap(sc)) goto START; - goto EVAL; - - case OP_OR_SAFE_AA: - op_or_safe_aa(sc); - goto START; + case OP_OR_AP: if (op_or_ap(sc)) continue; goto EVAL; + case OP_OR_SAFE_AA: op_or_safe_aa(sc); continue; /* -------------------------------- macro evaluation -------------------------------- */ - case OP_EVAL_MACRO: /* after (scheme-side) macroexpansion, evaluate the resulting expression */ - op_eval_macro(sc); - goto EVAL; - - case OP_EVAL_MACRO_MV: - if (op_eval_macro_mv(sc)) goto START; - goto EVAL; - - case OP_EXPANSION: - /* after the expander has finished, if a list was returned, we need to add some annotations. - * if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*). - */ - if (sc->value == sc->no_value) - sc->stack_end[-1] = (s7_pointer)OP_READ_NEXT; - else - { - if (is_pair(sc->value)) - sc->value = copy_body(sc, sc->value); - } - goto START; - - case OP_DEFINE_MACRO_WITH_SETTER: - op_define_macro_with_setter(sc); - goto START; - - case OP_DEFINE_BACRO: - case OP_DEFINE_BACRO_STAR: - case OP_DEFINE_EXPANSION: - case OP_DEFINE_EXPANSION_STAR: - case OP_DEFINE_MACRO: - case OP_DEFINE_MACRO_STAR: - if (op_define_macro(sc)) goto START; + case OP_EVAL_MACRO: op_eval_macro(sc); goto EVAL; + case OP_EVAL_MACRO_MV: if (op_eval_macro_mv(sc)) continue; goto EVAL; + case OP_EXPANSION: op_finish_expansion(sc); continue; + case OP_DEFINE_MACRO_WITH_SETTER: op_define_macro_with_setter(sc); continue; + + case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: + case OP_DEFINE_EXPANSION: case OP_DEFINE_EXPANSION_STAR: + case OP_DEFINE_MACRO: case OP_DEFINE_MACRO_STAR: + if (op_define_macro(sc)) continue; goto APPLY; - case OP_LAMBDA: - set_current_code(sc, sc->code); - check_lambda(sc); - make_closure_with_let(sc, sc->value, car(sc->code), cdr(sc->code), sc->envir, CLOSURE_ARITY_NOT_SET); /* sc->value=new closure cell, car=args, cdr=body */ - goto START; + case OP_LAMBDA: op_lambda(sc); continue; + case OP_LAMBDA_UNCHECKED: op_lambda_unchecked(sc); continue; - case OP_LAMBDA_UNCHECKED: /* pre-calculating type/arity in check_lambda was slower?? */ - set_current_code(sc, sc->code); - make_closure_with_let(sc, sc->value, cadr(sc->code), cddr(sc->code), sc->envir, CLOSURE_ARITY_NOT_SET); /* sc->value=new closure cell, car=args, cdr=body */ - goto START; + case OP_LAMBDA_STAR: op_lambda_star(sc); continue; + case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc); continue; - case OP_LAMBDA_STAR: - set_current_code(sc, sc->code); - check_lambda_star(sc); - sc->value = make_closure(sc, car(sc->code), cdr(sc->code), (!is_pair(car(sc->code))) ? T_CLOSURE : T_CLOSURE_STAR, CLOSURE_ARITY_NOT_SET); - goto START; - - case OP_LAMBDA_STAR_UNCHECKED: - set_current_code(sc, sc->code); - sc->code = cdr(sc->code); - sc->value = make_closure(sc, car(sc->code), cdr(sc->code), (!is_pair(car(sc->code))) ? T_CLOSURE : T_CLOSURE_STAR, CLOSURE_ARITY_NOT_SET); - goto START; /* -------------------------------- case -------------------------------- */ - case OP_CASE: /* case, car(sc->code) is the selector */ - if (check_case(sc)) goto EVAL; - /* else drop into CASE_G_G -- selector is a symbol or constant */ - - CASE_G_G: - case OP_CASE_G_G: - if (op_case_g_g(sc)) goto TOP_NO_POP; - goto FEED_TO; - + case OP_CASE: /* car(sc->code) is the selector */ /* selector A, key type: E=eq (symbol/char), I=integer, G=any, S=single keys and single bodies */ - case OP_CASE_A_E_S: - sc->code = cdr(sc->code); - sc->value = fx_call(sc, sc->code); - goto CASE_E_S; - - case OP_CASE_A_S_S: - sc->code = cdr(sc->code); - sc->value = fx_call(sc, sc->code); - goto CASE_S_S; - - case OP_CASE_A_I_S: - sc->code = cdr(sc->code); - sc->value = fx_call(sc, sc->code); - goto CASE_I_S; - - case OP_CASE_A_E_G: - sc->code = cdr(sc->code); - sc->value = fx_call(sc, sc->code); - goto CASE_E_G; - - case OP_CASE_A_S_G: - sc->code = cdr(sc->code); - sc->value = fx_call(sc, sc->code); - goto CASE_S_G; - - case OP_CASE_A_G_G: - sc->code = cdr(sc->code); - sc->value = fx_call(sc, sc->code); - goto CASE_G_G; - - case OP_CASE_S_G_S: - sc->code = cdr(sc->code); - sc->value = lookup_checked(sc, car(sc->code)); - goto CASE_G_S; - - case OP_CASE_S_G_G: - sc->code = cdr(sc->code); - sc->value = lookup_checked(sc, car(sc->code)); - goto CASE_G_G; - - /* selector = any */ - case OP_CASE_P_E_S: - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_CASE_E_S, sc->code); - sc->code = car(sc->code); - goto EVAL; - - case OP_CASE_P_S_S: - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_CASE_S_S, sc->code); - sc->code = car(sc->code); - goto EVAL; - - case OP_CASE_P_I_S: - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_CASE_I_S, sc->code); - sc->code = car(sc->code); - goto EVAL; - - case OP_CASE_P_G_S: - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_CASE_G_S, sc->code); - sc->code = car(sc->code); - goto EVAL; - - case OP_CASE_P_E_G: - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_CASE_E_G, sc->code); - sc->code = car(sc->code); - goto EVAL; - - case OP_CASE_P_S_G: - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_CASE_S_G, sc->code); - sc->code = car(sc->code); - goto EVAL; - - case OP_CASE_P_G_G: - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_CASE_G_G, sc->code); - sc->code = car(sc->code); - goto EVAL; - - case OP_CASE_S_E_S: - sc->code = cdr(sc->code); - sc->value = lookup_checked(sc, car(sc->code)); - /* goto CASE_E_S; */ - - CASE_E_S: - case OP_CASE_E_S: - op_case_e_s(sc); - goto EVAL; - - case OP_CASE_S_S_S: - sc->code = cdr(sc->code); - sc->value = lookup_checked(sc, car(sc->code)); - /* goto CASE_S_S; */ - - CASE_S_S: - case OP_CASE_S_S: - op_case_s_s(sc); - goto EVAL; + if (check_case(sc)) goto EVAL; /* else drop into CASE_G_G -- selector is a symbol or constant */ - case OP_CASE_S_I_S: - sc->code = cdr(sc->code); - sc->value = lookup_checked(sc, car(sc->code)); - /* goto CASE_I_S; */ - - CASE_I_S: - case OP_CASE_I_S: - if (op_case_i_s(sc)) goto START; - goto EVAL; + case OP_CASE_G_G: if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; + case OP_CASE_A_G_G: sc->value = fx_call(sc, cdr(sc->code)); if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; + case OP_CASE_S_G_G: sc->value = lookup_checked(sc, cadr(sc->code)); if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; + + case OP_CASE_P_G_G: push_stack_no_args(sc, OP_CASE_G_G, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_E_S: push_stack_no_args(sc, OP_CASE_E_S, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_S_S: push_stack_no_args(sc, OP_CASE_S_S, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_I_S: push_stack_no_args(sc, OP_CASE_I_S, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_G_S: push_stack_no_args(sc, OP_CASE_G_S, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_E_G: push_stack_no_args(sc, OP_CASE_E_G, sc->code); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_S_G: push_stack_no_args(sc, OP_CASE_S_G, sc->code); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_A_G_S: - sc->code = cdr(sc->code); - sc->value = fx_call(sc, sc->code); - /* goto CASE_G_S; */ + case OP_CASE_A_E_S: sc->value = fx_call(sc, cdr(sc->code)); op_case_e_s(sc); goto EVAL; + case OP_CASE_S_E_S: sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_E_S: op_case_e_s(sc); goto EVAL; - CASE_G_S: - case OP_CASE_G_S: - op_case_g_s(sc); - goto EVAL; + case OP_CASE_A_S_S: sc->value = fx_call(sc, cdr(sc->code)); op_case_s_s(sc); goto EVAL; + case OP_CASE_S_S_S: sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_S_S: op_case_s_s(sc); goto EVAL; - case OP_CASE_S_E_G: - sc->code = cdr(sc->code); - sc->value = lookup_checked(sc, car(sc->code)); - /* goto CASE_E_G; */ + case OP_CASE_A_I_S: sc->value = fx_call(sc, cdr(sc->code)); if (op_case_i_s(sc)) continue; goto EVAL; + case OP_CASE_S_I_S: sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_I_S: if (op_case_i_s(sc)) continue; goto EVAL; - CASE_E_G: - case OP_CASE_E_G: - if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto TOP_NO_POP; - goto FEED_TO; + case OP_CASE_S_G_S: sc->value = lookup_checked(sc, cadr(sc->code)); op_case_g_s(sc); goto EVAL; + case OP_CASE_A_G_S: sc->value = fx_call(sc, cdr(sc->code)); /* fall through */ + case OP_CASE_G_S: op_case_g_s(sc); goto EVAL; - case OP_CASE_S_S_G: - sc->code = cdr(sc->code); - sc->value = lookup_checked(sc, car(sc->code)); - /* goto CASE_S_G; */ + case OP_CASE_A_E_G: sc->value = fx_call(sc, cdr(sc->code)); if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto TOP_NO_POP; goto FEED_TO; + case OP_CASE_S_E_G: sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_E_G: if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto TOP_NO_POP; goto FEED_TO; - CASE_S_G: - case OP_CASE_S_G: - if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto TOP_NO_POP; - goto FEED_TO; + case OP_CASE_A_S_G: sc->value = fx_call(sc, cdr(sc->code)); if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto TOP_NO_POP; goto FEED_TO; + case OP_CASE_S_S_G: sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_S_G: if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto TOP_NO_POP; goto FEED_TO; case OP_ERROR_QUIT: @@ -88433,70 +89503,43 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) return(sc->F); case OP_ERROR_HOOK_QUIT: - sc->error_hook = sc->code; /* restore old value */ - - /* now mimic the end of the normal error handler. Since this error hook evaluation can happen - * in an arbitrary s7_call nesting, we can't just return from the current evaluation -- - * we have to jump to the original (top-level) call. Otherwise '#<unspecified> or whatever - * is simply treated as the (non-error) return value, and the higher level evaluations - * get confused. - */ - stack_reset(sc); /* is this necessary? is it a good idea?? */ - push_stack_op(sc, OP_ERROR_QUIT); /* added 3-Dec-16: try to make sure we actually exit! */ - sc->cur_op = OP_ERROR_QUIT; - if (sc->longjmp_ok) longjmp(sc->goto_start, ERROR_QUIT_JUMP); + op_error_hook_quit(sc); #if S7_DEBUGGING fprintf(stderr, "%d: op_error_hook_quit did not jump, returns %s\n", __LINE__, DISPLAY(sc->value)); #endif - return(sc->value); /* not executed I hope */ - case OP_EVAL_DONE: /* this is the "time to quit" operator */ + case OP_EVAL_DONE: /* this is the "time to quit" operator */ return(sc->F); case OP_GC_PROTECT: case OP_BARRIER: - case OP_CATCH_ALL: - case OP_CATCH: - case OP_CATCH_1: - case OP_CATCH_2: - goto START; - - case OP_DEACTIVATE_GOTO: - call_exit_active(sc->args) = false; /* as we leave the call-with-exit body, deactivate the exiter */ - goto START; + case OP_CATCH_ALL: case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: + continue; case OP_GET_OUTPUT_STRING: /* from call-with-output-string and with-output-to-string -- return the port string directly */ op_get_output_string(sc); /* fall through */ - case OP_UNWIND_OUTPUT: - op_unwind_output(sc); - goto START; - - case OP_UNWIND_INPUT: - op_unwind_input(sc); - goto START; + case OP_UNWIND_OUTPUT: + op_unwind_output(sc); + continue; - case OP_DYNAMIC_WIND: - if (op_dynamic_wind(sc) == goto_APPLY) goto APPLY; - goto START; + case OP_UNWIND_INPUT: op_unwind_input(sc); continue; + case OP_DYNAMIC_WIND: if (op_dynamic_wind(sc) == goto_apply) goto APPLY; continue; + case OP_DEACTIVATE_GOTO: call_exit_active(sc->args) = false; continue; /* deactivate the exiter */ - /* -------------------------------- with-let -------------------------------- - * - * the extra set! to pull in args, or fixup the outlet is annoying, but - * but with-let is hard to do right -- what if env is chained as in class/objects? - */ - case OP_WITH_LET_S: - op_with_let_s(sc); + /* -------------------------------- with-let -------------------------------- */ + case OP_WITH_LET_S: + op_with_let_s(sc); goto BEGIN; - case OP_WITH_LET: + case OP_WITH_LET: check_with_let(sc); - case OP_WITH_LET_UNCHECKED: + case OP_WITH_LET_UNCHECKED: if (op_with_let_unchecked(sc)) goto EVAL; - case OP_WITH_LET1: + case OP_WITH_LET1: activate_let(sc, sc->value); goto BEGIN; @@ -88505,15 +89548,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) check_with_baffle(sc); case OP_WITH_BAFFLE_UNCHECKED: - if (op_with_baffle_unchecked(sc)) goto START; + if (op_with_baffle_unchecked(sc)) continue; goto BEGIN; /* -------------------------------- the reader -------------------------------- */ - case OP_READ_INTERNAL: op_read_internal(sc); goto START; - case OP_READ_DONE: op_read_done(sc); goto START; + case OP_READ_INTERNAL: op_read_internal(sc); continue; + case OP_READ_DONE: op_read_done(sc); continue; case OP_LOAD_RETURN_IF_EOF: if (op_load_return_if_eof(sc)) goto EVAL; return(sc->F); - case OP_LOAD_CLOSE_AND_POP_IF_EOF: if (op_load_close_and_pop_if_eof(sc)) goto EVAL; goto START; + case OP_LOAD_CLOSE_AND_POP_IF_EOF: if (op_load_close_and_pop_if_eof(sc)) goto EVAL; continue; POP_READ_LIST: /* push-stack OP_READ_LIST is always no_code and op is always OP_READ_LIST (and not used), sc->envir is apparently not needed here */ @@ -88631,7 +89674,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) check_stack_size(sc); sc->value = read_expression(sc); if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - goto START; + continue; case ')': sc->tok = TOKEN_RIGHT_PAREN; @@ -88645,7 +89688,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) sc->tok = TOKEN_QUOTE; push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); sc->value = read_expression(sc); - goto START; + continue; case ';': sc->tok = port_read_semicolon(pt)(sc, pt); @@ -88653,12 +89696,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) case '"': sc->tok = TOKEN_DOUBLE_QUOTE; - sc->value = read_string_constant(sc, pt); - if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */ - return(string_read_error(sc, "end of input encountered while in a string")); - if (sc->value == sc->T) - read_error(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); + read_double_quote(sc); goto READ_LIST; case '`': @@ -88666,13 +89704,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); sc->value = read_expression(sc); if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - goto START; + continue; case ',': sc->tok = read_comma(sc, pt); /* at_mark or comma */ push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); sc->value = read_expression(sc); - goto START; + continue; case '#': sc->tok = read_sharp(sc, pt); @@ -88696,12 +89734,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) /* sc->args can't be null here */ sc->value = safe_reverse_in_place(sc, sc->args); if ((is_expansion(car(sc->value))) && - (op_expansion(sc) == goto_APPLY)) + (op_expansion(sc) == goto_apply)) { push_stack_no_code(sc, OP_EXPANSION, sc->nil); new_frame(sc, closure_let(sc->code), sc->envir); if (is_macro(sc->value)) goto APPLY_LAMBDA; /* define-expansion* */ - if (apply_lambda_star(sc) == goto_EVAL) goto EVAL; /* define-expansion* */ + if (apply_lambda_star(sc) == goto_eval) goto EVAL; /* define-expansion* */ goto BEGIN; /* bacros don't seem to make sense here -- they are tied to the run-time environment, * procedures would need to evaluate their arguments in rootlet @@ -88717,25 +89755,12 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) goto READ_LIST; case TOKEN_SHARP_CONST: - sc->value = port_read_sharp(sc->input_port)(sc, sc->input_port); - if (sc->value == sc->no_value) - { - /* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*)) - * (+ 1 #;(* 2 3) 4) - * so we need to get the next token, act on it without any assumptions about read list - */ - sc->tok = token(sc); - goto READ_TOK; - } + if (read_sharp_const(sc)) + goto READ_TOK; goto READ_LIST; case TOKEN_DOUBLE_QUOTE: - sc->value = read_string_constant(sc, sc->input_port); - if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */ - return(string_read_error(sc, "end of input encountered while in a string")); - if (sc->value == sc->T) - read_error(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); + read_double_quote(sc); goto READ_LIST; case TOKEN_DOT: @@ -88752,29 +89777,27 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) break; } if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - goto START; + continue; case OP_READ_DOT: - { - goto_t choice; - choice = op_read_dot(sc); - if (choice == goto_START) goto START; - if (choice == goto_POP_READ_LIST) goto POP_READ_LIST; - goto READ_TOK; - } + switch (op_read_dot(sc)) + { + case goto_start: continue; + case goto_pop_read_list: goto POP_READ_LIST; + default: goto READ_TOK; + } - case OP_READ_QUOTE: if (op_read_quote(sc)) goto START; goto POP_READ_LIST; - case OP_READ_QUASIQUOTE: if (op_read_quasiquote(sc)) goto START; goto POP_READ_LIST; - case OP_READ_UNQUOTE: if (op_read_unquote(sc)) goto START; goto POP_READ_LIST; - case OP_READ_APPLY_VALUES: if (op_read_apply_values(sc)) goto START; goto POP_READ_LIST; - case OP_READ_VECTOR: if (op_read_vector(sc)) goto START; goto POP_READ_LIST; - case OP_READ_INT_VECTOR: if (op_read_int_vector(sc)) goto START; goto POP_READ_LIST; - case OP_READ_FLOAT_VECTOR: if (op_read_float_vector(sc)) goto START; goto POP_READ_LIST; - case OP_READ_BYTE_VECTOR: if (op_read_byte_vector(sc)) goto START; goto POP_READ_LIST; + case OP_READ_QUOTE: if (op_read_quote(sc)) continue; goto POP_READ_LIST; + case OP_READ_QUASIQUOTE: if (op_read_quasiquote(sc)) continue; goto POP_READ_LIST; + case OP_READ_UNQUOTE: if (op_read_unquote(sc)) continue; goto POP_READ_LIST; + case OP_READ_APPLY_VALUES: if (op_read_apply_values(sc)) continue; goto POP_READ_LIST; + case OP_READ_VECTOR: if (op_read_vector(sc)) continue; goto POP_READ_LIST; + case OP_READ_INT_VECTOR: if (op_read_int_vector(sc)) continue; goto POP_READ_LIST; + case OP_READ_FLOAT_VECTOR: if (op_read_float_vector(sc)) continue; goto POP_READ_LIST; + case OP_READ_BYTE_VECTOR: if (op_read_byte_vector(sc)) continue; goto POP_READ_LIST; default: fprintf(stderr, "unknown operator: %" print_pointer " in %s\n", sc->cur_op, DISPLAY(current_code(sc))); - fprintf(stderr, "estr: %s\n", s7_object_to_c_string(sc, s7_name_to_value(sc, "estr"))); return(sc->F); } /* else cancel all the optimization info -- someone stepped on our symbol */ @@ -88786,122 +89809,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) fprintf(stderr, "cleared: %s\n", DISPLAY_80(sc->code)); #endif - UNOPT: - { - s7_pointer code; - code = sc->code; - if (is_pair(code)) - { - s7_pointer carc; - carc = car(code); - if (is_syntactic_symbol(carc)) /* carc can also be syntactic */ - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); - pair_set_syntax_op(code, sc->cur_op); -#if UNOPT_PRINT && (0) - fprintf(stderr, " syntax (1): %s\n", DISPLAY_80(sc->code)); -#endif - goto TOP_NO_POP; - } - - /* -------------------------------------------------------------------------------- */ - /* trailers */ - - if (is_symbol(carc)) - { - /* car is a symbol, sc->code a list */ - if (is_syntactic_symbol(carc)) - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); - pair_set_syntax_op(sc->code, sc->cur_op); -#if UNOPT_PRINT - fprintf(stderr, " syntax (2): %s\n", DISPLAY_80(sc->code)); -#endif - goto TOP_NO_POP; - } - sc->value = find_global_symbol_checked(sc, carc); - /* fprintf(stderr, "pair: %s\n", DISPLAY(code)); */ - set_optimize_op(code, OP_PAIR_SYM); -#if UNOPT_PRINT - fprintf(stderr, " pair_sym: %s\n", DISPLAY_80(code)); -#endif - /* pair_sym -> unknown* check seems to make no difference? - * maybe split pair_sym? - */ - goto EVAL_ARGS_TOP; - } - /* very uncommon case: car is either itself a pair or some non-symbol */ - if (is_pair(carc)) - { - /* 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 - */ - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, code); - push_stack(sc, OP_EVAL_ARGS, sc->nil, code); - - if (is_syntactic_symbol(car(carc))) - /* was checking for is_syntactic here but that can be confused by successive optimizer passes: - * (define (hi) (((lambda () list)) 1 2 3)) etc - */ - { - if ((car(carc) == sc->quote_symbol) && /* ('and #f) */ - ((!is_pair(cdr(carc))) || /* ((quote . #\h) (2 . #\i)) ! */ - (is_syntactic(cadr(carc))))) - apply_error(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc, cdr(code)); - - sc->code = carc; - sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); - pair_set_syntax_op(sc->code, sc->cur_op); -#if UNOPT_PRINT - fprintf(stderr, " syntax (3): %s\n", DISPLAY_80(sc->code)); -#endif - goto TOP_NO_POP; - } - set_optimize_op(code, OP_PAIR_PAIR); -#if UNOPT_PRINT - fprintf(stderr, " pair_pair: %s\n", DISPLAY_80(sc->code)); -#endif - push_stack(sc, OP_EVAL_ARGS, sc->nil, carc); - sc->code = car(carc); - goto EVAL; - } - /* here we can get syntax objects like quote */ - if (is_syntax(carc)) - { - sc->cur_op = (opcode_t)syntax_opcode(carc); - pair_set_syntax_op(sc->code, sc->cur_op); -#if UNOPT_PRINT - fprintf(stderr, " syntax (4): %s\n", DISPLAY_80(sc->code)); -#endif - goto TOP_NO_POP; - } - /* car must be the function to be applied, or (for example) a syntax variable like quote that has been used locally */ - set_optimize_op(code, OP_PAIR_ANY); -#if UNOPT_PRINT - fprintf(stderr, " pair_any: %s\n", DISPLAY_80(sc->code)); -#endif - sc->value = T_Pos(carc); - goto EVAL_ARGS_TOP; - } - if (is_symbol(code)) - { - sc->value = lookup_checked(sc, code); - set_optimize_op(code, (is_keyword(code)) ? OP_CON : OP_SYM); -#if UNOPT_PRINT - fprintf(stderr, " con/sym: %s\n", DISPLAY_80(sc->code)); -#endif - } - else - { - sc->value = T_Pos(code); - set_optimize_op(code, OP_CON); -#if UNOPT_PRINT - fprintf(stderr, " con: %s\n", DISPLAY_80(sc->code)); -#endif - } - goto START; - } + UNOPT: + switch (trailers(sc)) + { + case goto_top_no_pop: goto TOP_NO_POP; + case goto_eval_args_top: goto EVAL_ARGS_TOP; + case goto_eval: goto EVAL; + default: break; + } } return(sc->F); } @@ -90439,7 +91354,11 @@ static s7_pointer big_abs(s7_scheme *sc, s7_pointer args) case T_RATIO: if (numerator(p) < 0) - return(make_simple_ratio(sc, -numerator(p), denominator(p))); + { + if (numerator(p) == s7_int_min) + return(s7_make_ratio(sc, s7_int_max, denominator(p))); + return(make_simple_ratio(sc, -numerator(p), denominator(p))); + } return(p); case T_REAL: @@ -92915,14 +93834,6 @@ static void s7_gmp_init(s7_scheme *sc) mpc_set_default_precision((mp_prec_t)DEFAULT_BIGNUM_PRECISION); s7_symbol_set_value(sc, sc->pi_symbol, big_pi(sc)); - -#if 0 - /* if these fixnum limits were read as strings, they'd be bignums in the gmp case, - * so for consistency make the symbolic versions bignums as well. - */ - s7_symbol_set_value(sc, make_symbol(sc, "most-positive-fixnum"), s7_int_to_big_integer(sc, s7_integer(s7_name_to_value(sc, "most-positive-fixnum")))); - s7_symbol_set_value(sc, make_symbol(sc, "most-negative-fixnum"), s7_int_to_big_integer(sc, s7_integer(s7_name_to_value(sc, "most-negative-fixnum")))); -#endif s7_provide(sc, "gmp"); } @@ -92930,7 +93841,7 @@ static void s7_gmp_init(s7_scheme *sc) /* WITH_GMP */ -/* -------------------------------- *s7* environment -------------------------------- */ +/* -------------------------------- *s7* let -------------------------------- */ s7_int s7_print_length(s7_scheme *sc) {return(sc->print_length);} s7_int s7_set_print_length(s7_scheme *sc, s7_int new_len) @@ -92959,9 +93870,23 @@ typedef enum {SL_NO_FIELD=0, SL_STACK_TOP, SL_STACK_SIZE, SL_STACKTRACE_DEFAULTS 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_INFO, SL_AUTOLOADING, SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, - SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM} s7_let_field_t; + SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM, SL_NUM_FIELDS} s7_let_field_t; -static s7_pointer s7_let_field(s7_scheme *sc, const char *name, s7_let_field_t field) +static const char *s7_let_field_names[SL_NUM_FIELDS] = + {"no-field", "stack-top", "stack-size", "stacktrace-defaults", "heap-size", "free-heap-size", + "gc-freed", "gc-protected-objects", "file-names", "rootlet-size", "c-types", "safety", + "undefined-identifier-warnings", "undefined-constant-warnings", "gc-stats", "max-heap-size", + "max-port-data-size", "max-stack-size", "cpu-time", "catches", "stack", "max-string-length", + "max-format-length", "max-list-length", "max-vector-length", "max-vector-dimensions", + "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-info", "autoloading?", "accept-all-keyword-arguments", + "most-positive-fixnum", "most-negative-fixnum"}; + +static s7_int s7_let_length(void) {return(SL_NUM_FIELDS - 1);} + +static s7_pointer s7_let_add_field(s7_scheme *sc, const char *name, s7_let_field_t field) { s7_pointer sym; sym = make_symbol(sc, name); @@ -92975,49 +93900,49 @@ static s7_pointer s7_let_field(s7_scheme *sc, const char *name, s7_let_field_t f */ static void init_s7_let(s7_scheme *sc) { - s7_let_field(sc, "accept-all-keyword-arguments", SL_ACCEPT_ALL_KEYWORD_ARGUMENTS); - s7_let_field(sc, "autoloading?", SL_AUTOLOADING); - s7_let_field(sc, "bignum-precision", SL_BIGNUM_PRECISION); - s7_let_field(sc, "c-types", SL_C_TYPES); - s7_let_field(sc, "catches", SL_CATCHES); - s7_let_field(sc, "cpu-time", SL_CPU_TIME); - s7_let_field(sc, "default-hash-table-length", SL_DEFAULT_HASH_TABLE_LENGTH); - s7_let_field(sc, "default-random-state", SL_DEFAULT_RANDOM_STATE); - s7_let_field(sc, "default-rationalize-error", SL_DEFAULT_RATIONALIZE_ERROR); - s7_let_field(sc, "equivalent-float-epsilon", SL_EQUIVALENT_FLOAT_EPSILON); - s7_let_field(sc, "file-names", SL_FILE_NAMES); - s7_let_field(sc, "float-format-precision", SL_FLOAT_FORMAT_PRECISION); - s7_let_field(sc, "free-heap-size", SL_FREE_HEAP_SIZE); - s7_let_field(sc, "gc-freed", SL_GC_FREED); - s7_let_field(sc, "gc-protected-objects", SL_GC_PROTECTED_OBJECTS); - s7_let_field(sc, "gc-stats", SL_GC_STATS); - s7_let_field(sc, "hash-table-float-epsilon", SL_HASH_TABLE_FLOAT_EPSILON); - s7_let_field(sc, "heap-size", SL_HEAP_SIZE); - s7_let_field(sc, "history", SL_HISTORY); - s7_let_field(sc, "history-enabled", SL_HISTORY_ENABLED); - s7_let_field(sc, "history-size", SL_HISTORY_SIZE); - s7_let_field(sc, "initial-string-port-length", SL_INITIAL_STRING_PORT_LENGTH); - s7_let_field(sc, "max-format-length", SL_MAX_FORMAT_LENGTH); - s7_let_field(sc, "max-heap-size", SL_MAX_HEAP_SIZE); - s7_let_field(sc, "max-list-length", SL_MAX_LIST_LENGTH); - s7_let_field(sc, "max-port-data-size", SL_MAX_PORT_DATA_SIZE); - s7_let_field(sc, "max-stack-size", SL_MAX_STACK_SIZE); - s7_let_field(sc, "max-string-length", SL_MAX_STRING_LENGTH); - s7_let_field(sc, "max-vector-dimensions", SL_MAX_VECTOR_DIMENSIONS); - s7_let_field(sc, "max-vector-length", SL_MAX_VECTOR_LENGTH); - s7_let_field(sc, "memory-usage", SL_MEMORY_USAGE); - s7_let_field(sc, "most-negative-fixnum", SL_MOST_NEGATIVE_FIXNUM); - s7_let_field(sc, "most-positive-fixnum", SL_MOST_POSITIVE_FIXNUM); - s7_let_field(sc, "print-length", SL_PRINT_LENGTH); - s7_let_field(sc, "profile-info", SL_PROFILE_INFO); - s7_let_field(sc, "rootlet-size", SL_ROOTLET_SIZE); - s7_let_field(sc, "safety", SL_SAFETY); - s7_let_field(sc, "stack", SL_STACK); - s7_let_field(sc, "stack-size", SL_STACK_SIZE); - s7_let_field(sc, "stack-top", SL_STACK_TOP); - s7_let_field(sc, "stacktrace-defaults", SL_STACKTRACE_DEFAULTS); - s7_let_field(sc, "undefined-constant-warnings", SL_UNDEFINED_CONSTANT_WARNINGS); - s7_let_field(sc, "undefined-identifier-warnings", SL_UNDEFINED_IDENTIFIER_WARNINGS); + s7_let_add_field(sc, "accept-all-keyword-arguments", SL_ACCEPT_ALL_KEYWORD_ARGUMENTS); + s7_let_add_field(sc, "autoloading?", SL_AUTOLOADING); + s7_let_add_field(sc, "bignum-precision", SL_BIGNUM_PRECISION); + s7_let_add_field(sc, "c-types", SL_C_TYPES); + s7_let_add_field(sc, "catches", SL_CATCHES); + s7_let_add_field(sc, "cpu-time", SL_CPU_TIME); + s7_let_add_field(sc, "default-hash-table-length", SL_DEFAULT_HASH_TABLE_LENGTH); + s7_let_add_field(sc, "default-random-state", SL_DEFAULT_RANDOM_STATE); + s7_let_add_field(sc, "default-rationalize-error", SL_DEFAULT_RATIONALIZE_ERROR); + s7_let_add_field(sc, "equivalent-float-epsilon", SL_EQUIVALENT_FLOAT_EPSILON); + s7_let_add_field(sc, "file-names", SL_FILE_NAMES); + s7_let_add_field(sc, "float-format-precision", SL_FLOAT_FORMAT_PRECISION); + s7_let_add_field(sc, "free-heap-size", SL_FREE_HEAP_SIZE); + s7_let_add_field(sc, "gc-freed", SL_GC_FREED); + s7_let_add_field(sc, "gc-protected-objects", SL_GC_PROTECTED_OBJECTS); + s7_let_add_field(sc, "gc-stats", SL_GC_STATS); + s7_let_add_field(sc, "hash-table-float-epsilon", SL_HASH_TABLE_FLOAT_EPSILON); + s7_let_add_field(sc, "heap-size", SL_HEAP_SIZE); + s7_let_add_field(sc, "history", SL_HISTORY); + s7_let_add_field(sc, "history-enabled", SL_HISTORY_ENABLED); + s7_let_add_field(sc, "history-size", SL_HISTORY_SIZE); + s7_let_add_field(sc, "initial-string-port-length", SL_INITIAL_STRING_PORT_LENGTH); + s7_let_add_field(sc, "max-format-length", SL_MAX_FORMAT_LENGTH); + s7_let_add_field(sc, "max-heap-size", SL_MAX_HEAP_SIZE); + s7_let_add_field(sc, "max-list-length", SL_MAX_LIST_LENGTH); + s7_let_add_field(sc, "max-port-data-size", SL_MAX_PORT_DATA_SIZE); + s7_let_add_field(sc, "max-stack-size", SL_MAX_STACK_SIZE); + s7_let_add_field(sc, "max-string-length", SL_MAX_STRING_LENGTH); + s7_let_add_field(sc, "max-vector-dimensions", SL_MAX_VECTOR_DIMENSIONS); + s7_let_add_field(sc, "max-vector-length", SL_MAX_VECTOR_LENGTH); + s7_let_add_field(sc, "memory-usage", SL_MEMORY_USAGE); + s7_let_add_field(sc, "most-negative-fixnum", SL_MOST_NEGATIVE_FIXNUM); + s7_let_add_field(sc, "most-positive-fixnum", SL_MOST_POSITIVE_FIXNUM); + s7_let_add_field(sc, "print-length", SL_PRINT_LENGTH); + s7_let_add_field(sc, "profile-info", SL_PROFILE_INFO); + s7_let_add_field(sc, "rootlet-size", SL_ROOTLET_SIZE); + s7_let_add_field(sc, "safety", SL_SAFETY); + s7_let_add_field(sc, "stack", SL_STACK); + s7_let_add_field(sc, "stack-size", SL_STACK_SIZE); + s7_let_add_field(sc, "stack-top", SL_STACK_TOP); + s7_let_add_field(sc, "stacktrace-defaults", SL_STACKTRACE_DEFAULTS); + s7_let_add_field(sc, "undefined-constant-warnings", SL_UNDEFINED_CONSTANT_WARNINGS); + s7_let_add_field(sc, "undefined-identifier-warnings", SL_UNDEFINED_IDENTIFIER_WARNINGS); } #ifdef __linux__ @@ -93047,10 +93972,9 @@ static s7_pointer kmg(s7_scheme *sc, s7_int bytes) static s7_pointer memory_usage(s7_scheme *sc) /* (for-each (lambda (f) (format *stderr* "~S~%" f)) (*s7* 'memory-usage)) */ { - s7_int i, k, len, gc_loc; + s7_int gc_loc; s7_pointer x, mu_let; gc_list *gp; - s7_int ts[NUM_TYPES]; #ifdef __linux__ struct rusage info; @@ -93067,153 +93991,158 @@ static s7_pointer memory_usage(s7_scheme *sc) /* (for-each (lambda make_slot_1(sc, mu_let, make_symbol(sc, "process-size"), kmg(sc, info.ru_maxrss * 1024)); make_slot_1(sc, mu_let, make_symbol(sc, "IO"), cons(sc, make_integer(sc, info.ru_inblock), make_integer(sc, info.ru_oublock))); #endif + + if (sc->safety > 0) + { + s7_int i, k, len; + s7_int ts[NUM_TYPES]; #if (!S7_DEBUGGING) - make_slot_1(sc, mu_let, - make_symbol(sc, "permanent-cells"), - cons(sc, make_integer(sc, sc->permanent_cells), kmg(sc, sc->permanent_cells * sizeof(s7_cell)))); + make_slot_1(sc, mu_let, + make_symbol(sc, "permanent-cells"), + cons(sc, make_integer(sc, sc->permanent_cells), kmg(sc, sc->permanent_cells * sizeof(s7_cell)))); #else - make_slot_1(sc, mu_let, make_symbol(sc, "permanent-cells"), - s7_list(sc, 14, - make_integer(sc, sc->permanent_cells), kmg(sc, sc->permanent_cells * sizeof(s7_cell)), /* big allocs here, so this is slightly inaccurate */ - make_symbol(sc, "unheap"), make_integer(sc, petrified_pointers), - make_symbol(sc, "slot"), make_integer(sc, permanent_slots), - make_symbol(sc, "port"), make_integer(sc, permanent_ports), - make_symbol(sc, "string"), make_integer(sc, permanent_strings), - make_symbol(sc, "cons"), make_integer(sc, permanent_conses), - make_symbol(sc, "func"), make_integer(sc, permanent_functions))); - make_slot_1(sc, mu_let, make_symbol(sc, "permanent-strings"), kmg(sc, permanent_string_len)); -#endif - - make_slot_1(sc, mu_let, make_symbol(sc, "rootlet-size"), make_integer(sc, sc->rootlet_entries)); - make_slot_1(sc, mu_let, make_symbol(sc, "heap-size"), cons(sc, make_integer(sc, sc->heap_size), kmg(sc, sc->heap_size * sizeof(s7_cell)))); - make_slot_1(sc, mu_let, make_symbol(sc, "cell-size"), make_integer(sc, sizeof(s7_cell))); - - for (i = 0; i < NUM_TYPES; i++) ts[i] = 0; - for (k = 0; k < sc->heap_size; k++) - ts[unchecked_type(sc->heap[k])]++; - sc->w = sc->nil; - for (i = 0; i < NUM_TYPES; 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); - } - if (is_pair(sc->w)) - make_slot_1(sc, mu_let, make_symbol(sc, "types"), sc->w); - sc->w = sc->nil; - - make_slot_1(sc, mu_let, make_symbol(sc, "gc-protected-objects"), - cons(sc, make_integer(sc, sc->protected_objects_size - sc->gpofl_loc), - make_integer(sc, sc->protected_objects_size))); - make_slot_1(sc, mu_let, make_symbol(sc, "setters"), make_integer(sc, sc->protected_setters_loc)); - - { - s7_int syms = 0, gens = 0, keys = 0, mx_list = 0; - for (i = 0; i < SYMBOL_TABLE_SIZE; i++) + make_slot_1(sc, mu_let, make_symbol(sc, "permanent-cells"), + s7_list(sc, 14, + make_integer(sc, sc->permanent_cells), kmg(sc, sc->permanent_cells * sizeof(s7_cell)), /* big allocs here, so this is slightly inaccurate */ + make_symbol(sc, "unheap"), make_integer(sc, petrified_pointers), + make_symbol(sc, "slot"), make_integer(sc, permanent_slots), + make_symbol(sc, "port"), make_integer(sc, permanent_ports), + make_symbol(sc, "string"), make_integer(sc, permanent_strings), + make_symbol(sc, "cons"), make_integer(sc, permanent_conses), + make_symbol(sc, "func"), make_integer(sc, permanent_functions))); + make_slot_1(sc, mu_let, make_symbol(sc, "permanent-strings"), kmg(sc, permanent_string_len)); +#endif + make_slot_1(sc, mu_let, make_symbol(sc, "rootlet-size"), make_integer(sc, sc->rootlet_entries)); + make_slot_1(sc, mu_let, make_symbol(sc, "heap-size"), cons(sc, make_integer(sc, sc->heap_size), kmg(sc, sc->heap_size * sizeof(s7_cell)))); + make_slot_1(sc, mu_let, make_symbol(sc, "cell-size"), make_integer(sc, sizeof(s7_cell))); + + for (i = 0; i < NUM_TYPES; i++) ts[i] = 0; + for (k = 0; k < sc->heap_size; k++) + ts[unchecked_type(sc->heap[k])]++; + sc->w = sc->nil; + for (i = 0; i < NUM_TYPES; 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); + } + if (is_pair(sc->w)) + make_slot_1(sc, mu_let, make_symbol(sc, "types"), sc->w); + sc->w = sc->nil; + + make_slot_1(sc, mu_let, make_symbol(sc, "gc-protected-objects"), + cons(sc, make_integer(sc, sc->protected_objects_size - sc->gpofl_loc), + make_integer(sc, sc->protected_objects_size))); + make_slot_1(sc, mu_let, make_symbol(sc, "setters"), make_integer(sc, sc->protected_setters_loc)); + { - for (k = 0, x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x), k++) + s7_int syms = 0, gens = 0, keys = 0, mx_list = 0; + for (i = 0; i < SYMBOL_TABLE_SIZE; i++) { - syms++; - if (is_gensym(car(x))) gens++; - if (is_keyword(car(x))) keys++; + for (k = 0, x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x), k++) + { + syms++; + if (is_gensym(car(x))) gens++; + if (is_keyword(car(x))) keys++; + } + if (k > mx_list) mx_list = k; } - if (k > mx_list) mx_list = k; + make_slot_1(sc, mu_let, make_symbol(sc, "symbol-table"), + s7_list(sc, 9, + make_integer(sc, SYMBOL_TABLE_SIZE), + make_symbol(sc, "max-bin"), make_integer(sc, mx_list), + make_symbol(sc, "symbols"), cons(sc, make_integer(sc, syms), make_integer(sc, syms - gens - keys)), + make_symbol(sc, "gensyms"), make_integer(sc, gens), + make_symbol(sc, "keys"), make_integer(sc, keys))); } - make_slot_1(sc, mu_let, make_symbol(sc, "symbol-table"), - s7_list(sc, 9, - make_integer(sc, SYMBOL_TABLE_SIZE), - make_symbol(sc, "max-bin"), make_integer(sc, mx_list), - make_symbol(sc, "symbols"), cons(sc, make_integer(sc, syms), make_integer(sc, syms - gens - keys)), - make_symbol(sc, "gensyms"), make_integer(sc, gens), - make_symbol(sc, "keys"), make_integer(sc, keys))); - } - make_slot_1(sc, mu_let, make_symbol(sc, "stack"), cons(sc, make_integer(sc, s7_stack_top(sc)), make_integer(sc, sc->stack_size))); - - gp = sc->strings; - for (len = 0, i = 0; i < (int32_t)(gp->loc); i++) - len += string_length(gp->list[i]); - make_slot_1(sc, mu_let, make_symbol(sc, "strings"), cons(sc, make_integer(sc, gp->loc), make_integer(sc, len))); - - { - s7_int vlen = 0, flen = 0, ilen = 0, blen = 0; - for (k = 0, gp = sc->vectors; k < 2; k++) + make_slot_1(sc, mu_let, make_symbol(sc, "stack"), cons(sc, make_integer(sc, s7_stack_top(sc)), make_integer(sc, sc->stack_size))); + + gp = sc->strings; + for (len = 0, i = 0; i < (int32_t)(gp->loc); i++) + len += string_length(gp->list[i]); + make_slot_1(sc, mu_let, make_symbol(sc, "strings"), cons(sc, make_integer(sc, gp->loc), make_integer(sc, len))); + { - for (i = 0; i < gp->loc; i++) + s7_int vlen = 0, flen = 0, ilen = 0, blen = 0; + for (k = 0, gp = sc->vectors; k < 2; k++) { - s7_pointer v; - v = gp->list[i]; - if (is_float_vector(v)) - flen += vector_length(v); - else + for (i = 0; i < gp->loc; i++) { - if (is_int_vector(v)) - ilen += vector_length(v); + s7_pointer v; + v = gp->list[i]; + if (is_float_vector(v)) + flen += vector_length(v); else { - if (is_byte_vector(v)) - blen += vector_length(v); - else vlen += vector_length(v); + if (is_int_vector(v)) + ilen += vector_length(v); + else + { + if (is_byte_vector(v)) + blen += vector_length(v); + else vlen += vector_length(v); + } } } + gp = sc->multivectors; } - gp = sc->multivectors; + make_slot_1(sc, mu_let, make_symbol(sc, "vectors"), + s7_list(sc, 9, + make_integer(sc, sc->vectors->loc + sc->multivectors->loc), + make_symbol(sc, "vlen"), make_integer(sc, vlen), + make_symbol(sc, "fvlen"), make_integer(sc, flen), + make_symbol(sc, "ivlen"), make_integer(sc, ilen), + make_symbol(sc, "bvlen"), make_integer(sc, blen))); } - make_slot_1(sc, mu_let, make_symbol(sc, "vectors"), - s7_list(sc, 9, - make_integer(sc, sc->vectors->loc + sc->multivectors->loc), - make_symbol(sc, "vlen"), make_integer(sc, vlen), - make_symbol(sc, "fvlen"), make_integer(sc, flen), - make_symbol(sc, "ivlen"), make_integer(sc, ilen), - make_symbol(sc, "bvlen"), make_integer(sc, blen))); - } - - gp = sc->input_ports; - for (i = 0, len = 0; i < gp->loc; i++) - { - s7_pointer v; - v = gp->list[i]; - if (port_data(v)) len += port_data_size(v); - } - make_slot_1(sc, mu_let, make_symbol(sc, "input-ports"), cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, len))); - - gp = sc->output_ports; - for (i = 0, len = 0; i < gp->loc; i++) - { - s7_pointer v; - v = gp->list[i]; - if (port_data(v)) len += port_data_size(v); - } - make_slot_1(sc, mu_let, make_symbol(sc, "output-ports"), cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len))); - - gp = sc->continuations; - for (i = 0, len = 0; i < gp->loc; i++) - if (is_continuation(gp->list[i])) - len += continuation_stack_size(gp->list[i]); - make_slot_1(sc, mu_let, make_symbol(sc, "continuations"), cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, len))); - - make_slot_1(sc, mu_let, make_symbol(sc, "c-objects"), make_integer(sc, sc->c_objects->loc)); + + gp = sc->input_ports; + for (i = 0, len = 0; i < gp->loc; i++) + { + s7_pointer v; + v = gp->list[i]; + if (port_data(v)) len += port_data_size(v); + } + make_slot_1(sc, mu_let, make_symbol(sc, "input-ports"), cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, len))); + + gp = sc->output_ports; + for (i = 0, len = 0; i < gp->loc; i++) + { + s7_pointer v; + v = gp->list[i]; + if (port_data(v)) len += port_data_size(v); + } + make_slot_1(sc, mu_let, make_symbol(sc, "output-ports"), cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len))); + + gp = sc->continuations; + for (i = 0, len = 0; i < gp->loc; i++) + if (is_continuation(gp->list[i])) + len += continuation_stack_size(gp->list[i]); + make_slot_1(sc, mu_let, make_symbol(sc, "continuations"), cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, len))); + + make_slot_1(sc, mu_let, make_symbol(sc, "c-objects"), make_integer(sc, sc->c_objects->loc)); #if WITH_GMP - make_slot_1(sc, mu_let, make_symbol(sc, "bignums"), - s7_list(sc, 5, make_integer(sc, sc->big_integers->loc), make_integer(sc, sc->big_ratios->loc), - make_integer(sc, sc->big_reals->loc), make_integer(sc, sc->big_complexes->loc), - make_integer(sc, sc->big_random_states->loc))); + make_slot_1(sc, mu_let, make_symbol(sc, "bignums"), + s7_list(sc, 5, make_integer(sc, sc->big_integers->loc), make_integer(sc, sc->big_ratios->loc), + make_integer(sc, sc->big_reals->loc), make_integer(sc, sc->big_complexes->loc), + make_integer(sc, sc->big_random_states->loc))); #endif - - { - block_t *b; - for (i = 0, len = 0, sc->w = sc->nil; i < TOP_BLOCK_LIST; i++) + { - for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++); + block_t *b; + for (i = 0, len = 0, sc->w = sc->nil; i < TOP_BLOCK_LIST; i++) + { + for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++); + sc->w = cons(sc, make_integer(sc, k), sc->w); + len += ((sizeof(block_t) + (1LL << i)) * k); + } + for (b = sc->block_lists[TOP_BLOCK_LIST], k = 0; b; b = block_next(b), k++) + len += (sizeof(block_t) + block_size(b)); sc->w = cons(sc, make_integer(sc, k), sc->w); - len += ((sizeof(block_t) + (1LL << i)) * k); - } - for (b = sc->block_lists[TOP_BLOCK_LIST], k = 0; b; b = block_next(b), k++) - len += (sizeof(block_t) + block_size(b)); - sc->w = cons(sc, make_integer(sc, k), sc->w); - make_slot_1(sc, mu_let, make_symbol(sc, "free-lists"), - list_2(sc, cons(sc, make_symbol(sc, "bytes"), kmg(sc, len)), + make_slot_1(sc, mu_let, make_symbol(sc, "free-lists"), + list_2(sc, cons(sc, make_symbol(sc, "bytes"), kmg(sc, len)), cons(sc, make_symbol(sc, "bins"), safe_reverse_in_place(sc, sc->w)))); - sc->w = sc->nil; - } + sc->w = sc->nil; + } + } s7_gc_unprotect_at(sc, gc_loc); return(mu_let); @@ -93263,16 +94192,8 @@ static s7_pointer sl_history(s7_scheme *sc) #endif } -static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args) +static s7_pointer s7_let_field(s7_scheme *sc, s7_pointer sym) { - s7_pointer sym; - - sym = cadr(args); - if (!is_symbol(sym)) - return(simple_wrong_type_argument(sc, sc->let_ref_symbol, sym, T_SYMBOL)); - if (is_keyword(sym)) - sym = keyword_symbol(sym); - switch (symbol_s7_let(sym)) { case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: return(make_boolean(sc, sc->accept_all_keyword_arguments)); @@ -93324,6 +94245,50 @@ static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args) return(sc->undefined); } +static s7_pointer g_s7_let_ref_fallback(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym; + + sym = cadr(args); + if (!is_symbol(sym)) + return(simple_wrong_type_argument(sc, sc->let_ref_symbol, sym, T_SYMBOL)); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + return(s7_let_field(sc, sym)); +} + +static s7_pointer s7_let_iterate(s7_scheme *sc, s7_pointer iterator) +{ + s7_pointer symbol, value, osw; + + iterator_position(iterator)++; + if (iterator_position(iterator) >= SL_NUM_FIELDS) + return(iterator_quit(iterator)); + + symbol = make_symbol(sc, s7_let_field_names[iterator_position(iterator)]); + osw = sc->w; /* protect against s7_let_field list making */ + value = s7_let_field(sc, symbol); + sc->w = osw; + + if (iterator_let_cons(iterator)) + { + s7_pointer p; + p = iterator_let_cons(iterator); + set_car(p, symbol); + set_cdr(p, value); + return(p); + } + return(cons(sc, symbol, value)); +} + +static s7_pointer s7_let_make_iterator(s7_scheme *sc, s7_pointer iter) +{ + iterator_position(iter) = SL_NO_FIELD; + iterator_next(iter) = s7_let_iterate; + iterator_let_cons(iter) = NULL; + return(iter); +} + static s7_pointer sl_real_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) { if (!s7_is_real(val)) @@ -93594,6 +94559,7 @@ static const char *decoded_name(s7_scheme *sc, s7_pointer p) if (p == sc->unused) return("#<unused>"); if (p == sc->symbol_table) return("symbol_table"); if (p == sc->rootlet) return("rootlet"); + if (p == sc->s7_let) return("*s7*"); if (p == sc->unlet) return("unlet"); if (p == sc->input_port) return("input_port"); if (p == sc->output_port) return("output_port"); @@ -94070,6 +95036,7 @@ s7_scheme *s7_init(void) sc->autoloaded_already = NULL; sc->autoload_names_loc = 0; sc->is_autoloading = true; + sc->rec_stack = NULL; sc->heap_size = INITIAL_HEAP_SIZE; if ((sc->heap_size % 32) != 0) @@ -94082,7 +95049,7 @@ s7_scheme *s7_init(void) { s7_cell *cells; cells = (s7_cell *)calloc(INITIAL_HEAP_SIZE, sizeof(s7_cell)); /* calloc to make sure type=0 at start? (for gc/valgrind) */ - for (i = 0; i < INITIAL_HEAP_SIZE; i++) + for (i = 0; i < INITIAL_HEAP_SIZE; i++) /* LOOP_4 here is slower! */ { sc->heap[i] = &cells[i]; sc->free_heap[i] = sc->heap[i]; @@ -94383,7 +95350,7 @@ s7_scheme *s7_init(void) sc->key_allow_other_keys_symbol = s7_make_keyword(sc, "allow-other-keys"); sc->key_rest_symbol = s7_make_keyword(sc, "rest"); - sc->key_if_symbol = s7_make_keyword(sc, "if"); + sc->key_if_symbol = s7_make_keyword(sc, "if"); /* internal optimizer local-env marker */ sc->key_readable_symbol = s7_make_keyword(sc, "readable"); sc->key_display_symbol = s7_make_keyword(sc, "display"); sc->key_write_symbol = s7_make_keyword(sc, "write"); @@ -94587,7 +95554,7 @@ s7_scheme *s7_init(void) sc->read_symbol = unsafe_defun("read", read, 0, 1, false); /* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence * (not embedded in OP_SAFE_C_opSq for example) -- that is, it pushes OP_READ_INTERNAL, then returns - * expecting goto START, which would be nonsense if arg=c_callee(read) -> c_callee(arg). + * expecting continue (goto START), which would be nonsense if arg=c_callee(read) -> c_callee(arg). * a safe procedure leaves its argument list alone, does not push anything on the stack, * and leaves sc->code|args unscathed (c_call assumes that is the case). The stack part can * be hidden: if a c_function calls s7_apply_function (lambda passed as arg as in some clm gens) @@ -95125,6 +96092,11 @@ s7_scheme *s7_init(void) set_setter(sc->set_car_symbol); set_setter(sc->set_cdr_symbol); + set_safe_setter(sc->byte_vector_set_symbol); + set_safe_setter(sc->int_vector_set_symbol); + set_safe_setter(sc->float_vector_set_symbol); + set_safe_setter(sc->string_set_symbol); + #if (WITH_PURE_S7) /* we need to be able at least to set (current-output-port) to #f */ c_function_set_setter(slot_value(global_slot(sc->current_input_port_symbol)), @@ -95228,14 +96200,15 @@ s7_scheme *s7_init(void) s7_set_p_piip_function(slot_value(global_slot(sc->vector_set_symbol)), vector_set_p_piip); s7_set_p_pi_direct_function(slot_value(global_slot(sc->vector_ref_symbol)), vector_ref_p_pi_direct); s7_set_p_pip_direct_function(slot_value(global_slot(sc->vector_set_symbol)), vector_set_p_pip_direct); + s7_set_p_ppp_function(slot_value(global_slot(sc->vector_set_symbol)), vector_set_p_ppp); s7_set_p_pi_function(slot_value(global_slot(sc->list_ref_symbol)), list_ref_p_pi); s7_set_p_pip_function(slot_value(global_slot(sc->list_set_symbol)), list_set_p_pip); s7_set_p_pi_direct_function(slot_value(global_slot(sc->list_ref_symbol)), list_ref_p_pi_direct); s7_set_p_pip_direct_function(slot_value(global_slot(sc->list_set_symbol)), list_set_p_pip_direct); - s7_set_p_pp_function(slot_value(global_slot(sc->let_ref_symbol)), let_ref_p_pp); - s7_set_p_ppp_function(slot_value(global_slot(sc->let_set_symbol)), let_set_p_ppp); + s7_set_p_pp_function(slot_value(global_slot(sc->let_ref_symbol)), s7_let_ref); + s7_set_p_ppp_function(slot_value(global_slot(sc->let_set_symbol)), s7_let_set); s7_set_p_pi_function(slot_value(global_slot(sc->string_ref_symbol)), string_ref_p_pi); s7_set_p_pp_function(slot_value(global_slot(sc->string_ref_symbol)), string_ref_p_pp); @@ -95256,6 +96229,7 @@ s7_scheme *s7_init(void) s7_set_p_i_function(slot_value(global_slot(sc->number_to_string_symbol)), number_to_string_p_i); s7_set_p_p_function(slot_value(global_slot(sc->number_to_string_symbol)), number_to_string_p_p); s7_set_p_pp_function(slot_value(global_slot(sc->number_to_string_symbol)), number_to_string_p_pp); + s7_set_p_p_function(slot_value(global_slot(sc->string_to_number_symbol)), string_to_number_p_p); s7_set_p_pp_function(slot_value(global_slot(sc->string_to_number_symbol)), string_to_number_p_pp); #endif @@ -95268,6 +96242,12 @@ s7_scheme *s7_init(void) s7_set_p_p_function(slot_value(global_slot(sc->cdar_symbol)), cdar_p_p); s7_set_p_p_function(slot_value(global_slot(sc->cddr_symbol)), cddr_p_p); s7_set_p_p_function(slot_value(global_slot(sc->caddr_symbol)), caddr_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->caddar_symbol)), caddar_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->caadr_symbol)), caadr_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->caaddr_symbol)), caaddr_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->cadar_symbol)), cadar_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->cadadr_symbol)), cadadr_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->cdadr_symbol)), cdadr_p_p); s7_set_p_p_function(slot_value(global_slot(sc->string_to_symbol_symbol)), string_to_symbol_p_p); s7_set_p_p_function(slot_value(global_slot(sc->symbol_to_string_symbol)), symbol_to_string_p); @@ -95294,6 +96274,7 @@ s7_scheme *s7_init(void) s7_set_p_pp_function(slot_value(global_slot(sc->assoc_symbol)), assoc_p_pp); #if (!WITH_GMP) + s7_set_p_pp_function(slot_value(global_slot(sc->remainder_symbol)), remainder_p_pp); s7_set_i_i_function(slot_value(global_slot(sc->abs_symbol)), abs_i_i); s7_set_d_d_function(slot_value(global_slot(sc->abs_symbol)), abs_d_d); s7_set_d_d_function(slot_value(global_slot(sc->exp_symbol)), exp_d_d); @@ -95459,6 +96440,7 @@ s7_scheme *s7_init(void) s7_set_b_7pp_function(slot_value(global_slot(sc->is_defined_symbol)), is_defined_b_7pp); s7_set_b_7pp_function(slot_value(global_slot(sc->tree_memq_symbol)), s7_tree_memq); s7_set_b_7pp_function(slot_value(global_slot(sc->tree_set_memq_symbol)), tree_set_memq_b_7pp); + s7_set_p_pp_function(slot_value(global_slot(sc->tree_set_memq_symbol)), tree_set_memq_p_pp); s7_set_b_p_function(slot_value(global_slot(sc->is_immutable_symbol)), s7_is_immutable); s7_set_p_p_function(slot_value(global_slot(sc->is_pair_symbol)), is_pair_p_p); @@ -95470,7 +96452,9 @@ s7_scheme *s7_init(void) s7_set_p_p_function(slot_value(global_slot(sc->iterate_symbol)), iterate_p_p); s7_set_p_p_function(slot_value(global_slot(sc->list_symbol)), list_p_p); s7_set_p_pp_function(slot_value(global_slot(sc->list_symbol)), list_p_pp); + s7_set_p_ppp_function(slot_value(global_slot(sc->list_symbol)), list_p_ppp); s7_set_p_pp_function(slot_value(global_slot(sc->assq_symbol)), assq_p_pp); + s7_set_p_pp_function(slot_value(global_slot(sc->memq_symbol)), memq_p_pp); s7_set_p_p_function(slot_value(global_slot(sc->tree_leaves_symbol)), tree_leaves_p_p); s7_set_p_p_function(slot_value(global_slot(sc->length_symbol)), length_p_p); s7_set_p_p_function(slot_value(global_slot(sc->pair_line_number_symbol)), pair_line_number_p_p); @@ -95478,7 +96462,6 @@ s7_scheme *s7_init(void) s7_set_p_p_function(slot_value(global_slot(sc->c_pointer_type_symbol)), c_pointer_type_p_p); s7_set_p_p_function(slot_value(global_slot(sc->c_pointer_weak1_symbol)), c_pointer_weak1_p_p); s7_set_p_p_function(slot_value(global_slot(sc->c_pointer_weak2_symbol)), c_pointer_weak2_p_p); - s7_set_p_p_function(slot_value(global_slot(sc->is_negative_symbol)), is_negative_p_p); s7_set_p_p_function(slot_value(global_slot(sc->is_char_alphabetic_symbol)), is_char_alphabetic_p_p); s7_set_p_p_function(slot_value(global_slot(sc->is_char_whitespace_symbol)), is_char_whitespace_p_p); s7_set_p_i_function(slot_value(global_slot(sc->make_string_symbol)), make_string_p_i); @@ -95492,8 +96475,13 @@ s7_scheme *s7_init(void) s7_set_b_i_function(slot_value(global_slot(sc->is_even_symbol)), is_even_i); s7_set_b_i_function(slot_value(global_slot(sc->is_odd_symbol)), is_odd_i); +#if (!WITH_GMP) s7_set_b_i_function(slot_value(global_slot(sc->is_zero_symbol)), is_zero_i); s7_set_b_d_function(slot_value(global_slot(sc->is_zero_symbol)), is_zero_d); +#endif + s7_set_p_p_function(slot_value(global_slot(sc->is_zero_symbol)), is_zero_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->is_positive_symbol)), is_positive_p_p); + s7_set_p_p_function(slot_value(global_slot(sc->is_negative_symbol)), is_negative_p_p); s7_set_b_i_function(slot_value(global_slot(sc->is_positive_symbol)), is_positive_i); s7_set_b_d_function(slot_value(global_slot(sc->is_positive_symbol)), is_positive_d); s7_set_b_i_function(slot_value(global_slot(sc->is_negative_symbol)), is_negative_i); @@ -95552,7 +96540,9 @@ s7_scheme *s7_init(void) #endif s7_set_b_pp_function(slot_value(global_slot(sc->is_eq_symbol)), s7_is_eq); + s7_set_p_pp_function(slot_value(global_slot(sc->is_eq_symbol)), is_eq_p_pp); s7_set_b_pp_function(slot_value(global_slot(sc->is_eqv_symbol)), s7_is_eqv); + s7_set_p_pp_function(slot_value(global_slot(sc->is_eqv_symbol)), is_eqv_p_pp); s7_set_b_7pp_function(slot_value(global_slot(sc->is_equal_symbol)), is_equal_b_7pp); s7_set_b_7pp_function(slot_value(global_slot(sc->is_equivalent_symbol)), is_equivalent_b_7pp); s7_set_p_pp_function(slot_value(global_slot(sc->is_equal_symbol)), is_equal_p_pp); @@ -95721,8 +96711,7 @@ s7_scheme *s7_init(void) 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 (strcmp(op_names[OP_SAFE_CLOSURE_A_A], "safe_closure_a_a") != 0) fprintf(stderr, "clo op_name: %s\n", op_names[OP_SAFE_CLOSURE_A_A]); - if (NUM_OPS != 839) - fprintf(stderr, "size: cell: %d, block: %d, max op: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS); + if (NUM_OPS != 823) fprintf(stderr, "size: cell: %d, block: %d, max op: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS); /* 64 bit machine: cell size: 48, 80 if gmp, 160 if debugging, block size: 40 */ #endif @@ -95791,6 +96780,7 @@ int main(int argc, char **argv) * in *BSD: gcc s7.c -o repl -DWITH_MAIN -DUSE_SND=0 -I. -O2 -g -lm -Wl,-export-dynamic * in OSX: gcc s7.c -o repl -DWITH_MAIN -DUSE_SND=0 -I. -O2 -g -lm * (clang also needs LDFLAGS="-Wl,-export-dynamic" in Linux and "-fPIC") + * (compile time 29-Aug-19 42.5 secs) */ #endif @@ -95798,61 +96788,72 @@ int main(int argc, char **argv) * * new snd version: snd.h configure.ac HISTORY.Snd NEWS barchive diffs, /usr/ccrma/web/html/software/snd/index.html * - * ------------------------------------------------------------------------------ - * 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19.5 19.6 19.7 - * ------------------------------------------------------------------------------ - * tpeak | | | | 391 | 377 | 199 | 161 164 - * tmac | | | | 9052 | 264 | 236 | 236 233 - * tauto | | | 1752 | 1689 | 1700 | 835 | 610 622 - * tshoot | | | | | | 1095 | 834 831 - * index 44.3 | 3291 | 1725 | 1276 | 1255 | 1168 | 1022 | 977 875 - * tref | | | 2372 | 2125 | 1036 | 983 | 954 949 - * teq | | | 6612 | 2777 | 1931 | 1539 | 1530 1492 - * s7test 1721 | 1358 | 995 | 1194 | 2926 | 2110 | 1726 | 1702 1702 - * tvect | | | | | | 5729 | 2340 2033 - * lint | | | | 4041 | 2702 | 2120 | 2096 2121 - * tcopy | | | 13.6 | 3183 | 2974 | 2320 | 2249 2255 - * tread | | | | | 2357 | 2336 | 2279 2269 - * tlet | | | | | 4717 | 2959 | 2577 2285 - * tform | | | 6816 | 3714 | 2762 | 2362 | 2306 2288 - * tfft | | 15.5 | 16.4 | 17.3 | 3966 | 2493 | 2467 2401 - * tmat 8641 | 8458 | | | 7248 | 7252 | 6823 | 2664 - * tclo | | 4391 | 4666 | 4651 | 4682 | 3084 | 2930 2705 - * fbench 4123 | 3869 | 3486 | 3609 | 3602 | 3637 | 3495 | 2835 2783 - * trclo | | | | 10.3 | 10.5 | 8758 | 3932 3011 - * titer | | | | 5971 | 4646 | 3587 | 3504 3022 - * tmap | | | 9.3 | 5279 | 3445 | 3015 | 3069 3123 - * tsort | | | | 8584 | 4111 | 3327 | 3315 3314 - * tset | | | | | 10.0 | 6432 | 3463 3477 - * dup | | | | | 20.8 | 5711 | 3207 3715 - * trec 35.0 | 29.3 | 24.8 | 25.5 | 24.9 | 25.6 | 20.0 | 10.4 7115 - * thash | | | | | | 10.3 | 8873 8852 - * tgen | 71.0 | 70.6 | 38.0 | 12.6 | 11.9 | 11.2 | 11.3 10.8 - * tall 90.0 | 43.0 | 14.5 | 12.7 | 17.9 | 18.8 | 17.1 | 16.9 14.9 - * calls 359.0 |275.0 | 54.0 | 34.7 | 43.7 | 40.4 | 38.4 | 38.2 35.6 - * sg | | | |139.0 | 85.9 | 78.0 | 72.7 69.5 - * lg | | | |211.0 |133.0 |112.7 |108.0 109.3 - * tbig | | | | |246.9 |230.6 |184.8 182.2 - * ------------------------------------------------------------------------------------ + * -------------------------------------------------------------------------------- + * 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19.6 19.7 19.8 + * -------------------------------------------------------------------------------- + * tpeak | | | | 391 | 377 | 199 | 164 163 + * tauto | | | 1752 | 1689 | 1700 | 835 | 622 630 + * tshoot | | | | | | 1095 | 831 804 + * tref | | | 2372 | 2125 | 1036 | 983 | 949 876 + * index 44.3 | 3291 | 1725 | 1276 | 1255 | 1168 | 1022 | 875 880 + * teq | | | 6612 | 2777 | 1931 | 1539 | 1492 1485 + * s7test 1721 | 1358 | 995 | 1194 | 2926 | 2110 | 1726 | 1702 1685 + * tvect | | | | | | 5729 | 2033 1919 + * tmisc | | | | | | 2636 | 1949 + * lint | | | | 4041 | 2702 | 2120 | 2121 2090 + * tform | | | 6816 | 3714 | 2762 | 2362 | 2288 2238 + * tlet | | | | | 4717 | 2959 | 2285 2241 + * tcopy | | | 13.6 | 3183 | 2974 | 2320 | 2255 2251 + * tread | | | | | 2357 | 2336 | 2269 2258 + * tclo | | 4391 | 4666 | 4651 | 4682 | 3084 | 2705 2626 + * tmat 8641 | 8458 | | 7279 | 7248 | 7252 | 6823 | 2664 2655 + * fbench 4123 | 3869 | 3486 | 3609 | 3602 | 3637 | 3495 | 2783 2681 + * titer | | | | 5971 | 4646 | 3587 | 3022 2828 + * trclo | | | | 10.3 | 10.5 | 8758 | 3011 2886 + * tset | | | | | 10.0 | 6432 | 3477 2980 + * dup | | | | | 20.8 | 5711 | 3715 3028 + * tmap | | | 9.3 | 5279 | 3445 | 3015 | 3123 3049 + * tsort | | | | 8584 | 4111 | 3327 | 3314 3236 + * tmac 8550 | 8396 | 7556 | 5606 | 5503 | 5404 | 3969 | 3624 + * tfft | | 17.1 | 17.3 | 19.2 | 19.3 | 4466 | 4029 + * trec 35.0 | 29.3 | 24.8 | 25.5 | 24.9 | 25.6 | 20.0 | 7115 6435 + * thash | | | | | | 10.3 | 8852 8467 + * tgen | 71.0 | 70.6 | 38.0 | 12.6 | 11.9 | 11.2 | 10.8 10.8 + * tall 90.0 | 43.0 | 14.5 | 12.7 | 17.9 | 18.8 | 17.1 | 14.9 14.8 + * calls 359.0 |275.0 | 54.0 | 34.7 | 43.7 | 40.4 | 38.4 | 35.6 35.6 + * sg | | | |139.0 | 85.9 | 78.0 | 69.5 69.1 + * lg | | | |211.0 |133.0 |112.7 |109.3 106.8 + * tbig | | | | |246.9 |230.6 |182.2 181.2 + * -------------------------------------------------------------------------------- * * glistener, gtk-script, s7.html for gtk4, grepl.c gcall.c gcall2.c? * grepl compiles but the various key_press events are not valid, gtk-script appears to be ok + * wayland needs work * * gcc/clang have builtin __int128 or __int128_t and __uint128_t, use #if defined(__SIZEOF_INT128__)...#endif * also __float128 -> s7_big_int|double * - * b_idp_ok should try int_optimize of cdr? - * in unsafe closure, if no definers, shouldn't fx_tree still be ok? - * perhaps add define_safe to body_is_safe, so we can go down a step from recur_safe - * then walk tree handling 1-var lets also? + * fx*direct p_pp opts, opt_set_p_i_f* call make_integer, also p_d_f + * + * if envir is funclet or 1-var let, mark? then any annotate in marked env => fx_tree + * safe if we're the first expr in the body, or body is safe/recur + * lt_gtg and leq_gs (lint) + * permanent lets might also use the lamlet clear + * + * apply_lambda_star can preset simple opt args (lamlet list? in op_lambda?) + * a list of all opt vals (if fxable), then use list-tail to choose append + * or not append, just load (slot-pending-value instead? if saved let) + * (misc, mac, clo): simple_closure_star? + * + * c_s_opssq_direct->c_g_opgtq_direct, cond_fx with fxable results, do_no_body_simple_vars&result (closure in end-test) + * cond_fx or add cond_fp as check_and (fx if present else push return and jump to eval) + * safe_closure_fp if argnum less? * - * fx_c_Wt -> vector_ref_2 -> vector_ref_p_pp, so fx_c_Wt_direct would be good in dup [see fx_c_opstq_direct?] - * fx_c_ssa -> vector_ref_3(etc) (tbig) - * op_safe_c_sc -> g_display_2 tclo - * fx_c_optq -> g_iterate+g_type_of (iter) - * fx_c_u -> g_is_positive (rclo) -- is_positive_b_7p? (if not gmp) - * fx_c_sc -> direct cases (b) - * fx_tree v check (and residual tuTUVW) - * similarly lookup, maybe "v" arg in fx_tree - * is there any way to do op_safe_t or op_safe_tu? op_set_symbol_t? if_css(tu) + * permanent_let_star? (as the full stack of lets or did the old form work?) + * expand as fx_is_type_car for others like is_pair_car? (lg) see 53771 trec/trclo/lg: at least symbol? integer? + * s_to_s (a_to_s) could include and_s_2 etc [fx_safe_closure_s|t_d|a] et al + opssq if sc->envir=outlet [sc cs etc] + * a_to_a is hard -- c_s as "a" never happens, vector_ref needs the second arg (and needs yet another op) etc + * setter gc list (protected_setters) et al -> lamlet? but no one will mark it outside the setter list? + * as in old trace, if unheaped func refers to heaped func, the latter needs to be marked. + * many places in Snd assume non-bignum args (e.g. set-x-bounds) */ @@ -890,12 +890,14 @@ implement the standard old-time macros. `(let () (and ,@(map (lambda (v) `(define ,@v)) vars) (begin ,@body)))) > (define-macro (<em class=def id="trace">trace</em> f) - `(define ,f - (apply lambda 'args - `((format () "(~A ~{~A~^ ~}) -> " ',',f args) - (let ((val (apply ,,f args))) - (format () "~A~%" val) - val))))) + (let ((old-f (gensym))) + `(define ,f + (let ((,old-f ,f)) + (apply lambda 'args + `((format () "(~S ~{~S~^ ~}) -> " ',',f args) + (let ((val (apply ,,old-f args))) + (format () "~S~%" val) + val))))))) <em class="gray">trace</em> > (trace abs) <em class="gray">abs</em> @@ -1698,8 +1700,8 @@ Here's a generic FFT: </p> <pre class="indented"> -(define* (cfft! data n (dir 1)) ; (complex data) - (if (not n) (set! n (length data))) +(define* (cfft data n (dir 1)) ; complex data + (unless n (set! n (length data))) (do ((i 0 (+ i 1)) (j 0)) ((= i n)) @@ -1734,9 +1736,9 @@ Here's a generic FFT: (set! wc (* wc wpc)))) data) -> (cfft! (list 0.0 1+i 0.0 0.0)) +> (cfft (list 0.0 1+i 0.0 0.0)) <em class="gray">(1+1i -1+1i -1-1i 1-1i)</em> -> (cfft! (vector 0.0 1+i 0.0 0.0)) +> (cfft (vector 0.0 1+i 0.0 0.0)) <em class="gray">#(1+1i -1+1i -1-1i 1-1i)</em> </pre> @@ -5274,7 +5276,7 @@ profile.scm shows one way to sort and display this data. To clear the counts, <c <div class="separator"></div> -<p id="s7env"><b>*s7*</b> is an environment that gives access to some of s7's internal +<p id="s7env"><b>*s7*</b> is a let that gives access to some of s7's internal state: </p> <pre class="indented"> @@ -5695,7 +5697,9 @@ This is consistent with, for example, <code>(eq? #f '#f)</code> which is also #t. The standard says "the empty list is a special object of its own type", so surely either choice is acceptable in that regard (but, sigh, the standard stupidly goes on to deny that () can evaluate to itself). -The confusion appears to be caused by the word "list". I would describe the evaluator: "if it gets a +(I'm told that "is an error" means "is not portable" in the standard's weasely abuse of English; if +they mean "is not portable" why not say so?). +Some of the confusion appears to be caused by the word "list". I would describe the evaluator: "if it gets a constant (and () is a constant) it returns that constant; if a symbol, it returns the value associated with that symbol; if a pair, it looks at the pair's car to decide what to do". It's kinda looney to insist on looking at the car of a list when you know () has no car! @@ -20,7 +20,6 @@ ;;; N Higham, "Accuracy and Stability of Numerical Algorithms" ;;; various mailing lists and websites (see individual cases below) - (define full-test #f) ; this includes some time-consuming stuff (define with-bignums (provided? 'gmp)) ; scheme number has any number of bits ; we assume s7_double is double, and s7_int is int64_t @@ -398,8 +397,8 @@ (define (reinvert n op1 op2 arg) (let ((body (op2 (op1 arg)))) - (do ((i 1 (+ i 1))) - ((= i n) body) + (do ((i3 1 (+ i3 1))) + ((= i3 n) body) (set! body (op2 (op1 body)))))) (define (recompose n op arg) @@ -1334,33 +1333,33 @@ void block_init(s7_scheme *sc) } "))) -(let ((flags (if (provided? 'debugging) "-g3" "-g -O2"))) - (cond ((provided? 'osx) - (system (string-append "gcc -c s7test-block.c " flags)) - (system "gcc s7test-block.o -o s7test-block.so -dynamic -bundle -undefined suppress -flat_namespace")) - - ((or (provided? 'freebsd) - (provided? 'netbsd)) - (system (string-append "cc -fPIC -c s7test-block.c " flags)) - (system "cc s7test-block.o -shared -o s7test-block.so -lm -lc")) - - ((provided? 'openbsd) - (system (string-append "gcc -fPIC -ftrampolines -c s7test-block.c " flags)) - (system "gcc s7test-block.o -shared -o s7test-block.so -lm -lc")) - - ((provided? 'solaris) - (system "gcc -fPIC -c s7test-block.c") - (system "gcc s7test-block.o -shared -o s7test-block.so -G -ldl -lm")) - - (else - (system (string-append "gcc -fPIC -c s7test-block.c " flags)) - (system "gcc s7test-block.o -shared -o s7test-block.so -ldl -lm -Wl,-export-dynamic")))) - -(let ((new-env (sublet (curlet) (cons 'init_func 'block_init)))) ; load calls init_func - (load "s7test-block.so" new-env)) - -(define _c_obj_ (make-block 16)) -(unless (immutable? (block-let _c_obj_)) (format *stderr* "~S's let is mutable~%" _c_obj_))) ; with-block + (let ((flags (if (provided? 'debugging) "-g3" "-g -O2"))) + (cond ((provided? 'osx) + (system (string-append "gcc -c s7test-block.c " flags)) + (system "gcc s7test-block.o -o s7test-block.so -dynamic -bundle -undefined suppress -flat_namespace")) + + ((or (provided? 'freebsd) + (provided? 'netbsd)) + (system (string-append "cc -fPIC -c s7test-block.c " flags)) + (system "cc s7test-block.o -shared -o s7test-block.so -lm -lc")) + + ((provided? 'openbsd) + (system (string-append "gcc -fPIC -ftrampolines -c s7test-block.c " flags)) + (system "gcc s7test-block.o -shared -o s7test-block.so -lm -lc")) + + ((provided? 'solaris) + (system "gcc -fPIC -c s7test-block.c") + (system "gcc s7test-block.o -shared -o s7test-block.so -G -ldl -lm")) + + (else + (system (string-append "gcc -fPIC -c s7test-block.c " flags)) + (system "gcc s7test-block.o -shared -o s7test-block.so -ldl -lm -Wl,-export-dynamic")))) + + (let ((new-env (sublet (curlet) (cons 'init_func 'block_init)))) ; load calls init_func + (load "s7test-block.so" new-env)) + + (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 (define _null_ (c-pointer 0)) @@ -13898,6 +13897,7 @@ i" (lambda (p) (eval (read p)))) pi) (call-with-output-file "t923.scm" (lambda (p) + (format p "(define t923-old-eps (*s7* 'equivalent-float-epsilon))~%(set! (*s7* 'equivalent-float-epsilon) 1e-15)~%~%") (let ((fctr 0)) (for-each-permutation (lambda lst @@ -13905,10 +13905,10 @@ i" (lambda (p) (eval (read p)))) pi) (format p "(define (f~D x y) ~{~^~S ~})~%" fctr expr) (format p "(let ((e1 (f~D 3 4)))~%" fctr) (format p " (let ((e2 (let ((x 3) (y 4)) ~{~^~S ~})))~%" expr) - (format p " (let ((e3 (let ((x 3) (y 4)) (f~D x y))))~%" fctr) - (format p " (if (not (= e1 e2 e3))~% (format *stderr* \"~{~^~S ~}: ~~A ~~A ~~A~~%\" e1 e2 e3)))))~%~%" expr)) + (format p " (unless (equivalent? e1 e2)~% (format *stderr* \"~{~^~S ~}: ~~A ~~A~~%\" e1 e2))))~%~%" expr)) (set! fctr (+ fctr 1))) - (append ops args))))) + (append ops args))) + (format p "(set! (*s7* 'equivalent-float-epsilon) t923-old-eps)~%"))) (load "t923.scm"))) @@ -17361,8 +17361,7 @@ i" (lambda (p) (eval (read p)))) pi) (lambda (hlt) (define (nextchar) (let ((c (read-char))) - (if (and (char? c) - (char=? c #\space)) + (if (eq? c #\space) (nextchar) c))) @@ -21327,13 +21326,13 @@ c" (test (object->string (inlet 'a (lambda (b) (+ b 1))) :readable) "(inlet :a (lambda (b) (+ b 1)))") (test (object->string (inlet 'a (lambda b (list b 1))) :readable) "(inlet :a (lambda b (list b 1)))") (test (object->string (inlet 'a (lambda (a . b) (list a b))) :readable) "(inlet :a (lambda (a . b) (list a b)))") -(test (object->string (inlet 'a (define-macro (_m_ b) `(+ ,b 1))) :readable) "(inlet :a (define-macro (_m_ b) (list-values '+ b 1)))") -(test (object->string (inlet 'a (define-bacro (_m_ b) `(+ ,b 1))) :readable) "(inlet :a (define-bacro (_m_ b) (list-values '+ b 1)))") +(test (object->string (inlet 'a (define-macro (_m_ b) `(+ ,b 1))) :readable) "(inlet :a (define-macro (_m_ b) (list '+ b 1)))") +(test (object->string (inlet 'a (define-bacro (_m_ b) `(+ ,b 1))) :readable) "(inlet :a (define-bacro (_m_ b) (list '+ b 1)))") (test (object->string (inlet 'a (lambda* ((b 1)) (+ b 1))) :readable) "(inlet :a (lambda* ((b 1)) (+ b 1)))") (test (object->string (inlet 'a (lambda* a (list a))) :readable) "(inlet :a (lambda a (list a)))") ; lambda* until 22-Jan-19 (test (object->string (inlet 'a (lambda* (a (b 1) c) (list a b c))) :readable) "(inlet :a (lambda* (a (b 1) c) (list a b c)))") -(test (object->string (inlet 'a (define-macro* (_m_ (b 1)) `(+ ,b 1))) :readable) "(inlet :a (define-macro* (_m_ (b 1)) (list-values '+ b 1)))") -(test (object->string (inlet 'a (define-bacro* (_m_ (b 1)) `(+ ,b 1))) :readable) "(inlet :a (define-bacro* (_m_ (b 1)) (list-values '+ b 1)))") +(test (object->string (inlet 'a (define-macro* (_m_ (b 1)) `(+ ,b 1))) :readable) "(inlet :a (define-macro* (_m_ (b 1)) (list '+ b 1)))") +(test (object->string (inlet 'a (define-bacro* (_m_ (b 1)) `(+ ,b 1))) :readable) "(inlet :a (define-bacro* (_m_ (b 1)) (list '+ b 1)))") (when with-block (test (object->string (inlet 'a (block)) :readable) "(inlet :a (block))") (test (object->string (inlet 'a blocks) :readable) "(inlet :a blocks)") @@ -25275,6 +25274,8 @@ in s7: (set! x (+ x i)))) 4) +(let () (define (mk2 n) (do ((n n (- n 1)) (a () (cons () a))) ((= n 0) a))) (test (mk2 3) '(() () ()))) + (test (call-with-exit (lambda (exit) (do ((i 0 (+ i 1))) ((= i 100) i) (if (= i 2) (exit 321))))) 321) (test (call-with-exit (lambda (exit) (do ((i 0 (if (= i 3) (exit 321) (+ i 1)))) ((= i 100) i)))) 321) (test (call-with-exit (lambda (exit) (do ((i 0 (+ i 1))) ((= i 10) (exit 321))))) 321) @@ -29563,6 +29564,7 @@ in s7: (test (let ((g #f)) (+ (call-with-exit (lambda (ret) (set! g ret) (values 1 2 3)))) (g)) 'error) (test (+ (call-with-exit (lambda (ret) (ret (values 1 2 3))))) 6) (test (+ (call/cc (lambda (ret) (ret (values 1 2 3))))) 6) +(test ((lambda () (format #f "~S" (car (list (list-values ((lambda (a) (values a (+ a 1))) 2) :rest) (make-vector 3 '(1) pair?)))))) "(2 3 :rest)") (test (+ (with-input-from-string "123" (lambda () (values 1 2 3)))) 6) (test (+ (call-with-input-string "123" (lambda (p) (values 1 2 3)))) 6) @@ -29606,7 +29608,7 @@ in s7: (let-temporarily (((*s7* 'print-length) (values 1 2))) 1)) (lambda (type info) (apply format #f info))) - "let-set!: too many arguments: ((inlet 'let-ref-fallback s7-let-ref 'let-set-fallback s7-let-set) print-length 1 2)") + "let-set!: too many arguments: (*s7* print-length 1 2)") (test (catch #t (lambda () (let ((x 1)) (set! x (values 1 2)))) (lambda (type info) (apply format #f info))) "set!: can't set 'x to (values 1 2)") (test (catch #t (lambda () @@ -29752,6 +29754,13 @@ in s7: (test (string-append (values "123" "4" "5") "6" (values "78" "90")) "1234567890") (test (+ (dynamic-wind (lambda () #f) (lambda () (values 1 2 3)) (lambda () #f)) 4) 10) +(when with-block +;; 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)))) + (let ((x 'y) (y 32)) (define (f1) (values #f)) @@ -33962,7 +33971,7 @@ who says the continuation has to restart the map from the top? (test `(1 ,@(list 1 2) 4) '(1 1 2 4)) (test `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b) '(a 3 4 5 6 b)) (test `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f) '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)) -(test (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) '(a `(b ,x ,'y d) e)) +;(test (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)) '(a `(b ,x ,'y d) e)) ; list vs list-values confusion (test `(1 2 ,(* 9 9) 3 4) '(1 2 81 3 4)) (test `(1 ,(+ 1 1) 3) '(1 2 3)) (test `(,(+ 1 2)) '(3)) @@ -36307,6 +36316,15 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (hi arg arg) (list arg arg))) (list -1 #\a 1 #(1 2 3) 3.14 3/4 1.0+1.0i () 'hi abs #(()) (list 1 2 3) '(1 . 2)))) +(let () + (define* (f1 (allow-other-keys 32) (rest 4)) (+ rest allow-other-keys)) + (test (f1) 36) + (test (f1 :rest 3) 35) + (test (f1 :allow-other-keys 3) 7) + (test (f1 :allow-other-keys 3 :rest 3) 6) + (define* (f2 readable) (+ readable 1)) + (test (f2 :readable 2) 3)) + (let ((hi (lambda* (a (b 3) c) (list a b c)))) (test (hi) (list #f 3 #f)) (test (hi 1) (list 1 3 #f)) @@ -39274,6 +39292,15 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta ((list (funclet func)) 0 'lst)))) (test (func 1) '(1 2 3))) +(let () + (define f1 (let ((private-var 1)) (lambda () private-var))) + (define (f2) (+ ((funclet f1) 'private-var) 1)) + (test (list (f1) (f2)) '(1 2))) +(let ((f1 #f) (f2 #f)) + (let ((private-var 1)) + (set! f1 (lambda () private-var)) + (set! f2 (lambda () (+ private-var 1)))) + (test (list (f1) (f2)) '(1 2))) (for-each (lambda (arg) @@ -42531,6 +42558,8 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (let ((#_+ 3)) #_+) 'error) (test (define #_+ 3) 'error) (test (set! #_+ 3) 'error) +(test (with-let (inlet :rest 3) rest) 3) +(test (with-let (inlet :allow-other-keys 32) allow-other-keys) 32) (test (let ((a 21)) (let ((e (inlet (curlet)))) (set! a 32) (with-let e a))) 21) (test (let ((a 21)) (let ((e (sublet (curlet)))) (set! a 32) (with-let e a))) 32) @@ -43375,6 +43404,9 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (let ((x (openlet (inlet 'let-ref-fallback (lambda args args))))) (test (x) 'error) (test (x 1) (list x 1))) +(let ((x (openlet (inlet 'let-ref-fallback (lambda args args))))) + (let ((y (copy x))) + (test (y 1) (list y 1)))) (test ((inlet :a 1)) 'error) @@ -44196,6 +44228,13 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test ((owlet) 'error-file) error-file) )) +;;; this needs to be global (fx_tree outlet let* optimization bug, taken from array1.scm in the benchmarks) + (define (_create-y_ x) (let* ((n (vector-length x)) (result (make-vector n))) (do ((i (- n 1) (- i 1))) ((< i 0) result) (vector-set! result i 0)))) + (define (_test-fx_) (let loop ((repeat 2) (result ())) (if (> repeat 0) (loop (- repeat 1) (_create-y_ (make-vector 1))) result))) + (_test-fx_) + + + ;;; -------------------------------------------------------------------------------- ;;; object->let @@ -44389,7 +44428,7 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (e 'value) 1+) (test (e 'type) 'macro?) (test (e 'arity) '(1 . 1)) - (test (e 'source) '(lambda (x) (list-values '+ x 1))))) + (test (e 'source) '(lambda (x) (list '+ x 1))))) (test (substring "1234" ((openlet (inlet 'value 1)) 'value) ((openlet (object->let 3)) 'value)) "23") @@ -44518,6 +44557,11 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta (test (let ((x 1)) (case (let-temporarily ((x 2)) x) ((1) 'error) ((2) x))) 1) (test (let-temporarily ((1 2)) 1) 'error) (test (apply let-temporarily (list (list 1 2)) 2) 'error) +(let ((a 1)) + (test (let-temporarily ((a 2)) (let-temporarily ((a 3)))) ()) + (test a 1) + (test (let-temporarily ((a (let-temporarily ((a 3))))) a) ()) + (test a 1)) (let () (define ourlet @@ -45093,7 +45137,7 @@ hi6: (string-app... (test (let ((str (object->string (dilambda (lambda (x) x) logior) :readable))) (pair? (member str '("(dilambda (lambda (x) x) #_logior)" "(dilambda (lambda (x) x) logior)")))) #t) -(test (let () (define-macro (mac x) `(+ ,x 1)) (object->string (dilambda (lambda (x) x) mac) :readable)) "(dilambda (lambda (x) x) (lambda (x) (list-values '+ x 1)))") +(test (let () (define-macro (mac x) `(+ ,x 1)) (object->string (dilambda (lambda (x) x) mac) :readable)) "(dilambda (lambda (x) x) (lambda (x) (list '+ x 1)))") (test (object->string (dilambda (lambda (x) x) (lambda* (x y . z) x)) :readable) "(dilambda (lambda (x) x) (lambda* (x y . z) x))") (test (object->string (dilambda (lambda (x) x) (lambda (x . y) x)) :readable) "(dilambda (lambda (x) x) (lambda (x . y) x))") (test (object->string (dilambda (lambda* (x) x) (lambda* ((x 1) :rest y) x)) :readable) "(dilambda (lambda* (x) x) (lambda* ((x 1) :rest y) x))") @@ -67275,8 +67319,9 @@ hi6: (string-app... (test (= (* 10400200/16483927 1.0) (* 10781274/17087915 1.0)) #f) (test (= (* 10400200/16483927 1.0) 10781274/17087915) #f) -(test (= (* 10781274/17087915 1.0) (* 53715833/85137581 1.0)) #f) -(test (= (* 10781274/17087915 1.0) 53715833/85137581) #f) +(unless with-bignums ; equivalent? used here + (test (= (* 10781274/17087915 1.0) (* 53715833/85137581 1.0)) #f) + (test (= (* 10781274/17087915 1.0) 53715833/85137581) #f)) (test (= (* 12/19 1.0) (* 53/84 1.0)) #f) (test (= (* 12/19 1.0) 53/84) #f) (test (= (* 12941/20511 1.0) (* 15601/24727 1.0)) #f) @@ -67284,6 +67329,10 @@ hi6: (string-app... (test (= (* 15601/24727 1.0) (* 79335/125743 1.0)) #f) (test (= (* 15601/24727 1.0) 79335/125743) #f) +(test (positive? 9223372036854775808) #t) +(test (rational? -9223372036854775808/3) #t) +(test (positive? (abs -9223372036854775808/3)) #t) + ;;; (if with-bignums (test (= (* 171928773/272500658 1.0) (* 397573379/630138897 1.0)) #f)) -- needs more bits ;;; (test (= (* 171928773/272500658 1.0) 397573379/630138897) #f) @@ -79803,7 +79852,7 @@ hi6: (string-app... (num-test (* 7 6 5 4 3 2 1) 5040) (num-test (*) 1 ) (num-test (* (+ 1 3 5) (* 1 3 5)) 135) -(num-test (* -1/2147483648 1/4294967296) -1/9223372036854775808) +(when with-bignums (num-test (* -1/2147483648 1/4294967296) -1/9223372036854775808)) (num-test (* -2147483648 4294967296) -9223372036854775808) (num-test (* .000000000000123 .000000000000123) 1.5129e-26) (num-test (* 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20) 2432902008176640000) @@ -85072,7 +85121,7 @@ hi6: (string-app... (test (string->number "+nan+nani") #f) (test (equivalent? (string->number "#x+nan.0+i") +nan.0+1.0i) #t) (test (equivalent? (string->number "#x+nan.0+12i") +nan.0+18.0i) #t) -(test (string->number "#x+12/11+i") 1.0588235294117647+1.0i) +(test (equivalent? (string->number "#x+12/11+i") 1.0588235294117647+1.0i) #t) (test (string->number "#x1.2+i") 1.125+1.0i) (test (string->number "#x1e2+i") 482.0+1.0i) (test (string->number "#x12+i") 18.0+1.0i) @@ -89941,6 +89990,8 @@ etc (test (logior (mock-number 1) (mock-number 8) 2 4 16 (mock-number 32)) 63) (test (logxor (mock-number 1) (mock-number 7) 2 4 16 (mock-number 32)) (logxor 1 7 2 4 16 32)) (test (logand 63 15 31 127) (logand 63 (mock-number 15) (mock-number 31) 127)) + (test (+ (mock-number 4/3) (values)) 'error) + (test (+ (mock-number 4/3) (values) 1) 'error) (num-test (apply + nums) 37.6415926535898+1i) (num-test (apply - nums) 26.35840734641021-1i) (num-test (apply * nums) 150.7964473723101+150.7964473723101i) @@ -91170,6 +91221,50 @@ etc (test ((sublet *s7* 'a 1) 'heap-size) hpsize) (test (eval-string "heap-size" *s7*) hpsize) (test (symbol->value 'heap-size *s7*) hpsize)) +(test (length *s7*) 43) +(test (equal? *s7* *s7*) #t) +(test (type-of *s7*) 'let?) +(test (fill! *s7* #f) 'error) +(test (set! *s7* 3) 'error) +(test (let-temporarily ((*s7* 3)) 1) 'error) +(test (define *s7* 3) 'error) +(let ((old-pl (*s7* 'print-length))) + (let-temporarily (((*s7* 'print-length) 32)) + (test (eval-string "print-length" *s7*) 32) + (test (with-let *s7* print-length) 32) + (test (let ((s7 *s7*)) (s7 'print-length)) 32) + (test (let-set! *s7* 'print-length 8) 8) + (test (let-ref *s7* 'print-length) 8) + (test ((sublet *s7*) 'print-length) 8) + (test ((inlet *s7*) 'print-length) 8) + (test (with-let (sublet *s7*) print-length) 8) + (test (with-let (inlet *s7*) print-length) 8)) + (test (*s7* 'print-length) old-pl) + (test (coverlet *s7*) 'error) + (test (openlet *s7*) *s7*) + (test (*s7* 'print-length) old-pl)) +(test (object->string *s7*) "*s7*") +(test (object->string *s7* :readable) "*s7*") +(test (catch #t (lambda () (cutlet *s7* 'print-length)) (lambda (type info) (apply format #f info))) "can't cutlet *s7* (it is immutable)") +(test (catch #t (lambda () (varlet *s7* 'asdf 3)) (lambda (type info) (apply format #f info))) "varlet argument 1, *s7*, is a let but should be a mutable let") +(test (help *s7*) "*s7* is a let that gives access to s7's internal state: e.g. (*s7* 'print-length)") + +(let ((iter (make-iterator *s7*))) + (test (iterator? iter) #t) + (test (eq? (iterator-sequence iter) *s7*) #t) + (let ((val (iter))) + (test (eq? (car val) 'stack-top) #t) + (test (integer? (cdr val)) #t))) + +(test (object->let *s7*) (inlet 'value *s7* 'type 'let? 'length 43 'open #t 'outlet () 'immutable? #f)) +(test ((object->let (make-iterator *s7*)) 'sequence) *s7*) +(test (length (let->list *s7*)) 43) +(test (copy (inlet 'a 1) *s7*) 'error) +(test (vector? (copy *s7* (make-vector 4))) #t) +(test (length (map values *s7*)) 43) +(test (load "reactive.scm" *s7*) 'error) +(test (set! (setter *s7*) #f) 'error) +(test (set! (outlet *s7*) (curlet)) 'error) (test (integer? (*s7* 'stack-top)) #t) (test (integer? (*s7* 'stack-size)) #t) @@ -91252,9 +91347,8 @@ etc (test (let-set! *s7* 'a 1) 'error) (test (reverse! *s7*) 'error) (test (fill! *s7* #f) 'error) -(test (procedure? ((copy (inlet 'let-ref-fallback #f) *s7*) 'let-ref-fallback)) #t) +(test (copy (inlet 'let-ref-fallback #f) *s7*) 'error) (test (copy '((let-set-fallback . 32)) *s7*) 'error) -;; related... (test (let ((e (let () (define-constant a 1) (curlet)))) (let-set! e 'a 2) e) 'error) (test (let ((e (let () (define-constant a 1) (curlet)))) (set! (e 'a) 2) e) 'error) (test (let ((e (let () (define-constant a 1) (curlet)))) (with-let e (set! a 2)) e) 'error) @@ -91264,6 +91358,8 @@ etc (test (let () (define-constant a 3) (let ((a #f)) a)) 'error) (test (let ((e (let () (define-constant a 1) (curlet)))) (fill! e 2) e) 'error) (test (copy '((a . #f)) (let ((a 1)) (set! (setter 'a) integer?) (curlet))) 'error) +(test (defined? 'print-length *s7*) #t) +(test (defined? 'asdf *s7*) #f) (catch #t (lambda () @@ -91651,27 +91747,8 @@ etc (unless pure-s7 (test (let ((x #f)) (define (func) (let () (vector (quasiquote (fill! (with-baffle (unquote))))))) (define (hi) (func)) (hi)) 'error)) (test (let ((x #f)) (define (func) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (indexable?)))) (define (hi) (func)) (hi)) 'error) -(test (let () (define (func x) (make-list (reader-cond (#t _definee_ (define _definee_ 0))))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (make-list _definee_ (define _definee_ 0))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (make-list z (define z 0))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (string-ci>=? _definee_ -1.0 (define-bacro* _definee_ 0 (tan (string (A (f x) B) '() 1+i))))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (string-ci>=? _definee_ -1.0 (define _definee_ 0))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (call-with-input-string _definee_ (define _definee_ 0 `(x 1) (openlet (inlet 'abs (lambda (x) x))) lambda))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (call-with-input-string _definee_ (define _definee_ 0 (openlet (inlet 'abs 1))))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (quasiquote (define _definee_ 0)) (symbol _definee_)) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (int-vector-ref _definee_ (define _definee_ (define _definee_ 0)))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (vector-fill! _definee_ (char<=? enver (begin (define _definee_ 0))))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (fill! _definee_ (set! __var__ (define _definee_ 0)))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (list-ref _definee_ (with-baffle (define _definee_ 0)))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (max _definee_ (let 1/0+i (define _definee_ 0)))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (hash-table _definee_ (let-temporarily 1.0+123.0i (define _definee_ 0)))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (with-baffle (define _definee_ 0)) (for-each _definee_ (make-int-vector 3))) (define (hi) (func #f)) (hi)) 'error) ; with-baffle is like with-let -(test (let () (define (func x) (let-temporarily () (define _definee_ 2)) (+ 1 _definee_)) (define (hi) (func #f)) (hi)) 3) ; but let-temporarily is like begin?? (test (let () (let-temporarily () (define x 2)) (+ x 1)) 3) (test (let ((y 1)) (let-temporarily ((y 3)) (define x y)) (+ x y)) 4) -(test (let () (define (func x) (with-input-from-string _definee_ (lambda* 0/0+0/0i (define _definee_ 0)))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (with-input-from-string _definee_ (lambda* ((x (define _definee_ 0))) x))) (define (hi) (func #f)) (hi)) 'error) -(test (let () (define (func x) (c-pointer? _definee_ (let-temporarily () (define _definee_ 0)))) (define (hi) (func #f)) (hi)) 'error) (test (let ((x -1)) (define (func) (with-let (inlet 'a 1) (+ x 1))) (define (hi) (func)) (hi)) 'error) (test (let ((x -1)) (define (func) (with-let (inlet 'a 1) (+ 2 x 1))) (define (hi) (func)) (hi)) 'error) @@ -91692,6 +91769,9 @@ etc (test (let-temporarily ((__var__ 1)) (signature abs) . if) 'error) (test (with-let (inlet 'i 0) 1 cons . 2) 'error) (test (call-with-output-file "/dev/null" (lambda* '(- 1) (vector 1 '(3)) '((1)))) 'error) +;;; opt3 as lambda arglen +(test (dynamic-wind (lambda () (open-input-string (format #f "~W" (car (list (the (lambda args args) #i(1)) (or)))))) (lambda () #f) (lambda () #f)) 'error) +(test (call-with-exit (lambda (goto) (goto (with-input-from-string (lambda (a) (values a (+ a 1))) 2) (cadar (unless))))) 'error) (test (let () (define (f) (let ((_x_ (+ _x_ 1.0))) 1)) (f)) 'error) (test (let () (define (f) (define _x_ (let-ref (cdr _x_) 'a))) (f)) 'error) @@ -91882,25 +91962,6 @@ etc (let ((x #f)) (define (func) (call-with-exit (lambda (x) (char-ci>? (with-output-to-string x))))) (define (hi) (func)) (test (hi) 'error)) (let ((x #f)) (define (func) (call-with-exit (lambda (x) (char-ci>? (with-output-to-file "/dev/null" x))))) (define (hi) (func)) (test (hi) 'error)) (let ((x #f)) (define (func) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (indexable?)))) (define (hi) (func)) (test (hi) 'error)) -(let () (define (func x) (make-list (reader-cond (#t _definee_ (define _definee_ 0))))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (make-list _definee_ (define _definee_ 0))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (make-list z (define z 0))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (string-ci>=? _definee_ -1.0 (define-bacro* _definee_ 0 (tan (string (A (f x) B) '() 1+i))))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (string-ci>=? _definee_ -1.0 (define _definee_ 0))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (call-with-input-string _definee_ (define _definee_ 0 `(x 1) (openlet (inlet 'abs (lambda (x) x))) lambda))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (call-with-input-string _definee_ (define _definee_ 0 (openlet (inlet 'abs 1))))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (quasiquote (define _definee_ 0)) (symbol _definee_)) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (int-vector-ref _definee_ (define _definee_ (define _definee_ 0)))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (vector-fill! _definee_ (char<=? enver (begin (define _definee_ 0))))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (fill! _definee_ (set! __var__ (define _definee_ 0)))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (list-ref _definee_ (with-baffle (define _definee_ 0)))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (max _definee_ (let 1/0+i (define _definee_ 0)))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (hash-table _definee_ (let-temporarily 1.0+123.0i (define _definee_ 0)))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (with-baffle (define _definee_ 0)) (for-each _definee_ (make-int-vector 3))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (let-temporarily () (define _definee_ 2)) (+ 1 _definee_)) (define (hi) (func #f)) (test (hi) 3)) -(let () (define (func x) (with-input-from-string _definee_ (lambda* 0/0+0/0i (define _definee_ 0)))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (with-input-from-string _definee_ (lambda* ((x (define _definee_ 0))) x))) (define (hi) (func #f)) (test (hi) 'error)) -(let () (define (func x) (c-pointer? _definee_ (let-temporarily () (define _definee_ 0)))) (define (hi) (func #f)) (test (hi) 'error)) (let ((x -1)) (define (func) (with-let (inlet 'a 1) (+ x 1))) (define (hi) (func)) (test (hi) 'error)) (let ((x -1)) (define (func) (with-let (inlet 'a 1) (+ 2 x 1))) (define (hi) (func)) (test (hi) 'error)) (let ((x -1)) (define (func) (with-let (inlet 'a 1) (+ 3 2 x 1))) (define (hi) (func)) (test (hi) 'error)) @@ -94911,7 +94972,7 @@ etc let: assuming we see all set!s, the binding (list x) is pointless: perhaps (let ((list x)) (if (null? list) 3 2)) -> (if (null? x) 3 2)") (lint-test "(null? (string->list x))" " null?: perhaps (null? (string->list x)) -> (zero? (length x))") (lint-test "(memq x (if (memq y '(< <=)) '(< <=) '(> >=)))" "") ; this is checking the ->simple-type escape - (lint-test "(if q `(not ,op ,x) `(not ,op ,y))" "") ; make sure we don't try to rewrite quasiquote + (lint-test "(if q `(not ,op ,x) `(not ,op ,y))" "if: perhaps (if q (list 'not op x) (list 'not op y)) -> (list 'not op (if q x y))") (let-temporarily ((*report-one-armed-if* #t)) (lint-test "(if a (begin (set! x y) z))" " if: perhaps (if a (begin (set! x y) z)) -> (when a (set! x y) z)") @@ -95026,10 +95087,8 @@ etc cond: assuming we see all set!s, the binding (z w) is pointless: perhaps (let ((z w)) (+ x z)) -> (+ x w)") (lint-test "(cond (x (if x y z) (+ x 1)) (z 2))" " cond: this could be omitted: (if x y z)") (lint-test "(cond ((g x) `(c ,x) `(c ,y)))" - " cond: this could be omitted: (list-values 'c x) - cond: perhaps (list-values 'c x) -> (list 'c x) - cond: perhaps (list-values 'c y) -> (list 'c y) - cond: perhaps (cond ((g x) (list-values 'c x) (list-values 'c y))) -> (when (g x) (list-values 'c x) (list-values 'c y))") + " cond: this could be omitted: (list 'c x) + cond: perhaps (cond ((g x) (list 'c x) (list 'c y))) -> (when (g x) (list 'c x) (list 'c y))") (lint-test "(cond ((= x 1) 2) ((= x 2) 3))" " cond: perhaps use case instead of cond: (cond ((= x 1) 2) ((= x 2) 3)) -> (case x ((1) 2) ((2) 3))") (lint-test "(cond ((= x y) (begin (display x) y)) (else x))" " cond: redundant begin: (begin (display x) y)") (lint-test "(cond ((= x y) y) (else (begin (display x) x)))" @@ -95707,38 +95766,35 @@ etc list-values: perhaps (list-values (apply-values z) (apply-values z)) -> (append z z)") (lint-test "`(,@x ,@(map (lambda (z) `(,@z ,@z ,@x)) y))" " list-values: perhaps (list-values (apply-values z) (apply-values z) (apply-values x)) -> (append z z x)") - (lint-test "(append `(,x) z)" " append: perhaps (append (list x) z) -> (cons x z) append: perhaps (list-values x) -> (list x)") + (lint-test "(append `(,x) z)" " append: perhaps (append (list x) z) -> (cons x z)") (lint-test "(values `(x ,@y))" - " values: perhaps (values (list-values 'x (apply-values y))) -> (cons 'x y) + " values: perhaps (values (list-values 'x (apply-values y))) -> (cons 'x y) values: perhaps (list-values 'x (apply-values y)) -> (cons 'x y)") - (lint-test "(values `(x ,y) a)" " values: perhaps (values (list-values 'x y) a) -> (values (list 'x y) a) values: perhaps (list-values 'x y) -> (list 'x y)") (lint-test "(values `(,x ,@y) z)" " values: perhaps (values (list-values x (apply-values y)) z) -> (values (cons x y) z) values: perhaps (list-values x (apply-values y)) -> (cons x y)") (lint-test "(values `(,@x ,@y) `(,x z))" - " values: perhaps (values (list-values (apply-values x) (apply-values y)) (list-values x 'z)) -> (values (append x y) (list x 'z)) - values: perhaps (list-values (apply-values x) (apply-values y)) -> (append x y) - values: perhaps (list-values x 'z) -> (list x 'z)") + " values: perhaps (values (list-values (apply-values x) (apply-values y)) (list x 'z)) -> (values (append x y) (list x 'z)) + values: perhaps (list-values (apply-values x) (apply-values y)) -> (append x y)") (lint-test "(define (g x) `(+ ,y ,@(map f x)))" " g: perhaps (list-values '+ y (apply-values (map f x))) -> (cons '+ (cons y (map f x)))") (lint-test "(define (g x) `(+ ,@(map f x)))" " g: perhaps (list-values '+ (apply-values (map f x))) -> (cons '+ (map f x))") (lint-test "(define (g x) `(,e ,@(map f x)))" " g: perhaps (list-values e (apply-values (map f x))) -> (cons e (map f x))") (lint-test "(define (g x) `(f ,@x ,@y))" " g: perhaps (list-values 'f (apply-values x) (apply-values y)) -> (cons 'f (append x y))") (lint-test "(define (g x) `(display ,(map f x)))" " g: perhaps (list-values 'display (map f x)) -> (list 'display (map f x))") - (lint-test "(define-macro (g x) `(f ,x))" - " define-macro: perhaps (define-macro (g x) (list-values 'f x)) -> (define g f) - g: perhaps (list-values 'f x) -> (list 'f x)") (lint-test "(define-macro (g x) `(,@x ,y))" " g: perhaps (list-values (apply-values x) y) -> (append x (list y))") (lint-test "(define-macro (g x) `(,@x z))" " g: perhaps (list-values (apply-values x) 'z) -> (append x (list 'z))") (lint-test "(define-macro (g x) `(,@x ,(f y)))" " g: perhaps (list-values (apply-values x) (f y)) -> (append x (list (f y)))") (lint-test "(define-macro (g x) `(+ ,y ,@(map f x)))" " g: perhaps (list-values '+ y (apply-values (map f x))) -> (cons '+ (cons y (map f x)))") (lint-test "(define-macro (g x) `(,@x ,y ,@z))" " g: perhaps (list-values (apply-values x) y (apply-values z)) -> (append x (cons y z))") (lint-test "(define-macro (g x) `(,@x ,@y ,z))" " g: perhaps (list-values (apply-values x) (apply-values y) z) -> (append x y (list z))") + (lint-test "(define f `((cond . ,forced-indent) (case . ,print-case) (let . ,let-expr)))" - " f: perhaps (list-values (append (list-values 'cond) forced-indent) (append... -> (list (cons 'cond forced-indent) (cons 'case print-case) ...) - f: perhaps (append (list 'cond) forced-indent) -> (cons 'cond forced-indent)") + " f: perhaps (append (list 'cond) forced-indent) -> (cons 'cond forced-indent)") (lint-test "(define f `((cond . ,forced-indent) (let . ,let-expr)))" - " f: perhaps (list-values (append (list-values 'cond) forced-indent) (append... -> (list (cons 'cond forced-indent) (cons 'let let-expr)) + " f: perhaps (list-values (append (list 'cond) forced-indent) (append (list 'let) let-expr)) -> + (list (cons 'cond forced-indent) (cons 'let let-expr)) f: perhaps (append (list 'cond) forced-indent) -> (cons 'cond forced-indent)") + (lint-test "(set! x `(f . (,g . 100)))" " set!: perhaps (append (list 'f g) 100) -> (cons 'f (cons g 100)) set!: perhaps (list-values 'f g) -> (list 'f g)") @@ -96855,7 +96911,7 @@ etc (lint-test "(let loop ((i 0) (lst ())) (if (= i 10) lst (loop (+ i 1) (cons 1 lst))))" " loop: perhaps (let loop ((i 0) (lst ())) (if (= i 10) lst (loop (+ i 1) (cons 1 lst)))) -> (do ((i 0 (+ i 1)) (lst () (cons 1 lst))) ((= i 10) lst)) - loop: perhaps (do ((i 0 (+ i 1)) (lst () (cons 1 lst))) ((= i 10) lst)) -> (make-list 10 1)") + loop: perhaps (let loop ((i 0) (lst ())) (if (= i 10) lst (loop (+ i 1) (cons 1 lst)))) -> (make-list 10 1)") (lint-test "(let ((x (f y))) (display x) (define z (f x)) (do ((i 0 (+ i 1))) ((= i 3)) (display (+ x z i))))" " let: the scope of z could be reduced: (... (define z (f x)) (do ((i 0 (+ i 1))) ((= i 3)) (display (+ x z i)))) -> @@ -98086,7 +98142,7 @@ etc (lint-test "(apply f `(,@(list x y)))" " apply: perhaps (apply f (list-values (apply-values (list x y)))) -> (apply f (list x y)) apply: perhaps (list-values (apply-values (list x y))) -> (list x y)") - (lint-test "(apply f `(x (,y 1) ,z))" " apply: perhaps (apply f (list-values 'x (list-values y 1) z)) -> (f 'x (list y 1) z)") + (lint-test "(apply f `(x (,y 1) ,z))" " apply: perhaps (apply f (list-values 'x (list y 1) z)) -> (f 'x (list y 1) z)") (lint-test "(apply make-string tcnt initializer)" "") (lint-test "(apply cons x y)" " apply: perhaps (apply cons x y) -> (cons x (car y))") (lint-test "(apply string (make-list pad #\\null))" " apply: perhaps (apply string (make-list pad #\\null)) -> (make-string pad #\\null)") @@ -98215,8 +98271,7 @@ etc (lint-test "(number->string (cdr (or (assv i alist) (cons 0 0))))" " number->string: perhaps (cdr (or (assv i alist) (cons 0 0))) -> (cond ((assv i alist) => cdr) (else 0))") (lint-test "(cdr (or (assoc n oi) `(,n)))" - " cdr: perhaps (cdr (or (assoc n oi) (list-values n))) -> (cond ((assoc n oi) => cdr) (else (list))) - cdr: perhaps (list-values n) -> (list n)") + " cdr: perhaps (cdr (or (assoc n oi) (list n))) -> (cond ((assoc n oi) => cdr) (else (list)))") (lint-test "(cdr (or (assoc n oi) (list n y)))" " cdr: perhaps (cdr (or (assoc n oi) (list n y))) -> (cond ((assoc n oi) => cdr) (else (list y)))") (lint-test "(cdr (or (assoc n oi) (list n y z)))" @@ -98305,13 +98360,12 @@ etc ;; and here also (lint-test "(defmacro hi ())" " defmacro: defmacro declaration is messed up: (defmacro hi ())") - (lint-test "(defmacro (hi x) `(+ ,x 1))" " defmacro: defmacro used where s7 uses define-defmacro: (defmacro (hi x) (list-values '+ x 1))?") + (lint-test "(defmacro (hi x) `(+ ,x 1))" " defmacro: defmacro used where s7 uses define-defmacro: (defmacro (hi x) (list '+ x 1))?") (lint-test "(defmacro hi (a b a) a)" " defmacro: defmacro parameter is repeated: (a b a) hi: defmacro parameter a is declared twice") + (lint-test "(defmacro hi (a b) `(+ ,a ,b))" - " defmacro: defmacro is deprecated; perhaps (defmacro hi (a b) (list-values '+ a b)) -> (define-macro (hi a b) (list-values '+ a b)) - defmacro: perhaps (define-macro (hi a b) (list-values '+ a b)) -> (define hi +)") - (lint-test "(defmacro hi a `(+ ,a ,b))" - " defmacro: defmacro is deprecated; perhaps (defmacro hi a (list-values '+ a b)) -> (define-macro (hi . a) (list-values '+ a b))") + " defmacro: defmacro is deprecated; perhaps (defmacro hi (a b) (list '+ a b)) -> (define-macro (hi a b) (list '+ a b)) + defmacro: perhaps (define-macro (hi a b) (list '+ a b)) -> (define hi +)") (lint-test "(defmacro* mac1 (a :key b :optional c . d) `(list ,a ,b ,c ,@d))" " defmacro*: defmacro* is deprecated; perhaps (defmacro* mac1 (a :key b :optional c . d) (list-values 'list a b c... -> (define-macro* (mac1 a b c . d) (list-values 'list a b c (apply-values d)))") @@ -98324,6 +98378,7 @@ etc (lint-test "(define a a)" " define: this define is either not needed, or is an error: (define a a)") (lint-test "(define #(a) 2)" " define: strange form: (define #(a) 2)") (lint-test "(define (f1 a) (abs a))" " f1: f1 could be (define f1 abs)") + (lint-test "(define f1 (lambda (a) (cddr a)))" " f1: perhaps (lambda (a) (cddr a)) -> cddr") (lint-test "(define (f1 a b) \"a docstring\" (log a b))" " f1: f1 could be (define f1 log)") (lint-test "(let () (define (f1 a b) (* 2 (log a b))) (define (f2 a b) (f1 a b)) (f2 1 2))" " let: perhaps change f2 to a let: @@ -98478,7 +98533,7 @@ etc let: f1 has too many arguments: (f1 2 3)") (lint-test "(let () (define-macro (m1 a) a) (m1 2 3))" " let: m1 has too many arguments: (m1 2 3)") (lint-test "(let () (define-macro (m2 b) `(let ((a 12)) (+ a ,b))) (let ((a 1) (+ *)) (+ a (m2 a))))" - " let: possible problematic macro expansion: (m2 a) may collide with subsequently defined 'a, + + " let: possible problematic macro expansion: (m2 a) may collide with subsequently defined 'a let: assuming we see all set!s, the binding (+ *) is pointless: perhaps (let ((a 1) (+ *)) (+ a (m2 a))) -> (let ((a 1)) (* a (m2 a)))") (lint-test "(let () (define-macro (m3 b) `(let ((a 12)) (+ (symbol->value ,b) a))) (let ((a 1)) (+ a (m3 'a))))" " let: possible problematic macro expansion: (m3 'a) could conceivably collide with subsequently defined 'a") @@ -98488,7 +98543,7 @@ etc (lint-test "(define-macro (f a . x) `(+ ,a ,@x))" " define-macro: perhaps (define-macro (f a . x) (list-values '+ a (apply-values x))) -> (define f +) f: perhaps (list-values '+ a (apply-values x)) -> (cons '+ (cons a x))") - (lint-test "(define-macro (m1 a) `((,a b c)))" " m1: perhaps (list-values (list-values a 'b 'c)) -> (list (list a 'b 'c))") + (lint-test "(define-macro (m1 a) `((,a b c)))" " m1: perhaps (list-values (list a 'b 'c)) -> (list (list a 'b 'c))") (lint-test "(define pi (acos -1))" " define: (acos -1) is one of its many names, but pi is a predefined constant in s7 pi: perhaps (acos -1) -> pi") (lint-test "(+ x (atan 0 -1))" " +: perhaps (+ x (atan 0 -1)) -> (+ x pi)") @@ -98518,16 +98573,17 @@ etc (lint-test "(define-macro (m3) ''a)" " define-macro: perhaps (define-macro (m3) ''a) -> (define m3 'a) or (define (m3) 'a) m3: returns a list constant: ''a") + (lint-test "(define-macro (m4 a) `(abs ,a))" - " define-macro: perhaps (define-macro (m4 a) (list-values 'abs a)) -> (define m4 abs) - m4: perhaps (list-values 'abs a) -> (list 'abs a)") - (lint-test "(define-macro (m5 a) `(log ,a 2))" " define-macro: perhaps (define-macro (m5 a) (list-values 'log a 2)) -> (define (m5 a) (log a 2))") + " define-macro: perhaps (define-macro (m4 a) (list 'abs a)) -> (define m4 abs)") + (lint-test "(define-macro (m5 a) `(log ,a 2))" " define-macro: perhaps (define-macro (m5 a) (list 'log a 2)) -> (define (m5 a) (log a 2))") + (lint-test "(define-macro (m6 a) `(+ ,a ,a))" "") ; here a might be (display 32) -- should happen twice - (lint-test "(define-macro (m7 a b) `(set! ,a ,b))" " define-macro: perhaps (define-macro (m7 a b) (list-values 'set! a b)) -> (define m7 set!)") + (lint-test "(define-macro (m7 a b) `(set! ,a ,b))" " define-macro: perhaps (define-macro (m7 a b) (list 'set! a b)) -> (define m7 set!)") (lint-test "(define-macro (m8 a) `(lambda () ,a))" "") (lint-test "(define-macro (m8 a) `(let () ,a))" "") (lint-test "(define-macro (m9 a b) `(+ ,a (* ,b 2)))" "") - (lint-test "(define-macro (m10 a) `(+ ,a x))" " define-macro: perhaps (define-macro (m10 a) (list-values '+ a 'x)) -> (define (m10 a) (+ a x))") + (lint-test "(define-macro (m10 a) `(+ ,a x))" " define-macro: perhaps (define-macro (m10 a) (list '+ a 'x)) -> (define (m10 a) (+ a x))") (lint-test "(define-macro (m11) (- -1 (* -2 (expt 2 28))))" " define-macro: perhaps (define-macro (m11) (- -1 (* -2 (expt 2 28)))) -> (define m11 (- -1 (* -2 (expt 2 28)))) or (define (m11) (- -1 (* -2 (expt 2 28))))") @@ -98542,11 +98598,11 @@ etc (lint-test "(define-macro (m a) `(+ 1 a))" " define-macro: missing comma? (define-macro (m a) '(+ 1 a)) m: returns a list constant: '(+ 1 a)") (lint-test "(define-macro (m a) `(+ 1 ,a (* a 2)))" - " define-macro: perhaps (define-macro (m a) (list-values '+ 1 a '(* a 2))) -> (define (m a) (+ 1 a (* a 2))) - define-macro: missing comma? (define-macro (m a) (list-values '+ 1 a '(* a 2)))") + " define-macro: perhaps (define-macro (m a) (list '+ 1 a '(* a 2))) -> (define (m a) (+ 1 a (* a 2))) + define-macro: missing comma? (define-macro (m a) (list '+ 1 a '(* a 2)))") (lint-test "(define-macro (m1 x) `(begin (vector-set! ,x 0 1)))" - " m1: pointless begin: (list-values 'begin (list-values 'vector-set! x 0 1)) -> (list-values 'vector-set! x 0 1) - m1: perhaps (list-values 'begin (list-values 'vector-set! x 0 1)) -> (list 'begin (list 'vector-set! x 0 1))") + " m1: pointless begin: (list-values 'begin (list 'vector-set! x 0 1)) -> (list 'vector-set! x 0 1) + m1: perhaps (list-values 'begin (list 'vector-set! x 0 1)) -> (list 'begin (list 'vector-set! x 0 1))") (lint-test "(let ((a 1)) (define (f1 b) (+ a b)) (f1 0))" " let: perhaps (... (define (f1 b) (+ a b)) (f1 0)) -> (... (let ((b 0)) (+ a b))) @@ -98719,14 +98775,14 @@ etc " f21: perhaps (set! x 3) -> (let ((x 3)) ...) begin: f21's parameter 1's value is not used, but a value is passed: (+ z 1)") (lint-test "(begin (define (f22 x) (case y ((0) `(+ ,x 1)) (else #f))) (f22 2))" - " f22: perhaps (case y ((0) (list-values '+ x 1)) (else #f)) -> (and (eqv? y 0) (list-values '+ x 1))") + " f22: perhaps (case y ((0) (list '+ x 1)) (else #f)) -> (and (eqv? y 0) (list '+ x 1))") (lint-test "(begin (define (f23 x) (+ y 1)) (define (f24 x) (f23 (+ x 1))) (f24 0))" " f24: f23's parameter 1 is not used, but a value is passed: (+ x 1)") (unless pure-s7 (lint-test "(begin (define x 1) `#(,x))" ; this can be expanded: (lambda (x) #((unquote x))) " begin: quasiquoted vectors are not supported: #((unquote x)) perhaps use `(vector ...) rather than `#(...)")) (lint-test "(begin (define-macro (m1 x y) `(+ ,y 1)) (m1 a b))" - " begin: perhaps (define-macro (m1 x y) (list-values '+ y 1)) -> (define (m1 x y) (+ y 1)) + " begin: perhaps (define-macro (m1 x y) (list '+ y 1)) -> (define (m1 x y) (+ y 1)) begin: m1's parameter 1 is not used, but a value is passed: a") (lint-test "(begin (define (f30 x) (if (> x 0) (f30 #() (- x 1)))) (f30 1))" " f30: f30 has too many arguments: (f30 #() (- x 1))") @@ -100317,8 +100373,8 @@ etc (lint-test "(define (func x) (when `((x)) when '((())) and . case))" " func: when is messed up: (when '((x)) when '((())) and . case)") (lint-test "(define (func x) (do . 0)) (define (hi) (func (define-macro (_m1_ a) `(+ ,a 1)))) (hi)" " func: do is messed up: (do . 0) - hi: func's parameter 1 is not used, but a value is passed: (define-macro (_m1_ a) (list-values '+ a 1)) - hi: perhaps (define-macro (_m1_ a) (list-values '+ a 1)) -> (define (_m1_ a) (+ a 1))") + hi: func's parameter 1 is not used, but a value is passed: (define-macro (_m1_ a) (list '+ a 1)) + hi: perhaps (define-macro (_m1_ a) (list '+ a 1)) -> (define (_m1_ a) (+ a 1))") (lint-test "(define (func x) (unless .(atan . __asdf__)))" " func: unless is messed up: (unless atan . __asdf__)") (lint-test "(define (func x) (floor (* +.(inexact->exact))))" " func: inexact->exact needs 1 argument: (inexact->exact)") (lint-test "(define (func x) (if (proper-list? ) (and / when '((())) () begin) (call-with-input-string (stacktrace +0 -1 1 20100))))" @@ -101094,6 +101150,7 @@ etc (test (mc1 (let-temporarily ((else #f)) 1)) 1) (test (let-temporarily ((else #f)) (mc4 1)) 1)) +(test (let () (define (f) (let ((apply cons)) (apply abs -1))) (f)) (cons abs -1)) #| ;;; after much dithering I've decided that built-in C functions have a very aggressive take @@ -55,11 +55,11 @@ #include "snd-strings.h" -#define SND_DATE "31-July-19" +#define SND_DATE "3-Sep-19" #ifndef SND_VERSION -#define SND_VERSION "19.6" +#define SND_VERSION "19.7" #endif #define SND_MAJOR_VERSION "19" -#define SND_MINOR_VERSION "6" +#define SND_MINOR_VERSION "7" #endif @@ -1424,7 +1424,7 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.") ;;; -------------------------------------------------------------------------------- -(define (*s7*->list) +(define (*s7*->list) ;(let->list *s7*) but not using keywords (list :print-length (*s7* 'print-length) :safety (*s7* 'safety) @@ -1462,7 +1462,9 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.") :catches (*s7* 'catches) :history-size (*s7* 'history-size) :history-enabled (*s7* 'history-enabled) - :history (*s7* 'history))) + :history (*s7* 'history) + :most-positive-fixnum (*s7* 'most-positive-fixnum) + :most-negative-fixnum (*s7* 'most-negative-fixnum))) diff --git a/tools/auto-tester.scm b/tools/auto-tester.scm index 3756a11..557d0e2 100644 --- a/tools/auto-tester.scm +++ b/tools/auto-tester.scm @@ -85,10 +85,10 @@ (set! (*s7* 'max-stack-size) 32768) (set! (*s7* 'max-heap-size) (ash 1 23)) ; 8M -- 560000000 is about 8G -(set! (*s7* 'max-port-data-size) (ash 1 23)) +(set! (*s7* 'max-port-data-size) (ash 1 28)) ;(set! (*s7* 'gc-stats) #t) -(set! (*s7* 'print-length) 1000) -(set! (*s7* 'max-string-length) 100000) +(set! (*s7* 'print-length) 20) +(set! (*s7* 'max-string-length) 5000000) (set! (*s7* 'max-list-length) 10000) (set! (*s7* 'max-vector-length) 10000) (set! (*s7* 'max-vector-dimensions) 10) @@ -136,7 +136,7 @@ (define (s7-stacktrace-defaults) (copy (*s7* 'stacktrace-defaults))) (define (s7-gc-stats) (*s7* 'gc-stats)) (define (s7-undefined-identifier-warnings) (*s7* 'undefined-identifier-warnings)) -(define (s7-set-print-length x) (set! (*s7* 'print-length) x)) +;(define (s7-set-print-length x) (set! (*s7* 'print-length) x)) (define (s7-set-stacktrace-defaults x) (set! (*s7* 'stacktrace-defaults) x)) #| @@ -197,13 +197,32 @@ ;(define (_fnc6_ x) (unless (let? x) (let-temporarily (((*s7* 'safety) 1)) (fill! x #\a)))) ;;; (define (_fnc7_ x) (let-temporarily (((*s7* 'safety) 1)) (reverse! x))) +(define (fib n) + (if (< n 2) + n + (+ (fib (- n 1)) + (fib (- n 2))))) + +(define (fibr n) + (if (>= n 2) + (+ (fibr (- n 1)) + (fibr (- n 2))) + n)) + +(define (fibf n) + (if (< n 2.0) + n + (+ (fibf (- n 1.0)) + (fibf (- n 2.0))))) + + (define (local-random . args) (type-of (apply random args))) (define (local-read-string . args) (with-input-from-file "/home/bil/cl/all-lg-results" (lambda () - (read-string (car args))))) + (read-string (min 1000 (car args)))))) (define (checked-eval code) (and (pair? code) @@ -237,12 +256,12 @@ (define (checked-read-byte . args) (with-input-from-string "0123" (lambda () (apply read-byte args)))) (define (checked-read-line . args) (with-input-from-file "s7test.scm" (lambda () (apply read-line args)))) (define (checked-read-string . args) (with-input-from-file "s7test.scm" (lambda () (apply read-string args)))) -(define (checked-read . args) (with-input-from-file "s7test.scm" (lambda () (apply read args)))) +(define (checked-read . args) (with-input-from-file "dsp.scm" (lambda () (apply read args)))) (define (checked-reverse! . args) (reverse! (copy (car args)))) (define (checked-port-line-number . args) (apply port-line-number args) 0) ;(define (checked-let-set! . args) (apply let-set! (curlet) args)) -;(define (checked-varlet . args) (apply varlet (curlet) args)) -;(define (checked-cutlet . args) (apply cutlet (curlet) args)) +;(define (checked-varlet . args) (apply varlet (sublet (curlet)) args)) +;(define (checked-cutlet . args) (apply cutlet (sublet (curlet)) args)) (define (checked-procedure-source . args) (copy (apply procedure-source args) :readable)) (load "s7test-block.so" (sublet (curlet) (cons 'init_func 'block_init))) @@ -460,6 +479,48 @@ (lambda (t i) 'error))) +#| +(define-expansion (_fe1_ . args) + `(for-each (lambda (n) (n 0)) (list ,@args))) + +(define-expansion (_fe2_ . args) + `(do ((x (list ,@args) (cdr x))) + ((null? x) #unspscified>) + ((car x) 0))) + +(define-expansion (_fe3_ . args) + `(for-each (lambda (n) (set! (n) 0)) (list ,@args))) + +(define-expansion (_fe4_ . args) + `(do ((x (list ,@args) (cdr x))) + ((null? x) #unspscified>) + (set! ((car x)) 0))) +|# + +(define-macro (trace f) + (let ((old-f (gensym))) + `(define ,f + (let ((,old-f ,f)) + (apply lambda 'args + `((format () "(~S ~{~S~^ ~}) -> " ',',f args) + (let ((val (apply ,,old-f args))) + (format () "~S~%" val) + val))))))) + +(define-expansion (_tr1_ . args) + `(with-output-to-string + (lambda () + (define (tracy . pars) pars) + (trace tracy) + (apply tracy ,@args ())))) + +(define-expansion (_tr2_ . args) + `(with-output-to-string + (lambda () + ((lambda pars + (format () "(tracy ~{~S~^ ~}) -> ~S~%" pars pars)) + ,@args)))) + (define-constant ims (immutable! (string #\a #\b #\c))) (define-constant imbv (immutable! (byte-vector 0 1 2))) @@ -600,7 +661,8 @@ ;'read-char 'read-byte 'read-line 'read-string 'read ; stdin=>hangs 'checked-read-char 'checked-read-line 'checked-read-string 'checked-read-byte 'checked-read 'checked-reverse! 'checked-port-line-number - ;;'checked-let-set! 'checked-varlet 'checked-cutlet + ;;'checked-let-set! + 'checked-varlet 'checked-cutlet 'close-input-port ;;'current-input-port ;-- too many (read...) ;;'set-current-input-port ; -- collides with rd8 etc @@ -672,6 +734,8 @@ 'list-values 'byte-vector? 'openlet? 'iterator? 'string->byte-vector 'byte-vector->string + ;'pp + 's7-catches 's7-stack-top 's7-stack 's7-symbol-table @@ -749,7 +813,7 @@ "cons" "''2" "\"ra\"" "#\\a" "#\\A" "\"str1\"" "\"STR1\"" "#\\0" "(make-hook)" "(make-hook '__x__)" - "1+i" "0+i" "(ash 1 43)" + "1+i" "0+i" "(ash 1 43)" "(fib 8)" "(fibr 8)" "(fibf 8.0)" "(integer->char 255)" "(string (integer->char 255))" "(string #\\null)" "(byte-vector 0)" "pi" "+nan.0" "+inf.0" "-inf.0" "-nan.0" "(list)" "(string)" "#r()" "#u()" "(vector)" "#i()" "(make-iterator #(10 20))" "#i(1)" @@ -795,7 +859,7 @@ (set! lst (cdr lst)) res) #<eof>))))" - "#<eof>" "#<undefined>" "#<unspecified>" "#unknown" + "#<eof>" "#<undefined>" "#<unspecified>" "#unknown" "___lst" "#o123" "#b101" "#\\newline" "#\\alarm" "#\\delete" "#_cons" "#x123.123" "#\\x65" ;"_1234_" "kar" "(provide 'pizza)" "(require pizza)" @@ -899,6 +963,8 @@ "(make-hash-table 8 #f (cons symbol? block?))" "(let ((i 32)) (set! (setter 'i) integer?) (curlet))" + "(let () (define (boolean|integer? x) (or (boolean? x) (integer? x))) (make-vector 3 #f boolean|integer?)))" + "(immutable! #(1 2))" "(immutable! #r(1 2))" "(immutable! \"asdf\")" "(immutable! '(1 2))" "(immutable! (hash-table 'a 1))" ;"(lambda (x) (fill! x 0))" @@ -924,6 +990,7 @@ "(hash-table +nan.0 1)" "#\\7" "(inlet :a (hash-table 'b 1))" "(openlet (immutable! (inlet :a 1)))" "(subvector #i2d((1 2) (3 4)) 4)" "(subvector #i2d((1 2) (3 4)) '(4))" "(subvector #i2d((1 2) (3 4)) '(2 1))" + "(begin (ow!) #f)" #f #f #f )) @@ -972,8 +1039,13 @@ (list "(begin (string " "(apply string (list ") (list "(begin (float-vector " "(apply float-vector (list ") (list "(begin (values " "(apply values (list ") + (list "(begin (_tr1_ " "(begin (_tr2_ ") + + (list "(begin (do ((i 0 (+ i 1))) ((= i 1)) " "(let ((__x__ 1)) (do ((i 0 (+ i __x__))) ((= i __x__)) ") ;(list "(cond ((= x 0) " "(begin (when (= x 0) ") + ;(list "(_fe1_ " "(_fe2_ ") + ;(list "(_fe3_ " "(_fe4_ ") (list "(begin (_iter_ " "(begin (_map_ ") (list "(begin (_cat1_ " "(begin (_cat2_ ") @@ -1195,6 +1267,7 @@ )) (define (eval-it str) + ;(ow!) (set! (current-output-port) #f) ;(format *stderr* "~S~%" str) (set! estr str) @@ -1210,14 +1283,16 @@ (not (eq? error-type last-error-type))) (format *stderr* "~S ~S~%" last-error-type error-type) (set! last-error-type error-type)) - (if (eq? type 'stack-too-big) + (if (and (eq? type 'stack-too-big) + (not (string-position "lambda" str))) (format *stderr* "stack overflow from ~S~%" str)) (when (eq? type 'heap-too-big) (format *stderr* "heap overflow from ~S~%" str)) (unless (or (not (eq? type 'read-error)) (string-position "junk" (car info)) (string-position "clobbered" (car info)) - (string-position "unexpected" (car info))) + (string-position "unexpected" (car info)) + (string-position "eval-string" str)) ;; "unexpected" close paren from: (eval-string (reverse (object->string ()))) -> (eval-string ")(") (format *stderr* "read-error from ~S: ~S~%" str (apply format #f info)) (if (string-position "a1" str) (format *stderr* "a1: ~W~%" a1)) @@ -1249,7 +1324,10 @@ (val3 (eval-it str3)) (val4 (eval-it str4))) ;(gc) (gc) + (set! (*s7* 'print-length) 20) (same-type? val1 val2 val3 val4 str str1 str2 str3 str4) + (unless (hash-table? a1) + (format *stderr* "a1: ~S, str: ~S~%" a1 str)) )) #| (let* ((outer (codes (random codes-len))) @@ -1287,7 +1365,8 @@ (lambda () (test-it)) (lambda (type info) - (format *stderr* "outer: ~S ~S from ~S~%" type (apply format #f info) estr))))) + (format *stderr* "~%~%outer: ~S ~S from ~S~%" type (apply format #f info) estr) + (format *stderr* "owlet: ~S~%" (owlet)))))) ;;; (let () ((lambda () str))) (let () (define _f_ (lambda () str)) (_f_)) ;;; (let _f_ ((x #f) (i 0)) str) diff --git a/tools/dup.scm b/tools/dup.scm index 547d5a0..f5fc45f 100644 --- a/tools/dup.scm +++ b/tools/dup.scm @@ -9,8 +9,8 @@ (define dups (let ((unique #f)) - (define-constant (all-positive? start end) - (do ((j end (- j 1))) + (define-constant (all-positive? start len) + (do ((j (+ start len) (- j 1))) ((or (vector-ref unique j) (= j start)) j))) @@ -89,14 +89,14 @@ (last-line (- total-lines size)) (i 0 (+ i 1))) ((>= i last-line)) ; >= because i is set below - (let ((j (all-positive? i (+ i size-1)))) ; is a match possible? + (let ((j (all-positive? i size-1))) ; is a match possible? (if (not (= j i)) (set! i j) (let ((lenseq (subvector lens size i)) (lineseq (subvector lines size i))) (do ((k (+ i 1) (+ k 1))) ((>= k last-line)) - (let ((jk (all-positive? k (+ k size-1)))) + (let ((jk (all-positive? k size-1))) (if (not (= jk k)) (set! k jk) (when (and (equal? lenseq (subvector lens size k)) diff --git a/tools/fbench.scm b/tools/fbench.scm index 274504b..8754328 100644 --- a/tools/fbench.scm +++ b/tools/fbench.scm @@ -176,10 +176,10 @@ (set! current-surfaces 4) (define (fbench iteration-count) - (let ((od-sa '())) + (let ((od-sa ())) (do ((iteration 0 (+ iteration 1))) ((> iteration iteration-count)) - (set! od-sa '()) + (set! od-sa ()) (do ((jp 0 (+ jp 1))) ((> jp 1)) ;; Do main trace in D light @@ -228,9 +228,9 @@ (if (not (equal? (car expected) (car received))) (begin (set! errors (+ errors 1)) - (format #t "Error in results in line ~D...~%" line) - (format #t "Expected: ~A~%" (car expected)) - (format #t "Received: ~A~%" (car received))))))))) + (format () "Error in results in line ~D...~%" line) + (format () "Expected: ~A~%" (car expected)) + (format () "Received: ~A~%" (car received))))))))) (fbench 50000) diff --git a/tools/makexg.scm b/tools/makexg.scm index a407ccf..b2687bc 100755 --- a/tools/makexg.scm +++ b/tools/makexg.scm @@ -182,7 +182,7 @@ "glong" "double" "GdkAxisFlags" "GdkSubpixelLayout" "GdkTouchpadGesturePhase" "GdkEventMotion*" - "GtkCssSection*" + "GtkCssSection*" "GdkPaintableFlags" )) (define no-xen-to-c @@ -211,7 +211,7 @@ "glong" "GdkAxisFlags" "GdkSubpixelLayout" "GdkTouchpadGesturePhase" "GdkEventMotion*" - "GtkCssSection*" + "GtkCssSection*" "GdkPaintableFlags" )) (for-each (lambda (lst) @@ -1748,7 +1748,7 @@ ;(hey "#define C_to_Xen_GtkTreeSelectionFunc(Arg) wrap_for_Xen(GtkTreeSelectionFunc, Arg)~%") ;(hey "#define C_to_Xen_GtkMenuPositionFunc(Arg) wrap_for_Xen(GtkMenuPositionFunc, Arg)~%") ;(hey "#define C_to_Xen_GtkDestroyNotify(Arg) wrap_for_Xen(GtkDestroyNotify, Arg)~%") -(hey "#define Xen_to_C_GdkFilterReturn(Arg) (GdkFilterReturn)Xen_integer_to_C_int(Arg)~%") +;(hey "#define Xen_to_C_GdkFilterReturn(Arg) (GdkFilterReturn)Xen_integer_to_C_int(Arg)~%") ;(hey "#define Xen_to_C_String(Arg) Xen_string_to_C_string(Arg)~%") (hey "#define C_to_Xen_String(Arg) C_string_to_Xen_string((char *)Arg)~%") diff --git a/tools/tauto.scm b/tools/tauto.scm index a6946cb..5f10d0a 100644 --- a/tools/tauto.scm +++ b/tools/tauto.scm @@ -39,7 +39,8 @@ #i(1 2) (vector 1 '(3)) (let ((x 3)) (lambda (y) (+ x y))) abs 'a 'b one (lambda args args) (lambda* ((a 3) (b 2)) (+ a b)) (lambda () 3) (sublet () 'a 1) ;(rootlet) - *load-hook* *error-hook* (random-state 123) + *load-hook* *error-hook* + (random-state 123) quasiquote macroexpand begin let letrec* if case cond (call-with-exit (lambda (goto) goto)) (with-baffle (call/cc (lambda (cc) cc))) (string #\a #\null #\b) #2d((1 2) (3 4)) (inlet 'a 2 'b 3) diff --git a/tools/tbig.scm b/tools/tbig.scm index 1367da6..b23aded 100644 --- a/tools/tbig.scm +++ b/tools/tbig.scm @@ -27,6 +27,7 @@ (define fft-size (ash 1 17)) (define little-size 1000000) + ;; -------------------------------------------------------------------------------- (format () "complex fft...~%") @@ -200,7 +201,6 @@ (clear-and-gc) - ;; -------------------------------------------------------------------------------- (format () "strings...~%") @@ -208,6 +208,7 @@ (clear-and-gc) (let ((bigstr (make-string big-size))) (define (big-string-filler) + ;(fill! bigstr #\null 0 big-size)) (do ((i 0 (+ i 1))) ((= i big-size)) (string-set! bigstr i #\null))) @@ -250,6 +251,7 @@ (test (length p) 20) (test p "dddddddddddddddddddd")) (big-string-filler) + ; -- why the do loop? (fill! bigstr #\null 0 big-size) (let ((bv (string->byte-vector bigstr))) (test (byte-vector? bv) #t) (test (length bv) (length bigstr)) diff --git a/tools/tcopy.scm b/tools/tcopy.scm index 13fdbd7..0d52cd8 100644 --- a/tools/tcopy.scm +++ b/tools/tcopy.scm @@ -19,7 +19,7 @@ (do ((i 0 (+ i 1))) ((= i size)) - (hash-table-set! old-hash (string->symbol (number->string i)) #\a)) + (hash-table-set! old-hash (string->symbol (number->string i)) #\a)) ; gensym is slower, even with "" as prefix (copy old-hash old-let) (let ((new-string (make-string size #\space)) diff --git a/tools/teq.scm b/tools/teq.scm index 5a78413..0079ed7 100644 --- a/tools/teq.scm +++ b/tools/teq.scm @@ -69,7 +69,7 @@ ;(format *stderr* "~A ~A ~A ~A ~A~%" (length hash-0) (length hash-1) (length hash-2) (length hash-3) (length hash-4)) -(set! (*s7* 'initial-string-port-length) 64) +;(set! (*s7* 'initial-string-port-length) 64) (define (tests size) (let ((str #f) diff --git a/tools/tfft.scm b/tools/tfft.scm index 9c7bbaa..8da1272 100644 --- a/tools/tfft.scm +++ b/tools/tfft.scm @@ -84,12 +84,70 @@ (set! ui ti)) #t)) +(if (not (defined? 'complex)) + (define complex make-rectangular)) +(if (not (defined? 'when)) + (define-macro (when test . body) `(if ,test (begin ,@body)))) + +(define* (cfft data n (dir 1)) ; complex data + (unless n (set! n (length data))) + (do ((i 0 (+ i 1)) + (j 0)) + ((= i n)) + (if (> j i) + (let ((temp (data j))) + (set! (data j) (data i)) + (set! (data i) temp))) + (do ((m (/ n 2) (/ m 2))) + ((or (< m 2) + (< j m)) + (set! j (+ j m))) + (set! j (- j m)))) + (do ((ipow (floor (log n 2))) + (prev 1) + (lg 0 (+ lg 1)) + (mmax 2 (* mmax 2)) + (pow (/ n 2) (/ pow 2)) + (theta (complex 0.0 (* pi dir)) (* theta 0.5))) + ((= lg ipow)) + (do ((wpc (exp theta)) + (wc 1.0) + (ii 0 (+ ii 1))) + ((= ii prev) + (set! prev mmax)) + (do ((jj 0 (+ jj 1)) + (i ii (+ i mmax)) + (j (+ ii prev) (+ j mmax))) + ((>= jj pow)) + (let ((tc (* wc (data j)))) + (set! (data j) (- (data i) tc)) + (set! (data i) (+ (data i) tc)))) + (set! wc (* wc wpc)))) + data) + +(when (defined? 'equivalent?) + (unless (equivalent? (cfft (vector 0.0 1+i 0.0 0.0)) #(1+1i -1+1i -1-1i 1-1i)) + (format *stderr* "cfft 1: ~S~%" (cfft (vector 0.0 1+i 0.0 0.0)))) + (let-temporarily (((*s7* 'equivalent-float-epsilon) 1e-14)) + (unless (equivalent? (cfft (vector 0 0 1+i 0 0 0 1-i 0)) #(2 -2 -2 2 2 -2 -2 2)) + (format *stderr* "cfft 2: ~S~%" (cfft (vector 0 0 1+i 0 0 0 1-i 0)))))) + (define (fft-bench) (let ((*re* (make-float-vector (+ size 1) 0.10)) (*im* (make-float-vector (+ size 1) 0.10))) (do ((ntimes 0 (+ ntimes 1))) ((= ntimes times)) - (b_fft *re* *im*)))) + (b_fft *re* *im*))) + + (let* ((n 256) + (cdata (make-vector n 0.0))) + (do ((i 0 (+ i 1))) + ((= i times)) + (fill! cdata 0.0) + (vector-set! cdata 2 1+i) + (vector-set! cdata (- n 1) 1-i) + (cfft cdata))) + ) (fft-bench) diff --git a/tools/tform.scm b/tools/tform.scm index 0854d1b..d7fb8b0 100644 --- a/tools/tform.scm +++ b/tools/tform.scm @@ -34,7 +34,7 @@ (make-vector '(2 3) "hi") #("hiho" "hi" "hoho") (subvector (make-int-vector '(2 3) 1) 6) (subvector (subvector (make-float-vector '(2 3) 1.0) 6) '(2 2)) (vector-ref #2d((#(1 2 3)) (#(3 4 5))) 0 0) (define-macro (m a) `(+ ,a 1)) - (c-pointer 0) (c-pointer -1) :readable *s7* else (define-bacro* (m (a 1)) `(+ ,a 1)) + (c-pointer 0) (c-pointer -1) :readable else (define-bacro* (m (a 1)) `(+ ,a 1)) (byte-vector 0 1 2) (byte-vector) (byte-vector 255 0 127) (make-iterator (vector '(a . 2))) (lambda (dir) 1.0) (float-vector) (make-float-vector '(2 2)) (int-vector 1 2 3) (int-vector) (inlet 'value 1 '+ (lambda args 1)) (inlet) (make-iterator (inlet 'a 1 'b 2) (cons #f #f)) @@ -66,36 +66,36 @@ (define-constant ctrl-chars-len (length ctrl-chars)) (define (test-calls ctrl-str tries size1 op) - (let ((x #f) (y #f) (z #f) (pos 0) - (cs constants) - (cs-len constants-len)) - (do ((i 0 (+ i 1))) - ((= i tries)) - (do ((j 1 (+ j 1))) - ((= j size1)) - (string-set! ctrl-str j (string-ref ctrl-chars (random ctrl-chars-len)))) - - (set! x (vector-ref cs (random cs-len))) - (set! y (vector-ref cs (random cs-len))) - (set! z (vector-ref cs (random cs-len))) - - (object->string x) - (display x op) - - (catch #t (lambda () (format #f "~{~^~S ~} ~{~|~S ~} ~W" x y z)) (lambda arg 'error)) - (catch #t (lambda () (format #f ctrl-str)) (lambda arg 'error)) - (catch #t (lambda () (format #f ctrl-str x)) (lambda arg 'error)) - (catch #t (lambda () (format #f ctrl-str y)) (lambda arg 'error)) - (catch #t (lambda () (format #f ctrl-str z)) (lambda arg 'error)) - (set! pos (char-position #\~ ctrl-str 1)) - (when pos - (catch #t (lambda () (format #f ctrl-str x z)) (lambda arg 'error)) - (catch #t (lambda () (format #f ctrl-str x y)) (lambda arg 'error)) - (catch #t (lambda () (format #f ctrl-str y z)) (lambda arg 'error)) - (catch #t (lambda () (format #f ctrl-str z x)) (lambda arg 'error)) - (when (char-position #\~ ctrl-str (+ pos 1)) - (catch #t (lambda () (format #f ctrl-str x y z)) (lambda arg 'error)) - (catch #t (lambda () (format #f ctrl-str z y x)) (lambda arg 'error))))))) + (do ((i 0 (+ i 1)) + (x #f) (y #f) (z #f) (pos 0) + (cs constants) + (cs-len constants-len)) + ((= i tries)) + (do ((j 1 (+ j 1))) + ((= j size1)) + (string-set! ctrl-str j (string-ref ctrl-chars (random ctrl-chars-len)))) + + (set! x (vector-ref cs (random cs-len))) + (set! y (vector-ref cs (random cs-len))) + (set! z (vector-ref cs (random cs-len))) + + (object->string x) + (display x op) + + (catch #t (lambda () (format #f "~{~^~S ~} ~{~|~S ~} ~W" x y z)) (lambda arg 'error)) + (catch #t (lambda () (format #f ctrl-str)) (lambda arg 'error)) + (catch #t (lambda () (format #f ctrl-str x)) (lambda arg 'error)) + (catch #t (lambda () (format #f ctrl-str y)) (lambda arg 'error)) + (catch #t (lambda () (format #f ctrl-str z)) (lambda arg 'error)) + (set! pos (char-position #\~ ctrl-str 1)) + (when pos + (catch #t (lambda () (format #f ctrl-str x z)) (lambda arg 'error)) + (catch #t (lambda () (format #f ctrl-str x y)) (lambda arg 'error)) + (catch #t (lambda () (format #f ctrl-str y z)) (lambda arg 'error)) + (catch #t (lambda () (format #f ctrl-str z x)) (lambda arg 'error)) + (when (char-position #\~ ctrl-str (+ pos 1)) + (catch #t (lambda () (format #f ctrl-str x y z)) (lambda arg 'error)) + (catch #t (lambda () (format #f ctrl-str z y x)) (lambda arg 'error)))))) (define (test-chars) (let ((op (open-output-string))) diff --git a/tools/tgen.scm b/tools/tgen.scm index fbb836c..488b648 100644 --- a/tools/tgen.scm +++ b/tools/tgen.scm @@ -19,7 +19,7 @@ (set! *clm-file-buffer-size* 16) (set! *clm-table-size* 16) (set! *clm-clipped* #f) -;(set! (*s7* 'gc-stats) #t) +;(set! (*s7* 'gc-stats) #t) ; also, unset heap-size is best (define start-run (get-internal-real-time)) (define M (float-vector 0 0 1 10)) diff --git a/tools/tmac.scm b/tools/tmac.scm index 495cfab..cfb0145 100644 --- a/tools/tmac.scm +++ b/tools/tmac.scm @@ -1,19 +1,5 @@ -(define size 500000) - -(define (f1 x) - (let ((y x)) - (do ((j 0 (+ j 1))) - ((= j 1)) - (do ((i 0 (+ i 1))) - ((= i size)) - (let-temporarily ((y 32)) - (if (not (= y 32)) - (format *stderr* "temp y: ~A~%" y))) - (if (not (= y x)) - (format *stderr* "y: ~A~%" y)))))) - -(f1 1) +(define size 500000) (define-macro (m2 a b) `(+ ,a ,@b 1)) (define (f2) @@ -44,4 +30,68 @@ (f3) +(define (f4 m) (+ 2 (m 3))) +(define (f4-test mx) + (do ((i 0 (+ i 1))) + ((= i size)) + (f4 mx))) + +(define-macro (m4 a) `(+ ,a 1)) +(f4-test m4) + +(define-macro (m5 a . b) `(+ ,a ,@b)) +(f4-test m5) + +(define-macro* (m6 (a 21)) `(+ ,a 1)) +(f4-test m6) + +(define (f5-test) + (do ((i 0 (+ i 1))) + ((= i size)) + (m5 1 3 4 5))) +(f5-test) + +(define-macro (m61 a b) `(+ ,a ,@b)) +(define (f61-test mx) + (do ((i 0 (+ i 1))) + ((= i size)) + (mx 1 (3 4 5)))) +(f61-test m61) + +(define (f7-test mx) + (do ((i 0 (+ i 1))) + ((= i size)) + (mx 1 ()))) +(f7-test m61) + +(define (f8-test mx) + (let loop ((ctr size)) + (mx 1 3 4 5) + (if (= ctr 0) + 0 + (loop (- ctr 1))))) +(f8-test m5) + + +(define-macro (trace f) + (let ((old-f (gensym))) + `(define ,f + (let ((,old-f ,f)) + (apply lambda 'args + `((format #f "(~S ~{~S~^ ~}) -> " ',',f args) + (let ((val (apply ,,old-f args))) + (format #f "~S~%" val) + val))))))) + +(define (trace-test) + (let loop ((count 0)) + (if (< count 30000) ; not 'when for old snd timings + (begin + (let ((f1 (lambda (x y z) (+ x y z)))) + (trace f1) ; op_macro_d I think + (f1 count count count) + (loop (+ count 1))))))) + +(trace-test) + (exit) diff --git a/tools/tmap.scm b/tools/tmap.scm index 71d1900..4098d28 100644 --- a/tools/tmap.scm +++ b/tools/tmap.scm @@ -314,8 +314,7 @@ ;;; this is a revision of some code posted in comp.lang.lisp by melzzzzz for euler project 512 -;;; apparently sbcl computes the big case (below) in "about a minute" -- well, so does s7! -;;; 53 secs sbcl, 80 in s7 + #| (define (make-boolean-vector n) (make-int-vector (ceiling (/ n 63)))) @@ -328,7 +327,7 @@ (logior (int-vector-ref ,v (quotient ,n 63)) (ash 1 (remainder ,n 63))))) |# -;;; this is slightly faster +;;; this is slightly faster (using int-vector is better for the largest cases) (define (make-boolean-vector n) (make-vector n #f)) (define boolean-vector-ref vector-ref) (define-expansion (boolean-vector-set! v j) `(vector-set! ,v ,j #t)) @@ -383,7 +382,9 @@ (display r) (newline))) -;;; (display (getr 500000000)) ;50660591862310323 +;;; (getr 5000000) 5066059769259 .5 +;;; (getr 50000000) 506605921933035 6 +;;; (getr 500000000) 50660591862310323 67 (32M, mutable_do) (exit) diff --git a/tools/tmisc.scm b/tools/tmisc.scm new file mode 100644 index 0000000..1984506 --- /dev/null +++ b/tools/tmisc.scm @@ -0,0 +1,163 @@ +(set! (*s7* 'heap-size) 1024000) + +(define size 500000) + +;;; let-temporarily +(define (w1 x) + (let ((y x)) + (do ((j 0 (+ j 1))) + ((= j 1)) + (do ((i 0 (+ i 1))) + ((= i size)) + (let-temporarily ((y 32)) + (unless (= y 32) + (format *stderr* "temp y: ~A~%" y))) + (unless (= y x) + (format *stderr* "y: ~A~%" y)))))) + +(define (w2) + (let ((x 1)) + (let ((y (let-temporarily ((x 32)) + (+ x 1)))) + (+ x y)))) + +(define (w3) + (let ((x 1) + (y 2)) + (let ((z (let-temporarily ((x 6) (y 7)) + (+ x y)))) + (+ x y z)))) + +(define (w4) + (let ((y (let-temporarily (((*s7* 'print-length) 32)) + (*s7* 'print-length)))) + (+ y 1))) + +(define (wtest) + (w1 3) + (unless (= (w2) 34) (format *stderr* "w2 got ~S~%" (w2))) + (unless (= (w3) 16) (format *stderr* "w3 got ~S~%" (w3))) + (do ((i 0 (+ i 1))) + ((= i size)) + (w2) + (w3))) + + +;;; => +(define (f1) + (cond (-2 => abs))) + +(define (x+1 x) + (+ x 1)) + +(define (f2) + (cond (32 => x+1))) + +(define* (x+y x (y 2)) + (+ x y)) + +(define (f3 z) + (cond ((if z 1 3) => x+y))) + +(define (f4) + (cond ((random 1) => "asdf"))) + +(define (xs) + (values 1 2 3)) + +(define (f5) + (do ((i 0 (+ i 1))) ((xs) => +))) + +(define (f6 x) + (case x ((1) 2) (else => abs))) + +(define (ftest) + (unless (= (f1) 2) (format *stderr* "f1 got ~S~%" (f1))) + (unless (= (f2) 33) (format *stderr* "f2 got ~S~%" (f2))) + (unless (= (f3 #t) 3) (format *stderr* "(f3 #t) got ~S~%" (f3 #t))) + (unless (= (f3 #f) 5) (format *stderr* "(f3 #f) got ~S~%" (f3 #f))) + (unless (char=? (f4) #\a) (format *stderr* "(f4) got ~S~%" (f4))) + (unless (= (f5) 6) (format *stderr* "(f5) got ~S~%" (f5))) + (unless (= (f6 -2) 2) (format *stderr* "(f6 -2) got ~S~%" (f6 -2))) + + (do ((i 0 (+ i 1))) + ((= i size)) + (f1) + (f2) + (f3 #t) + (f4) + (f5) + (f6 -2))) + +(ftest) +(wtest) + + +;;; mv +(define (mv1) + (+ (values 1 2 3))) +(define (mv2) + (+ 1 (values 2 3))) +(define (mv3) + (+ (values 1 2) 3)) +(define (mv4 x) + (+ x (values x x))) +(define (mv5 x) + (+ (values x x) x)) +(define (mv-clo1 x y) + (+ x y)) +(define (mv6 x) + (mv-clo1 (values x 1))) +(define (mv-clo2 . args) + (apply + args)) +(define (mv7 x) + (mv-clo2 (values x 1))) +(define (mv8) + (+ (values 1 2 3) (values 3 -2 -1))) +(define (mv9) + (+ (abs -1) (values 2 3 4) -4)) +(define (mv10) + (+ (values 1 2 3))) +(define (mv11) + (+ (abs -1) (values -1 2 4))) +(define (mv12 x y) + (+ x y (values 2 3 4))) + +;;; pair_sym: (mv-clo (values x 1)), h_c_aa: (values x 1), splice_eval_args2 ([i] 1), eval_arg2->apply mv-clo! (loop below is safe_dotimes_step_p +;;; not enough args for mv-clo1? +;;; mv-clo2: closure_s_p -> pair_sym ->h_c_aa etc as above! +;;; perhaps apply_[safe_]closure? + +(define (mvtest) + (unless (= (mv1) 6) (format *stderr* "mv1: ~S~%" (mv1))) + (unless (= (mv2) 6) (format *stderr* "mv2: ~S~%" (mv2))) + (unless (= (mv3) 6) (format *stderr* "mv3: ~S~%" (mv3))) + (unless (= (mv4 2) 6) (format *stderr* "(mv4 2): ~S~%" (mv4 2))) + (unless (= (mv5 2) 6) (format *stderr* "(mv5 2): ~S~%" (mv5 2))) + (unless (= (mv6 5) 6) (format *stderr* "(mv6 5): ~S~%" (mv6 5))) + (unless (= (mv7 5) 6) (format *stderr* "(mv7 5): ~S~%" (mv7 5))) + (unless (= (mv8) 6) (format *stderr* "mv8: ~S~%" (mv8))) + (unless (= (mv9) 6) (format *stderr* "mv9: ~S~%" (mv9))) + (unless (= (mv10) 6) (format *stderr* "mv10: ~S~%" (mv10))) + (unless (= (mv11) 6) (format *stderr* "mv11: ~S~%" (mv11))) + (unless (= (mv12 -1 -2) 6) (format *stderr* "(mv12 -1 -2): ~S~%" (mv12 -1 -2))) + (do ((i 0 (+ i 1))) + ((= i 50000)) + (mv1) + (mv2) + (mv3) + (mv4 i) + (mv5 i) + (mv6 i) + (mv7 i) + (mv8) + (mv9) + (mv10) + (mv11) + (mv12 -2 -1) + )) + +(mvtest) + + +(exit) diff --git a/tools/valcall.scm b/tools/valcall.scm index 4d9110d..ab78110 100644 --- a/tools/valcall.scm +++ b/tools/valcall.scm @@ -13,6 +13,7 @@ ("tread.scm" . "v-read") ("tmap.scm" . "v-map") ("tmat.scm" . "v-mat") + ("tmisc.scm" . "v-misc") ("lg.scm" . "v-lg") ("titer.scm" . "v-iter") ("tsort.scm" . "v-sort") @@ -73,29 +74,30 @@ (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" "tmac.scm") (list "repl" "tauto.scm") (list "repl" "tshoot.scm") - (list "snd -noinit" "make-index.scm") (list "repl" "tref.scm") + (list "snd -noinit" "make-index.scm") (list "repl" "teq.scm") (list "repl" "s7test.scm") (list "repl" "tvect.scm") + (list "repl" "tmisc.scm") (list "repl" "lt.scm") + (list "repl" "tform.scm") + (list "repl" "tlet.scm") (list "repl" "tcopy.scm") (list "repl" "tread.scm") - (list "repl" "tlet.scm") - (list "repl" "tform.scm") - (list "repl" "tfft.scm") - (list "repl" "tmat.scm") (list "repl" "tclo.scm") + (list "repl" "tmat.scm") (list "repl" "fbench.scm") - (list "repl" "trclo.scm") (list "repl" "titer.scm") - (list "repl" "tmap.scm") - (list "repl" "tsort.scm") + (list "repl" "trclo.scm") (list "repl" "tset.scm") (list "repl" "dup.scm") + (list "repl" "tmap.scm") + (list "repl" "tsort.scm") + (list "repl" "tmac.scm") + (list "repl" "tfft.scm") (list "repl" "trec.scm") (list "repl" "thash.scm") (list "snd -noinit" "tgen.scm") ; repl here + cload sndlib was slower @@ -1288,7 +1288,7 @@ void xen_initialize(void) -/* ------------------------------ S7 ------------------------------ */ +/* ------------------------------ s7 ------------------------------ */ #if HAVE_SCHEME #include "s7.h" @@ -288,7 +288,6 @@ static Xen xg_GtkTreeListRow__symbol, xg_GtkTreeListModel__symbol, xg_GtkText__s #define Xen_is_lambda_data(Arg) 1 #define C_to_Xen_GtkTreeViewSearchPositionFunc(Arg) wrap_for_Xen(GtkTreeViewSearchPositionFunc, Arg) #define C_to_Xen_GtkTreeViewSearchEqualFunc(Arg) wrap_for_Xen(GtkTreeViewSearchEqualFunc, Arg) -#define Xen_to_C_GdkFilterReturn(Arg) (GdkFilterReturn)Xen_integer_to_C_int(Arg) #define C_to_Xen_String(Arg) C_string_to_Xen_string((char *)Arg) static Xen C_to_Xen_GError_(GError *err) { @@ -937,8 +936,6 @@ Xm_type_Ptr_1(GdkGeometry_, GdkGeometry*) Xm_type_Ptr(GdkDrop_, GdkDrop*) Xm_type_Ptr(GdkDrag_, GdkDrag*) Xm_type_Ptr(GdkGLTexture_, GdkGLTexture*) -#define Xen_to_C_GdkPaintableFlags(Arg) (GdkPaintableFlags)(Xen_integer_to_C_int(Arg)) -#define Xen_is_GdkPaintableFlags(Arg) Xen_is_integer(Arg) #define C_to_Xen_GtkPropagationPhase(Arg) C_int_to_Xen_integer(Arg) #define Xen_to_C_GtkPropagationPhase(Arg) (GtkPropagationPhase)(Xen_integer_to_C_int(Arg)) #define Xen_is_GtkPropagationPhase(Arg) Xen_is_integer(Arg) @@ -39155,13 +39152,13 @@ static void define_functions(void) { #if HAVE_SCHEME s7_pointer s_boolean, s_integer, s_real, s_string, s_any, s_pair, s_float, s_gtk_enum_t, s_pair_false; - s7_pointer pl_bsu, pl_bsigb, pl_buuusuug, pl_i, pl_bu, pl_pb, pl_bur, pl_bug, pl_bus, pl_bui, pl_bub, pl_buui, pl_buus, pl_busu, pl_buub, pl_buig, pl_busib, pl_buuub, pl_buttu, pl_busgu, pl_buuui, pl_buuig, pl_buiuig, pl_buusib, pl_buuuub, pl_buurbr, pl_t, pl_iit, pl_iiit, pl_ti, pl_it, pl_tiu, pl_itsub, pl_itiiub, pl_itstttg, pl_itgiiut, pl_tts, pl_tti, pl_g, pl_s, pl_gi, pl_igi, pl_tg, pl_p, pl_si, pl_is, pl_isi, pl_sig, pl_isgt, pl_isigutttiiu, pl_ts, pl_tsi, pl_tsig, pl_tsiu, pl_tsiuui, pl_tsiiuui, pl_iu, pl_pi, pl_iur, pl_iug, pl_iui, pl_ius, pl_piu, pl_pit, pl_iuis, pl_iusi, pl_iuui, pl_iuuui, pl_iuisi, pl_iuuuui, pl_iuisut, pl_tusiuiui, pl_tuiiiiui, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_pt, pl_tu, pl_tut, pl_tus, pl_tug, pl_tur, pl_tui, pl_tub, pl_tusg, pl_tugb, pl_tugs, pl_tuui, pl_tuib, pl_tusi, pl_tuug, pl_tuig, pl_tuur, pl_turi, pl_tusr, pl_tusb, pl_tuub, pl_tuus, pl_tugu, pl_tugr, pl_tugi, pl_tusu, pl_tuut, pl_tugt, pl_tuis, pl_tust, pl_tuiu, pl_tuit, pl_tuuiu, pl_tuurb, pl_tuuri, pl_tuugi, pl_turgs, pl_tuisi, pl_tusri, pl_tuuut, pl_tuubr, pl_tuuub, pl_tuuir, pl_tuuui, pl_tuusi, pl_tuiiu, pl_tuiggu, pl_turrrb, pl_tuusit, pl_tuurbr, pl_tusiis, pl_tusuig, pl_tuuubr, pl_tuuiuui, pl_tubiiiu, pl_du, pl_pr, pl_dui, pl_dus, pl_dusi, pl_dusr, pl_sg, pl_gs, pl_b, pl_gu, pl_pg, pl_gus, pl_pgi, pl_pgu, pl_gui, pl_guut, pl_pgbi, pl_guuut, pl_gurrsiu, pl_gussitu, pl_ssi, pl_ssig, pl_bi, pl_big, pl_su, pl_ps, pl_bt, pl_tb, pl_bti, pl_sui, pl_sug, pl_psi, pl_psb, pl_psu, pl_sus, pl_psg, pl_psgi, pl_psiu, pl_psut, pl_btiib, pl_suuub, pl_psugt, pl_psiuub, pl_psrrrb, pl_psgbiiiit, pl_psiiuusu, pl_pu, pl_pur, pl_pub, pl_pui, pl_pug, pl_pus, pl_put, pl_pugi, pl_pubi, pl_puri, pl_pust, pl_pusi, pl_pusu, pl_pugu, pl_puiu, pl_puiig, pl_puigu, pl_pusiu, pl_pusub, pl_puuiu, pl_puiiu, pl_pussu, pl_puibu, pl_pusig, pl_puiigi, pl_pugiiu, pl_puuubu, pl_pusigu, pl_pusiiu, pl_puuiiu, pl_pusiuiu, pl_puuusuug, pl_pusiuibu, pl_bpt; + s7_pointer pl_si, pl_is, pl_isi, pl_sig, pl_isgt, pl_isigutttiiu, pl_tg, pl_sg, pl_gs, pl_iu, pl_pi, pl_iur, pl_iug, pl_iui, pl_ius, pl_piu, pl_pit, pl_iuis, pl_iusi, pl_iuui, pl_iuuui, pl_iuisi, pl_iuuuui, pl_iuisut, pl_gu, pl_pg, pl_gus, pl_pgi, pl_pgu, pl_gui, pl_guut, pl_pgbi, pl_guuut, pl_gurrsiu, pl_gussitu, pl_t, pl_s, pl_du, pl_pr, pl_dui, pl_dus, pl_dusi, pl_dusr, pl_p, pl_tts, pl_tti, pl_ts, pl_tsi, pl_tsig, pl_tsiu, pl_tsiuui, pl_tsiiuui, pl_ssi, pl_ssig, pl_bi, pl_big, pl_tusiuiui, pl_tuiiiiui, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_pt, pl_tu, pl_tut, pl_tus, pl_tug, pl_tur, pl_tui, pl_tub, pl_tusg, pl_tugb, pl_tugs, pl_tuui, pl_tuib, pl_tusi, pl_tuug, pl_tuig, pl_tuur, pl_turi, pl_tusr, pl_tusb, pl_tuub, pl_tuus, pl_tugu, pl_tugr, pl_tugi, pl_tusu, pl_tuut, pl_tugt, pl_tuis, pl_tust, pl_tuiu, pl_tuit, pl_tuuiu, pl_tuurb, pl_tuuri, pl_tuugi, pl_turgs, pl_tuisi, pl_tusri, pl_tuuut, pl_tuubr, pl_tuuub, pl_tuuir, pl_tuuui, pl_tuusi, pl_tuiiu, pl_tuiggu, pl_turrrb, pl_tuusit, pl_tuurbr, pl_tusiis, pl_tusuig, pl_tuuubr, pl_tuuiuui, pl_tubiiiu, pl_su, pl_ps, pl_sui, pl_sug, pl_psi, pl_psb, pl_psu, pl_sus, pl_psg, pl_psgi, pl_psiu, pl_psut, pl_suuub, pl_psugt, pl_psiuub, pl_psrrrb, pl_psgbiiiit, pl_psiiuusu, pl_pu, pl_pur, pl_pub, pl_pui, pl_pug, pl_pus, pl_put, pl_pugi, pl_pubi, pl_puri, pl_pust, pl_pusi, pl_pusu, pl_pugu, pl_puiu, pl_puiig, pl_puigu, pl_pusiu, pl_pusub, pl_puuiu, pl_puiiu, pl_pussu, pl_puibu, pl_pusig, pl_puiigi, pl_pugiiu, pl_puuubu, pl_pusigu, pl_pusiiu, pl_puuiiu, pl_pusiuiu, pl_puuusuug, pl_pusiuibu, pl_b, pl_bt, pl_tb, pl_bti, pl_btiib, pl_bsu, pl_bsigb, pl_buuusuug, pl_bu, pl_pb, pl_bur, pl_bug, pl_bus, pl_bui, pl_bub, pl_buui, pl_buus, pl_busu, pl_buub, pl_buig, pl_busib, pl_buuub, pl_buttu, pl_busgu, pl_buuui, pl_buuig, pl_buiuig, pl_buusib, pl_buuuub, pl_buurbr, pl_iit, pl_iiit, pl_gi, pl_igi, pl_i, pl_g, pl_ti, pl_it, pl_tiu, pl_itsub, pl_itiiub, pl_itstttg, pl_itgiiut, pl_bpt; #if GTK_CHECK_VERSION(3, 0, 0) - s7_pointer pl_buigu, pl_tuuugi, pl_tuuuub, pl_pgr, pl_gug, pl_puuig, pl_puiiui; + s7_pointer pl_pgr, pl_gug, pl_tuuugi, pl_tuuuub, pl_puuig, pl_puiiui, pl_buigu; #endif #if GTK_CHECK_VERSION(3, 4, 0) - s7_pointer pl_tsu, pl_prrru, pl_suiig; + s7_pointer pl_prrru, pl_tsu, pl_suiig; #endif #if GTK_CHECK_VERSION(3, 6, 0) @@ -39185,11 +39182,11 @@ static void define_functions(void) #endif #if GTK_CHECK_VERSION(3, 94, 0) - s7_pointer pl_busi, pl_buib, pl_iuugs, pl_piigui, pl_tuiut, pl_tuuur, pl_tugug, pl_tugui, pl_tuuiut, pl_tutisi, pl_tuiiut, pl_tubbbt, pl_tusuiut, pl_tuugggi, pl_tuuuggu, pl_pst, pl_purru, pl_purrrru; + s7_pointer pl_iuugs, pl_piigui, pl_tuiut, pl_tuuur, pl_tugug, pl_tugui, pl_tuuiut, pl_tutisi, pl_tuiiut, pl_tubbbt, pl_tusuiut, pl_tuugggi, pl_tuuuggu, pl_pst, pl_purru, pl_purrrru, pl_busi, pl_buib; #endif #if GTK_CHECK_VERSION(3, 96, 0) - s7_pointer pl_buiu, pl_buiib, pl_tuiiiu, pl_tuugiu, pl_purrg, pl_puuugi, pl_bg; + s7_pointer pl_tuiiiu, pl_tuugiu, pl_bg, pl_purrg, pl_puuugi, pl_buiu, pl_buiib; #endif #endif @@ -39211,62 +39208,15 @@ static void define_functions(void) s_gtk_enum_t = s7_make_symbol(s7, "gtk_enum_t?"); s_any = s7_t(s7); - pl_bsu = s7_make_circular_signature(s7, 2, 3, s_boolean, s_string, s_pair_false); - pl_bsigb = s7_make_circular_signature(s7, 4, 5, s_boolean, s_string, s_integer, s_gtk_enum_t, s_boolean); - pl_buuusuug = s7_make_circular_signature(s7, 7, 8, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_string, s_pair_false, s_pair_false, s_gtk_enum_t); - pl_i = s7_make_circular_signature(s7, 0, 1, s_integer); - pl_bu = s7_make_circular_signature(s7, 1, 2, s_boolean, s_pair_false); - pl_pb = s7_make_circular_signature(s7, 1, 2, s_pair, s_boolean); - pl_bur = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_real); - pl_bug = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_gtk_enum_t); - pl_bus = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_string); - pl_bui = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_integer); - pl_bub = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_boolean); - pl_buui = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_integer); - pl_buus = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_string); - pl_busu = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_string, s_pair_false); - pl_buub = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_boolean); - pl_buig = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_integer, s_gtk_enum_t); - pl_busib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_string, s_integer, s_boolean); - pl_buuub = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_boolean); - pl_buttu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_any, s_any, s_pair_false); - pl_busgu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_string, s_gtk_enum_t, s_pair_false); - pl_buuui = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_integer); - pl_buuig = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t); - pl_buiuig = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_integer, s_pair_false, s_integer, s_gtk_enum_t); - pl_buusib = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_string, s_integer, s_boolean); - pl_buuuub = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean); - pl_buurbr = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_real, s_boolean, s_real); - pl_t = s7_make_circular_signature(s7, 0, 1, s_any); - pl_iit = s7_make_circular_signature(s7, 2, 3, s_integer, s_integer, s_any); - pl_iiit = s7_make_circular_signature(s7, 3, 4, s_integer, s_integer, s_integer, s_any); - pl_ti = s7_make_circular_signature(s7, 1, 2, s_any, s_integer); - pl_it = s7_make_circular_signature(s7, 1, 2, s_integer, s_any); - pl_tiu = s7_make_circular_signature(s7, 2, 3, s_any, s_integer, s_pair_false); - pl_itsub = s7_make_circular_signature(s7, 4, 5, s_integer, s_any, s_string, s_pair_false, s_boolean); - pl_itiiub = s7_make_circular_signature(s7, 5, 6, s_integer, s_any, s_integer, s_integer, s_pair_false, s_boolean); - pl_itstttg = s7_make_circular_signature(s7, 6, 7, s_integer, s_any, s_string, s_any, s_any, s_any, s_gtk_enum_t); - pl_itgiiut = s7_make_circular_signature(s7, 6, 7, s_integer, s_any, s_gtk_enum_t, s_integer, s_integer, s_pair_false, s_any); - pl_tts = s7_make_circular_signature(s7, 2, 3, s_any, s_any, s_string); - pl_tti = s7_make_circular_signature(s7, 2, 3, s_any, s_any, s_integer); - pl_g = s7_make_circular_signature(s7, 0, 1, s_gtk_enum_t); - pl_s = s7_make_circular_signature(s7, 0, 1, s_string); - pl_gi = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_integer); - pl_igi = s7_make_circular_signature(s7, 2, 3, s_integer, s_gtk_enum_t, s_integer); - pl_tg = s7_make_circular_signature(s7, 1, 2, s_any, s_gtk_enum_t); - pl_p = s7_make_circular_signature(s7, 0, 1, s_pair); pl_si = s7_make_circular_signature(s7, 1, 2, s_string, s_integer); pl_is = s7_make_circular_signature(s7, 1, 2, s_integer, s_string); pl_isi = s7_make_circular_signature(s7, 2, 3, s_integer, s_string, s_integer); pl_sig = s7_make_circular_signature(s7, 2, 3, s_string, s_integer, s_gtk_enum_t); pl_isgt = s7_make_circular_signature(s7, 3, 4, s_integer, s_string, s_gtk_enum_t, s_any); pl_isigutttiiu = s7_make_circular_signature(s7, 10, 11, s_integer, s_string, s_integer, s_gtk_enum_t, s_pair_false, s_any, s_any, s_any, s_integer, s_integer, s_pair_false); - pl_ts = s7_make_circular_signature(s7, 1, 2, s_any, s_string); - pl_tsi = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_integer); - pl_tsig = s7_make_circular_signature(s7, 3, 4, s_any, s_string, s_integer, s_gtk_enum_t); - pl_tsiu = s7_make_circular_signature(s7, 3, 4, s_any, s_string, s_integer, s_pair_false); - pl_tsiuui = s7_make_circular_signature(s7, 5, 6, s_any, s_string, s_integer, s_pair_false, s_pair_false, s_integer); - pl_tsiiuui = s7_make_circular_signature(s7, 6, 7, s_any, s_string, s_integer, s_integer, s_pair_false, s_pair_false, s_integer); + pl_tg = s7_make_circular_signature(s7, 1, 2, s_any, s_gtk_enum_t); + pl_sg = s7_make_circular_signature(s7, 1, 2, s_string, s_gtk_enum_t); + pl_gs = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_string); pl_iu = s7_make_circular_signature(s7, 1, 2, s_integer, s_pair_false); pl_pi = s7_make_circular_signature(s7, 1, 2, s_pair, s_integer); pl_iur = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_real); @@ -39282,6 +39232,38 @@ static void define_functions(void) pl_iuisi = s7_make_circular_signature(s7, 4, 5, s_integer, s_pair_false, s_integer, s_string, s_integer); pl_iuuuui = s7_make_circular_signature(s7, 5, 6, s_integer, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_integer); pl_iuisut = s7_make_circular_signature(s7, 5, 6, s_integer, s_pair_false, s_integer, s_string, s_pair_false, s_any); + pl_gu = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_pair_false); + pl_pg = s7_make_circular_signature(s7, 1, 2, s_pair, s_gtk_enum_t); + pl_gus = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_string); + pl_pgi = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_integer); + pl_pgu = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_pair_false); + pl_gui = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_integer); + pl_guut = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_pair_false, s_any); + pl_pgbi = s7_make_circular_signature(s7, 3, 4, s_pair, s_gtk_enum_t, s_boolean, s_integer); + pl_guuut = s7_make_circular_signature(s7, 4, 5, s_gtk_enum_t, s_pair_false, s_pair_false, s_pair_false, s_any); + pl_gurrsiu = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_real, s_real, s_string, s_integer, s_pair_false); + pl_gussitu = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_string, s_string, s_integer, s_any, s_pair_false); + pl_t = s7_make_circular_signature(s7, 0, 1, s_any); + pl_s = s7_make_circular_signature(s7, 0, 1, s_string); + pl_du = s7_make_circular_signature(s7, 1, 2, s_float, s_pair_false); + pl_pr = s7_make_circular_signature(s7, 1, 2, s_pair, s_real); + pl_dui = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_integer); + pl_dus = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_string); + pl_dusi = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_integer); + pl_dusr = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_real); + pl_p = s7_make_circular_signature(s7, 0, 1, s_pair); + pl_tts = s7_make_circular_signature(s7, 2, 3, s_any, s_any, s_string); + pl_tti = s7_make_circular_signature(s7, 2, 3, s_any, s_any, s_integer); + pl_ts = s7_make_circular_signature(s7, 1, 2, s_any, s_string); + pl_tsi = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_integer); + pl_tsig = s7_make_circular_signature(s7, 3, 4, s_any, s_string, s_integer, s_gtk_enum_t); + pl_tsiu = s7_make_circular_signature(s7, 3, 4, s_any, s_string, s_integer, s_pair_false); + pl_tsiuui = s7_make_circular_signature(s7, 5, 6, s_any, s_string, s_integer, s_pair_false, s_pair_false, s_integer); + pl_tsiiuui = s7_make_circular_signature(s7, 6, 7, s_any, s_string, s_integer, s_integer, s_pair_false, s_pair_false, s_integer); + pl_ssi = s7_make_circular_signature(s7, 2, 3, s_string, s_string, s_integer); + pl_ssig = s7_make_circular_signature(s7, 3, 4, s_string, s_string, s_integer, s_gtk_enum_t); + pl_bi = s7_make_circular_signature(s7, 1, 2, s_boolean, s_integer); + pl_big = s7_make_circular_signature(s7, 2, 3, s_boolean, s_integer, s_gtk_enum_t); pl_tusiuiui = s7_make_circular_signature(s7, 7, 8, s_any, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_pair_false, s_integer); pl_tuiiiiui = s7_make_circular_signature(s7, 7, 8, s_any, s_pair_false, s_integer, s_integer, s_integer, s_integer, s_pair_false, s_integer); pl_tuuiiiirrrrg = s7_make_circular_signature(s7, 11, 12, s_any, s_pair_false, s_pair_false, s_integer, s_integer, s_integer, s_integer, s_real, s_real, s_real, s_real, s_gtk_enum_t); @@ -39341,35 +39323,8 @@ static void define_functions(void) pl_tuuubr = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_boolean, s_real); pl_tuuiuui = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false, s_pair_false, s_integer); pl_tubiiiu = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_boolean, s_integer, s_integer, s_integer, s_pair_false); - pl_du = s7_make_circular_signature(s7, 1, 2, s_float, s_pair_false); - pl_pr = s7_make_circular_signature(s7, 1, 2, s_pair, s_real); - pl_dui = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_integer); - pl_dus = s7_make_circular_signature(s7, 2, 3, s_float, s_pair_false, s_string); - pl_dusi = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_integer); - pl_dusr = s7_make_circular_signature(s7, 3, 4, s_float, s_pair_false, s_string, s_real); - pl_sg = s7_make_circular_signature(s7, 1, 2, s_string, s_gtk_enum_t); - pl_gs = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_string); - pl_b = s7_make_circular_signature(s7, 0, 1, s_boolean); - pl_gu = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_pair_false); - pl_pg = s7_make_circular_signature(s7, 1, 2, s_pair, s_gtk_enum_t); - pl_gus = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_string); - pl_pgi = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_integer); - pl_pgu = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_pair_false); - pl_gui = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_integer); - pl_guut = s7_make_circular_signature(s7, 3, 4, s_gtk_enum_t, s_pair_false, s_pair_false, s_any); - pl_pgbi = s7_make_circular_signature(s7, 3, 4, s_pair, s_gtk_enum_t, s_boolean, s_integer); - pl_guuut = s7_make_circular_signature(s7, 4, 5, s_gtk_enum_t, s_pair_false, s_pair_false, s_pair_false, s_any); - pl_gurrsiu = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_real, s_real, s_string, s_integer, s_pair_false); - pl_gussitu = s7_make_circular_signature(s7, 6, 7, s_gtk_enum_t, s_pair_false, s_string, s_string, s_integer, s_any, s_pair_false); - pl_ssi = s7_make_circular_signature(s7, 2, 3, s_string, s_string, s_integer); - pl_ssig = s7_make_circular_signature(s7, 3, 4, s_string, s_string, s_integer, s_gtk_enum_t); - pl_bi = s7_make_circular_signature(s7, 1, 2, s_boolean, s_integer); - pl_big = s7_make_circular_signature(s7, 2, 3, s_boolean, s_integer, s_gtk_enum_t); pl_su = s7_make_circular_signature(s7, 1, 2, s_string, s_pair_false); pl_ps = s7_make_circular_signature(s7, 1, 2, s_pair, s_string); - pl_bt = s7_make_circular_signature(s7, 1, 2, s_boolean, s_any); - pl_tb = s7_make_circular_signature(s7, 1, 2, s_any, s_boolean); - pl_bti = s7_make_circular_signature(s7, 2, 3, s_boolean, s_any, s_integer); pl_sui = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_integer); pl_sug = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_gtk_enum_t); pl_psi = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_integer); @@ -39380,7 +39335,6 @@ static void define_functions(void) pl_psgi = s7_make_circular_signature(s7, 3, 4, s_pair, s_string, s_gtk_enum_t, s_integer); pl_psiu = s7_make_circular_signature(s7, 3, 4, s_pair, s_string, s_integer, s_pair_false); pl_psut = s7_make_circular_signature(s7, 3, 4, s_pair, s_string, s_pair_false, s_any); - pl_btiib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_any, s_integer, s_integer, s_boolean); pl_suuub = s7_make_circular_signature(s7, 4, 5, s_string, s_pair_false, s_pair_false, s_pair_false, s_boolean); pl_psugt = s7_make_circular_signature(s7, 4, 5, s_pair, s_string, s_pair_false, s_gtk_enum_t, s_any); pl_psiuub = s7_make_circular_signature(s7, 5, 6, s_pair, s_string, s_integer, s_pair_false, s_pair_false, s_boolean); @@ -39420,20 +39374,63 @@ static void define_functions(void) pl_pusiuiu = s7_make_circular_signature(s7, 6, 7, s_pair, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_pair_false); pl_puuusuug = s7_make_circular_signature(s7, 7, 8, s_pair, s_pair_false, s_pair_false, s_pair_false, s_string, s_pair_false, s_pair_false, s_gtk_enum_t); pl_pusiuibu = s7_make_circular_signature(s7, 7, 8, s_pair, s_pair_false, s_string, s_integer, s_pair_false, s_integer, s_boolean, s_pair_false); + pl_b = s7_make_circular_signature(s7, 0, 1, s_boolean); + pl_bt = s7_make_circular_signature(s7, 1, 2, s_boolean, s_any); + pl_tb = s7_make_circular_signature(s7, 1, 2, s_any, s_boolean); + pl_bti = s7_make_circular_signature(s7, 2, 3, s_boolean, s_any, s_integer); + pl_btiib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_any, s_integer, s_integer, s_boolean); + pl_bsu = s7_make_circular_signature(s7, 2, 3, s_boolean, s_string, s_pair_false); + pl_bsigb = s7_make_circular_signature(s7, 4, 5, s_boolean, s_string, s_integer, s_gtk_enum_t, s_boolean); + pl_buuusuug = s7_make_circular_signature(s7, 7, 8, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_string, s_pair_false, s_pair_false, s_gtk_enum_t); + pl_bu = s7_make_circular_signature(s7, 1, 2, s_boolean, s_pair_false); + pl_pb = s7_make_circular_signature(s7, 1, 2, s_pair, s_boolean); + pl_bur = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_real); + pl_bug = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_gtk_enum_t); + pl_bus = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_string); + pl_bui = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_integer); + pl_bub = s7_make_circular_signature(s7, 2, 3, s_boolean, s_pair_false, s_boolean); + pl_buui = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_integer); + pl_buus = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_string); + pl_busu = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_string, s_pair_false); + pl_buub = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_boolean); + pl_buig = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_integer, s_gtk_enum_t); + pl_busib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_string, s_integer, s_boolean); + pl_buuub = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_boolean); + pl_buttu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_any, s_any, s_pair_false); + pl_busgu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_string, s_gtk_enum_t, s_pair_false); + pl_buuui = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_integer); + pl_buuig = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t); + pl_buiuig = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_integer, s_pair_false, s_integer, s_gtk_enum_t); + pl_buusib = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_string, s_integer, s_boolean); + pl_buuuub = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean); + pl_buurbr = s7_make_circular_signature(s7, 5, 6, s_boolean, s_pair_false, s_pair_false, s_real, s_boolean, s_real); + pl_iit = s7_make_circular_signature(s7, 2, 3, s_integer, s_integer, s_any); + pl_iiit = s7_make_circular_signature(s7, 3, 4, s_integer, s_integer, s_integer, s_any); + pl_gi = s7_make_circular_signature(s7, 1, 2, s_gtk_enum_t, s_integer); + pl_igi = s7_make_circular_signature(s7, 2, 3, s_integer, s_gtk_enum_t, s_integer); + pl_i = s7_make_circular_signature(s7, 0, 1, s_integer); + pl_g = s7_make_circular_signature(s7, 0, 1, s_gtk_enum_t); + pl_ti = s7_make_circular_signature(s7, 1, 2, s_any, s_integer); + pl_it = s7_make_circular_signature(s7, 1, 2, s_integer, s_any); + pl_tiu = s7_make_circular_signature(s7, 2, 3, s_any, s_integer, s_pair_false); + pl_itsub = s7_make_circular_signature(s7, 4, 5, s_integer, s_any, s_string, s_pair_false, s_boolean); + pl_itiiub = s7_make_circular_signature(s7, 5, 6, s_integer, s_any, s_integer, s_integer, s_pair_false, s_boolean); + pl_itstttg = s7_make_circular_signature(s7, 6, 7, s_integer, s_any, s_string, s_any, s_any, s_any, s_gtk_enum_t); + pl_itgiiut = s7_make_circular_signature(s7, 6, 7, s_integer, s_any, s_gtk_enum_t, s_integer, s_integer, s_pair_false, s_any); pl_bpt = s7_make_signature(s7, 2, s_pair_false, s_any); #if GTK_CHECK_VERSION(3, 0, 0) - pl_buigu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_integer, s_gtk_enum_t, s_pair_false); - pl_tuuugi = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer); - pl_tuuuub = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean); pl_pgr = s7_make_circular_signature(s7, 2, 3, s_pair, s_gtk_enum_t, s_real); pl_gug = s7_make_circular_signature(s7, 2, 3, s_gtk_enum_t, s_pair_false, s_gtk_enum_t); + pl_tuuugi = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer); + pl_tuuuub = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_boolean); pl_puuig = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_pair_false, s_integer, s_gtk_enum_t); pl_puiiui = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_integer, s_integer, s_pair_false, s_integer); + pl_buigu = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_integer, s_gtk_enum_t, s_pair_false); #endif #if GTK_CHECK_VERSION(3, 4, 0) - pl_tsu = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_pair_false); pl_prrru = s7_make_circular_signature(s7, 4, 5, s_pair, s_real, s_real, s_real, s_pair_false); + pl_tsu = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_pair_false); pl_suiig = s7_make_circular_signature(s7, 4, 5, s_string, s_pair_false, s_integer, s_integer, s_gtk_enum_t); #endif @@ -39465,8 +39462,6 @@ static void define_functions(void) #endif #if GTK_CHECK_VERSION(3, 94, 0) - pl_busi = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_string, s_integer); - pl_buib = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_integer, s_boolean); pl_iuugs = s7_make_circular_signature(s7, 4, 5, s_integer, s_pair_false, s_pair_false, s_gtk_enum_t, s_string); pl_piigui = s7_make_circular_signature(s7, 5, 6, s_pair, s_integer, s_integer, s_gtk_enum_t, s_pair_false, s_integer); pl_tuiut = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_pair_false, s_any); @@ -39483,16 +39478,18 @@ static void define_functions(void) pl_pst = s7_make_circular_signature(s7, 2, 3, s_pair, s_string, s_any); pl_purru = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_real, s_real, s_pair_false); pl_purrrru = s7_make_circular_signature(s7, 6, 7, s_pair, s_pair_false, s_real, s_real, s_real, s_real, s_pair_false); + pl_busi = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_string, s_integer); + pl_buib = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_integer, s_boolean); #endif #if GTK_CHECK_VERSION(3, 96, 0) - pl_buiu = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_integer, s_pair_false); - pl_buiib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_integer, s_integer, s_boolean); pl_tuiiiu = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_integer, s_integer, s_integer, s_pair_false); pl_tuugiu = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer, s_pair_false); + pl_bg = s7_make_circular_signature(s7, 1, 2, s_boolean, s_gtk_enum_t); pl_purrg = s7_make_circular_signature(s7, 4, 5, s_pair, s_pair_false, s_real, s_real, s_gtk_enum_t); pl_puuugi = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer); - pl_bg = s7_make_circular_signature(s7, 1, 2, s_boolean, s_gtk_enum_t); + pl_buiu = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_integer, s_pair_false); + pl_buiib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_integer, s_integer, s_boolean); #endif #endif @@ -46838,7 +46835,7 @@ void Init_libxg(void) Xen_provide_feature("gtk2"); #endif #endif - Xen_define("xg-version", C_string_to_Xen_string("26-Jul-19")); + Xen_define("xg-version", C_string_to_Xen_string("27-Aug-19")); xg_already_inited = true; #if HAVE_SCHEME #if USE_SND |