summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorIOhannes m zmölnig <zmoelnig@umlautS.umlaeute.mur.at>2019-12-07 20:51:24 +0100
committerIOhannes m zmölnig <zmoelnig@umlautS.umlaeute.mur.at>2019-12-07 20:51:24 +0100
commitde0701160858925861e61744d18d54a803314b86 (patch)
treef9c65118033952d4a5690958b60932a42f0c2526
parent5c109139c73cbc2eb4ac3afea1317fd882791e21 (diff)
parent5ba89b689d1e218796b58af8acf28021adc1ee36 (diff)
Update upstream source from tag 'upstream/19.9'
Update to upstream version '19.9' with Debian dir 54e5f7e73e88fe578aafc0b5d12baddf5bdf7133
-rw-r--r--audio.c7
-rwxr-xr-xconfigure20
-rw-r--r--configure.ac4
-rw-r--r--generators.scm33
-rw-r--r--leslie.cms173
-rw-r--r--libgtk_s7.c323
-rw-r--r--lint.scm6
-rw-r--r--peak-phases.scm3
-rw-r--r--repl.c62
-rw-r--r--s7.c7098
-rw-r--r--s7.h24
-rw-r--r--s7.html148
-rw-r--r--s7test.scm602
-rw-r--r--snd-xref.c64
-rw-r--r--snd.h6
-rw-r--r--snd.html3
-rw-r--r--stuff.scm2
-rw-r--r--tools/dup.scm4
-rw-r--r--tools/make-index.scm1
-rw-r--r--tools/tclo.scm124
-rw-r--r--tools/tgen.scm2
-rw-r--r--tools/thash.scm2
-rw-r--r--tools/tmac.scm11
-rw-r--r--tools/tmisc.scm37
-rw-r--r--tools/tpeak.scm5
-rw-r--r--tools/trclo.scm8
-rw-r--r--tools/trec.scm8
-rw-r--r--tools/tshoot.scm12
-rw-r--r--tools/tvect.scm10
-rw-r--r--tools/valcall.scm10
-rw-r--r--tools/xgdata.scm10
-rw-r--r--xg.c307
32 files changed, 5273 insertions, 3856 deletions
diff --git a/audio.c b/audio.c
index f0cf3a0..3939198 100644
--- a/audio.c
+++ b/audio.c
@@ -5046,8 +5046,11 @@ int mus_audio_close(int line)
return(MUS_NO_ERROR);
}
-
-static int netbsd_default_outputs = (AUDIO_HEADPHONE | AUDIO_LINE_OUT | AUDIO_SPEAKER);
+#if defined(__NetBSD__) && (__NetBSD_Version__ < 900000000)
+ static int netbsd_default_outputs = (AUDIO_HEADPHONE | AUDIO_LINE_OUT | AUDIO_SPEAKER);
+#else
+ static int netbsd_default_outputs = 0;
+#endif
int mus_audio_open_output(int dev, int srate, int chans, mus_sample_t samp_type, int size)
{
diff --git a/configure b/configure
index 51e0c8e..49d6e25 100755
--- a/configure
+++ b/configure
@@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.69 for snd 19.8.
+# Generated by GNU Autoconf 2.69 for snd 19.9.
#
# 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.8'
-PACKAGE_STRING='snd 19.8'
+PACKAGE_VERSION='19.9'
+PACKAGE_STRING='snd 19.9'
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.8 to adapt to many kinds of systems.
+\`configure' configures snd 19.9 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.8:";;
+ short | recursive ) echo "Configuration of snd 19.9:";;
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.8
+snd configure 19.9
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.8, which was
+It was created by snd $as_me 19.9, 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.8
+VERSION=19.9
#--------------------------------------------------------------------------------
# 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.8, which was
+This file was extended by snd $as_me 19.9, 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.8
+snd config.status 19.9
configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
diff --git a/configure.ac b/configure.ac
index 7109cc7..68d2773 100644
--- a/configure.ac
+++ b/configure.ac
@@ -5,7 +5,7 @@
# gmp, mpfr, and mpc deliberately have none!
-AC_INIT(snd, 19.8, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz)
+AC_INIT(snd, 19.9, 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.8
+VERSION=19.9
#--------------------------------------------------------------------------------
# configuration options
diff --git a/generators.scm b/generators.scm
index cdc9db8..ccc2a56 100644
--- a/generators.scm
+++ b/generators.scm
@@ -5596,23 +5596,22 @@ returns the sum of the last n inputs weighted by (-n/(n+1))^k"))
(make-polywave frequency :xcoeffs cos-amps :ycoeffs sin-amps))))
-(define (polyoid-env gen fm amps phases)
+(define (polyoid-env gen fm amps phases original-data)
;; amps and phases are the envelopes, one for each harmonic, setting the sample-wise amp and phase
- (let ((original-data (polyoid-partial-amps-and-phases gen)))
- (let ((data-len (length original-data))
- (amps-len (length amps))
- (tn (polyoid-tn gen))
- (un (polyoid-un gen)))
- (do ((i 0 (+ i 3))
- (j 0 (+ j 1)))
- ((or (= j amps-len)
- (= i data-len)))
- (let ((hn (floor (original-data i)))
- (amp (env (amps j)))
- (phase (env (phases j))))
- (set! (tn hn) (* amp (sin phase)))
- (set! (un hn) (* amp (cos phase)))))
- (polyoid gen fm))))
+ (let ((data-len (length original-data))
+ (amps-len (length amps))
+ (tn (polyoid-tn gen))
+ (un (polyoid-un gen)))
+ (do ((i 0 (+ i 3))
+ (j 0 (+ j 1)))
+ ((or (= j amps-len)
+ (= i data-len)))
+ (let ((hn (floor (original-data i)))
+ (amp (env (amps j)))
+ (phase (env (phases j))))
+ (set! (tn hn) (* amp (sin phase)))
+ (set! (un hn) (* amp (cos phase)))))
+ (polyoid gen fm)))
#|
(with-sound (:clipped #f)
@@ -5667,7 +5666,7 @@ returns the sum of the last n inputs weighted by (-n/(n+1))^k"))
;;; 0 diff up to 4096 so far (unopt and opt) -- 1.0e-12 at 4096, opt is more than 20 times as fast
-
+;; these won't work as is -- polyoid-env needs the vectors passed to make-polyoid as its "original-data" argument
(with-sound (:clipped #f :channels 2 :statistics #t)
(let* ((samps 44100)
(gen1 (make-polyoid 100.0 (vector 1 0.5 0.0 3 0.25 0.0 4 .25 0.0)))
diff --git a/leslie.cms b/leslie.cms
index c6d721b..e2b64b8 100644
--- a/leslie.cms
+++ b/leslie.cms
@@ -19,92 +19,49 @@
;;
;; juanig@ccrma
;;
-;; First version March 20, 2004
-;; Last update September 12, 2014
;;
;; NOTES:
;; Get Leslie effect on a pulse-train waveshape. Try acceleration with the vel-envelope.
;; It can also be used to apply a Leslie effect to a soundfile. Just switch to the
;; 'make-readin', readin ug.
;;
+;; First version: Sat 20 Mar 2004 11:22:47 AM PST
+;; Last update: Wed 13 Nov 2019 04:13:30 PM PST
+;;
+;; HISTORY:
;; 06/20/2014 fixed delays and delay lines length
;; 09/10/2014 added reflection delay lines
-;; 09/12/2014 added lowport baffle section using a lowpass butterworth
+;; 09/12/2014 added lowport baffle section
;; 09/18/2014 S7 .cms version
+;; 11/13/2019 Fixed delay line lengths and added a two-pole for the baffle part.
+;; Removed butterworth in exchange for a two-pole frequency shifting.
+;;
;;
-;;
+;;
(define sspeed 345.12) ;; Velocity of sound
(define twopi (* 2 pi))
(define oneturn (* pi 2))
-
-
-;; We need a Lowpass filter for the lower part, low frequency (baffle)
-;; of the Leslie cabinet
-
-
-;; A butterworth Lowpass filter (as in dsp.scm).
-
-(define (make-butter-low-pass fq)
- (let* ((r (/ 1.0 (tan (/ (* pi fq) *clm-srate*))))
- (r2 (* r r))
- (c1 (/ 1.0 (+ 1.0 (* r (sqrt 2.0)) r2)))
- (c2 (* 2.0 c1))
- (c3 c1)
- (c4 (* 2.0 (- 1.0 r2) c1))
- (c5 (* (+ (- 1.0 (* r (sqrt 2.0))) r2) c1))
- (arra (make-float-vector 3 ))
- (arrb (make-float-vector 3 )))
- (set! (arra 0) c1)
- (set! (arra 1) c2)
- (set! (arra 2) c3)
- (set! (arrb 0) 0.0)
- (set! (arrb 1) c4)
- (set! (arrb 2) c5)
- (make-filter 3 arra arrb) ))
-
-
-;;; Macros to handle Lowpass filter
;;
-
-(define (butter f sample0)
- (filter f sample0))
-
-
-;; macro to sweep frequencies
+;;;
;;
-
-(define (sweep-butterfq b freq)
- `(let* ((fq ,freq)
- (r (/ 1.0 (tan (/ (* pi fq) *srate*))))
- (r2 (* r r))
- (c1 (/ 1.0 (+ 1.0 (* r (sqrt 2.0)) r2))))
- (set! (mus-xcoeff ,b 0) c1)
- (set! (mus-xcoeff ,b 1) (* 2.0 c1))
- (set! (mus-xcoeff ,b 2) c1)
- (set! (mus-ycoeff ,b 1) (* 2.0 (- 1.0 r2) c1))
- (set! (mus-ycoeff ,b 2) (* (+ (- 1.0 (* r (sqrt 2.0))) r2) c1))
- ))
-
-
-
-(definstrument (rotates start dur freq
+(definstrument (rotates start dur freq
(speedsl 3.33) ;; Speed source listener mts/sec
(velenv '(0 1 100 1)) ;; Velocity envelope
- (gain 0.125) ;; scales output
- ;; (onset 0.0) ;; onset values in case of reading a soundfile
+ (gain 0.35) ;; scales output
+ ;; (onset 0.0) ;; onset duration (secs) in case of reading a soundfile
(rev-amount 0.025)) ;; very short reverb
(let* ((beg (seconds->samples start))
(sig (make-pulse-train :frequency freq))
- ;;; (rdA (make-readin :file file ;; just in case you want to read
- ;;; :start (seconds->samples onset)) ;; a soundfile instead
+ ;; (rdA (make-readin :file infile ;; just in case you want to read
+ ;; :start (seconds->samples onset))) ;; a soundfile instead
;;;
- (maxddelayl (if (= *clm-srate* 44100) (values 96)
- (values 104)))
- (startddelay (if (= *clm-srate* 44100) (values 48)
- (values 52)))
+ (maxddelayl (if (= *clm-srate* 44100) (values 160)
+ (values 192)))
+ (startddelay (if (= *clm-srate* 44100) (values 48)
+ (values 52)))
(m2samp (/ *clm-srate* sspeed))
(vel-env (make-env velenv :duration (* dur 0.5)))
;;;
@@ -125,10 +82,9 @@
(fshift (make-vector 4))
(baffleout (make-vector 4))
;;
- (bfila (make-butter-low-pass 200))
- (bfilb (make-butter-low-pass 200))
- (bfilc (make-butter-low-pass 200))
- (bfild (make-butter-low-pass 200))
+ ;;
+ (lpf (make-vector 4))
+ ;;
;;
(growf0 0.0)
(growf1 0.0)
@@ -156,8 +112,18 @@
((= i 4 ))
(set! (dpdelays i) (make-delay :size startddelay
:max-size maxddelayl
- :type mus-interp-linear))
- (set! (refldelays i) (make-delay )))
+ :type mus-interp-linear
+ ))
+ (set! (refldelays i) (make-delay :size startddelay
+ :max-size (ceiling (* cabinetlen 2 m2samp))
+ )) )
+ ;;
+ ;; Make filters
+ ;;
+ (do ((i 0 (1+ i)))
+ ((= i 4 ))
+ (set! (lpf i) (make-two-pole :a0 0.304 :b1 0.62986 :b2 0.825))
+ )
;;
;;
;;;
@@ -167,23 +133,27 @@
((= i end ))
;;
(let ((sample (pulse-train sig))
- ;;; (sample (readin rdA)) switch in case of reading a soundfile
+ ;; (sample (readin rdA)) ;; switch in case of reading a soundfile
(deltavel (env vel-env))
- (sigouta 0.0) (sigoutb 0.0) ;; horn
- (sigoutc 0.0) (sigoutd 0.0) ;; reflections
+ (sigouta 0.0) (sigoutb 0.0) ;; horn
+ (sigoutc 0.0) (sigoutd 0.0) ;; reflections
(woofera 0.0) (wooferb 0.0)) ;; low baffle output
;;
- ;; set acceleration of horn
+ ;;; set acceleration of horn
+ ;;
(set! hornangvel (* speedsl deltavel))
(set! hornangle (+ hornangle (* twopi (/ hornangvel *clm-srate*))))
- ;; baffle lower port
- (set! baffleangvel (* 0.98 speedsl ))
+ ;;
+ ;;; set motion parameter for baffle lower port
+ ;;
+ (set! baffleangvel (* 0.895 speedsl )) ;; 0.98
(set! baffleangle (+ baffleangle (* twopi (/ baffleangvel *clm-srate*))))
;;
(if (> hornangle twopi) (set! hornangle (- hornangle twopi)))
(if (> baffleangle twopi) (set! baffleangle (- baffleangle twopi)))
;;
- ;; calculate grow functions for delay line size (horn Doppler shifts)
+ ;;; calculate grow functions for delay line size (horn Doppler shifts)
+ ;;
(set! growf0 (/ (*(* (- twopi) hornradius) (* hornangvel (cos hornangle))) sspeed))
(set! growf1 (/ (*(* (- twopi) hornradius) (* hornangvel (sin hornangle))) sspeed))
;;
@@ -197,7 +167,7 @@
(set! (hornout j ) (delay (dpdelays j) sample (dshift j)))
)
;;
- ;; Reflections
+ ;;; Reflections
;;
(set! xdev (* hornradius (cos hornangle)))
(set! ydev (* hornradius (sin hornangle)))
@@ -207,6 +177,7 @@
(set! (reflectlen 3) (* (+ cabinetlen xdev) m2samp))
;;
;; Need to add these reflections to *reverb*
+ ;;
(do ((j 0 (1+ j)))
((= j 4))
(set! (reflections j) (delay (refldelays j)
@@ -218,45 +189,59 @@
(set! sigoutc (+ (reflections 0) (reflections 2)))
(set! sigoutd (+ (reflections 1) (reflections 3)))
;;
+ ;;
;; Grow functions baffle low port section
(set! growfa (* (- twopi) baffleradius baffleangvel (cos baffleangle)))
(set! growfb (* (- twopi) baffleradius baffleangvel (sin baffleangle)))
;;
- (set! (fshift 0) (+ 250 (* growfa 50)))
- (set! (fshift 1) (+ 250 (* growfb 50)))
- (set! (fshift 2) (+ 250 (* (- growfa) 50)))
- (set! (fshift 3) (+ 250 (* (- growfb) 50)))
+ (set! (fshift 0) (+ 200 (* growfa 250)))
+ (set! (fshift 1) (+ 200 (* growfb 250)))
+ (set! (fshift 2) (+ 225 (* (- growfa) 250)))
+ (set! (fshift 3) (+ 225 (* (- growfb) 250)))
+ ;;
+ ;;; Filter for baffle low port section
+ ;;
+ (do ((k 0 (1+ k)))
+ ((= k 4))
+ (set! (mus-frequency (lpf k)) (fshift k))
+ (set! (mus-scaler (lpf k)) 0.938987)
+ )
+ ;;
+ ;;
+ (do ((k 0 (1+ k)))
+ ((= k 4))
+ (set! (baffleout k) (two-pole (lpf k) sample))
+ )
;;
- (sweep-butterfq bfila (fshift 0))
- (sweep-butterfq bfilb (fshift 1))
- (sweep-butterfq bfilc (fshift 2))
- (sweep-butterfq bfild (fshift 3))
;;
- (set! (baffleout 0) (butter bfila sample))
- (set! (baffleout 1) (butter bfilb sample))
- (set! (baffleout 2) (butter bfilc sample))
- (set! (baffleout 3) (butter bfild sample))
+ (set! woofera (* 0.175 (+ (baffleout 0) (baffleout 2))))
+ (set! wooferb (* 0.175 (+ (baffleout 1) (baffleout 3))))
;;
- (set! woofera (+ (baffleout 0) (baffleout 2)))
- (set! wooferb (+ (baffleout 1) (baffleout 3)))
;;
(outa i (* gain (+ sigouta sigoutc woofera)))
(outb i (* gain (+ sigoutb sigoutd wooferb)))
- ;;;
+ ;;
+ ;;; in case of reverb
+ ;;
(if *reverb*
(progn
- (outa i (* (* 0.5 gain) (+ sigoutc woofera) rev-amount) *reverb*)
- (outb i (* (* 0.5 gain) (+ sigoutd wooferb) rev-amount) *reverb*) ))
+ (outa i (* (* 0.5 gain) (+ sigouta woofera) rev-amount) *reverb*)
+ (outb i (* (* 0.5 gain) (+ sigoutb wooferb) rev-amount) *reverb*) ))
))
))
+
;;; (with-sound (:channels 2) (rotates 0 1 800))
;;; (with-sound (:channels 2) (rotates 0 3 200))
;;; (with-sound (:channels 2) (rotates 0 8 300 :speedsl 1.0))
;;; (with-sound (:channels 2) (rotates 0 3 500 :speedsl 1.0))
-;;; (with-sound (:channels 2) (rotates 0 3 500 :velenv '(0 0 100 1)))
+;;; (with-sound (:channels 2) (rotates 0 3 800 :velenv '(0 0.05 100 1)))
;;; (with-sound (:channels 2) (rotates 0 3 500 :velenv '(0 1 100 0.25)))
+;;; (with-sound (:channels 2) (rotates 0 5 1000 :velenv '(0 0.25 50 1 100 0.3)))
+
+
;;; (load "nrev.ins")
;;; (with-sound (:channels 2 :reverb nrev :reverb-channels 2) (rotates 0 5 500 :velenv '(0 1 100 0.25)))
+
diff --git a/libgtk_s7.c b/libgtk_s7.c
index 7f34f32..5536502 100644
--- a/libgtk_s7.c
+++ b/libgtk_s7.c
@@ -95,9 +95,9 @@ static s7_pointer GtkTreeListRow__sym, GtkTreeListModel__sym, GtkText__sym, GtkS
GtkToggleToolButton__sym, GtkSeparatorToolItem__sym, GtkRadioToolButton__sym, GtkEntryCompletionMatchFunc_sym, GtkFontButton__sym,
GtkExpander__sym, GtkComboBox__sym, GtkTreeModelFilter__sym, GtkToolItem__sym, GdkDisplay__sym,
PangoLayoutRun__sym, PangoLayoutIter__sym, PangoLayoutLine__sym, int__sym, PangoItem__sym,
- PangoGlyphString__sym, PangoFontMap__sym, PangoFontFace__sym, PangoFontFace___sym, PangoFontFamily__sym,
- PangoFontDescription___sym, PangoCoverage__sym, PangoFontMetrics__sym, PangoFontset__sym, PangoFont__sym,
- PangoFontFamily___sym, PangoLogAttr__sym, PangoAnalysis__sym, PangoAttrList___sym, PangoAttrIterator__sym,
+ PangoAnalysis__sym, PangoGlyphString__sym, PangoFontMap__sym, PangoFontFace__sym, PangoFontFace___sym,
+ PangoFontFamily__sym, PangoFontDescription___sym, PangoCoverage__sym, PangoFontMetrics__sym, PangoFontset__sym,
+ PangoFont__sym, PangoFontFamily___sym, PangoLogAttr__sym, PangoAttrList___sym, PangoAttrIterator__sym,
PangoRectangle__sym, PangoAttribute__sym, PangoColor__sym, GtkWindow__sym, PangoContext__sym,
AtkObject__sym, GtkViewport__sym, GtkTreeViewSearchEqualFunc_sym, GtkTreeViewMappingFunc_sym, GtkTreeViewColumnDropFunc_sym,
GtkTreeCellDataFunc_sym, GtkTreeStore__sym, GtkTreeIterCompareFunc_sym, GtkTreeSortable__sym, GtkTreeSelectionForeachFunc_sym,
@@ -13520,27 +13520,6 @@ PangoAttrList** attr_list, char** text, gunichar* accel_char, GError** [error])"
}
}
-static s7_pointer lg_pango_break(s7_scheme *sc, s7_pointer args)
-{
- #define H_pango_break "void pango_break(gchar* text, int length, PangoAnalysis* analysis, PangoLogAttr* attrs, \
-int attrs_len)"
- s7_pointer _p;
- s7_pointer text, length, analysis, attrs, attrs_len;
- _p = args;
- text = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_string(text)) s7_wrong_type_arg_error(sc, "pango_break", 1, text, "gchar*");
- length = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_integer(length)) s7_wrong_type_arg_error(sc, "pango_break", 2, length, "int");
- analysis = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_c_pointer_of_type(analysis, PangoAnalysis__sym)) s7_wrong_type_arg_error(sc, "pango_break", 3, analysis, "PangoAnalysis*");
- attrs = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_c_pointer_of_type(attrs, PangoLogAttr__sym)) s7_wrong_type_arg_error(sc, "pango_break", 4, attrs, "PangoLogAttr*");
- attrs_len = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_integer(attrs_len)) s7_wrong_type_arg_error(sc, "pango_break", 5, attrs_len, "int");
- pango_break((gchar*)s7_string(text), (int)s7_integer(length), (PangoAnalysis*)s7_c_pointer(analysis), (PangoLogAttr*)s7_c_pointer(attrs), (int)s7_integer(attrs_len));
- return(lg_false);
-}
-
static s7_pointer lg_pango_find_paragraph_boundary(s7_scheme *sc, s7_pointer args)
{
#define H_pango_find_paragraph_boundary "void pango_find_paragraph_boundary(gchar* text, gint length, \
@@ -13796,48 +13775,6 @@ static s7_pointer lg_pango_coverage_set(s7_scheme *sc, s7_pointer args)
return(lg_false);
}
-static s7_pointer lg_pango_coverage_max(s7_scheme *sc, s7_pointer args)
-{
- #define H_pango_coverage_max "void pango_coverage_max(PangoCoverage* coverage, PangoCoverage* other)"
- s7_pointer _p;
- s7_pointer coverage, other;
- _p = args;
- coverage = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_c_pointer_of_type(coverage, PangoCoverage__sym)) s7_wrong_type_arg_error(sc, "pango_coverage_max", 1, coverage, "PangoCoverage*");
- other = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_c_pointer_of_type(other, PangoCoverage__sym)) s7_wrong_type_arg_error(sc, "pango_coverage_max", 2, other, "PangoCoverage*");
- pango_coverage_max((PangoCoverage*)s7_c_pointer(coverage), (PangoCoverage*)s7_c_pointer(other));
- return(lg_false);
-}
-
-static s7_pointer lg_pango_coverage_to_bytes(s7_scheme *sc, s7_pointer args)
-{
- #define H_pango_coverage_to_bytes "void pango_coverage_to_bytes(PangoCoverage* coverage, guchar** [bytes], \
-int* [n_bytes])"
- s7_pointer _p;
- s7_pointer coverage;
- guchar* ref_bytes = NULL;
- int ref_n_bytes;
- _p = args;
- coverage = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_c_pointer_of_type(coverage, PangoCoverage__sym)) s7_wrong_type_arg_error(sc, "pango_coverage_to_bytes", 1, coverage, "PangoCoverage*");
- pango_coverage_to_bytes((PangoCoverage*)s7_c_pointer(coverage), &ref_bytes, &ref_n_bytes);
- return(s7_list(sc, 2, s7_make_c_pointer(sc, ref_bytes), s7_make_integer(sc, ref_n_bytes)));
-}
-
-static s7_pointer lg_pango_coverage_from_bytes(s7_scheme *sc, s7_pointer args)
-{
- #define H_pango_coverage_from_bytes "PangoCoverage* pango_coverage_from_bytes(guchar* bytes, int n_bytes)"
- s7_pointer _p;
- s7_pointer bytes, n_bytes;
- _p = args;
- bytes = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_c_pointer_of_type(bytes, guchar__sym)) s7_wrong_type_arg_error(sc, "pango_coverage_from_bytes", 1, bytes, "guchar*");
- n_bytes = s7_car(_p); _p = s7_cdr(_p);
- if (!s7_is_integer(n_bytes)) s7_wrong_type_arg_error(sc, "pango_coverage_from_bytes", 2, n_bytes, "int");
- return(lg_make_c_pointer_with_type(sc, PangoCoverage__sym, pango_coverage_from_bytes((guchar*)s7_c_pointer(bytes), (int)s7_integer(n_bytes))));
-}
-
static s7_pointer lg_pango_font_description_new(s7_scheme *sc, s7_pointer args)
{
#define H_pango_font_description_new "PangoFontDescription* pango_font_description_new( void)"
@@ -19535,15 +19472,6 @@ static s7_pointer lg_pango_layout_get_auto_dir(s7_scheme *sc, s7_pointer args)
return(s7_make_boolean(sc, pango_layout_get_auto_dir((PangoLayout*)s7_c_pointer(layout))));
}
-static s7_pointer lg_pango_script_for_unichar(s7_scheme *sc, s7_pointer args)
-{
- #define H_pango_script_for_unichar "PangoScript pango_script_for_unichar(gunichar ch)"
- s7_pointer ch;
- ch = s7_car(args);
- if (!s7_is_integer(ch)) s7_wrong_type_arg_error(sc, "pango_script_for_unichar", 1, ch, "gunichar");
- return(s7_make_integer(sc, pango_script_for_unichar((gunichar)s7_integer(ch))));
-}
-
static s7_pointer lg_pango_script_iter_new(s7_scheme *sc, s7_pointer args)
{
#define H_pango_script_iter_new "PangoScriptIter* pango_script_iter_new(char* text, int length)"
@@ -47423,13 +47351,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_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;
+ s7_pointer pl_isigutttiiu, pl_si, pl_is, pl_isi, pl_sig, pl_isgt, pl_iu, pl_pi, pl_bt, pl_tb, pl_iur, pl_bti, pl_iug, pl_iui, pl_ius, pl_piu, pl_pit, pl_iuis, pl_iusi, pl_iuui, pl_btiib, pl_iuuui, pl_iuisi, pl_iuuuui, pl_iuisut, pl_t, pl_du, pl_pr, pl_dui, pl_dus, pl_dusi, pl_dusr, pl_tts, pl_tti, pl_sg, pl_gs, pl_bi, pl_ssi, pl_big, pl_ssig, pl_gu, pl_pg, pl_gus, pl_pgi, pl_pgu, pl_gui, pl_guut, pl_pgbi, pl_guuut, pl_gurrsiu, pl_gussitu, pl_i, 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_ti, pl_it, pl_tiu, pl_itsub, pl_itiiub, pl_itstttg, pl_itgiiut, pl_bsu, pl_bsigb, pl_g, pl_s, pl_buuusuug, pl_bu, pl_pb, pl_bur, pl_bug, pl_bus, pl_bui, pl_bub, pl_buui, pl_busu, pl_buub, pl_buig, pl_buus, pl_busib, pl_buuub, pl_buttu, pl_busgu, pl_buuig, pl_buuui, pl_buiuig, pl_buusib, pl_buuuub, pl_buurbr, pl_p, pl_iit, pl_iiit, pl_tg, pl_ts, pl_tsi, pl_tsig, pl_tsiu, pl_tsiiuui, 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_tusiuiui, pl_tuiiiiui, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_b, pl_igi, pl_bpt;
#if GTK_CHECK_VERSION(3, 0, 0)
- s7_pointer pl_pgr, pl_gug, pl_tuuugi, pl_tuuuub, pl_puuig, pl_puiiui, pl_buigu;
+ s7_pointer pl_pgr, pl_gug, pl_puuig, pl_puiiui, pl_buigu, pl_tuuugi, pl_tuuuub;
#endif
#if GTK_CHECK_VERSION(3, 4, 0)
- s7_pointer pl_prrru, pl_tsu, pl_suiig;
+ s7_pointer pl_prrru, pl_suiig, pl_tsu;
#endif
#if GTK_CHECK_VERSION(3, 6, 0)
@@ -47437,7 +47365,7 @@ static void define_functions(s7_scheme *sc)
#endif
#if GTK_CHECK_VERSION(3, 10, 0)
- s7_pointer pl_tuuuui, pl_pusiig, pl_puuiig, pl_pusiigu;
+ s7_pointer pl_pusiig, pl_puuiig, pl_pusiigu, pl_tuuuui;
#endif
#if GTK_CHECK_VERSION(3, 16, 0)
@@ -47453,11 +47381,11 @@ static void define_functions(s7_scheme *sc)
#endif
#if GTK_CHECK_VERSION(3, 94, 0)
- 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;
+ s7_pointer pl_iuugs, pl_piigui, pl_pst, pl_purru, pl_purrrru, pl_busi, pl_buib, pl_tuiut, pl_tuuur, pl_tugug, pl_tugui, pl_tuuiut, pl_tutisi, pl_tuiiut, pl_tubbbt, pl_tusuiut, pl_tuugggi, pl_tuuuggu;
#endif
#if GTK_CHECK_VERSION(3, 96, 0)
- s7_pointer pl_tuiiiu, pl_tuugiu, pl_bg, pl_purrg, pl_puuugi, pl_buiu, pl_buiib;
+ s7_pointer pl_purrg, pl_puuugi, pl_bg, pl_buiu, pl_buiib, pl_tuiiiu, pl_tuugiu;
#endif
@@ -47471,18 +47399,18 @@ static void define_functions(s7_scheme *sc)
s_gtk_enum_t = s7_make_symbol(sc, "gtk_enum_t?");
s_any = s7_t(sc);
+ 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_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_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_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_iur = s7_make_circular_signature(sc, 2, 3, s_integer, s_pair_false, s_real);
+ pl_bti = s7_make_circular_signature(sc, 2, 3, s_boolean, s_any, s_integer);
pl_iug = s7_make_circular_signature(sc, 2, 3, s_integer, s_pair_false, s_gtk_enum_t);
pl_iui = s7_make_circular_signature(sc, 2, 3, s_integer, s_pair_false, s_integer);
pl_ius = s7_make_circular_signature(sc, 2, 3, s_integer, s_pair_false, s_string);
@@ -47491,101 +47419,38 @@ static void define_functions(s7_scheme *sc)
pl_iuis = s7_make_circular_signature(sc, 3, 4, s_integer, s_pair_false, s_integer, s_string);
pl_iusi = s7_make_circular_signature(sc, 3, 4, s_integer, s_pair_false, s_string, s_integer);
pl_iuui = s7_make_circular_signature(sc, 3, 4, s_integer, s_pair_false, s_pair_false, s_integer);
+ pl_btiib = s7_make_circular_signature(sc, 4, 5, s_boolean, s_any, s_integer, s_integer, s_boolean);
pl_iuuui = s7_make_circular_signature(sc, 4, 5, s_integer, s_pair_false, s_pair_false, s_pair_false, s_integer);
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_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_bi = s7_make_circular_signature(sc, 1, 2, s_boolean, s_integer);
+ pl_ssi = s7_make_circular_signature(sc, 2, 3, s_string, s_string, 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);
- pl_tuuiiiirrrrgi = s7_make_circular_signature(sc, 12, 13, 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, s_integer);
- pl_pt = s7_make_circular_signature(sc, 1, 2, s_pair, s_any);
- pl_tu = s7_make_circular_signature(sc, 1, 2, s_any, s_pair_false);
- pl_tut = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_any);
- pl_tus = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_string);
- pl_tug = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_gtk_enum_t);
- pl_tur = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_real);
- pl_tui = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_integer);
- pl_tub = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_boolean);
- pl_tusg = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_gtk_enum_t);
- pl_tugb = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_boolean);
- pl_tugs = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_string);
- pl_tuui = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_integer);
- pl_tuib = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_boolean);
- pl_tusi = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_integer);
- pl_tuug = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_gtk_enum_t);
- pl_tuig = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_gtk_enum_t);
- pl_tuur = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_real);
- pl_turi = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_real, s_integer);
- pl_tusr = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_real);
- pl_tusb = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_boolean);
- pl_tuub = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_boolean);
- pl_tuus = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_string);
- pl_tugu = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_pair_false);
- pl_tugr = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_real);
- pl_tugi = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_integer);
- pl_tusu = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_pair_false);
- pl_tuut = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_any);
- pl_tugt = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_any);
- pl_tuis = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_string);
- pl_tust = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_any);
- pl_tuiu = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_pair_false);
- pl_tuit = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_any);
- pl_tuuiu = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false);
- pl_tuurb = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_boolean);
- pl_tuuri = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_integer);
- pl_tuugi = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer);
- pl_turgs = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_real, s_gtk_enum_t, s_string);
- pl_tuisi = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_integer, s_string, s_integer);
- pl_tusri = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_string, s_real, s_integer);
- pl_tuuut = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_any);
- pl_tuubr = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_boolean, s_real);
- pl_tuuub = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_boolean);
- pl_tuuir = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_real);
- pl_tuuui = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_integer);
- pl_tuusi = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_string, s_integer);
- pl_tuiiu = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_integer, s_integer, s_pair_false);
- pl_tuiggu = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_integer, s_gtk_enum_t, s_gtk_enum_t, s_pair_false);
- pl_turrrb = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_real, s_real, s_real, s_boolean);
- pl_tuusit = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_string, s_integer, s_any);
- pl_tuurbr = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_real, s_boolean, s_real);
- pl_tusiis = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_string, s_integer, s_integer, s_string);
- pl_tusuig = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_string, s_pair_false, s_integer, s_gtk_enum_t);
- 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_ssig = s7_make_circular_signature(sc, 3, 4, s_string, s_string, s_integer, s_gtk_enum_t);
+ 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_i = s7_make_circular_signature(sc, 0, 1, s_integer);
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_sui = s7_make_circular_signature(sc, 2, 3, s_string, s_pair_false, s_integer);
@@ -47637,13 +47502,17 @@ 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_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_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_g = s7_make_circular_signature(sc, 0, 1, s_gtk_enum_t);
+ pl_s = s7_make_circular_signature(sc, 0, 1, s_string);
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);
@@ -47653,48 +47522,105 @@ static void define_functions(s7_scheme *sc)
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_buus = s7_make_circular_signature(sc, 3, 4, s_boolean, s_pair_false, s_pair_false, s_string);
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_buuui = s7_make_circular_signature(sc, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_integer);
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_p = s7_make_circular_signature(sc, 0, 1, s_pair);
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_tg = s7_make_circular_signature(sc, 1, 2, s_any, s_gtk_enum_t);
+ 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_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_pt = s7_make_circular_signature(sc, 1, 2, s_pair, s_any);
+ pl_tu = s7_make_circular_signature(sc, 1, 2, s_any, s_pair_false);
+ pl_tut = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_any);
+ pl_tus = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_string);
+ pl_tug = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_gtk_enum_t);
+ pl_tur = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_real);
+ pl_tui = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_integer);
+ pl_tub = s7_make_circular_signature(sc, 2, 3, s_any, s_pair_false, s_boolean);
+ pl_tusg = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_gtk_enum_t);
+ pl_tugb = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_boolean);
+ pl_tugs = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_string);
+ pl_tuui = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_integer);
+ pl_tuib = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_boolean);
+ pl_tusi = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_integer);
+ pl_tuug = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_gtk_enum_t);
+ pl_tuig = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_gtk_enum_t);
+ pl_tuur = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_real);
+ pl_turi = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_real, s_integer);
+ pl_tusr = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_real);
+ pl_tusb = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_boolean);
+ pl_tuub = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_boolean);
+ pl_tuus = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_string);
+ pl_tugu = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_pair_false);
+ pl_tugr = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_real);
+ pl_tugi = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_integer);
+ pl_tusu = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_pair_false);
+ pl_tuut = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_pair_false, s_any);
+ pl_tugt = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_any);
+ pl_tuis = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_string);
+ pl_tust = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_string, s_any);
+ pl_tuiu = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_pair_false);
+ pl_tuit = s7_make_circular_signature(sc, 3, 4, s_any, s_pair_false, s_integer, s_any);
+ pl_tuuiu = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false);
+ pl_tuurb = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_boolean);
+ pl_tuuri = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_integer);
+ pl_tuugi = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer);
+ pl_turgs = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_real, s_gtk_enum_t, s_string);
+ pl_tuisi = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_integer, s_string, s_integer);
+ pl_tusri = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_string, s_real, s_integer);
+ pl_tuuut = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_any);
+ pl_tuubr = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_boolean, s_real);
+ pl_tuuub = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_boolean);
+ pl_tuuir = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_real);
+ pl_tuuui = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_integer);
+ pl_tuusi = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_string, s_integer);
+ pl_tuiiu = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_integer, s_integer, s_pair_false);
+ pl_tuiggu = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_integer, s_gtk_enum_t, s_gtk_enum_t, s_pair_false);
+ pl_turrrb = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_real, s_real, s_real, s_boolean);
+ pl_tuusit = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_string, s_integer, s_any);
+ pl_tuurbr = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_real, s_boolean, s_real);
+ pl_tusiis = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_string, s_integer, s_integer, s_string);
+ pl_tusuig = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_string, s_pair_false, s_integer, s_gtk_enum_t);
+ 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_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);
+ pl_tuuiiiirrrrgi = s7_make_circular_signature(sc, 12, 13, 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, s_integer);
+ pl_b = s7_make_circular_signature(sc, 0, 1, s_boolean);
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_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);
+ 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);
#endif
#if GTK_CHECK_VERSION(3, 4, 0)
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);
+ pl_tsu = s7_make_circular_signature(sc, 2, 3, s_any, s_string, s_pair_false);
#endif
#if GTK_CHECK_VERSION(3, 6, 0)
@@ -47703,10 +47629,10 @@ static void define_functions(s7_scheme *sc)
#endif
#if GTK_CHECK_VERSION(3, 10, 0)
- pl_tuuuui = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_integer);
pl_pusiig = s7_make_circular_signature(sc, 5, 6, s_pair, s_pair_false, s_string, s_integer, s_integer, s_gtk_enum_t);
pl_puuiig = s7_make_circular_signature(sc, 5, 6, s_pair, s_pair_false, s_pair_false, s_integer, s_integer, s_gtk_enum_t);
pl_pusiigu = s7_make_circular_signature(sc, 6, 7, s_pair, s_pair_false, s_string, s_integer, s_integer, s_gtk_enum_t, s_pair_false);
+ pl_tuuuui = s7_make_circular_signature(sc, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_integer);
#endif
#if GTK_CHECK_VERSION(3, 16, 0)
@@ -47727,6 +47653,11 @@ static void define_functions(s7_scheme *sc)
#if GTK_CHECK_VERSION(3, 94, 0)
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_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);
pl_tuiut = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_integer, s_pair_false, s_any);
pl_tuuur = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_real);
pl_tugug = s7_make_circular_signature(sc, 4, 5, s_any, s_pair_false, s_gtk_enum_t, s_pair_false, s_gtk_enum_t);
@@ -47738,21 +47669,16 @@ static void define_functions(s7_scheme *sc)
pl_tusuiut = s7_make_circular_signature(sc, 6, 7, s_any, s_pair_false, s_string, s_pair_false, s_integer, s_pair_false, s_any);
pl_tuugggi = s7_make_circular_signature(sc, 6, 7, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_gtk_enum_t, s_gtk_enum_t, s_integer);
pl_tuuuggu = s7_make_circular_signature(sc, 6, 7, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_gtk_enum_t, s_pair_false);
- 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_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);
+ 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);
#endif
@@ -48751,7 +48677,6 @@ static void define_functions(s7_scheme *sc)
s7_define_typed_function(sc, "pango_attr_iterator_get", lg_pango_attr_iterator_get, 2, 0, 0, H_pango_attr_iterator_get, pl_pug);
s7_define_typed_function(sc, "pango_attr_iterator_get_font", lg_pango_attr_iterator_get_font, 2, 2, 0, H_pango_attr_iterator_get_font, pl_pu);
s7_define_typed_function(sc, "pango_parse_markup", lg_pango_parse_markup, 6, 1, 0, H_pango_parse_markup, pl_psiiuusu);
- s7_define_typed_function(sc, "pango_break", lg_pango_break, 5, 0, 0, H_pango_break, pl_tsiuui);
s7_define_typed_function(sc, "pango_find_paragraph_boundary", lg_pango_find_paragraph_boundary, 2, 2, 0, H_pango_find_paragraph_boundary, pl_psiu);
s7_define_typed_function(sc, "pango_get_log_attrs", lg_pango_get_log_attrs, 6, 0, 0, H_pango_get_log_attrs, pl_tsiiuui);
s7_define_typed_function(sc, "pango_context_list_families", lg_pango_context_list_families, 1, 2, 0, H_pango_context_list_families, pl_pu);
@@ -48771,9 +48696,6 @@ static void define_functions(s7_scheme *sc)
s7_define_typed_function(sc, "pango_coverage_copy", lg_pango_coverage_copy, 1, 0, 0, H_pango_coverage_copy, pl_pu);
s7_define_typed_function(sc, "pango_coverage_get", lg_pango_coverage_get, 2, 0, 0, H_pango_coverage_get, pl_gui);
s7_define_typed_function(sc, "pango_coverage_set", lg_pango_coverage_set, 3, 0, 0, H_pango_coverage_set, pl_tuig);
- s7_define_typed_function(sc, "pango_coverage_max", lg_pango_coverage_max, 2, 0, 0, H_pango_coverage_max, pl_tu);
- s7_define_typed_function(sc, "pango_coverage_to_bytes", lg_pango_coverage_to_bytes, 1, 2, 0, H_pango_coverage_to_bytes, pl_pu);
- s7_define_typed_function(sc, "pango_coverage_from_bytes", lg_pango_coverage_from_bytes, 2, 0, 0, H_pango_coverage_from_bytes, pl_psi);
s7_define_typed_function(sc, "pango_font_description_new", lg_pango_font_description_new, 0, 0, 0, H_pango_font_description_new, pl_p);
s7_define_typed_function(sc, "pango_font_description_copy", lg_pango_font_description_copy, 1, 0, 0, H_pango_font_description_copy, pl_pu);
s7_define_typed_function(sc, "pango_font_description_copy_static", lg_pango_font_description_copy_static, 1, 0, 0, H_pango_font_description_copy_static, pl_pu);
@@ -49231,7 +49153,6 @@ static void define_functions(s7_scheme *sc)
s7_define_typed_function(sc, "pango_font_face_list_sizes", lg_pango_font_face_list_sizes, 1, 2, 0, H_pango_font_face_list_sizes, pl_pu);
s7_define_typed_function(sc, "pango_layout_set_auto_dir", lg_pango_layout_set_auto_dir, 2, 0, 0, H_pango_layout_set_auto_dir, pl_tub);
s7_define_typed_function(sc, "pango_layout_get_auto_dir", lg_pango_layout_get_auto_dir, 1, 0, 0, H_pango_layout_get_auto_dir, pl_bu);
- s7_define_typed_function(sc, "pango_script_for_unichar", lg_pango_script_for_unichar, 1, 0, 0, H_pango_script_for_unichar, pl_gi);
s7_define_typed_function(sc, "pango_script_iter_new", lg_pango_script_iter_new, 2, 0, 0, H_pango_script_iter_new, pl_psi);
s7_define_typed_function(sc, "pango_script_iter_get_range", lg_pango_script_iter_get_range, 1, 3, 0, H_pango_script_iter_get_range, pl_pu);
s7_define_typed_function(sc, "pango_script_iter_next", lg_pango_script_iter_next, 1, 0, 0, H_pango_script_iter_next, pl_bu);
@@ -53443,6 +53364,7 @@ static void define_symbols(s7_scheme *sc)
PangoLayoutLine__sym = s7_make_symbol(sc, "PangoLayoutLine_");
int__sym = s7_make_symbol(sc, "int_");
PangoItem__sym = s7_make_symbol(sc, "PangoItem_");
+ PangoAnalysis__sym = s7_make_symbol(sc, "PangoAnalysis_");
PangoGlyphString__sym = s7_make_symbol(sc, "PangoGlyphString_");
PangoFontMap__sym = s7_make_symbol(sc, "PangoFontMap_");
PangoFontFace__sym = s7_make_symbol(sc, "PangoFontFace_");
@@ -53455,7 +53377,6 @@ static void define_symbols(s7_scheme *sc)
PangoFont__sym = s7_make_symbol(sc, "PangoFont_");
PangoFontFamily___sym = s7_make_symbol(sc, "PangoFontFamily__");
PangoLogAttr__sym = s7_make_symbol(sc, "PangoLogAttr_");
- PangoAnalysis__sym = s7_make_symbol(sc, "PangoAnalysis_");
PangoAttrList___sym = s7_make_symbol(sc, "PangoAttrList__");
PangoAttrIterator__sym = s7_make_symbol(sc, "PangoAttrIterator_");
PangoRectangle__sym = s7_make_symbol(sc, "PangoRectangle_");
@@ -54888,7 +54809,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, "27-Aug-19"));
+ s7_define(sc, cur_env, s7_make_symbol(sc, "libgtk-version"), s7_make_string(sc, "30-Oct-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 */
diff --git a/lint.scm b/lint.scm
index faaedb4..10dc032 100644
--- a/lint.scm
+++ b/lint.scm
@@ -13771,6 +13771,12 @@
(not (= (car ary) (cdr ary)))
(not (= (length args) (cdr ary))))
(format #f "leaving aside ~A's optional arg~P, " cval (- (cdr ary) (length args)))
+ ;; optional args is only one of the problems:
+ ;; (define (f5 x) (read x)) (with-input-from-string f5) -- f5 is not a thunk
+ ;; (define (f5 x y) (macro x y)) -- f5 evals its arguments, passing (values x y) makes this worse
+ ;; (define (f5 x) (f6 x)) where f6 can be redefined later -- expectation is that new f6 is called
+ ;; (object->string (define (f5 x y) (+ x y)) :readable) returns "+"
+ ;; and undoubtedly many more
"")
function-name
function-name
diff --git a/peak-phases.scm b/peak-phases.scm
index 371f1d9..b77dedd 100644
--- a/peak-phases.scm
+++ b/peak-phases.scm
@@ -1,5 +1,6 @@
(provide 'snd-peak-phases.scm)
-(load "primes.scm")
+(unless (defined? 'primes)
+ (load "primes.scm"))
;;; multiply these phases by pi before use as initial-phases (and use sin, not cos -- see tstall below)
;;; to translate these peaks into the more standard crest-factor, (/ (* peak (sqrt 2)) (sqrt N))
diff --git a/repl.c b/repl.c
index c8d2a4d..f2fd4c4 100644
--- a/repl.c
+++ b/repl.c
@@ -1,23 +1,75 @@
#include <stdio.h>
#include <stdlib.h>
+#include <string.h>
+#ifndef _MSC_VER
+ #include <errno.h>
+ #include <unistd.h>
+#endif
#include "s7.h"
+#ifndef _MSC_VER
+static char *realdir(const char *filename)
+{
+ char *path;
+ char *p;
+
+ if (!strchr(filename, '/'))
+ {
+ char *pwd;
+ if (access("libc_s7.so", F_OK) != 0)
+ {
+ fprintf(stderr, "%s needs libc_s7.so (give the explicit pathname)\n", filename); /* env PATH=/home/bil/cl repl */
+ exit(2);
+ }
+ return(NULL); /* we're in the libc_s7.so directory, I hope (user could start a version of s7 that does not match the local libc_s7.so...) */
+ }
+ if (!(path = realpath(filename, NULL)))
+ {
+ fprintf(stderr, "%s: %s\n", strerror(errno), filename);
+ exit(2);
+ }
+ if (!(p = strrchr(path, '/')))
+ {
+ free(path);
+ fprintf(stderr, "please provide the full pathname for %s\n", filename);
+ exit(2);
+ }
+ if (p > path) *p = '\0'; else p[1] = 0;
+ return(path);
+}
+#endif
+
int main(int argc, char **argv)
{
s7_scheme *sc;
+
sc = s7_init();
+ /* fprintf(stderr, "s7: %s\n", S7_DATE); */
if (argc == 2)
{
fprintf(stderr, "load %s\n", argv[1]);
- if (!s7_load(sc, argv[1]))
- fprintf(stderr, "can't find %s\n", argv[1]); /* it could also be a directory */
+ s7_load(sc, argv[1]);
}
- else
+ else
{
- s7_load(sc, "repl.scm");
- s7_eval_c_string(sc, "((*repl* 'run))");
+#ifdef _MSC_VER
+ dumb_repl(sc);
+#else
+#ifdef S7_LOAD_PATH
+ s7_add_to_load_path(sc, S7_LOAD_PATH);
+#else
+ char *dir;
+ dir = realdir(argv[0]);
+ if (dir)
+ {
+ s7_add_to_load_path(sc, dir);
+ free(dir);
+ }
+#endif
+ s7_repl(sc);
+#endif
}
return(0);
}
diff --git a/s7.c b/s7.c
index 8c67cfc..c5199f6 100644
--- a/s7.c
+++ b/s7.c
@@ -420,8 +420,8 @@
#define __func__ __FUNCTION__
#endif
-#define DISPLAY(Obj) string_value(s7_object_to_string(sc, Obj, false))
-#define DISPLAY_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80))
+#define display(Obj) string_value(s7_object_to_string(sc, Obj, false))
+#define display_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80))
typedef intptr_t opcode_t;
@@ -548,7 +548,7 @@ typedef struct {
s7_pointer (*read_name)(s7_scheme *sc, s7_pointer pt); /* internal get-next-name reader */
s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer pt); /* internal get-next-sharp-constant reader */
s7_pointer (*read_line)(s7_scheme *sc, s7_pointer pt, bool eol_case, bool copied); /* function to read a string up to \n */
- void (*display)(s7_scheme *sc, const char *s, s7_pointer pt);
+ void (*displayer)(s7_scheme *sc, const char *s, s7_pointer pt);
void (*close_port)(s7_scheme *sc, s7_pointer p); /* close-in|output-port */
} port_functions;
@@ -737,9 +737,9 @@ struct opt_info {
int32_t slots;
opt_type_t types[NUM_VUNIONS];
int32_t addrs[NUM_VUNIONS];
- s7_pointer vexpr;
+ s7_pointer expr;
const char *func;
- int32_t line;
+ int32_t line, loc;
#endif
};
@@ -1111,7 +1111,8 @@ struct s7_scheme {
s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions, max_format_length, max_port_data_size, rec_loc, rec_len;
s7_pointer stacktrace_defaults;
- s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p, rec_resp, rec_slot1, rec_slot2, rec_slot3;
+ s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p;
+ s7_pointer rec_resp, rec_slot1, rec_slot2, rec_slot3, rec_p1, rec_p2;
s7_function rec_testf, rec_f1f, rec_f2f, rec_f3f, rec_f4f, rec_f5f, rec_f6f, rec_f7f, rec_f8f, rec_f9f, rec_resf, rec_call;
s7_int (*rec_fi1)(opt_info *o);
s7_int (*rec_fi2)(opt_info *o);
@@ -1126,7 +1127,6 @@ struct s7_scheme {
s7_i_ii_t rec_i_ii_f;
s7_d_dd_t rec_d_dd_f;
s7_pointer rec_val1, rec_val2;
- int32_t rec_pc1, rec_pc2;
int32_t float_format_precision;
vdims_t *wrap_only;
@@ -1281,7 +1281,7 @@ struct s7_scheme {
#endif
/* syntax symbols et al */
- s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, unquote_symbol, macroexpand_symbol,
+ s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, quasiquote_symbol, unquote_symbol, macroexpand_symbol,
define_expansion_symbol, define_expansion_star_symbol, baffle_symbol, with_let_symbol, if_symbol, autoload_error_symbol,
when_symbol, unless_symbol, begin_symbol, cond_symbol, case_symbol, and_symbol, or_symbol, do_symbol,
define_symbol, define_star_symbol, define_constant_symbol, with_baffle_symbol, define_macro_symbol,
@@ -1304,7 +1304,7 @@ struct s7_scheme {
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_3, list_set_i, hash_table_ref_2, hash_table_2,
+ 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, geq_2, add_i_random, is_defined_in_rootlet;
@@ -1359,25 +1359,8 @@ struct s7_scheme {
heap_block_t *heap_blocks;
};
-#if S7_DEBUGGING
-static void reset_opts(s7_scheme *sc)
-{
- int32_t i;
- opt_info *o;
- for (i = 0; i < 32; i++)
- {
- int32_t k;
- o = sc->opts[i];
- o->slots = 0;
- for (k = 0; k < NUM_VUNIONS; k++)
- {
- o->v[k].obj = NULL;
- o->types[k] = OO_P;
- }
- }
-}
-#else
-#define reset_opts(sc)
+#if S7_DEBUGGING && (0)
+static void gdb_break(void) {};
#endif
static s7_scheme *cur_sc = NULL; /* intended for gdb (see gdbinit) */
@@ -1539,7 +1522,6 @@ static inline char *alloc_permanent_string(s7_scheme *sc, size_t len)
#if S7_DEBUGGING
permanent_string_len += ALLOC_STRING_SIZE;
#endif
- /* fprintf(stderr, "new heap: %ld lost\n", ALLOC_STRING_SIZE - sc->alloc_string_k); */
sc->alloc_string_cells = (char *)malloc(ALLOC_STRING_SIZE);
sc->alloc_string_k = 0;
next_k = len;
@@ -2061,7 +2043,7 @@ static void init_types(void)
/* this marks symbols that represent syntax objects, it should be in the second byte */
#define T_SIMPLE_ARG_DEFAULTS (1 << (TYPE_BITS + 2))
-#define lambda_has_simple_defaults(p) has_type_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS)
+#define lambda_has_simple_defaults(p) has_type_bit(T_Pair(closure_body(p)), T_SIMPLE_ARG_DEFAULTS)
#define lambda_set_simple_defaults(p) set_type_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS)
/* are all lambda* default values simple? This is set on closure_body, so it doesn't mess up closure_is_ok_1 */
@@ -2160,8 +2142,12 @@ static void init_types(void)
}
#define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__)
#else
+#if S7_DEBUGGING
+#define set_local(p) do {if (is_keyword(p)) {fprintf(stderr, "%s[%d]: set %s local\n", __func__, __LINE__, symbol_name(p)); if (sc->stop_at_error) abort();} typeflag(T_Sym(p)) = ((typeflag(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));} while (0)
+#else
#define set_local(p) typeflag(T_Sym(p)) = ((typeflag(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC))
#endif
+#endif
#define T_HIGH_C T_LOCAL
#define has_high_c(p) has_type_bit(T_Pair(p), T_HIGH_C)
@@ -2342,10 +2328,6 @@ 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_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)
@@ -2778,6 +2760,7 @@ static void init_types(void)
#define fx_call(Sc, F) c_call(F)(Sc, car(F))
#define d_call(Sc, F) c_call(F)(Sc, cdr(F))
#endif
+/* fx_call can affect the stack and sc->value */
#define car(p) (T_Pair(p))->object.cons.car
#define set_car(p, Val) (T_Pair(p))->object.cons.car = T_Pos(Val)
@@ -2820,6 +2803,10 @@ static void init_types(void)
#define cddadr(p) cdr(cdr(car(cdr(p))))
#define cddaar(p) cdr(cdr(car(car(p))))
+#define cadaddr(p) car(cdr(car(cdr(cdr(p)))))
+#define caddadr(p) car(cdr(cdr(car(cdr(p)))))
+#define caddaddr(p) car(cdr(cdr(car(cdr(cdr(p))))))
+
#if WITH_GCC
/* slightly tricky because cons can be called recursively */
#define cons(Sc, A, B) ({s7_pointer _X_, _A_, _B_; _A_ = A; _B_ = B; new_cell(Sc, _X_, T_PAIR | T_SAFE_PROCEDURE); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;})
@@ -2859,7 +2846,6 @@ static void init_types(void)
#endif
#define optimize_op_match(P, Q) ((is_optimized(P)) && ((optimize_op(P) & 0xfffe) == (Q)))
#define op_no_hop(P) (optimize_op(P) & 0xfffe)
-#define clear_hop(P) set_optimize_op(P, op_no_hop(P))
#define clear_optimize_op(P) set_optimize_op(P, 0)
#define set_safe_optimize_op(P, Q) do {set_optimized(P); set_optimize_op(P, Q);} while (0)
#define set_unsafe_optimize_op(P, Q) do {set_unsafely_optimized(P); set_optimize_op(P, Q);} while (0)
@@ -2933,6 +2919,7 @@ static void symbol_set_id(s7_pointer p, s7_int id)
#define next_slot(p) T_Sln((T_Slt(p))->object.slt.nxt)
#define slot_set_next(p, Val) (T_Slt(p))->object.slt.nxt = T_Sln(Val)
#define slot_set_pending_value(p, Val) do {(T_Slt(p))->object.slt.pending_value = T_Pos(Val); slot_set_has_pending_value(p);} while (0)
+#define slot_simply_set_pending_value(p, Val) (T_Slt(p))->object.slt.pending_value = T_Pos(Val)
#if S7_DEBUGGING
static s7_pointer slot_pending_value(s7_pointer p) {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "slot: no pending value\n"); abort();}
static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "slot: no expression\n"); abort();}
@@ -2940,6 +2927,7 @@ static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p))
#define slot_pending_value(p) (T_Slt(p))->object.slt.pending_value
#define slot_expression(p) (T_Slt(p))->object.slt.expr
#endif
+#define slot_pending_value_unchecked(p) (T_Slt(p))->object.slt.pending_value
#define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Pos(Val); slot_set_has_expression(p);} while (0)
#define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Pos(Val)
#define slot_setter(p) T_Prc(T_Slt(p)->object.slt.expr)
@@ -3135,7 +3123,7 @@ static s7_pointer slot_expression(s7_pointer p) {if (slot_has_expression(p))
#define port_read_character(p) port_port(p)->pf->read_character
#define port_read_line(p) port_port(p)->pf->read_line
-#define port_display(p) port_port(p)->pf->display
+#define port_display(p) port_port(p)->pf->displayer
#define port_write_character(p) port_port(p)->pf->write_character
#define port_write_string(p) port_port(p)->pf->write_string
#define port_read_semicolon(p) port_port(p)->pf->read_semicolon
@@ -3408,8 +3396,10 @@ static s7_pointer make_permanent_integer_unchecked(s7_int i)
return(p);
}
-#define NUM_SMALL_INTS 2048
-static s7_pointer small_ints[NUM_SMALL_INTS + 1];
+#ifndef NUM_SMALL_INTS
+ #define NUM_SMALL_INTS 8192
+#endif
+static s7_pointer small_ints[NUM_SMALL_INTS];
#define small_int(Val) small_ints[Val]
#define is_small(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0)
@@ -3420,8 +3410,8 @@ static void init_small_ints(void)
const char *ones[10] = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"};
s7_cell *cells;
int32_t i;
- cells = (s7_cell *)calloc((NUM_SMALL_INTS + 1), sizeof(s7_cell));
- for (i = 0; i <= NUM_SMALL_INTS; i++)
+ cells = (s7_cell *)calloc((NUM_SMALL_INTS), sizeof(s7_cell));
+ for (i = 0; i < NUM_SMALL_INTS; i++)
{
s7_pointer p;
small_ints[i] = &cells[i];
@@ -3775,7 +3765,6 @@ static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int
static token_t token(s7_scheme *sc);
static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices);
static void free_hash_table(s7_scheme *sc, s7_pointer table);
-static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args);
static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst);
static inline s7_pointer symbol_to_slot(s7_scheme *sc, s7_pointer symbol);
static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len);
@@ -3819,6 +3808,7 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj);
#endif
static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol);
+static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer env, s7_pointer symbol);
static s7_pointer find_let(s7_scheme *sc, s7_pointer obj);
static bool call_begin_hook(s7_scheme *sc);
static s7_pointer default_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val);
@@ -3862,10 +3852,8 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_SAFE_C_opDq, HOP_SAFE_C_opDq, OP_SAFE_C_opSq, HOP_SAFE_C_opSq,
OP_SAFE_C_opSSq, HOP_SAFE_C_opSSq, OP_SAFE_C_opSCq, HOP_SAFE_C_opSCq,
OP_SAFE_C_opCSq, HOP_SAFE_C_opCSq, OP_SAFE_C_S_opSq, HOP_SAFE_C_S_opSq,
- OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq,
- OP_SAFE_C_S_opSCq, HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq,
- OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S,
- OP_SAFE_C_opSq_C, HOP_SAFE_C_opSq_C,
+ OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, OP_SAFE_C_S_opSCq, HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq,
+ OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, OP_SAFE_C_opSq_C, HOP_SAFE_C_opSq_C,
OP_SAFE_C_opSq_opSq, HOP_SAFE_C_opSq_opSq, OP_SAFE_C_S_opSSq, HOP_SAFE_C_S_opSSq, OP_SAFE_C_C_opSq, HOP_SAFE_C_C_opSq,
OP_SAFE_C_C_opCSq, HOP_SAFE_C_C_opCSq, OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C,
OP_SAFE_C_S_opDq, HOP_SAFE_C_S_opDq, OP_SAFE_C_opSSq_C, HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq,
@@ -3873,16 +3861,14 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq,
OP_SAFE_C_opSSq_opSq, HOP_SAFE_C_opSSq_opSq,
OP_SAFE_C_opSq_opSSq, HOP_SAFE_C_opSq_opSSq,
- OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S,
- OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S,
- OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C,
+ OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S, OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C,
OP_SAFE_C_S_op_opSq_Cq, HOP_SAFE_C_S_op_opSq_Cq,
OP_SAFE_C_S_op_S_opSSqq, HOP_SAFE_C_S_op_S_opSSqq, OP_SAFE_C_S_op_S_opSqq, HOP_SAFE_C_S_op_S_opSqq,
- OP_SAFE_C_op_opSSq_q_C, HOP_SAFE_C_op_opSSq_q_C, OP_SAFE_C_op_opSq_q_C, HOP_SAFE_C_op_opSq_q_C,
- OP_SAFE_C_op_opSSq_q_S, HOP_SAFE_C_op_opSSq_q_S,
+ OP_SAFE_C_op_opSSqq_C, HOP_SAFE_C_op_opSSqq_C, OP_SAFE_C_op_opSqq_C, HOP_SAFE_C_op_opSqq_C,
+ OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S,
OP_SAFE_C_S_op_opSSq_opSSqq, HOP_SAFE_C_S_op_opSSq_opSSqq, OP_SAFE_C_op_opSSq_Sq_S, HOP_SAFE_C_op_opSSq_Sq_S,
- OP_SAFE_C_op_opSq_q, HOP_SAFE_C_op_opSq_q,
- OP_SAFE_C_op_S_opSq_q, HOP_SAFE_C_op_S_opSq_q, OP_SAFE_C_op_opSq_S_q, HOP_SAFE_C_op_opSq_S_q,
+ OP_SAFE_C_op_opSqq, HOP_SAFE_C_op_opSqq, OP_SAFE_C_op_opSq_Cq, HOP_SAFE_C_op_opSq_Cq,
+ OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq, HOP_SAFE_C_op_opSq_Sq,
OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS,
OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_CA, HOP_SAFE_C_CA, OP_SAFE_C_AC, HOP_SAFE_C_AC,
@@ -3903,16 +3889,16 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
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_SAFE_CLOSURE_S_TO_SC, HOP_SAFE_CLOSURE_S_TO_SC,
+ OP_SAFE_CLOSURE_S_TO_S, HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC, HOP_SAFE_CLOSURE_S_TO_SC, OP_SAFE_CLOSURE_A_TO_SC, HOP_SAFE_CLOSURE_A_TO_SC,
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_SAFE_CLOSURE_ID_S, HOP_SAFE_CLOSURE_ID_S,
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,
- OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA,
- OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, HOP_SAFE_CLOSURE_PA,
+ OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA, OP_CLOSURE_PP, HOP_CLOSURE_PP,
+ OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, HOP_SAFE_CLOSURE_PA, OP_SAFE_CLOSURE_PP, HOP_SAFE_CLOSURE_PP,
OP_CLOSURE_FA, HOP_CLOSURE_FA,
+ OP_SAFE_OR_UNSAFE_CLOSURE_3P, HOP_SAFE_OR_UNSAFE_CLOSURE_3P,
OP_CLOSURE_SS, HOP_CLOSURE_SS, OP_CLOSURE_SS_P, HOP_CLOSURE_SS_P,
OP_SAFE_CLOSURE_SS, HOP_SAFE_CLOSURE_SS, OP_SAFE_CLOSURE_SS_P, HOP_SAFE_CLOSURE_SS_P, OP_SAFE_CLOSURE_SS_A, HOP_SAFE_CLOSURE_SS_A,
@@ -3930,12 +3916,15 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
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_SAFE_CLOSURE_3S_A, HOP_SAFE_CLOSURE_3S_A,
+ OP_SAFE_CLOSURE_FP, HOP_SAFE_CLOSURE_FP,
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,
+ OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A, OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA,
+ OP_SAFE_CLOSURE_STAR_A1, HOP_SAFE_CLOSURE_STAR_A1,
+ OP_SAFE_CLOSURE_STAR_KA, HOP_SAFE_CLOSURE_STAR_KA, OP_CLOSURE_STAR_KA, HOP_CLOSURE_STAR_KA,
OP_SAFE_CLOSURE_STAR_FX, HOP_SAFE_CLOSURE_STAR_FX, OP_SAFE_CLOSURE_STAR_FX_0, HOP_SAFE_CLOSURE_STAR_FX_0,
OP_SAFE_CLOSURE_STAR_FX_1, HOP_SAFE_CLOSURE_STAR_FX_1, OP_SAFE_CLOSURE_STAR_FX_2, HOP_SAFE_CLOSURE_STAR_FX_2,
- OP_SAFE_CLOSURE_FP, HOP_SAFE_CLOSURE_FP,
/* these can't be embedded, and have to be the last thing called */
OP_C_FX, HOP_C_FX, OP_CALL_WITH_EXIT, HOP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_P, HOP_CALL_WITH_EXIT_P,
@@ -3974,6 +3963,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
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_FX_1, OP_LET_TEMP_SETTER, OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, OP_LET_TEMP_SETTER_UNWIND,
+ OP_LET_TEMP_A_A,
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,
@@ -4015,7 +4005,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
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_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_LET_STAR_FX, OP_LET_STAR_FX_A,
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,
OP_CASE_S_E_S, OP_CASE_S_I_S, OP_CASE_S_G_S, OP_CASE_S_E_G, OP_CASE_S_G_G, OP_CASE_S_S_S, OP_CASE_S_S_G,
@@ -4028,7 +4018,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_COND_FEED, OP_COND_FEED_1,
OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2, OP_WHEN_AND_3, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P,
- OP_IF_A_CC, OP_IF_A_A, OP_IF_A_AA, OP_IF_NOT_A_A, OP_IF_NOT_A_AA,
+ OP_IF_A_CC, OP_IF_A_A, OP_IF_A_AA, OP_IF_S_AA, OP_IF_AND2_SA, OP_IF_NOT_A_A, OP_IF_NOT_A_AA,
OP_IF_A_A_P, OP_IF_S_P_A, OP_IF_IS_TYPE_S_P_A,
OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N,
@@ -4053,21 +4043,24 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_SAFE_C_SP_1, OP_SAFE_C_SP_MV, OP_SAFE_CONS_SP_1, OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, OP_SAFE_SUBTRACT_SP_1,
OP_SAFE_C_PS_1, OP_SAFE_C_PC_1, OP_SAFE_C_PS_MV, OP_SAFE_C_PC_MV,
OP_EVAL_MACRO_MV, OP_MACROEXPAND_1, OP_APPLY_LAMBDA,
- 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_SAFE_CLOSURE_P_1, OP_CLOSURE_P_1,
+ OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_PP_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_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_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_PP_1,
OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV, OP_SAFE_CLOSURE_FP_2,
+ OP_SAFE_OR_UNSAFE_CLOSURE_3P_1, OP_SAFE_OR_UNSAFE_CLOSURE_3P_2, OP_SAFE_OR_UNSAFE_CLOSURE_3P_3,
OP_SET_WITH_LET_1, OP_SET_WITH_LET_2,
- OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, OP_TC_OR_A_AND_A_LAA, OP_TC_OR_A_A_AND_A_A_LA, OP_TC_OR_A_AND_A_A_L3A,
+ OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, OP_TC_OR_A_AND_A_LAA, OP_TC_OR_A_A_AND_A_A_LA,
+ OP_TC_OR_A_AND_A_A_L3A, OP_TC_AND_A_OR_A_A_LA,
OP_TC_LET_WHEN_LAA, OP_TC_LET_UNLESS_LAA,
OP_TC_COND_A_Z_A_Z_LAA, OP_TC_COND_A_Z_A_LAA_LAA, OP_TC_LET_COND,
- OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z, OP_TC_IF_A_T_AND_A_A_L3A,
- OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_IF_A_Z_IF_A_LAA_Z,
+ OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_Z_L3A, OP_TC_IF_A_L3A_Z, OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z, OP_TC_IF_A_T_AND_A_A_L3A,
+ OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_COND_A_Z_A_Z_LA,
+ OP_TC_IF_A_Z_IF_A_LAA_Z, OP_TC_IF_A_Z_IF_A_L3A_L3A,
OP_TC_LET_IF_A_Z_LAA,
OP_TC_CASE_LA,
@@ -4075,7 +4068,7 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_opLA_LAq_A,
OP_RECUR_IF_A_A_opA_LA_LAq, OP_RECUR_IF_A_opA_LA_LAq_A,
OP_RECUR_IF_A_A_opLA_LA_LAq,
- OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A,
+ OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A, OP_RECUR_IF_A_A_opA_L3Aq,
OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq, OP_RECUR_IF_A_A_AND_A_LAA_LAA,
OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq, /* same as cond case below */
@@ -4086,7 +4079,6 @@ enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_prot
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;
@@ -4103,10 +4095,8 @@ static const char* op_names[NUM_OPS] =
"safe_c_opdq", "h_safe_c_opdq", "safe_c_opsq", "h_safe_c_opsq",
"safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq",
"safe_c_opcsq", "h_safe_c_opcsq", "safe_c_s_opsq", "h_safe_c_s_opsq",
- "safe_c_c_opscq", "h_safe_c_c_opscq",
- "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq",
- "safe_c_opsq_s", "h_safe_c_opsq_s",
- "safe_c_opsq_c", "h_safe_c_opsq_c",
+ "safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq",
+ "safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c",
"safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq", "h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq",
"safe_c_c_opcsq", "h_safe_c_c_opcsq", "safe_c_opcsq_c", "h_safe_c_opcsq_c",
"safe_c_s_opdq", "h_safe_c_s_opdq", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq",
@@ -4114,16 +4104,14 @@ static const char* op_names[NUM_OPS] =
"safe_c_opssq_opssq", "h_safe_c_opssq_opssq",
"safe_c_opssq_opsq", "h_safe_c_opssq_opsq",
"safe_c_opsq_opssq", "h_safe_c_opsq_opssq",
- "safe_c_opssq_s", "h_safe_c_opssq_s",
- "safe_c_opcsq_s", "h_safe_c_opcsq_s",
- "safe_c_opscq_c", "h_safe_c_opscq_c",
+ "safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s", "h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c",
"safe_c_s_op_opsq_cq", "h_safe_c_s_op_opsq_cq",
"safe_c_s_op_s_opssqq", "h_safe_c_s_op_s_opssqq", "safe_c_s_op_s_opsqq", "h_safe_c_s_op_s_opsqq",
- "safe_c_op_opssq_q_c", "h_safe_c_op_opssq_q_c", "safe_c_op_opsq_q_c", "h_safe_c_op_opsq_q_c",
- "safe_c_op_opssq_q_s", "h_safe_c_op_opssq_q_s",
+ "safe_c_op_opssqq_c", "h_safe_c_op_opssqq_c", "safe_c_op_opsqq_c", "h_safe_c_op_opsqq_c",
+ "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s",
"safe_c_s_op_opssq_opssqq", "h_safe_c_s_op_opssq_opssqq", "safe_c_opssq_sq_s", "h_safe_c_opssq_sq_s",
- "safe_c_op_opsq_q", "h_safe_c_op_opsq_q",
- "safe_c_op_s_opsq_q", "h_safe_c_op_s_opsq_q", "safe_c_op_opsq_s_q", "h_safe_c_op_opsq_s_q",
+ "safe_c_op_opsqq", "h_safe_c_op_opsqq", "safe_c_op_opsq_cq", "h_safe_c_op_opsq_cq",
+ "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", "h_safe_c_op_opsq_sq",
"safe_c_opsq_cs", "h_safe_c_opsq_cs",
"safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_ca", "h_safe_c_ca", "safe_c_ac", "h_safe_c_ac",
@@ -4143,16 +4131,16 @@ static const char* op_names[NUM_OPS] =
"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", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc",
+ "safe_closure_s_to_s", "h_safe_closure_s_to_s", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc", "safe_closure_a_to_sc", "h_safe_closure_a_to_sc",
"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",
- "safe_closure_id_s", "h_safe_closure_id_s",
"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",
- "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa",
- "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa",
+ "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa", "closure_pp", "h_closure_pp",
+ "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa", "safe_closure_pp", "h_safe_closure_pp",
"closure_fa", "h_closure_fa",
+ "safe_or_unsafe_closure_3p", "h_safe_or_unsafe_closure_3p",
"closure_ss", "h_closure_ss", "closure_ss_p", "h_closure_ss_p",
"safe_closure_ss", "h_safe_closure_ss", "safe_closure_ss_p", "h_safe_closure_ss_p", "safe_closure_ss_a", "h_safe_closure_ss_a",
@@ -4170,12 +4158,15 @@ static const char* op_names[NUM_OPS] =
"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",
+ "safe_closure_3s_a", "h_safe_closure_3s_a",
+ "safe_closure_fp", "h_safe_closure_fp",
"closure*_a", "h_closure*_a", "closure*_fx", "h_closure*_fx",
- "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa",
+ "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa",
+ "safe_closure*_a1", "h_safe_closure*_a1",
+ "safe_closure*_ka", "h_safe_closure*_ka", "closure*_ka", "h_closure*_ka",
"safe_closure*_fx", "h_safe_closure*_fx", "safe_closure*_fx_0", "h_safe_closure*_fx_0",
"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",
"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",
@@ -4212,6 +4203,7 @@ static const char* op_names[NUM_OPS] =
"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_fx_1", "let_temp_setter", "let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind",
+ "let_temp_a_a",
"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*",
@@ -4250,7 +4242,7 @@ static const char* op_names[NUM_OPS] =
"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_2", "let_a_new_2",
- "let*_fx_old", "let*_fx_new", "let*_fx_a_old", "let*_fx_a_new",
+ "let*_fx", "let*_fx_a",
"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",
"case_s_e_s", "case_s_i_s", "case_s_g_s", "case_s_e_g", "case_s_g_g", "case_s_s_s", "case_s_s_g",
@@ -4263,7 +4255,7 @@ static const char* op_names[NUM_OPS] =
"cond_feed", "cond_feed_1",
"when_s", "when_a", "when_p", "when_and_ap", "when_and_2", "when_and_3", "unless_s", "unless_a", "unless_p",
- "if_a_cc", "if_a_a", "if_a_aa", "if_not_a_a", "if_not_a_aa",
+ "if_a_cc", "if_a_a", "if_a_aa", "if_s_aa", "if_and2_sa", "if_not_a_a", "if_not_a_aa",
"if_a_a_p", "if_s_p_a", "if_is_type_s_p_a",
"if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n",
@@ -4288,21 +4280,24 @@ static const char* op_names[NUM_OPS] =
"safe_c_sp_1", "safe_c_sp_mv", "safe_cons_sp_1", "safe_add_sp_1", "safe_multiply_sp_1", "safe_subtract_sp_1",
"safe_c_ps_1", "safe_c_pc_1", "safe_c_ps_mv", "safe_c_pc_mv",
"eval_macro_mv", "macroexpand_1", "apply_lambda",
- "safe_closure_p_1", "closure_p_1", "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_fp_1", "safe_closure_fp_mv_1",
+ "safe_closure_p_1", "closure_p_1",
+ "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_pp_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", "safe_c_fp_2",
- "closure_ap_1", "closure_pa_1",
- "closure_p_mv", "closure_ap_mv", "closure_pa_mv",
+ "closure_ap_1", "closure_pa_1", "closure_pp_1",
"safe_c_pa_1", "safe_c_pa_mv", "safe_closure_fp_2",
+ "safe_or_unsafe_closure_3p_1", "safe_or_unsafe_closure_3p_2", "safe_or_unsafe_closure_3p_3",
"set_with_let_1", "set_with_let_2",
- "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa", "tc_or_a_and_a_laa", "tc_or_a_a_and_a_a_la", "tc_or_a_and_a_a_l3a",
+ "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa", "tc_or_a_and_a_laa", "tc_or_a_a_and_a_a_la",
+ "tc_or_a_and_a_a_l3a", "tc_and_a_or_a_a_la",
"tc_let_when_laa", "tc_let_unless_laa",
"tc_cond_a_z_a_z_laa", "tc_cond_a_z_a_laa_laa", "tc_let_cond",
- "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_la_z", "tc_if_a_laa_z", "tc_if_a_t_and_a_a_l3a",
- "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", "tc_if_a_z_if_a_laa_z",
+ "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_z_l3a", "tc_if_a_l3a_z", "tc_if_a_la_z", "tc_if_a_laa_z", "tc_if_a_t_and_a_a_l3a",
+ "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", "tc_cond_a_z_a_z_la",
+ "tc_if_a_z_if_a_laa_z", "tc_if_a_z_if_a_l3a_l3a",
"tc_let_if_a_z_laa",
"tc_case_la",
@@ -4310,7 +4305,7 @@ static const char* op_names[NUM_OPS] =
"recur_if_a_a_opla_laq", "recur_if_a_opla_laq_a",
"recur_if_a_a_opa_la_laq", "recur_if_a_opa_la_laq_a",
"recur_if_a_a_opla_la_laq",
- "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a",
+ "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a", "recur_if_a_a_opa_l3aq",
"recur_if_a_a_lopl3a_l3a_l3aq", "recur_if_a_a_and_a_laa_laa",
"recur_if_a_a_if_a_laa_opa_laaq",
@@ -4336,14 +4331,6 @@ static bool is_h_optimized(s7_pointer p)
(optimize_op(p) > OP_GC_PROTECT));
}
-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_GC_PROTECT));
-}
-
/* -------- */
static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1)
{
@@ -4461,7 +4448,7 @@ static int32_t position_of(s7_pointer p, s7_pointer args)
s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
{
if (has_active_methods(sc, obj))
- return(find_method(sc, find_let(sc, obj), method));
+ return(find_method_with_let(sc, obj, method));
return(sc->undefined);
}
@@ -4474,7 +4461,7 @@ static inline s7_pointer copy_list(s7_scheme *sc, s7_pointer lst);
{ \
s7_pointer func; \
if ((has_active_methods(sc, Obj)) && \
- ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
+ ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \
return(s7_apply_function(Sc, func, copy_list(Sc, Args))); \
}
@@ -4482,7 +4469,7 @@ static inline s7_pointer copy_list(s7_scheme *sc, s7_pointer lst);
{ \
s7_pointer func; \
if ((has_active_methods(sc, Obj)) && \
- ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
+ ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \
return(s7_apply_function(Sc, func, Args)); \
}
@@ -4490,7 +4477,7 @@ static inline s7_pointer copy_list(s7_scheme *sc, s7_pointer lst);
{ \
s7_pointer func; \
if ((has_active_methods(sc, Obj)) && \
- ((func = find_method(Sc, find_let(Sc, Obj), Method)) != Sc->undefined)) \
+ ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \
{unstack(Sc); return(s7_apply_function(Sc, func, copy_list(Sc, Args)));} \
}
@@ -4499,7 +4486,7 @@ static inline s7_pointer copy_list(s7_scheme *sc, s7_pointer lst);
static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
{
s7_pointer func;
- func = find_method(sc, find_let(sc, obj), method);
+ func = find_method_with_let(sc, obj, method);
if (func == sc->undefined) return(sc->F);
return(s7_apply_function(sc, func, list_1(sc, obj)));
}
@@ -4615,7 +4602,7 @@ static s7_pointer g_is_unspecified(s7_scheme *sc, s7_pointer args)
/* -------------------------------- eof-object? -------------------------------- */
-s7_pointer eof_object = NULL;
+s7_pointer eof_object = NULL; /* #<eof> -- a character, an entry in the chars array, so not a part of sc */
s7_pointer s7_eof_object(s7_scheme *sc) {return(eof_object);}
@@ -5197,7 +5184,7 @@ static void add_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter)
s7_int i;
#if S7_DEBUGGING
if ((!is_any_closure(setter)) && (!is_any_macro(setter)))
- fprintf(stderr, "add_setter: %s %d?\n", DISPLAY(setter), type(setter));
+ fprintf(stderr, "add_setter: %s %d?\n", display(setter), type(setter));
#endif
for (i = 0; i < sc->setters_loc; i++)
{
@@ -5813,6 +5800,9 @@ static int64_t gc(s7_scheme *sc)
gc_mark(car(sc->qlist_3)); gc_mark(cadr(sc->qlist_3)); gc_mark(caddr(sc->qlist_3));
gc_mark(car(sc->u1_1));
+ gc_mark(sc->rec_p1);
+ gc_mark(sc->rec_p2);
+
{
s7_pointer p;
for (p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) gc_mark(car(p));
@@ -5890,8 +5880,8 @@ static int64_t gc(s7_scheme *sc)
heap_top = (s7_pointer *)(sc->heap + sc->heap_size);
#if S7_DEBUGGING
-#define gc_call(P, Tp) \
- p = (*tp++); \
+ #define gc_call(Tp) \
+ p = (*Tp++); \
if (is_marked(T_Any(p))) \
clear_mark(p); \
else \
@@ -5905,16 +5895,16 @@ static int64_t gc(s7_scheme *sc)
(*fp++) = p; \
}}
#else
- #define gc_call(P, Tp) p = (*tp++); if (is_marked(p)) clear_mark(p); else {if (!is_free_and_clear(p)) {clear_type(p); (*fp++) = p;}}
+ #define gc_call(Tp) p = (*Tp++); if (is_marked(p)) clear_mark(p); else {if (!is_free_and_clear(p)) {clear_type(p); (*fp++) = p;}}
#endif
while (tp < heap_top) /* != here or ^ makes no difference */
{
s7_pointer p;
- LOOP_8(gc_call(p, tp));
- LOOP_8(gc_call(p, tp));
- LOOP_8(gc_call(p, tp));
- LOOP_8(gc_call(p, tp));
+ LOOP_8(gc_call(tp));
+ LOOP_8(gc_call(tp));
+ LOOP_8(gc_call(tp));
+ LOOP_8(gc_call(tp));
}
sc->free_heap_top = fp;
@@ -6453,6 +6443,8 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c
#define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code)
#define push_stack_op(Sc, Op) push_stack(Sc, Op, sc->unused, sc->unused)
#define push_stack_op_let(Sc, Op) push_stack(Sc, Op, sc->unused, sc->unused)
+#define push_stack_direct(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code)
+#define push_stack_no_args_direct(Sc, Op, Code) push_stack(Sc, Op, sc->unused, Code)
/* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */
#else
@@ -6460,6 +6452,9 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c
#define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0)
#define pop_stack_no_op(Sc) {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0)
+/* TODO: these should protect against gc_protect_direct or some other push_stack happening in fx_* as an argument --
+ * the stack pointer changes, and the push is in consistent
+ */
#define push_stack(Sc, Op, Args, Code) \
do { \
Sc->stack_end[0] = Code; \
@@ -6469,6 +6464,13 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c
Sc->stack_end += 4; \
} while (0)
+#define push_stack_direct(Sc, Op, Args, Code) \
+ do { \
+ memcpy((void *)(Sc->stack_end), (void *)Sc, 3 * sizeof(s7_pointer)); \
+ Sc->stack_end[3] = (s7_pointer)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+
#define push_stack_no_code(Sc, Op, Args) \
do { \
Sc->stack_end[1] = Sc->envir; \
@@ -6492,6 +6494,13 @@ static void push_stack(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer c
Sc->stack_end += 4; \
} while (0)
+#define push_stack_no_args_direct(Sc, Op, Code) \
+ do { \
+ memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \
+ Sc->stack_end[3] = (s7_pointer)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+
#define push_stack_no_let(Sc, Op, Args, Code) \
do { \
Sc->stack_end[0] = Code; \
@@ -6582,7 +6591,7 @@ static void resize_stack(s7_scheme *sc)
if (show_stack_stats(sc))
{
- s7_warn(sc, 128, "stack grows to %u, %s\n", new_size, DISPLAY_80(sc->code));
+ s7_warn(sc, 128, "stack grows to %u, %s\n", new_size, display_80(sc->code));
s7_show_let(sc);
}
}
@@ -7350,7 +7359,6 @@ static s7_pointer old_frame_with_three_slots(s7_scheme *sc, s7_pointer env, s7_p
return(env);
}
-
#if S7_DEBUGGING
static s7_int permanent_slots = 0;
#endif
@@ -7397,21 +7405,6 @@ static s7_pointer make_permanent_let(s7_scheme *sc, s7_pointer vars)
return(frame);
}
-static s7_pointer activate_permanent_let_star(s7_scheme *sc, s7_pointer frame, s7_pointer vars)
-{
- s7_pointer slot, var;
- let_id(frame) = ++sc->let_number;
- set_outlet(frame, sc->envir);
- sc->envir = frame;
- for (var = vars, slot = let_slots(frame); is_pair(var); var = cdr(var), slot = next_slot(slot))
- {
- slot_set_value(slot, fx_call(sc, cdar(var)));
- symbol_set_local(caar(var), sc->let_number, slot);
- }
- return(frame);
-}
-
-
static s7_pointer find_let(s7_scheme *sc, s7_pointer obj)
{
if (is_let(obj)) return(obj);
@@ -7501,6 +7494,11 @@ static s7_pointer find_method(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
return(sc->undefined);
}
+static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer env, s7_pointer symbol)
+{
+ return(find_method(sc, find_let(sc, env), symbol));
+}
+
static s7_int s7_let_length(void);
static s7_int let_length(s7_scheme *sc, s7_pointer e)
@@ -7693,7 +7691,6 @@ s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_poi
static s7_pointer make_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value)
{
- /* this is for a do-loop optimization -- an unattached slot */
s7_pointer y;
new_cell(sc, y, T_SLOT);
slot_set_symbol(y, variable);
@@ -8247,11 +8244,13 @@ static s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args)
for (x = args; is_pair(x); x = cddr(x))
{
s7_pointer symbol, slot;
+
symbol = car(x);
if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */
symbol = keyword_symbol(symbol);
if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */
return(wrong_type_argument_with_type(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string));
+
new_cell_no_check(sc, slot, T_SLOT);
slot_set_symbol(slot, symbol);
slot_set_value(slot, cadr(x));
@@ -8274,6 +8273,9 @@ static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value)
symbol = keyword_symbol(symbol);
if (is_constant_symbol(sc, symbol))
return(wrong_type_argument_with_type(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string));
+ if ((is_global(symbol)) &&
+ (is_syntax(slot_value(global_slot(symbol)))))
+ return(wrong_type_argument_with_type(sc, sc->inlet_symbol, 1, symbol, wrap_string(sc, "a non-syntactic name", 20)));
new_cell(sc, x, T_LET | T_SAFE_PROCEDURE);
sc->temp3 = x;
@@ -9000,7 +9002,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)); */
+ /* 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
@@ -9504,7 +9506,7 @@ static int tree_is_cyclic_or_has_pairs(s7_scheme *sc, s7_pointer tree)
if (fast == slow) return(TREE_CYCLIC);
}
#if S7_DEBUGGING
- if (!has_pairs) fprintf(stderr, "at end but no pairs: %s\n", DISPLAY(tree));
+ if (!has_pairs) fprintf(stderr, "at end but no pairs: %s\n", display(tree));
#endif
return(TREE_HAS_PAIRS);
}
@@ -10374,7 +10376,7 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c)
dynamic_wind_state(x) = DWIND_FINISH;
if (dynamic_wind_out(x) != sc->F)
{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->args = sc->nil;
sc->code = dynamic_wind_out(x);
eval(sc, OP_APPLY);
@@ -10419,7 +10421,7 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c)
x = stack_code(continuation_stack(c), i);
if (dynamic_wind_in(x) != sc->F)
{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->args = sc->nil;
sc->code = dynamic_wind_in(x);
eval(sc, OP_APPLY);
@@ -10591,7 +10593,7 @@ static void call_with_exit(s7_scheme *sc)
dynamic_wind_state(lx) = DWIND_FINISH;
if (dynamic_wind_out(lx) != sc->F)
{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->args = sc->nil;
sc->code = dynamic_wind_out(lx);
eval(sc, OP_APPLY);
@@ -12729,8 +12731,8 @@ static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name)
* The procedure can call read-char to read ahead in the current-input-port.
* If it returns anything other than #f, that is the value of the sharp expression.
* Since #f means "nothing found", it is tricky to handle #F:
- * (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t))))
- * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback.
+ * (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) ; or ''#f used in lint.scm
+ * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback. Added #_ later)
*/
need_loader_port = is_loader_port(sc->input_port);
@@ -12812,6 +12814,23 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool with_error
{
/* name is the stuff after the '#', return sc->nil if not a recognized #... entity */
+ if (name[0] == '_')
+ {
+ /* this needs to be unsettable via *#readers*:
+ * (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1))))))
+ * (let ((+ -)) (#_+ 1 2)): -1
+ */
+ s7_pointer sym;
+ sym = make_symbol(sc, (char *)(name + 1));
+ if ((!is_gensym(sym)) && (is_slot(initial_slot(sym))))
+ return(slot_value(initial_slot(sym)));
+ /* here we should not necessarily raise an error that *_... is undefined. reader-cond, for example, needs to
+ * read undefined #_ vals that it will eventually discard.
+ */
+ return(make_unknown(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */
+ }
+
+ /* stupid r7rs special cases */
if ((name[0] == 't') &&
((name[1] == '\0') || (strings_are_equal(name, "true"))))
return(sc->T);
@@ -12852,19 +12871,6 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, char *name, bool with_error
case 'b': /* #b (binary) */
return(make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), NO_SYMBOLS, with_error));
- /* -------- #_... -------- */
- case '_':
- {
- s7_pointer sym;
- sym = make_symbol(sc, (char *)(name + 1));
- if ((!is_gensym(sym)) && (is_slot(initial_slot(sym))))
- return(slot_value(initial_slot(sym)));
- /* here we should not necessarily raise an error that *_... is undefined. reader-cond, for example, needs to
- * read undefined #_ vals that it will eventually discard.
- */
- return(make_unknown(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */
- }
-
/* -------- #\... -------- */
case '\\':
if (name[2] == 0) /* the most common case: #\a */
@@ -13478,13 +13484,17 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym
break;
case 'n':
+#if (!DISABLE_DEPRECATED)
if (local_strcmp(p, "an.0")) /* nan.0 */
return(real_NaN);
+#endif
return((want_symbol) ? make_symbol(sc, q) : sc->F);
case 'i':
+#if (!DISABLE_DEPRECATED)
if (local_strcmp(p, "nf.0")) /* inf.0 */
return(real_infinity);
+#endif
return((want_symbol) ? make_symbol(sc, q) : sc->F);
case '0': /* these two are always digits */
@@ -13912,7 +13922,7 @@ static bool is_rational_via_method(s7_scheme *sc, s7_pointer p) /* used in gmp a
if (has_active_methods(sc, p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->is_rational_symbol);
+ f = find_method_with_let(sc, p, sc->is_rational_symbol);
if (f != sc->undefined)
return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
}
@@ -13975,12 +13985,10 @@ static double my_hypot(double x, double y)
return(sqrt(x * x + y * y));
}
-static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args)
+static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x)
{
- #define H_magnitude "(magnitude z) returns the magnitude of z"
- #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
- s7_pointer x;
- x = car(args);
+ if (is_t_complex(x))
+ return(make_real(sc, my_hypot(imag_part(x), real_part(x))));
switch (type(x))
{
@@ -14006,14 +14014,18 @@ static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args)
return(make_real(sc, -real(x)));
return(x);
- case T_COMPLEX:
- return(make_real(sc, my_hypot(imag_part(x), real_part(x))));
-
default:
- return(method_or_bust_with_type_one_arg(sc, x, sc->magnitude_symbol, args, a_number_string));
+ return(method_or_bust_with_type_one_arg(sc, x, sc->magnitude_symbol, list_1(sc, x), a_number_string));
}
}
+static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args)
+{
+ #define H_magnitude "(magnitude z) returns the magnitude of z"
+ #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
+ return(magnitude_p_p(sc, car(args)));
+}
+
/* -------------------------------- rationalize -------------------------------- */
static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args)
@@ -14506,11 +14518,9 @@ static s7_pointer g_sin(s7_scheme *sc, s7_pointer args)
s7_pointer x;
x = car(args);
+ if (is_t_real(x)) return(make_real(sc, sin(real(x))));
switch (type(x))
{
- case T_REAL:
- return(make_real(sc, sin(real(x))));
-
case T_INTEGER:
if (integer(x) == 0) return(small_int(0)); /* (sin 0) -> 0 */
return(make_real(sc, sin((s7_double)integer(x))));
@@ -14645,6 +14655,7 @@ static s7_pointer g_asin(s7_scheme *sc, s7_pointer args)
s7_pointer n;
n = car(args);
+ if (is_t_real(n)) return(c_asin(sc, real(n)));
switch (type(n))
{
case T_INTEGER:
@@ -14655,9 +14666,6 @@ static s7_pointer g_asin(s7_scheme *sc, s7_pointer args)
case T_RATIO:
return(c_asin(sc, (s7_double)numerator(n) / (s7_double)denominator(n)));
- case T_REAL:
- return(c_asin(sc, real(n)));
-
case T_COMPLEX:
#if HAVE_COMPLEX_NUMBERS
/* if either real or imag part is very large, use explicit formula, not casin */
@@ -15512,16 +15520,9 @@ static s7_int c_quo_dbl(s7_scheme *sc, s7_double x, s7_double y)
static s7_int quotient_i_7ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(c_quo_int(sc, i1, i2));}
static s7_int quotient_i_ii_direct(s7_int i1, s7_int i2) {return(i1 / i2);} /* i2 > 0 */
-static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
+static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
- #define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1"
- #define Q_quotient s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_real_symbol, sc->is_real_symbol)
- /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */
- s7_pointer x, y;
s7_int d1, d2, n1, n2;
-
- x = car(args);
- y = cadr(args);
if ((is_t_integer(x)) && (is_t_integer(y)))
return(make_integer(sc, c_quo_int(sc, integer(x), integer(y))));
@@ -15543,13 +15544,13 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
case T_REAL:
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->quotient_symbol, args));
+ return(division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y)));
if ((is_inf(real(y))) || (is_NaN(real(y))))
return(wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, y, a_normal_real_string));
return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y))); /* s7_truncate returns an integer */
default:
- return(method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2));
+ return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2));
}
case T_RATIO:
@@ -15557,7 +15558,7 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
{
case T_INTEGER:
if (integer(y) == 0)
- return(division_by_zero_error(sc, sc->quotient_symbol, args));
+ return(division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y)));
n1 = numerator(x);
d1 = denominator(x);
n2 = integer(y);
@@ -15592,13 +15593,13 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
case T_REAL:
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->quotient_symbol, args));
+ return(division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y)));
if ((is_inf(real(y))) || (is_NaN(real(y))))
return(wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, y, a_normal_real_string));
return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y)));
default:
- return(method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2));
+ return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2));
}
case T_REAL:
@@ -15614,7 +15615,7 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
{
case T_INTEGER:
if (integer(y) == 0)
- return(division_by_zero_error(sc, sc->quotient_symbol, args));
+ return(division_by_zero_error(sc, sc->quotient_symbol, set_elist_2(sc, x, y)));
return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)integer(y)));
case T_RATIO:
@@ -15624,14 +15625,22 @@ static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
return(make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */
default:
- return(method_or_bust(sc, y, sc->quotient_symbol, args, T_REAL, 2));
+ return(method_or_bust(sc, y, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2));
}
default:
- return(method_or_bust(sc, x, sc->quotient_symbol, args, T_REAL, 2));
+ return(method_or_bust(sc, x, sc->quotient_symbol, list_2(sc, x, y), T_REAL, 2));
}
}
+static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
+{
+ #define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1"
+ #define Q_quotient s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_real_symbol, sc->is_real_symbol)
+ /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */
+ return(quotient_p_pp(sc, car(args), cadr(args)));
+}
+
/* -------------------------------- remainder -------------------------------- */
static inline s7_int c_rem_int(s7_scheme *sc, s7_int x, s7_int y)
@@ -16831,7 +16840,29 @@ 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)));}
+
+static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p0, p1, p2;
+ p0 = car(args);
+ p1 = cadr(args);
+ p2 = caddr(args);
+ if ((is_t_integer(p0)) && (is_t_integer(p1)) && (is_t_integer(p2)))
+ {
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val;
+ if ((!add_overflow(integer(p0), integer(p1), &val)) &&
+ (!add_overflow(val, integer(p2), &val)))
+ return(make_integer(sc, val));
+ return(make_real(sc, (double)integer(p0) + (double)integer(p1) + (double)integer(p2)));
+#else
+ return(make_integer(sc, integer(p0) + integer(p1) + integer(p2)));
+#endif
+ }
+ if ((is_t_real(p0)) && (is_t_real(p1)) && (is_t_real(p2)))
+ return(make_real(sc, real(p0) + real(p1) + real(p2)));
+ return(add_p_pp(sc, add_p_pp(sc, p0, p1), p2));
+}
/* 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_x1_1(s7_scheme *sc, s7_pointer x, s7_pointer args)
@@ -17396,7 +17427,10 @@ static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x)
static s7_pointer g_subtract_s1(s7_scheme *sc, s7_pointer args)
{
- return(minus_c1(sc, car(args)));
+ s7_pointer p;
+ p = car(args);
+ if (is_t_integer(p)) return(make_integer(sc, integer(p) - 1));
+ return(minus_c1(sc, p));
}
static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */
@@ -17452,6 +17486,30 @@ static s7_double subtract_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_do
#if (!WITH_GMP)
static s7_pointer sub_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 - x2));}
+
+static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y)
+{
+ if (is_t_integer(x))
+ {
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val;
+ if (subtract_overflow(integer(x), y, &val))
+ return(make_real(sc, (double)integer(x) - (double)y));
+ return(make_integer(sc, val));
+#else
+ return(make_integer(sc, integer(x) - y));
+#endif
+ }
+ switch (type(x))
+ {
+ case T_RATIO: return(s7_make_ratio(sc, numerator(x) - (y * denominator(x)), denominator(x)));
+ case T_REAL: return(make_real(sc, real(x) - y));
+ case T_COMPLEX: return(s7_make_complex(sc, real_part(x) - y, imag_part(x)));
+ default:
+ return(method_or_bust_with_type(sc, x, sc->subtract_symbol, list_2(sc, x, make_integer(sc, y)), a_number_string, 1));
+ }
+ return(x);
+}
#endif
@@ -17993,14 +18051,14 @@ static bool is_number_via_method(s7_scheme *sc, s7_pointer p)
if (has_active_methods(sc, p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->is_number_symbol);
+ f = find_method_with_let(sc, p, sc->is_number_symbol);
if (f != sc->undefined)
return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
}
return(false);
}
-static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer args)
+static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
{
/* splitting out real/real here saves very little */
switch (type(x))
@@ -18030,7 +18088,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin
if (is_NaN(real(y))) return(real_NaN);
if (is_inf(real(y))) return(real_zero);
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->divide_symbol, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
return(make_real(sc, (s7_double)(integer(x)) / real(y)));
case T_COMPLEX:
@@ -18097,7 +18155,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin
case T_REAL:
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->divide_symbol, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
return(make_real(sc, fraction(x) / real(y)));
case T_COMPLEX:
@@ -18120,7 +18178,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin
{
case T_INTEGER:
if (integer(y) == 0)
- return(division_by_zero_error(sc, sc->divide_symbol, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
if (is_NaN(real(x))) return(real_NaN); /* what is (/ +nan.0 0)? */
if (is_inf(real(x))) return((real(x) > 0.0) ? ((integer(y) > 0) ? real_infinity : real_minus_infinity) : ((integer(y) > 0) ? real_minus_infinity : real_infinity));
return(make_real(sc, real(x) / (s7_double)integer(y)));
@@ -18133,7 +18191,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin
case T_REAL:
if (is_NaN(real(y))) return(real_NaN);
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->divide_symbol, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
if (is_NaN(real(x))) return(real_NaN);
if (is_inf(real(y)))
{
@@ -18167,7 +18225,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin
{
s7_double r1;
if (integer(y) == 0)
- return(division_by_zero_error(sc, sc->divide_symbol, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
r1 = 1.0 / (s7_double)integer(y);
return(s7_make_complex(sc, real_part(x) * r1, imag_part(x) * r1));
}
@@ -18183,7 +18241,7 @@ static s7_pointer g_divide_xy(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_poin
{
s7_double r1;
if (real(y) == 0.0)
- return(division_by_zero_error(sc, sc->divide_symbol, args));
+ return(division_by_zero_error(sc, sc->divide_symbol, set_elist_2(sc, x, y)));
r1 = 1.0 / real(y);
return(s7_make_complex(sc, real_part(x) * r1, imag_part(x) * r1));
}
@@ -18235,14 +18293,14 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
return(s7_invert(sc, x));
}
if (is_null(cdr(p)))
- return(g_divide_xy(sc, x, cadr(args), args));
+ return(divide_p_pp(sc, x, cadr(args)));
y = g_multiply_1(sc, p, sc->divide_symbol); /* in some schemes (/ 1 0 +nan.0) is not equal to (/ 1 (* 0 +nan.0)), in s7 they're both +nan.0 */
#if WITH_GMP
if (s7_is_bignum(y))
return(big_divide(sc, set_plist_2(sc, x, y)));
#endif
- return(g_divide_xy(sc, x, y, args));
+ return(divide_p_pp(sc, x, y));
}
#if (!WITH_GMP)
@@ -18275,7 +18333,7 @@ static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args)
static s7_pointer g_divide_2(s7_scheme *sc, s7_pointer args)
{
- return(g_divide_xy(sc, car(args), cadr(args), args));
+ return(divide_p_pp(sc, car(args), cadr(args)));
}
static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args)
@@ -18340,7 +18398,7 @@ static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(s7_make_ratio(sc,
static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p)
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->is_real_symbol);
+ f = find_method_with_let(sc, p, sc->is_real_symbol);
if (f != sc->undefined)
return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
return(false);
@@ -18867,16 +18925,10 @@ static bool num_eq_b_pi(s7_scheme *sc, s7_pointer x, s7_int y)
{
if (is_t_integer(x))
return(integer(x) == y);
-
- switch (type(x))
- {
- case T_INTEGER: return(integer(x) == y);
- case T_RATIO: return(false);
- case T_REAL: return(real(x) == y);
- case T_COMPLEX: return(false);
- default:
- simple_wrong_type_argument_with_type(sc, sc->num_eq_symbol, x, a_number_string);
- }
+ if (is_t_real(x))
+ return(real(x) == y);
+ if (!is_number(x))
+ simple_wrong_type_argument_with_type(sc, sc->num_eq_symbol, x, a_number_string);
return(false);
}
@@ -20337,13 +20389,8 @@ s7_double s7_imag_part(s7_pointer x)
return(0.0);
}
-static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args)
+static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p)
{
- #define H_real_part "(real-part num) returns the real part of num"
- #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
-
- s7_pointer p;
- p = car(args);
switch (type(p))
{
case T_INTEGER:
@@ -20374,19 +20421,21 @@ static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args)
#endif
default:
- return(method_or_bust_with_type_one_arg(sc, p, sc->real_part_symbol, args, a_number_string));
+ return(method_or_bust_with_type_one_arg(sc, p, sc->real_part_symbol, list_1(sc, p), a_number_string));
}
}
-static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args)
+static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args)
{
- #define H_imag_part "(imag-part num) returns the imaginary part of num"
- #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
- s7_pointer p;
- /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */
+ #define H_real_part "(real-part num) returns the real part of num"
+ #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
+ return(real_part_p_p(sc, car(args)));
+}
- p = car(args);
- switch (type(p))
+
+static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer p)
+{
+ switch (type(p))
{
case T_INTEGER:
case T_RATIO:
@@ -20419,10 +20468,18 @@ static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args)
#endif
default:
- return(method_or_bust_with_type_one_arg(sc, p, sc->imag_part_symbol, args, a_number_string));
+ return(method_or_bust_with_type_one_arg(sc, p, sc->imag_part_symbol, list_1(sc, p), a_number_string));
}
}
+static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args)
+{
+ #define H_imag_part "(imag-part num) returns the imaginary part of num"
+ #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
+ /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */
+ return(imag_part_p_p(sc, car(args)));
+}
+
/* ---------------------------------------- numerator denominator ---------------------------------------- */
@@ -21609,7 +21666,7 @@ static void init_chars(void)
set_type(eof_object, T_EOF_OBJECT | T_IMMUTABLE | T_UNHEAP);
unique_name_length(eof_object) = 6;
unique_name(eof_object) = "#<eof>";
- chars++; /* now chars[EOF] == chars[-1] == eof_object */
+ chars++; /* now chars[EOF] == chars[-1] == #<eof> */
cells++;
for (i = 0; i < NUM_CHARS; i++)
@@ -21740,7 +21797,7 @@ static bool is_char_whitespace_b_7p(s7_scheme *sc, s7_pointer c)
if (has_active_methods(sc, c))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, c), sc->is_char_whitespace_symbol);
+ f = find_method_with_let(sc, c, sc->is_char_whitespace_symbol);
if (f != sc->undefined)
return(is_true(sc, s7_apply_function(sc, f, cons(sc, c, sc->nil))));
}
@@ -21842,7 +21899,7 @@ static bool is_character_via_method(s7_scheme *sc, s7_pointer p)
if (has_active_methods(sc, p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->is_char_symbol);
+ f = find_method_with_let(sc, p, sc->is_char_symbol);
if (f != sc->undefined)
return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
}
@@ -22793,7 +22850,7 @@ static void unstack_1(s7_scheme *sc, const char *func, int line)
if (((opcode_t)sc->stack_end[3]) != OP_GC_PROTECT)
{
fprintf(stderr, "%s%s[%d]: popped %s?%s\n", BOLD_TEXT, func, line, op_names[(opcode_t)sc->stack_end[3]], UNBOLD_TEXT);
- fprintf(stderr, " code: %s, args: %s\n", DISPLAY(sc->code), DISPLAY(sc->args));
+ fprintf(stderr, " code: %s, args: %s\n", display(sc->code), display(sc->args));
}
}
#else
@@ -22824,7 +22881,7 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer c
if (has_active_methods(sc, p))
{
s7_pointer func;
- func = find_method(sc, find_let(sc, p), caller);
+ func = find_method_with_let(sc, p, caller);
if (func != sc->undefined)
{
s7_pointer y;
@@ -23031,7 +23088,7 @@ static bool is_string_via_method(s7_scheme *sc, s7_pointer p)
if (has_active_methods(sc, p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->is_string_symbol);
+ f = find_method_with_let(sc, p, sc->is_string_symbol);
if (f != sc->undefined)
return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
}
@@ -23465,7 +23522,7 @@ static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
if (has_active_methods(sc, p))
{
s7_pointer func;
- func = find_method(sc, find_let(sc, p), sym);
+ func = find_method_with_let(sc, p, sym);
if (func != sc->undefined)
{
s7_pointer y;
@@ -25493,7 +25550,7 @@ s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc
static inline void push_input_port(s7_scheme *sc, s7_pointer new_port)
{
#if S7_DEBUGGING
- if (!is_input_port(new_port)) fprintf(stderr, "push %s\n", DISPLAY(new_port));
+ if (!is_input_port(new_port)) fprintf(stderr, "push %s\n", display(new_port));
#endif
if (sc->input_port_stack_loc >= sc->input_port_stack_size)
{
@@ -25589,6 +25646,13 @@ static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args)
return(chars[port_read_character(port)(sc, port)]);
}
+static s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port)
+{
+ if (!is_input_port(port))
+ return(method_or_bust_with_type_one_arg(sc, port, sc->read_char_symbol, list_1(sc, port), an_input_port_string));
+ return(chars[port_read_character(port)(sc, port)]);
+}
+
static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args)
{
s7_pointer port;
@@ -25915,7 +25979,7 @@ s7_pointer s7_read(s7_scheme *sc, s7_pointer port)
else
{
push_stack_no_let_no_code(sc, OP_BARRIER, port);
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
eval(sc, OP_READ_INTERNAL);
@@ -26757,7 +26821,7 @@ s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_
{
s7_pointer code, port, result;
TRACK(sc);
- push_stack(sc, OP_GC_PROTECT, sc->args, sc->code);
+ push_stack_direct(sc, OP_GC_PROTECT, sc->args, sc->code);
/* maybe this should just use locals? (GC protection is not the issue here),
* but this is way down in the noise -- read/eval below are 99% of the computing
*/
@@ -26921,7 +26985,7 @@ static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args)
if (!is_string(str))
return(method_or_bust(sc, str, sc->with_input_from_string_symbol, args, T_STRING, 1));
- if (cadr(args) == slot_value(global_slot(sc->read_symbol)))
+ if (cadr(args) == slot_value(global_slot(sc->read_symbol))) /* if chooser for this, make_function_with_class needs to handle unsafe functions */
{
s7_pointer old_input_port;
if (string_length(str) == 0)
@@ -27206,7 +27270,7 @@ static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer obj)
p = iterator_sequence(obj);
cur = iterator_current(obj);
set_car(sc->z2_1, sc->x);
- set_car(sc->z2_2, sc->z); /* is this necessary? */
+ set_car(sc->z2_2, sc->z); /* is this necessary? (save/restore sc->x/y across c_object iteration) */
set_car(cur, p);
set_car(cdr(cur), make_integer(sc, iterator_position(obj)));
result = (*(c_object_ref(sc, p)))(sc, cur);
@@ -27259,7 +27323,7 @@ static s7_pointer iterator_method(s7_scheme *sc, s7_pointer e)
{
s7_pointer func;
if ((has_active_methods(sc, e)) &&
- ((func = find_method(sc, find_let(sc, e), sc->make_iterator_symbol)) != sc->undefined))
+ ((func = find_method_with_let(sc, e, sc->make_iterator_symbol)) != sc->undefined))
{
s7_pointer it;
it = s7_apply_function(sc, func, list_1(sc, e));
@@ -27452,7 +27516,7 @@ in the sequence each time it is called. When it reaches the end, it returns " I
else /* (let-temporarily (((*s7* 'safety) 1)) (make-iterator "asdf" (cons 1 2))) */
{
if (sc->safety > MORE_SAFETY_WARNINGS)
- s7_warn(sc, 256, "(make-iterator %s %s) does not need the second argument\n", DISPLAY_80(seq), DISPLAY_80(carrier));
+ s7_warn(sc, 256, "(make-iterator %s %s) does not need the second argument\n", display_80(seq), display_80(carrier));
}
}
}
@@ -30454,14 +30518,14 @@ void s7_show_let(s7_scheme *sc) /* debugging convenience */
else
{
if (is_funclet(olet))
- fprintf(stderr, "(%s funclet): ", DISPLAY(funclet_function(olet)));
+ fprintf(stderr, "(%s funclet): ", display(funclet_function(olet)));
else
{
if (olet == sc->shadow_rootlet)
fprintf(stderr, "(shadow rootlet): ");
}
}
- fprintf(stderr, "%s\n", DISPLAY(olet));
+ fprintf(stderr, "%s\n", display(olet));
}
}
@@ -30484,9 +30548,9 @@ void s7_show_history(s7_scheme *sc)
int32_t i, size;
size = sc->history_size;
for (i = 0, p = cdr(sc->cur_code); i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */
- safe_print(fprintf(stderr, "%s\n", DISPLAY(car(p))));
+ safe_print(fprintf(stderr, "%s\n", display(car(p))));
#else
- fprintf(stderr, "%s\n", DISPLAY(sc->cur_code));
+ fprintf(stderr, "%s\n", display(sc->cur_code));
#endif
}
@@ -31191,7 +31255,7 @@ static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, in
fprintf(stderr, " symbol_id: %" print_s7_int ", let_id: %" print_s7_int ", bits: %s", symbol_id(sym), let_id(sc->envir), s = describe_type_bits(sc, sym));
free(s);
slot = symbol_to_local_slot(sc, sym, sc->envir);
- if (is_slot(slot)) fprintf(stderr, ", slot: %s", DISPLAY(slot));
+ if (is_slot(slot)) fprintf(stderr, ", slot: %s", display(slot));
fprintf(stderr, "\n");
if (sc->stop_at_error) abort();
}
@@ -31488,7 +31552,7 @@ static void counter_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_
#if S7_DEBUGGING
char data[256];
size_t len;
- len = snprintf(data, 256, "#<counter: %s %s %s>", DISPLAY_80(counter_list(obj)), DISPLAY_80(counter_result(obj)), DISPLAY_80(counter_let(obj)));
+ len = snprintf(data, 256, "#<counter: %s %s %s>", display_80(counter_list(obj)), display_80(counter_result(obj)), display_80(counter_let(obj)));
port_write_string(port)(sc, data, len, port);
#else
port_write_string(port)(sc, "#<counter>", 10, port);
@@ -31599,16 +31663,15 @@ static void macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_wr
static void c_function_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info *ci)
{
- if (use_write == P_READABLE)
+ s7_pointer sym;
+ sym = make_symbol(sc, c_function_name(obj));
+ if ((!is_global(sym)) &&
+ (is_slot(initial_slot(sym))) &&
+ ((use_write == P_READABLE) || (lookup(sc, sym) != slot_value(initial_slot(sym)))))
{
- s7_pointer sym;
- sym = make_symbol(sc, c_function_name(obj));
- if ((is_slot(initial_slot(sym))) && (!is_global(sym)))
- {
- port_write_string(port)(sc, "#_", 2, port);
- port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port);
- return;
- }
+ port_write_string(port)(sc, "#_", 2, port);
+ port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port);
+ return;
}
if (c_function_name_length(obj) > 0)
port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port);
@@ -32637,7 +32700,7 @@ static bool format_method(s7_scheme *sc, const char *str, format_data *fdat, s7_
obj = car(fdat->args);
if ((!has_active_methods(sc, obj)) ||
- ((func = find_method(sc, find_let(sc, obj), sc->format_symbol)) == sc->undefined))
+ ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined))
return(false);
ctrl_str[0] = '~';
@@ -34834,6 +34897,33 @@ static s7_pointer list_set_p_pip_direct(s7_scheme *sc, s7_pointer p1, s7_int i1,
return(p2);
}
+static s7_pointer list_increment_p_pip_direct(opt_info *o)
+{
+ s7_scheme *sc;
+ s7_pointer p, p1, p2;
+ s7_int i, index;
+ sc = o->sc;
+ p = slot_value(o->v[2].p);
+ index = integer(p);
+ if ((index < 0) || (index > sc->max_list_length))
+ out_of_range(sc, sc->list_set_symbol, small_int(2), p, (index < 0) ? its_negative_string : its_too_large_string);
+ p1 = slot_value(o->v[1].p);
+ for (i = 0, p = p1; ((is_pair(p)) && (i < index)); i++, p = cdr(p));
+ if (!is_pair(p))
+ {
+ if (type(p) == T_NIL)
+ out_of_range(sc, sc->list_set_symbol, small_int(2), wrap_integer1(sc, index), its_too_large_string);
+ else simple_wrong_type_argument_with_type(sc, sc->list_set_symbol, p1, a_proper_list_string);
+ }
+#if (!WITH_GMP)
+ p2 = g_add_xi(sc, car(p), integer(o->v[3].p));
+#else
+ p2 = g_add(sc, list_2(sc, car(p), make_integer(sc, integer(o->v[3].p))));
+#endif
+ set_car(p, p2);
+ return(p2);
+}
+
static s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2)
{
if (!is_pair(p1))
@@ -34869,17 +34959,11 @@ static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args)
/* -------------------------------- list-tail -------------------------------- */
-static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args)
+static s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer p)
{
- #define H_list_tail "(list-tail lst i) returns the list from the i-th element on"
- #define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */
- s7_pointer lst, p;
s7_int i, index;
-
- lst = car(args);
- p = cadr(args);
if (!s7_is_integer(p))
- return(method_or_bust(sc, p, sc->list_tail_symbol, args, T_INTEGER, 2));
+ return(method_or_bust(sc, p, sc->list_tail_symbol, list_2(sc, lst, p), T_INTEGER, 2));
index = s7_integer(p);
if (!is_list(lst))
@@ -34894,6 +34978,13 @@ static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args)
return(p);
}
+static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args)
+{
+ #define H_list_tail "(list-tail lst i) returns the list from the i-th element on"
+ #define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */
+ return(list_tail_p_pp(sc, car(args), cadr(args)));
+}
+
/* -------------------------------- cons -------------------------------- */
static s7_pointer g_cons(s7_scheme *sc, s7_pointer args)
@@ -35680,7 +35771,6 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of
for (; is_pair(x); x = cdr(x))
{
slot_set_value(b, caar(x));
- sc->pc = 0;
if (o->v[0].fb(o))
return(car(x));
}
@@ -35794,9 +35884,9 @@ static bool assoc_if(s7_scheme *sc)
return(true);
}
set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list */
- push_stack(sc, OP_ASSOC_IF, sc->args, sc->code);
+ push_stack_direct(sc, OP_ASSOC_IF, sc->args, sc->code);
}
- else push_stack(sc, OP_ASSOC_IF1, sc->args, sc->code);
+ else push_stack_direct(sc, OP_ASSOC_IF1, sc->args, sc->code);
if (!is_pair(car(opt1_fast(orig_args)))) /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */
eval_type_error(sc, "assoc: second arg is not an alist: ~S", 37, orig_args);
@@ -35915,10 +36005,10 @@ static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args)
static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops)
{
if ((is_proper_quote(sc, caddr(expr))) &&
- (is_pair(cadr(caddr(expr)))))
+ (is_pair(cadaddr(expr))))
{
s7_int len;
- len = s7_list_length(sc, cadr(caddr(expr)));
+ len = s7_list_length(sc, cadaddr(expr));
if (len > 0)
{
if (len == 2)
@@ -36152,13 +36242,11 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c
for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow))
{
slot_set_value(b, car(x));
- sc->pc = 0;
if (fp(o) != sc->F) return(x);
if (!is_pair(cdr(x))) return(sc->F);
x = cdr(x);
if (x == slow) return(sc->F);
slot_set_value(b, car(x));
- sc->pc = 0;
if (fp(o) != sc->F) return(x);
}
}
@@ -36167,13 +36255,11 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c
for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow))
{
slot_set_value(b, car(x));
- sc->pc = 0;
if (o->v[0].fb(o)) return(x);
if (!is_pair(cdr(x))) return(sc->F);
x = cdr(x);
if (x == slow) return(sc->F);
slot_set_value(b, car(x));
- sc->pc = 0;
if (o->v[0].fb(o)) return(x);
}
}
@@ -36252,9 +36338,9 @@ static bool member_if(s7_scheme *sc)
return(true);
}
set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list (check for circular list) */
- push_stack(sc, OP_MEMBER_IF, sc->args, sc->code);
+ push_stack_direct(sc, OP_MEMBER_IF, sc->args, sc->code);
}
- else push_stack(sc, OP_MEMBER_IF1, sc->args, sc->code);
+ else push_stack_direct(sc, OP_MEMBER_IF1, sc->args, sc->code);
if (needs_copied_args(sc->code))
sc->args = list_2(sc, caar(orig_args), car(opt1_fast(orig_args)));
@@ -37218,7 +37304,7 @@ static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args)
if (has_active_methods(sc, x))
{
s7_pointer func;
- func = find_method(sc, find_let(sc, x), sc->vector_append_symbol);
+ func = find_method_with_let(sc, x, sc->vector_append_symbol);
if (func != sc->undefined)
{
int32_t k;
@@ -38730,9 +38816,9 @@ static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
*/
if (dims <= 0) /* #0d(...) #2147483649D() [if dims is int32_t this is negative] */
- return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer1(sc, dims), "must be 1 or more"));
+ return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer2(sc, dims), "must be 1 or more")); /* out_of_range uses integer1 */
if (dims > sc->max_vector_dimensions)
- return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer1(sc, dims), "must be < 512")); /* sc->max_vector_dimensions=512 currently */
+ return(s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer2(sc, dims), "must be < (*s7* 'max-vector-dimensions)"));
sc->w = sc->nil;
if (is_null(data)) /* dims are already 0 (calloc above) */
@@ -39566,7 +39652,6 @@ static bool c_function_is_ok(s7_scheme *sc, s7_pointer x)
/* this is nearly always global and p == opt1_cfunc(x)
* p can be null if we evaluate some code, optimizing it, then eval it again in a context
* where the incoming p was undefined(!) -- explicit use of eval and so on.
- * I guess ideally eval would ignore optimization info -- copy :readable or something.
*/
return((p == opt1_any(x)) ||
((is_any_c_function(p)) &&
@@ -39790,7 +39875,6 @@ static int32_t opt_bool_sort(const void *v1, const void *v2, void *arg)
s7_scheme *sc = (s7_scheme *)arg;
slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); /* first slot in curlet */
slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); /* second slot in curlet */
- sc->pc = 0; /* always opt_bool_call here, so insert it */
return((sc->sort_fb(sc->sort_o)) ? -1 : 1);
}
@@ -39807,37 +39891,37 @@ static int32_t opt_bool_sort_p(const void *v1, const void *v2, void *arg)
s7_scheme *sc = (s7_scheme *)arg;
slot_set_value(sc->sort_v1, (*(s7_pointer *)v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *)v2));
- sc->pc = 0;
return((sc->opts[0]->v[O_WRAP].fp(sc->opts[0]) == sc->F) ? 1 : -1);
}
+#define SORT_O1 1
static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, void *arg)
{
s7_scheme *sc = (s7_scheme *)arg;
s7_int i;
- opt_info *o;
+ opt_info *top, *o;
slot_set_value(sc->sort_v1, (*(s7_pointer *)v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *)v2));
- sc->pc = -1;
+ top = sc->opts[0];
for (i = 0; i < sc->sort_body_len - 1; i++)
{
- o = sc->opts[++sc->pc]; /* 1..15? */
+ o = top->v[SORT_O1 + i].o1;
o->v[0].fp(o);
}
- o = sc->opts[++sc->pc];
+ o = top->v[SORT_O1 + i].o1;
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;
+ opt_info *top, *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];
+ top = sc->opts[0];
+ o = top->v[SORT_O1].o1;
o->v[0].fp(o);
- o = sc->opts[++sc->pc];
+ o = top->v[SORT_O1 + 1].o1;
return((o->v[0].fb(o)) ? -1 : 1);
}
@@ -39845,16 +39929,16 @@ 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;
+ opt_info *top, *o;
slot_set_value(sc->sort_v1, (*(s7_pointer *)v1));
slot_set_value(sc->sort_v2, (*(s7_pointer *)v2));
- sc->pc = -1;
+ top = sc->opts[0];
for (i = 0; i < sc->sort_body_len - 1; i++)
{
- o = sc->opts[++sc->pc]; /* 1..15? */
+ o = top->v[SORT_O1 + i].o1;
o->v[0].fp(o);
}
- o = sc->opts[++sc->pc];
+ o = top->v[SORT_O1 + i].o1;
return((o->v[0].fp(o) != sc->F) ? -1 : 1);
}
@@ -39882,6 +39966,13 @@ static int32_t closure_sort_begin(const void *v1, const void *v2, void *arg)
}
static s7_b_7pp_t s7_b_7pp_function(s7_pointer f);
+#if S7_DEBUGGING
+#define alloc_opo(Sc, Expr) alloc_opo_2(Sc, Expr, __func__, __LINE__)
+static opt_info *alloc_opo_2(s7_scheme *sc, s7_pointer expr, const char *func, int line);
+#else
+#define alloc_opo(Sc, Expr) alloc_opo_1(Sc)
+static opt_info *alloc_opo_1(s7_scheme *sc);
+#endif
static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
{
@@ -39982,7 +40073,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
((caadr(expr) == sc->car_symbol) || (caadr(expr) == sc->cdr_symbol)) &&
(caadr(expr) == caaddr(expr)) &&
(car(largs) == cadadr(expr)) &&
- (cadr(largs) == cadr(caddr(expr))))
+ (cadr(largs) == cadaddr(expr)))
{
lp = lookup(sc, car(expr));
sc->sort_f = s7_b_7pp_function(lp);
@@ -40015,42 +40106,55 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
sc->sort_v2 = next_slot(let_slots(sc->envir));
if (is_null(cdr(closure_body(lessp))))
{
- s7_function sf1;
- sf1 = s7_bool_optimize(sc, closure_body(lessp));
- if (sf1 == opt_bool_any)
+ if (!no_bool_opt(closure_body(lessp)))
{
- if (sc->opts[0]->v[0].fb == p_to_b)
- sort_func = opt_bool_sort_p;
- else
+ s7_function sf1;
+ sf1 = s7_bool_optimize(sc, closure_body(lessp));
+ if (sf1 == opt_bool_any)
{
- sc->sort_o = sc->opts[0];
- sc->sort_fb = sc->sort_o->v[0].fb;
- sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort;
+ if (sc->opts[0]->v[0].fb == p_to_b)
+ sort_func = opt_bool_sort_p;
+ else
+ {
+ sc->sort_o = sc->opts[0];
+ sc->sort_fb = sc->sort_o->v[0].fb;
+ sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort;
+ }
}
+ else set_no_bool_opt(closure_body(lessp));
}
}
else
{
if (setjmp(sc->opt_exit) == 0)
{
- s7_pointer p;
sc->sort_body_len = s7_list_length(sc, closure_body(lessp));
- sc->pc = 0;
- reset_opts(sc);
- for (p = closure_body(lessp); is_pair(cdr(p)); p = cdr(p))
- if (!cell_optimize(sc, p))
- break;
- if (is_null(cdr(p)))
+ if (sc->sort_body_len < 14)
{
- int32_t start;
- start = sc->pc;
- if (bool_optimize_nw(sc, p))
- sort_func = (sc->sort_body_len == 2) ? opt_begin_bool_sort_b2 : opt_begin_bool_sort_b;
- else
+ s7_pointer p;
+ int32_t ctr;
+ opt_info *top;
+ sc->pc = 0;
+ top = alloc_opo(sc, closure_body(lessp));
+ for (ctr = SORT_O1, p = closure_body(lessp); is_pair(cdr(p)); ctr++, p = cdr(p))
{
- pc_fallback(sc, start);
- if (cell_optimize(sc, p))
- sort_func = opt_begin_bool_sort_p;
+ top->v[ctr].o1 = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ break;
+ }
+ if (is_null(cdr(p)))
+ {
+ int32_t start;
+ start = sc->pc;
+ top->v[ctr].o1 = sc->opts[start];
+ if (bool_optimize_nw(sc, p))
+ sort_func = (sc->sort_body_len == 2) ? opt_begin_bool_sort_b2 : opt_begin_bool_sort_b;
+ else
+ {
+ pc_fallback(sc, start);
+ if (cell_optimize(sc, p))
+ sort_func = opt_begin_bool_sort_p;
+ }
}
}
}
@@ -40101,7 +40205,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc);
for (p = data, i = 0; i < len; i++, p = cdr(p))
set_car(p, elements[i]);
-
+ sc->v = sc->nil;
unstack(sc); /* not pop_stack! */
return(data);
}
@@ -40176,6 +40280,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
for (i = 0; i < len; i++)
chrs[i] = character(elements[i]);
}
+ sc->v = sc->nil;
unstack(sc); /* not pop_stack! */
return(data);
}
@@ -40238,7 +40343,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
for (i = 0; i < len; i++)
vector_setter(data)(sc, data, i, elements[i]); /* data is not a typed vector */
-
+ sc->v = sc->nil;
unstack(sc);
return(data);
}
@@ -40322,6 +40427,7 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
vector_element(lx, 4) = make_mutable_integer(sc, 0);
vector_element(lx, 5) = make_integer(sc, n * n);
}
+ sc->v = sc->nil;
push_stack(sc, OP_SORT, args, lx);
s7_gc_unprotect_at(sc, gc_loc);
}
@@ -40423,7 +40529,7 @@ static s7_pointer op_heapsort(s7_scheme *sc)
SORT_J = j;
if (j < n)
{
- push_stack(sc, OP_SORT1, sc->args, sc->code);
+ push_stack_direct(sc, OP_SORT1, sc->args, sc->code);
lx = SORT_LESSP; /* cadr of sc->args */
if (needs_copied_args(lx))
sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1));
@@ -40451,7 +40557,7 @@ static bool op_sort1(s7_scheme *sc)
j = j + 1;
SORT_J = j;
}
- push_stack(sc, OP_SORT2, sc->args, sc->code);
+ push_stack_direct(sc, OP_SORT2, sc->args, sc->code);
lx = SORT_LESSP;
if (needs_copied_args(lx))
sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j));
@@ -40493,7 +40599,7 @@ static bool op_sort(s7_scheme *sc)
{
SORT_K = k - 1;
SORT_K1 = k - 1;
- push_stack(sc, OP_SORT, sc->args, sc->code);
+ push_stack_direct(sc, OP_SORT, sc->args, sc->code);
return(false);
}
return(true);
@@ -40514,7 +40620,7 @@ static bool op_sort3(s7_scheme *sc)
SORT_DATA(n) = lx;
SORT_N = n - 1;
SORT_K1 = 0;
- push_stack(sc, OP_SORT3, sc->args, sc->code);
+ push_stack_direct(sc, OP_SORT3, sc->args, sc->code);
return(false);
}
@@ -40756,7 +40862,7 @@ static s7_int hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key)
args = closure_args(f);
body = closure_body(f);
new_frame_with_slot(sc, closure_let(f), sc->envir, (is_symbol(car(args))) ? car(args) : caar(args), key);
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
if (is_pair(cdr(body)))
push_stack_no_args(sc, sc->begin_op, cdr(body));
sc->code = car(body);
@@ -41223,7 +41329,7 @@ static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer ke
if (hash_entry_raw_hash(x) == hash)
{
slot_set_value(next_slot(let_slots(sc->envir)), hash_entry_key(x));
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
if (is_pair(cdr(body)))
push_stack_no_args(sc, sc->begin_op, cdr(body));
sc->code = car(body);
@@ -42612,7 +42718,7 @@ static s7_pointer g_is_macro(s7_scheme *sc, s7_pointer args)
static s7_pointer s7_macroexpand(s7_scheme *sc, s7_pointer mac, s7_pointer args)
{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->code = mac;
sc->args = copy_list_with_arglist_error(sc, args);
new_frame(sc, closure_let(sc->code), sc->envir);
@@ -43598,7 +43704,7 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args)
{
s7_pointer func;
if ((has_active_methods(sc, x)) &&
- ((func = find_method(sc, find_let(sc, x), sc->is_aritable_symbol)) != sc->undefined))
+ ((func = find_method_with_let(sc, x, sc->is_aritable_symbol)) != sc->undefined))
return(s7_apply_function(sc, func, list_2(sc, x, s7_make_integer(sc, args))) != sc->F);
return(is_safe_procedure(x));
}
@@ -44115,7 +44221,7 @@ static s7_pointer bind_symbol_with_setter(s7_scheme *sc, opcode_t op, s7_pointer
else
{
sc->args = list_2(sc, symbol, new_value);
- push_stack(sc, op, sc->args, sc->code);
+ push_stack_direct(sc, op, sc->args, sc->code);
sc->code = func;
return(sc->no_value); /* this means the setter in set! needs to goto APPLY to get the new value */
}
@@ -44388,7 +44494,7 @@ static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, share
if (has_active_methods(sc, X)) \
{ \
s7_pointer equal_func; \
- equal_func = find_method(Sc, find_let(Sc, X), Sc->is_equivalent_symbol); \
+ equal_func = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \
if (equal_func != Sc->undefined) \
return(s7_boolean(Sc, s7_apply_function(Sc, equal_func, list_2(Sc, X, Y)))); \
}} \
@@ -45961,29 +46067,20 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
{
if (is_let(dest))
{
- if (has_let_fallback(dest))
+ for (i = start; i < end; i++)
{
- for (i = start; i < end; i++)
- {
- while (!x) x = elements[++loc];
- if (!is_symbol(hash_entry_key(x)))
- return(simple_wrong_type_argument(sc, caller, hash_entry_key(x), T_SYMBOL));
- if ((hash_entry_key(x) != sc->let_ref_fallback_symbol) &&
- (hash_entry_key(x) != sc->let_set_fallback_symbol))
- make_slot_1(sc, dest, hash_entry_key(x), hash_entry_value(x));
- x = hash_entry_next(x);
- }
- }
- else
- {
- for (i = start; i < end; i++)
- {
- while (!x) x = elements[++loc];
- if (!is_symbol(hash_entry_key(x)))
- return(simple_wrong_type_argument(sc, caller, hash_entry_key(x), T_SYMBOL));
- make_slot_1(sc, dest, hash_entry_key(x), hash_entry_value(x));
- x = hash_entry_next(x);
- }
+ s7_pointer symbol;
+ while (!x) x = elements[++loc];
+ symbol = hash_entry_key(x);
+ if (!is_symbol(symbol))
+ return(simple_wrong_type_argument(sc, caller, symbol, T_SYMBOL));
+ if (is_constant_symbol(sc, symbol))
+ return(s7_error(sc, sc->wrong_type_arg_symbol,
+ set_elist_4(sc, wrap_string(sc, "~A into ~A: ~A is a constant", 28), caller, dest, symbol)));
+ if ((symbol != sc->let_ref_fallback_symbol) &&
+ (symbol != sc->let_set_fallback_symbol))
+ make_slot_1(sc, dest, symbol, hash_entry_value(x));
+ x = hash_entry_next(x);
}
}
else
@@ -48160,7 +48257,7 @@ static s7_pointer prepackaged_type_name(s7_scheme *sc, s7_pointer x)
if (has_active_methods(sc, x))
{
- p = find_method(sc, find_let(sc, x), sc->class_name_symbol);
+ p = find_method_with_let(sc, x, sc->class_name_symbol);
if (is_symbol(p))
return(symbol_name_cell(p));
}
@@ -48376,7 +48473,7 @@ s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_p
}
else
{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->args = sc->nil;
new_cell(sc, p, T_DYNAMIC_WIND);
@@ -48455,7 +48552,7 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
if (is_symbol(closure_args(proc)))
new_frame_with_slot(sc, closure_let(proc), sc->envir, closure_args(proc), sc->nil);
else new_frame(sc, closure_let(proc), sc->envir);
- push_stack_no_args(sc, sc->begin_op, T_Pair(sc->code));
+ push_stack_no_args_direct(sc, sc->begin_op, T_Pair(sc->code));
}
else push_stack(sc, OP_APPLY, sc->nil, proc);
@@ -48882,7 +48979,7 @@ static bool catch_dw_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_point
dynamic_wind_state(x) = DWIND_FINISH; /* make sure an uncaught error in the exit thunk doesn't cause us to loop */
if (dynamic_wind_out(x) != sc->F)
{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->code = dynamic_wind_out(x);
sc->args = sc->nil;
eval(sc, OP_APPLY); /* I guess this means no call/cc out of the exit thunk in an error-catching context */
@@ -49349,6 +49446,12 @@ static s7_pointer apply_error(s7_scheme *sc, s7_pointer obj, s7_pointer args)
/* the operator type is needed here else the error message is confusing:
* (apply '+ (list 1 2))) -> ;attempt to apply + to (1 2)?
*/
+#if 0
+ fprintf(stderr, "code: %s, cur_code: %s\n", display(sc->code), display(sc->cur_code));
+ fprintf(stderr, "stack code: %s, args: %s\n", display(stack_code(sc->stack, s7_stack_top(sc) - 1)), display(stack_args(sc->stack, s7_stack_top(sc) - 1)));
+ /* for op_do, args has useful info on original code
+ */
+#endif
if (is_null(obj))
return(s7_error(sc, sc->syntax_error_symbol,
set_elist_3(sc, wrap_string(sc, "attempt to apply nil to ~S in ~S?", 33),
@@ -49735,7 +49838,7 @@ static bool call_begin_hook(s7_scheme *sc)
opcode_t op;
op = sc->cur_op;
- push_stack(sc, OP_BARRIER, sc->args, sc->code);
+ push_stack_direct(sc, OP_BARRIER, sc->args, sc->code);
sc->begin_hook(sc, &result);
if (result)
{
@@ -49802,7 +49905,7 @@ static s7_pointer g_apply(s7_scheme *sc, s7_pointer args)
if (is_null(cdr(args)))
{
sc->args = sc->nil;
- push_stack(sc, OP_APPLY, sc->args, sc->code);
+ push_stack_direct(sc, OP_APPLY, sc->args, sc->code);
return(sc->nil);
}
@@ -49852,7 +49955,7 @@ s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
if (is_c_function(fnc))
return(c_function_call(fnc)(sc, args));
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->code = fnc;
sc->args = (needs_copied_args(sc->code)) ? copy_list(sc, args) : args;
eval(sc, OP_APPLY);
@@ -49954,7 +50057,7 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic
(c_function_all_args(obj) >= len))
return(c_function_call(obj)(sc, indices));
}
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->code = obj;
sc->args = (needs_copied_args(obj)) ? copy_list(sc, indices) : indices;
eval(sc, OP_APPLY);
@@ -50127,7 +50230,7 @@ s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args
sc->code = sc->z;
return(sc->value);
}
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->code = fnc;
sc->args = (needs_copied_args(sc->code)) ? copy_list(sc, args) : args;
eval(sc, OP_APPLY);
@@ -50157,7 +50260,7 @@ s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e)
}
else
{
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->code = code;
if ((e != sc->rootlet) &&
(is_let(e)))
@@ -50212,7 +50315,7 @@ pass (rootlet):\n\
if (s7_stack_top(sc) < 12)
push_stack_op(sc, OP_BARRIER);
- push_stack(sc, OP_EVAL, sc->args, sc->code);
+ push_stack_direct(sc, OP_EVAL, sc->args, sc->code);
return(sc->nil);
}
@@ -50224,7 +50327,7 @@ s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args)
set_current_code(sc, history_cons(sc, func, args));
#if SHOW_EVAL_OPS
- safe_print(fprintf(stderr, "%s: %s %s\n", __func__, DISPLAY(func), DISPLAY_80(args)));
+ safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display(func), display_80(args)));
#endif
if (is_c_function(func))
@@ -50249,7 +50352,7 @@ s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args)
if (sc->safety > NO_SAFETY)
check_list_validity(sc, "s7_call", args);
- push_stack(sc, OP_EVAL_DONE, sc->args, sc->code); /* this saves the current evaluation and will eventually finish this (possibly) nested call */
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code); /* this saves the current evaluation and will eventually finish this (possibly) nested call */
sc->code = func;
sc->args = (needs_copied_args(func)) ? copy_list(sc, args) : args;
/* besides a closure, "func" can also be an object (T_C_OBJECT) -- in Snd, a generator for example */
@@ -50425,10 +50528,10 @@ static void check_let_slots_1(s7_scheme *sc, s7_pointer e, const char* func, s7_
{
fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n",
func,
- DISPLAY(expr),
- DISPLAY(var),
- DISPLAY(sc->envir),
- (tis_slot(let_slots(e))) ? DISPLAY(let_slots(e)) : "no slots");
+ display(expr),
+ display(var),
+ display(sc->envir),
+ (tis_slot(let_slots(e))) ? display(let_slots(e)) : "no slots");
if (sc->stop_at_error) abort();
}
}
@@ -50439,10 +50542,10 @@ static void check_next_let_slot_1(s7_scheme *sc, s7_pointer e, const char* func,
{
fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n",
func,
- DISPLAY(expr),
- DISPLAY(var),
- DISPLAY(e),
- (tis_slot(next_slot(let_slots(e)))) ? DISPLAY(next_slot(let_slots(e))) : "no next slot");
+ display(expr),
+ display(var),
+ display(e),
+ (tis_slot(next_slot(let_slots(e)))) ? display(next_slot(let_slots(e))) : "no next slot");
if (sc->stop_at_error) abort();
}
}
@@ -50459,17 +50562,18 @@ static void check_next_let_slot_1(s7_scheme *sc, s7_pointer e, const char* func,
/* arg here is the full expression */
static s7_pointer fx_c(s7_scheme *sc, s7_pointer arg) {return(arg);}
-static s7_pointer fx_unspecified(s7_scheme *sc, s7_pointer arg) {return(sc->unspecified);}
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);
return(slot_value(let_slots(sc->envir)));
}
+
static s7_pointer fx_u(s7_scheme *sc, s7_pointer arg)
{
check_next_let_slot(sc, __func__, arg, arg);
@@ -50481,6 +50585,7 @@ static s7_pointer fx_T(s7_scheme *sc, s7_pointer arg)
check_outer_let_slots(sc, __func__, arg, arg);
return(slot_value(let_slots(outlet(sc->envir))));
}
+
static s7_pointer fx_U(s7_scheme *sc, s7_pointer arg)
{
check_outer_next_let_slot(sc, __func__, arg, arg);
@@ -50498,7 +50603,7 @@ static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg)
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));
+ if (is_t_integer(val)) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, display(val));
#endif
switch (type(val))
{
@@ -50601,7 +50706,7 @@ static s7_pointer fx_add_T1(s7_scheme *sc, s7_pointer arg)
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 */
+static s7_pointer fx_add_U1(s7_scheme *sc, s7_pointer arg)
{
s7_pointer x;
check_outer_next_let_slot(sc, __func__, arg, cadr(arg));
@@ -50753,12 +50858,12 @@ static s7_pointer fx_is_eq_caar_q(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_not_is_eq_car_q(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer lst, a;
- a = opt2_pair(cdr(arg));
- lst = lookup(sc, opt2_sym(a));
+ s7_pointer lst;
+ /* fprintf(stderr, "%s %s\n", __func__, display(arg)); */
+ lst = lookup(sc, opt2_sym(cdr(arg)));
if (is_pair(lst))
- return(make_boolean(sc, car(lst) != opt3_any(a)));
- return(make_boolean(sc, !s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt3_any(a))));
+ return(make_boolean(sc, car(lst) != opt3_any(cdr(arg))));
+ return(make_boolean(sc, !s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt3_any(cdr(arg)))));
}
static s7_pointer fx_is_pair_car_s(s7_scheme *sc, s7_pointer arg)
@@ -50771,7 +50876,7 @@ static s7_pointer fx_is_pair_car_s(s7_scheme *sc, s7_pointer arg)
if (has_active_methods(sc, p))
{
s7_pointer func;
- func = find_method(sc, p, sc->car_symbol);
+ func = find_method_with_let(sc, p, sc->car_symbol);
if (func != sc->undefined)
return(make_boolean(sc, is_pair(s7_apply_function(sc, func, list_1(sc, p)))));
}
@@ -50911,6 +51016,16 @@ static s7_pointer fx_is_symbol_cadr_t(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_car_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_pair(val))
+ return(make_boolean(sc, is_symbol(car(val))));
+ return(make_boolean(sc, is_symbol(g_car(sc, set_plist_1(sc, val)))));
+}
+
static s7_pointer fx_c_s(s7_scheme *sc, s7_pointer arg)
{
set_car(sc->t1_1, lookup(sc, cadr(arg)));
@@ -50950,23 +51065,17 @@ static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer 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)
+static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer 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)
+static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer arg)
{
check_let_slots(sc, __func__, arg, cadr(arg));
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(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir)))));
-}
-
static s7_pointer fx_iterate_p_p(s7_scheme *sc, s7_pointer arg)
{
s7_pointer iter;
@@ -51156,6 +51265,17 @@ static s7_pointer fx_is_symbol_t(s7_scheme *sc, s7_pointer arg)
return((is_symbol(slot_value(let_slots(sc->envir)))) ? sc->T : sc->F);
}
+static s7_pointer fx_is_eof_s(s7_scheme *sc, s7_pointer arg)
+{
+ return((lookup(sc, cadr(arg)) == eof_object) ? sc->T : sc->F);
+}
+
+static s7_pointer fx_is_eof_t(s7_scheme *sc, s7_pointer arg)
+{
+ check_let_slots(sc, __func__, arg, cadr(arg));
+ return((slot_value(let_slots(sc->envir)) == eof_object) ? sc->T : sc->F);
+}
+
static s7_pointer fx_is_type_s(s7_scheme *sc, s7_pointer arg)
{
return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(lookup(sc, cadr(arg)))));
@@ -51167,6 +51287,12 @@ static s7_pointer fx_is_type_t(s7_scheme *sc, s7_pointer arg)
return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(slot_value(let_slots(sc->envir)))));
}
+static s7_pointer fx_is_type_u(s7_scheme *sc, s7_pointer arg)
+{
+ check_next_let_slot(sc, __func__, arg, cadr(arg));
+ return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(slot_value(next_slot(let_slots(sc->envir))))));
+}
+
static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg)
{
#if WITH_GMP
@@ -51295,7 +51421,11 @@ 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_sc_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));
+}
+
static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer arg)
{
check_let_slots(sc, __func__, arg, cadr(arg));
@@ -51307,7 +51437,6 @@ 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)))));
}
-#endif
static s7_pointer fx_c_uc(s7_scheme *sc, s7_pointer arg) /* few hits */
{
@@ -51365,6 +51494,17 @@ static s7_pointer fx_c_ss(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+static s7_pointer fx_c_ss_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
+}
+
+static s7_pointer fx_c_ts_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)), lookup(sc, opt2_sym(cdr(arg)))));
+}
+
static s7_pointer fx_c_st(s7_scheme *sc, s7_pointer arg)
{
check_let_slots(sc, __func__, arg, opt2_sym(cdr(arg)));
@@ -51381,7 +51521,7 @@ static s7_pointer fx_c_gt(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer fx_c_Wt_direct(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_c_Wt_direct(s7_scheme *sc, s7_pointer arg) /* dup */
{
s7_pointer old_e, W;
old_e = sc->envir;
@@ -51419,13 +51559,6 @@ static s7_pointer fx_cons_ts(s7_scheme *sc, s7_pointer arg)
return(cons(sc, slot_value(let_slots(sc->envir)), lookup(sc, opt2_sym(cdr(arg)))));
}
-static s7_pointer fx_cons_tU(s7_scheme *sc, s7_pointer arg)
-{
- check_outer_next_let_slot(sc, __func__, arg, opt2_sym(arg));
- check_let_slots(sc, __func__, arg, cadr(arg));
- return(cons(sc, slot_value(let_slots(sc->envir)), slot_value(next_slot(let_slots(outlet(sc->envir))))));
-}
-
static s7_pointer fx_add_ss(s7_scheme *sc, s7_pointer arg)
{
return(add_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
@@ -51562,20 +51695,20 @@ static s7_pointer fx_sqr_tt(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_c_sqr_sqr(s7_scheme *sc, s7_pointer arg) /* tbig -- need t case here */
{
set_car(sc->t2_1, fx_sqr_1(sc, lookup(sc, cadr(cadr(arg)))));
- set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg)))));
+ set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadaddr(arg))));
return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer fx_c_s_sqr(s7_scheme *sc, s7_pointer arg) /* call */
{
set_car(sc->t2_1, lookup(sc, cadr(arg)));
- set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg)))));
+ set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadaddr(arg))));
return(c_call(arg)(sc, sc->t2_1));
}
static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer arg) /* fb */
{
- set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadr(caddr(arg)))));
+ set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, cadaddr(arg))));
set_car(sc->t2_1, cadr(arg));
return(c_call(arg)(sc, sc->t2_1));
}
@@ -51591,6 +51724,19 @@ static s7_pointer fx_geq_ts(s7_scheme *sc, s7_pointer arg)
return(geq_p_pp(sc, slot_value(let_slots(sc->envir)), lookup(sc, opt2_sym(cdr(arg)))));
}
+static s7_pointer fx_geq_us(s7_scheme *sc, s7_pointer arg)
+{
+ check_next_let_slot(sc, __func__, arg, cadr(arg));
+ return(geq_p_pp(sc, slot_value(next_slot(let_slots(sc->envir))), lookup(sc, opt2_sym(cdr(arg)))));
+}
+
+static s7_pointer fx_geq_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(geq_p_pp(sc, slot_value(let_slots(sc->envir)), slot_value(let_slots(outlet(sc->envir)))));
+}
+
static s7_pointer fx_geq_tu(s7_scheme *sc, s7_pointer arg)
{
check_let_slots(sc, __func__, arg, cadr(arg));
@@ -51964,6 +52110,11 @@ static s7_pointer fx_c_sss(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t3_1));
}
+static s7_pointer fx_c_sss_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_sym(cdr(arg))), lookup(sc, opt2_sym(cdr(arg)))));
+}
+
static s7_pointer fx_c_tus(s7_scheme *sc, s7_pointer arg)
{
check_let_slots(sc, __func__, arg, cadr(arg));
@@ -51982,6 +52133,11 @@ static s7_pointer fx_c_scs(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t3_1));
}
+static s7_pointer fx_c_scs_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg)), lookup(sc, opt2_sym(cdr(arg)))));
+}
+
static s7_pointer fx_c_tcs(s7_scheme *sc, s7_pointer arg)
{
check_let_slots(sc, __func__, arg, cadr(arg));
@@ -52064,9 +52220,10 @@ static s7_pointer fx_c_opdq_s(s7_scheme *sc, s7_pointer arg)
static inline void gc_protect_direct(s7_scheme *sc, s7_pointer val)
{
+ sc->stack_end[2] = val;
sc->stack_end[3] = (s7_pointer)OP_GC_PROTECT;
sc->stack_end += 4;
- sc->stack_end[-2] = val;
+ /* sc->stack_end[-2] = val; */
}
static s7_pointer fx_c_opsq(s7_scheme *sc, s7_pointer arg)
@@ -52165,10 +52322,10 @@ static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg)
if (is_pair(val))
return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(car(val))));
- if (has_active_methods(sc, val))
+ if (has_active_methods(sc, val)) /* this verbosity saves 1/3 total compute time (overhead!) */
{
s7_pointer func;
- func = find_method(sc, val, sc->car_symbol);
+ func = find_method_with_let(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))));
}
@@ -52185,7 +52342,7 @@ static s7_pointer fx_c_weak1_type_s(s7_scheme *sc, s7_pointer arg)
if (has_active_methods(sc, val))
{
s7_pointer func;
- func = find_method(sc, val, sc->c_pointer_weak1_symbol);
+ func = find_method_with_let(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))));
}
@@ -52211,10 +52368,15 @@ 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_opssq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), lookup(sc, opt1_sym(cdr(arg))))));
+}
+
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)));
+ check_next_let_slot(sc, __func__, arg, caddadr(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));
@@ -52225,8 +52387,8 @@ static s7_pointer fx_c_opstq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
largs = cadr(arg);
- set_car(sc->t2_1, lookup(sc, cadr(largs)));
check_let_slots(sc, __func__, arg, caddr(largs));
+ set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, slot_value(let_slots(sc->envir)));
set_car(sc->t1_1, c_call(largs)(sc, sc->t2_1));
return(c_call(arg)(sc, sc->t1_1));
@@ -52234,9 +52396,21 @@ 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(cdr(arg)))(sc,
- ((s7_p_pp_t)opt3_direct(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, opt3_sym(arg)), slot_value(let_slots(sc->envir)))));
+}
+
+#if (!WITH_GMP)
+static s7_pointer fx_is_zero_remainder_1(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer s, t;
+ check_let_slots(sc, __func__, arg, caddadr(arg));
+ s = lookup(sc, opt3_sym(arg));
+ t = slot_value(let_slots(sc->envir));
+ if ((is_t_integer(s)) && (is_t_integer(t)))
+ return(make_boolean(sc, c_rem_int(sc, integer(s), integer(t)) == 0));
+ return(is_zero_p_p(sc, remainder_p_pp(sc, s, t)));
}
+#endif
static s7_pointer fx_not_opssq(s7_scheme *sc, s7_pointer arg)
{
@@ -52264,7 +52438,7 @@ static s7_pointer fx_not_oputq(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_not_lt_ut(s7_scheme *sc, s7_pointer arg)
{
s7_pointer x, y;
- check_let_slots(sc, __func__, arg, caddr(cadr(arg)));
+ check_let_slots(sc, __func__, arg, caddadr(arg));
check_next_let_slot(sc, __func__, arg, cadadr(arg));
y = slot_value(next_slot(let_slots(sc->envir)));
x = slot_value(let_slots(sc->envir));
@@ -52330,40 +52504,130 @@ static s7_pointer fx_c_opssq_s(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_c_opssq_s_direct(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
- largs = cdadr(arg);
+ largs = opt3_pair(arg); /* cdadr(arg) */
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)
+#if (!WITH_GMP)
+static s7_pointer fx_add_vref_s(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, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs))),
- slot_value(let_slots(sc->envir))));
+ largs = opt3_pair(arg); /* cdadr(arg) */
+ return(add_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg))));
}
-static s7_pointer fx_vector_ref_vector_ref_gs_t(s7_scheme *sc, s7_pointer arg) /* ugh! */
+static s7_pointer fx_add_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdaddr(arg) */
+ return(add_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
+}
+
+static s7_pointer fx_subtract_vref_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdadr(arg) */
+ return(subtract_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg))));
+}
+
+static s7_pointer fx_subtract_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdaddr(arg) */
+ return(subtract_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
+}
+
+static s7_pointer fx_multiply_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdaddr(arg) */
+ return(multiply_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
+}
+
+static s7_pointer fx_add_mul_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdadr(arg) */
+ return(add_p_pp(sc, multiply_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg))));
+}
+
+static s7_pointer fx_gt_add_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdadr(arg) */
+ return(gt_p_pp(sc, add_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg))));
+}
+
+static s7_pointer fx_gt_vref_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdadr(arg) */
+ return(gt_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg))));
+}
+
+static s7_pointer fx_geq_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdaddr(arg) */
+ return(geq_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
+}
+
+static s7_pointer fx_is_eq_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdaddr(arg) */
+ return(make_boolean(sc, lookup(sc, cadr(arg)) == vector_ref_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
+}
+
+static s7_pointer fx_vref_s_add(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = opt3_pair(arg); /* cdaddr(arg) */
+ return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), add_p_pp(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
+}
+#endif
+
+static s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer v1, s7_pointer p1, s7_pointer p2)
{
- s7_pointer p1, p2, v1, v2, largs;
- p1 = slot_value(let_slots(sc->envir));
- largs = cdadr(arg);
- p2 = lookup(sc, opt2_sym(largs));
- v1 = lookup_global(sc, car(largs));
if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1)))
{
s7_int i1, i2;
i1 = integer(p1);
i2 = integer(p2);
- if ((i1 >= 0) && (i2 >= 0) && (i2 < vector_length(v1)))
+ if ((i1 >= 0) && (i2 >= 0) && (i1 < vector_length(v1)))
{
- v2 = vector_element(v1, i2);
- if ((is_normal_vector(v2)) && (vector_rank(v2) == 1) && (i1 < vector_length(v2)))
- return(vector_element(v2, i1));
+ s7_pointer v2;
+ v2 = vector_element(v1, i1);
+ if ((is_normal_vector(v2)) && (vector_rank(v2) == 1) && (i2 < vector_length(v2)))
+ return(vector_element(v2, i2));
}}
- return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p2), p1));
+ return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p1), p2));
+}
+
+static s7_pointer fx_vref_vref_ss_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = cdadr(arg);
+ return(fx_vref_vref_3(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs)), lookup(sc, caddr(arg))));
+}
+
+/* need var3 here */
+static s7_pointer fx_vref_vref_tu_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer slot;
+ check_let_slots(sc, __func__, arg, cadadr(arg));
+ check_next_let_slot(sc, __func__, arg, caddadr(arg));
+ slot = let_slots(sc->envir);
+ return(fx_vref_vref_3(sc, slot_value(slot), slot_value(next_slot(slot)), lookup(sc, caddr(arg))));
+}
+
+static s7_pointer fx_vref_vref_gs_t(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = cdadr(arg);
+ return(fx_vref_vref_3(sc, lookup_global(sc, 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)
@@ -52410,6 +52674,13 @@ static s7_pointer fx_c_opsq_s(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+static s7_pointer fx_c_opsq_s_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc,
+ ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg)))), /* cadadr(arg) */
+ lookup(sc, caddr(arg))));
+}
+
static s7_pointer fx_c_optq_s(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -52421,6 +52692,14 @@ static s7_pointer fx_c_optq_s(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+static s7_pointer fx_c_optq_s_direct(s7_scheme *sc, s7_pointer arg)
+{
+ check_let_slots(sc, __func__, arg, cadadr(arg));
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc,
+ ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir))),
+ lookup(sc, caddr(arg))));
+}
+
static s7_pointer fx_c_opuq_t(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -52442,11 +52721,18 @@ static s7_pointer fx_c_opuq_t_direct(s7_scheme *sc, s7_pointer arg)
slot_value(let_slots(sc->envir))));
}
+static s7_pointer fx_cons_opuq_t(s7_scheme *sc, s7_pointer arg)
+{
+ check_let_slots(sc, __func__, arg, caddr(arg));
+ check_next_let_slot(sc, __func__, arg, cadadr(arg));
+ return(cons(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir)))), slot_value(let_slots(sc->envir))));
+}
+
static s7_pointer fx_c_opsq_cs(s7_scheme *sc, s7_pointer arg)
{
set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg); */
set_car(sc->t3_1, c_call(cadr(arg))(sc, sc->t1_1));
- set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadr(caddr(arg)) */
+ set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadaddr(arg) */
set_car(sc->t3_3, lookup(sc, opt2_sym(cdr(arg)))); /* cadddr(arg); */
return(c_call(arg)(sc, sc->t3_1));
}
@@ -52527,23 +52813,14 @@ static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg)
static s7_pointer fx_c_s_opssq_direct(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
+ largs = opt3_pair(arg); /* cdaddr(arg) */
arg = cdr(arg);
- largs = cdadr(arg);
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)))));
}
-/* multiply_s_opssq_direct saved almost nothing */
-static s7_pointer fx_c_g_opgsq_direct(s7_scheme *sc, s7_pointer arg)
-{
- s7_pointer largs;
- arg = cdr(arg);
- largs = cdadr(arg);
- return(((s7_p_pp_t)opt2_direct(arg))(sc, lookup_global(sc, car(arg)),
- ((s7_p_pp_t)opt3_direct(arg))(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
-}
-
-static s7_pointer fx_vector_ref_g_vector_ref_gs(s7_scheme *sc, s7_pointer arg)
+#if (!WITH_GMP)
+static s7_pointer fx_vref_g_vref_gs(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
arg = cdr(arg);
@@ -52551,19 +52828,6 @@ static s7_pointer fx_vector_ref_g_vector_ref_gs(s7_scheme *sc, s7_pointer arg)
return(vector_ref_p_pp(sc, lookup_global(sc, car(arg)),
vector_ref_p_pp(sc, lookup_global(sc, car(largs)), lookup(sc, opt2_sym(largs)))));
}
-
-#if (!WITH_GMP)
-static s7_pointer fx_num_eq_add_ss(s7_scheme *sc, s7_pointer arg)
-{
- s7_pointer largs, x, y, z;
- largs = cdaddr(arg);
- x = lookup(sc, car(largs));
- y = lookup(sc, cadr(largs));
- 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(num_eq_p_pp(sc, z, add_p_pp(sc, x, y)));
-}
#endif
static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg)
@@ -52573,19 +52837,21 @@ static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg)
set_car(sc->t2_1, lookup(sc, cadr(largs)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs))));
set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1));
- set_car(sc->t2_1, cadr(arg));
+ set_car(sc->t2_1, cadr(arg)); /* currently (<safe-f> 'a <opssq>) goes to safe_c_ca so this works by inadvertence */
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer direct_c_c_opssq(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_c_c_opssq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, cadr(arg), /* see above */
+ ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), lookup(sc, opt1_sym(cdr(arg))))));
+}
+
+static s7_pointer fx_c_d_opssq_direct(s7_scheme *sc, s7_pointer arg) /* clm2xen (* 1.0 (oscil g2 x2)) */
{
- s7_pointer largs;
s7_double x2;
- arg = cdr(arg);
- largs = cdadr(arg);
- 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(arg))(sc, real_to_double(sc, car(arg), "*"), x2));
+ x2 = ((s7_d_pd_t)opt3_direct(cdr(arg)))(lookup(sc, opt3_sym(arg)), real_to_double(sc, lookup(sc, opt1_sym(cdr(arg))), "number_to_double"));
+ return(((s7_p_dd_t)opt2_direct(cdr(arg)))(sc, real_to_double(sc, cadr(arg), "*"), x2));
}
static s7_pointer fx_c_s_opscq(s7_scheme *sc, s7_pointer arg)
@@ -52599,17 +52865,31 @@ static s7_pointer fx_c_s_opscq(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer fx_c_t_opucq(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_c_s_opscq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)),
+ ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg)))));
+}
+
+static s7_pointer fx_c_s_opsiq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)),
+ ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), integer(opt1_con(cdr(arg))))));
+}
+
+static s7_pointer fx_c_t_opscq_direct(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer largs;
- largs = caddr(arg);
check_let_slots(sc, __func__, arg, cadr(arg));
- check_next_let_slot(sc, __func__, arg, cadr(largs));
- set_car(sc->t2_1, slot_value(next_slot(let_slots(sc->envir))));
- set_car(sc->t2_2, opt2_con(cdr(largs)));
- set_car(sc->t2_2, c_call(largs)(sc, sc->t2_1));
- set_car(sc->t2_1, slot_value(let_slots(sc->envir)));
- return(c_call(arg)(sc, sc->t2_1));
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir)),
+ ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg)))));
+}
+
+static s7_pointer fx_c_t_opucq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ check_let_slots(sc, __func__, arg, cadr(arg));
+ check_next_let_slot(sc, __func__, arg, opt3_sym(arg));
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, slot_value(let_slots(sc->envir)),
+ ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, slot_value(next_slot(let_slots(sc->envir))), opt1_con(cdr(arg)))));
}
static s7_pointer fx_c_s_opsq(s7_scheme *sc, s7_pointer arg)
@@ -52631,7 +52911,7 @@ static s7_pointer fx_c_s_opsq_direct(s7_scheme *sc, s7_pointer 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)));
+ check_next_let_slot(sc, __func__, arg, cadaddr(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))))));
}
@@ -52649,14 +52929,14 @@ static s7_pointer fx_c_t_car_u(s7_scheme *sc, s7_pointer arg)
{
s7_pointer val;
check_let_slots(sc, __func__, arg, cadr(arg));
- check_next_let_slot(sc, __func__, arg, cadr(caddr(arg)));
+ check_next_let_slot(sc, __func__, arg, cadaddr(arg));
val = slot_value(next_slot(let_slots(sc->envir)));
set_car(sc->t2_2, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val)));
set_car(sc->t2_1, slot_value(let_slots(sc->envir)));
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer fx_add_s_car_s(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_add_s_car_s(s7_scheme *sc, s7_pointer arg) /* tshoot prime? */
{
s7_pointer val1, val2;
val2 = lookup(sc, opt2_sym(cdr(arg)));
@@ -52682,7 +52962,7 @@ static s7_pointer fx_add_u_car_t(s7_scheme *sc, s7_pointer arg)
}
#endif
-static s7_pointer fx_c_op_s_opsq_q(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_c_op_s_opsqq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer outer, args;
outer = cadr(arg);
@@ -52694,7 +52974,18 @@ static s7_pointer fx_c_op_s_opsq_q(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t1_1));
}
-static s7_pointer fx_c_op_opsq_s_q(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_not_op_s_opsqq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer outer, args;
+ outer = cadr(arg);
+ args = caddr(outer);
+ set_car(sc->t1_1, lookup(sc, cadr(args)));
+ set_car(sc->t2_2, c_call(args)(sc, sc->t1_1));
+ set_car(sc->t2_1, lookup(sc, cadr(outer)));
+ return(((c_call(outer)(sc, sc->t2_1)) == sc->F) ? sc->T : sc->F);
+}
+
+static s7_pointer fx_c_op_opsq_sq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer outer, args;
outer = cadr(arg);
@@ -52706,6 +52997,19 @@ static s7_pointer fx_c_op_opsq_s_q(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t1_1));
}
+static s7_pointer fx_c_op_opsq_cq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer outer, args;
+ outer = cadr(arg);
+ args = cadr(outer);
+ /* fprintf(stderr, "%s %s: outer %s, args %s\n", __func__, display(arg), display(outer), display(args)); */
+ set_car(sc->t1_1, lookup(sc, cadr(args)));
+ set_car(sc->t2_1, c_call(args)(sc, sc->t1_1));
+ set_car(sc->t2_2, opt2_con(cdr(outer))); /* caddr(outer)); */ /* opt2_any(...) */
+ set_car(sc->t1_1, c_call(outer)(sc, sc->t2_1));
+ return(c_call(arg)(sc, sc->t1_1));
+}
+
static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -52716,16 +53020,6 @@ 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_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(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)
{
s7_pointer largs;
@@ -52743,6 +53037,15 @@ static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+static s7_pointer fx_c_opsq_opsq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs;
+ largs = cdr(arg);
+ return(((s7_p_pp_t)opt3_direct(arg))(sc,
+ ((s7_p_p_t)opt2_direct(largs))(sc, lookup(sc, cadar(largs))),
+ ((s7_p_p_t)opt3_direct(largs))(sc, lookup(sc, cadadr(largs)))));
+}
+
static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer arg)
{
s7_pointer largs;
@@ -52807,7 +53110,54 @@ static s7_pointer fx_c_opssq_opssq(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer fx_c_op_opssq_q_c(s7_scheme *sc, s7_pointer code)
+#if (!WITH_GMP)
+static s7_pointer fx_sub_mul2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer a1;
+ a1 = cdaddr(arg);
+ sc->u = multiply_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1)));
+ a1 = cdadr(arg);
+ return(subtract_p_pp(sc, multiply_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->u));
+}
+
+static s7_pointer fx_add_mul2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer a1;
+ a1 = cdaddr(arg);
+ sc->u = multiply_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1)));
+ a1 = cdadr(arg);
+ return(add_p_pp(sc, multiply_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->u));
+}
+
+static s7_pointer fx_lt_sub2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer a1;
+ a1 = cdaddr(arg);
+ sc->u = subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1)));
+ a1 = cdadr(arg);
+ return(lt_p_pp(sc, subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->u));
+}
+
+static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p1, p2, v1, a1;
+ a1 = cdadr(arg);
+ v1 = lookup(sc, car(a1));
+ p1 = lookup(sc, cadr(a1));
+ p2 = lookup(sc, caddaddr(arg));
+ if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1)))
+ {
+ s7_int i1, i2;
+ i1 = integer(p1);
+ i2 = integer(p2);
+ if ((i1 >= 0) && (i1 <= vector_length(v1)) && (i2 >= 0) && (i2 < vector_length(v1)))
+ return(subtract_p_pp(sc, vector_ref_p_pi(sc, v1, i1), vector_ref_p_pi(sc, v1, i2)));
+ }
+ return(subtract_p_pp(sc, vector_ref_p_pp(sc, v1, p1), vector_ref_p_pp(sc, v1, p2)));
+}
+#endif
+
+static s7_pointer fx_c_op_opssqq_c(s7_scheme *sc, s7_pointer code)
{
s7_pointer arg;
arg = cadadr(code);
@@ -52819,7 +53169,7 @@ static s7_pointer fx_c_op_opssq_q_c(s7_scheme *sc, s7_pointer code)
return(c_call(code)(sc, sc->t2_1));
}
-static s7_pointer fx_c_op_opsq_q(s7_scheme *sc, s7_pointer code)
+static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer code)
{
s7_pointer arg;
arg = cadadr(code);
@@ -52884,7 +53234,7 @@ static s7_pointer fx_c_s_op_s_opssqq_direct(s7_scheme *sc, s7_pointer code)
((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)
+static s7_pointer fx_c_op_opsqq_c(s7_scheme *sc, s7_pointer code)
{
s7_pointer arg;
arg = cadadr(code);
@@ -53034,6 +53384,13 @@ static s7_pointer fx_c_sa(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
+#if 0
+static s7_pointer fx_c_sa(s7_scheme *sc, s7_pointer arg)
+{
+ /* a -> direct as well? why isn't this already happening? */
+}
+#endif
+
static s7_pointer fx_c_as(s7_scheme *sc, s7_pointer arg)
{
s7_pointer a1;
@@ -53076,7 +53433,7 @@ static s7_pointer fx_multiply_sa(s7_scheme *sc, s7_pointer arg)
}
#endif
-static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer arg) /* tbig */
{
s7_pointer a1, a2;
a1 = cdr(arg);
@@ -53158,7 +53515,6 @@ static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg)
set_car(sc->t2_2, fx_call(sc, cddr(p)));
set_car(sc->t2_1, sc->stack_end[-2]);
sc->stack_end -= 4;
-
set_car(sc->t1_1, c_call(p)(sc, sc->t2_1));
return(c_call(arg)(sc, sc->t1_1));
}
@@ -53291,7 +53647,7 @@ static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer arg)
return(c_call(arg)(sc, sc->t2_1));
}
-static s7_pointer fx_c_op_opssq_q_s(s7_scheme *sc, s7_pointer code)
+static s7_pointer fx_c_op_opssqq_s(s7_scheme *sc, s7_pointer code)
{
s7_pointer arg;
arg = opt1_pair(cdr(code));
@@ -53303,7 +53659,7 @@ 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)
+static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme *sc, s7_pointer code)
{
s7_pointer arg;
arg = opt1_pair(cdr(code));
@@ -53320,7 +53676,7 @@ static s7_pointer fx_c_op_opssq_sq_s(s7_scheme *sc, s7_pointer code)
set_car(sc->t2_1, lookup(sc, cadr(arg)));
set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg))));
set_car(sc->t2_1, c_call(arg)(sc, sc->t2_1));
- set_car(sc->t2_2, lookup(sc, caddr(cadr(code))));
+ set_car(sc->t2_2, lookup(sc, caddadr(code)));
set_car(sc->t2_1, c_call(cadr(code))(sc, sc->t2_1));
set_car(sc->t2_2, lookup(sc, caddr(code)));
return(c_call(code)(sc, sc->t2_1));
@@ -53419,6 +53775,21 @@ static s7_pointer fx_if_a_aa(s7_scheme *sc, s7_pointer arg)
return(fx_call(sc, opt2_pair(arg)));
}
+static s7_pointer fx_if_s_aa(s7_scheme *sc, s7_pointer arg)
+{
+ if (lookup(sc, cadr(arg)) != sc->F)
+ return(fx_call(sc, opt1_pair(arg)));
+ return(fx_call(sc, opt2_pair(arg)));
+}
+
+static s7_pointer fx_if_and2_sa(s7_scheme *sc, s7_pointer arg)
+{
+ /* fprintf(stderr, "%s, opt1: %s, opt2: %s\n", display(arg), display(opt1_pair(arg)), display(opt2_pair(arg))); */
+ if ((fx_call(sc, opt1_pair(arg)) == sc->F) || (fx_call(sc, opt2_pair(arg)) == sc->F))
+ return(fx_call(sc, cdddr(arg)));
+ return(lookup(sc, opt3_sym(arg)));
+}
+
static s7_pointer fx_if_not_a_aa(s7_scheme *sc, s7_pointer arg)
{
if (is_false(sc, fx_call(sc, opt1_pair(arg))))
@@ -53446,6 +53817,56 @@ static inline s7_pointer fx_and_s_2(s7_scheme *sc, s7_pointer arg)
return(c_call(caddr(arg))(sc, sc->t1_1));
}
+#if (!WITH_GMP)
+static s7_pointer fx_and_or_2_vref(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer or1, arg11, v, ip, jp, xp, arg12;
+ or1 = cadr(arg);
+ arg11 = cadr(or1);
+ v = lookup(sc, cadadr(arg11));
+ if ((is_normal_vector(v)) && (vector_rank(v) == 1))
+ {
+ arg12 = caddr(or1);
+ ip = lookup(sc, caddadr(arg11));
+ jp = lookup(sc, caddaddr(arg12));
+ if ((is_t_integer(ip)) && (is_t_integer(jp)))
+ {
+ s7_int i, j;
+ i = integer(ip);
+ j = integer(jp);
+ if ((i >= 0) && (j >= 0) &&
+ (i < vector_length(v)) && (j < vector_length(v)) &&
+ (is_t_real(vector_element(v, i))) && (is_t_real(vector_element(v, j))))
+ {
+ xp = lookup(sc, caddr(arg11));
+ if (is_t_real(xp))
+ {
+ s7_double xf, vi, vj;
+ vi = real(vector_element(v, i));
+ vj = real(vector_element(v, j));
+ xf = real(xp);
+ return(make_boolean(sc, ((vi > xf) || (xf >= vj)) && ((vj > xf) || (xf >= vi))));
+ }}}}
+ return(fx_and_2(sc, arg));
+}
+#endif
+
+static s7_pointer fx_len2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val;
+ check_let_slots(sc, __func__, arg, cadadr(arg));
+ val = slot_value(let_slots(sc->envir));
+ return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_null(cddr(val)))));
+}
+
+static s7_pointer fx_len3(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val;
+ check_let_slots(sc, __func__, arg, cadadr(arg));
+ val = slot_value(let_slots(sc->envir));
+ return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_pair(cddr(val)))));
+}
+
static s7_pointer fx_and_3(s7_scheme *sc, s7_pointer arg)
{
s7_pointer p, val;
@@ -53496,13 +53917,20 @@ static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg)
return(make_boolean(sc, (type(x) == integer(opt3_any(arg))) || (type(x) == integer(opt2_any(cdr(arg))))));
}
+static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val;
+ val = lookup(sc, opt3_sym(arg));
+ return(make_boolean(sc, (!is_symbol(val)) || (is_keyword(val))));
+}
+
static s7_pointer fx_or_and_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 = cdadr(p);
+ p = opt3_pair(arg); /* cdadr(p); */
val = fx_call(sc, p);
if (val == sc->F) return(val);
return(fx_call(sc, cdr(p)));
@@ -53514,7 +53942,7 @@ static s7_pointer fx_or_and_3(s7_scheme *sc, s7_pointer arg)
p = cdr(arg);
val = fx_call(sc, p);
if (val != sc->F) return(val);
- p = cdadr(p);
+ p = opt3_pair(arg); /* cdadr(p); */
val = fx_call(sc, p);
if (val == sc->F) return(val);
p = cdr(p);
@@ -53583,8 +54011,6 @@ static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code)
return(result);
}
-static s7_pointer fx_safe_closure_id_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, opt2_sym(arg)));}
-
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)));
@@ -53598,51 +54024,11 @@ static s7_pointer fx_safe_closure_s_to_sc(s7_scheme *sc, s7_pointer arg)
return(c_call(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1));
}
-static s7_pointer fx_c_closure_s_a(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer clo_arg;
- clo_arg = cadr(arg);
- 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)));
- 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_safe_closure_s_d(s7_scheme *sc, s7_pointer code)
-{
- 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)));
- 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_safe_closure_t_d(s7_scheme *sc, s7_pointer code)
-{
- s7_pointer result;
- check_let_slots(sc, __func__, code, opt2_sym(code));
- gc_protect_direct(sc, sc->envir);
- sc->envir = old_frame_with_slot(sc, closure_let(opt1_lambda(code)), slot_value(let_slots(sc->envir)));
- 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 clo_arg;
- clo_arg = cadr(arg);
- 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)));
- 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));
+ set_car(sc->t2_1, fx_call(sc, cdr(arg)));
+ set_car(sc->t2_2, opt3_any(cdr(arg)));
+ return(c_call(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1));
}
static s7_pointer fx_and_2_closure_s(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2 */
@@ -53696,6 +54082,17 @@ static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code)
return(result);
}
+static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer result;
+ gc_protect_direct(sc, sc->envir);
+ sc->envir = old_frame_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code)));
+ 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)
{
@@ -53727,189 +54124,8 @@ static inline s7_pointer fx_cond_fx_fx(s7_scheme *sc, s7_pointer code) /* all t
return(sc->unspecified);
}
-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);
-static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_case_la(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_if_a_t_and_a_a_l3a(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_let_unless_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_let_cond(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg);
-
-static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme *sc, s7_pointer arg);
-static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer arg);
-
-static s7_pointer fx_opif_a_ssq_a(s7_scheme *sc, s7_pointer code);
-
static s7_function fx_function[NUM_OPS];
-static void fx_function_init(void)
-{
- int32_t i;
- for (i = 0; i < NUM_OPS; i++)
- fx_function[i] = NULL;
-
- fx_function[HOP_SAFE_C_D] = fx_c_d;
-
- fx_function[HOP_SAFE_C_S] = fx_c_s;
- fx_function[HOP_SAFE_C_opDq] = fx_c_opdq;
- fx_function[HOP_SAFE_C_opSq] = fx_c_opsq;
- fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq;
- fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq;
- fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq;
-
- fx_function[HOP_SAFE_C_SC] = fx_c_sc;
- fx_function[HOP_SAFE_C_CS] = fx_c_cs;
- fx_function[HOP_SAFE_C_CQ] = fx_c_cq;
- fx_function[HOP_SAFE_C_SS] = fx_c_ss;
-
- fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s;
- fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c;
- fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs;
- fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq;
- fx_function[HOP_SAFE_C_S_opDq] = fx_c_s_opdq;
- fx_function[HOP_SAFE_C_opDq_S] = fx_c_opdq_s;
- fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq;
- fx_function[HOP_SAFE_C_C_opDq] = fx_c_c_opdq;
- fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c;
- fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s;
- fx_function[HOP_SAFE_C_C_opCSq] = fx_c_c_opcsq;
- fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq;
- fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c;
- fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c;
- fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s;
- fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq;
- fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq;
- fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq;
- fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq;
- fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq;
- fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq;
- fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq;
- fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq;
- fx_function[HOP_SAFE_C_op_opSSq_q_C] = fx_c_op_opssq_q_c;
- fx_function[HOP_SAFE_C_op_opSq_q] = fx_c_op_opsq_q;
- fx_function[HOP_SAFE_C_op_opSq_q_C] = fx_c_op_opsq_q_c;
- fx_function[HOP_SAFE_C_op_S_opSq_q] = fx_c_op_s_opsq_q;
- fx_function[HOP_SAFE_C_op_opSq_S_q] = fx_c_op_opsq_s_q;
- fx_function[HOP_SAFE_C_S_op_S_opSqq] = fx_c_s_op_s_opsqq;
- fx_function[HOP_SAFE_C_S_op_S_opSSqq] = fx_c_s_op_s_opssqq;
- fx_function[HOP_SAFE_C_S_op_opSq_Cq] = fx_c_s_op_opsq_cq;
- fx_function[HOP_SAFE_C_op_opSSq_q_S] = fx_c_op_opssq_q_s;
- fx_function[HOP_SAFE_C_op_opSSq_Sq_S] = fx_c_op_opssq_sq_s;
- fx_function[HOP_SAFE_C_S_op_opSSq_opSSqq] = fx_c_s_op_opssq_opssqq;
-
- 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;
- fx_function[HOP_SAFE_C_SCC] = fx_c_scc;
- fx_function[HOP_SAFE_C_CSS] = fx_c_css;
- fx_function[HOP_SAFE_C_CSC] = fx_c_csc;
- fx_function[HOP_SAFE_C_CCS] = fx_c_ccs;
- fx_function[HOP_SAFE_C_ALL_S] = fx_c_all_s;
-
- fx_function[HOP_SAFE_C_A] = fx_c_a;
- fx_function[HOP_SAFE_C_AA] = fx_c_aa;
- fx_function[HOP_SAFE_C_CA] = fx_c_ca;
- fx_function[HOP_SAFE_C_AC] = fx_c_ac;
- fx_function[HOP_SAFE_C_AAA] = fx_c_aaa;
- fx_function[HOP_SAFE_C_CAC] = fx_c_cac;
- fx_function[HOP_SAFE_C_CSA] = fx_c_csa;
- 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[HOP_SAFE_C_ALL_CA] = fx_c_all_ca;
- fx_function[HOP_SAFE_C_FX] = fx_c_fx;
- fx_function[HOP_SAFE_C_4A] = fx_c_4a;
- fx_function[HOP_SAFE_C_opAq] = fx_c_opaq;
- fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq;
- fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq;
- fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s;
- fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq;
- fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq;
- fx_function[HOP_SAFE_C_S_opAAAq] = fx_c_s_opaaaq;
-
- fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a;
- fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a;
- 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_SSA_DIRECT] = fx_c_ssa_direct;
- fx_function[OP_HASH_INCREMENT] = fx_hash_increment;
-
- fx_function[HOP_SAFE_CLOSURE_ID_S] = fx_safe_closure_id_s;
-
- fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s;
- fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc;
-
- fx_function[OP_COND_FX_FX] = fx_cond_fx_fx;
- fx_function[OP_opIF_A_SSq_A] = fx_opif_a_ssq_a;
- fx_function[OP_IF_A_CC] = fx_if_a_cc;
- fx_function[OP_IF_A_A] = fx_if_a_a;
- fx_function[OP_IF_A_AA] = fx_if_a_aa;
- fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a;
- fx_function[OP_IF_NOT_A_AA] = fx_if_not_a_aa;
- fx_function[OP_OR_2] = fx_or_2;
- fx_function[OP_OR_S_2] = fx_or_s_2;
- fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2;
- fx_function[OP_OR_3] = fx_or_3;
- fx_function[OP_OR_N] = fx_or_n;
- fx_function[OP_AND_2] = fx_and_2;
- fx_function[OP_AND_S_2] = fx_and_s_2;
- fx_function[OP_AND_3] = fx_and_3;
- fx_function[OP_AND_N] = fx_and_n;
-
- fx_function[OP_SYM] = fx_unsafe_s; /* these 4 probably never happen */
- fx_function[OP_GLOBAL_SYM] = fx_g;
- fx_function[OP_CON] = fx_c;
- fx_function[OP_UNSPECIFIED] = fx_unspecified;
-
- 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;
- fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la;
- fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa;
- fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa;
- fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la;
- fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z;
- fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa;
- fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z;
- fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la;
- fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z;
- fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa;
- fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z;
- fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa;
- fx_function[OP_TC_CASE_LA] = fx_tc_case_la;
- fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a;
- fx_function[OP_TC_IF_A_T_AND_A_A_L3A] = fx_tc_if_a_t_and_a_a_l3a;
- fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa;
- fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa;
- fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa;
- fx_function[OP_TC_LET_COND] = fx_tc_let_cond;
- fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa;
-
- fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq;
- fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a;
- fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = fx_recur_if_a_a_and_a_laa_laa;
- fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = fx_recur_cond_a_a_a_a_opla_laq;
-}
-
static bool is_fxable(s7_scheme *sc, s7_pointer p)
{
if (!is_pair(p)) return(true);
@@ -53940,12 +54156,16 @@ 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_p_dd_t s7_p_dd_function(s7_pointer f);
+static s7_p_pi_t s7_p_pi_function(s7_pointer f);
+
+#define is_global_and_has_func(P, Func) ((is_global(P)) && (Func(slot_value(global_slot(P)))))
static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, safe_sym_t *checker)
{
s7_pointer arg;
arg = car(holder);
- /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, DISPLAY(arg), op_names[optimize_op(arg)]); */
+ /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(arg), op_names[optimize_op(arg)]); */
if (!is_pair(arg))
{
@@ -53956,7 +54176,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
(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));
+ 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);
@@ -53978,10 +54198,39 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
return(fx_c_d);
case OP_OR_2:
- if (c_callee(cddr(arg)) == fx_and_2) return(fx_or_and_2);
- if (c_callee(cddr(arg)) == fx_and_3) return(fx_or_and_3);
+ if (c_callee(cddr(arg)) == fx_and_2) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_2);}
+ if (c_callee(cddr(arg)) == fx_and_3) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_3);}
+ if ((c_callee(cdr(arg)) == fx_not_is_symbol_s) && (c_callee(cddr(arg)) == fx_is_keyword_s) && (cadr(cadadr(arg)) == cadaddr(arg)))
+ {
+ /* (or (not (symbol? body)) (keyword? body)) */
+ set_opt3_sym(arg, cadaddr(arg));
+ return(fx_not_symbol_or_keyword);
+ }
return(fx_or_2);
-
+
+#if (!WITH_GMP)
+ case OP_AND_2:
+ if ((c_callee(cdr(arg)) == fx_or_2) && (c_callee(cddr(arg)) == fx_or_2))
+ {
+ s7_pointer o1, o2, i, j, v, x;
+ o1 = cadr(arg);
+ o2 = caddr(arg);
+ if ((c_callee(cdr(o1)) == fx_gt_vref_s) && (c_callee(cddr(o1)) == fx_geq_s_vref) && (c_callee(cdr(o2)) == fx_gt_vref_s) && (c_callee(cddr(o2)) == fx_geq_s_vref))
+ {
+ v = cadr(cadadr(o1));
+ if ((v == cadr(cadadr(o2))) && (v == (cadr(caddaddr(o1)))) && (v == (cadr(caddaddr(o2)))))
+ {
+ x = caddadr(o1);
+ if ((x == caddadr(o2)) && (x == cadr(caddr(o1))) && (x == cadr(caddr(o2))))
+ {
+ i = caddr(cadadr(o1));
+ j = caddaddr(caddr(o1));
+ if ((j == caddr(cadadr(o2))) && (i == caddaddr(caddr(o2))))
+ return(fx_and_or_2_vref);
+ }}}}
+ return(fx_and_2);
+#endif
+
case HOP_SAFE_C_S:
if (car(arg) == sc->cdr_symbol) return(fx_cdr_s);
if (car(arg) == sc->car_symbol) return(fx_car_s);
@@ -53992,6 +54241,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
if (car(arg) == sc->is_null_symbol) return(fx_is_null_s);
if (car(arg) == sc->is_pair_symbol) return(fx_is_pair_s);
if (car(arg) == sc->is_symbol_symbol) return(fx_is_symbol_s);
+ if (car(arg) == sc->is_eof_object_symbol) return(fx_is_eof_s);
if (car(arg) == sc->is_integer_symbol) return(fx_is_integer_s);
if (car(arg) == sc->is_string_symbol) return(fx_is_string_s);
if (car(arg) == sc->not_symbol) return(fx_not_s);
@@ -54007,7 +54257,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
return(fx_is_type_s);
}
}
- if (symbol_id(car(arg)) == 0)
+ if ((symbol_id(car(arg)) == 0) && (is_slot(global_slot(car(arg)))))
{
/* car_p_p (et al) does not look for a method so in:
* (define kar car) (load "mockery.scm") (let ((p (mock-pair '(1 2 3)))) (call-with-exit (lambda (x) (x (kar p)))))
@@ -54019,11 +54269,8 @@ 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_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);
+ return((f == iterate_p_p) ? fx_iterate_p_p : fx_c_s_direct);
}
}
}
@@ -54047,22 +54294,51 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
if ((c_callee(arg) == g_hash_table_ref_2) && (is_symbol(car(arg))) && (is_symbol(cadr(arg))))
return(fx_hash_table_ref_ss);
+
+ if (is_global_and_has_func(car(arg), s7_p_pp_function))
+ {
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
+ return(fx_c_ss_direct);
+ }
return(fx_c_ss);
+
+ case HOP_SAFE_C_opSq_S:
+ if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
+ (is_global_and_has_func(caadr(arg), s7_p_p_function)))
+ {
+ set_opt1_sym(cdr(arg), cadadr(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(caadr(arg))))));
+ return(fx_c_opsq_s_direct);
+ }
+ return(fx_c_opsq_s);
-#if (!WITH_GMP)
case HOP_SAFE_C_SSS:
+#if (!WITH_GMP)
if ((c_callee(arg) == g_less) && (is_global(cadr(arg))) && (is_global(cadddr(arg)))) return(fx_lt_gsg);
- return(fx_c_sss);
#endif
+ if (is_global_and_has_func(car(arg), s7_p_ppp_function))
+ {
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(slot_value(global_slot(car(arg))))));
+ return(fx_c_sss_direct);
+ }
+ return(fx_c_sss);
case HOP_SAFE_C_SSA:
- if (s7_p_ppp_function(slot_value(global_slot(car(arg)))))
+ if (is_global_and_has_func(car(arg), s7_p_ppp_function))
{
- 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_SCS:
+ if (is_global_and_has_func(car(arg), s7_p_ppp_function))
+ {
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(slot_value(global_slot(car(arg))))));
+ return(fx_c_scs_direct);
+ }
+ return(fx_c_scs);
case HOP_SAFE_C_AAA:
if ((c_callee(cdr(arg)) == fx_g) && (c_callee(cdddr(arg)) == fx_c)) return(fx_c_gac);
@@ -54086,41 +54362,45 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
s2 = caddr(arg);
if ((car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2)))
return(fx_c_s_sqr);
-
- if ((car(arg) == sc->num_eq_symbol) && (car(s2) == sc->add_symbol))
- return(fx_num_eq_add_ss);
}
#endif
- if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
- (s7_p_pp_function(slot_value(global_slot(caaddr(arg))))))
+ if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
+ (is_global_and_has_func(caaddr(arg), s7_p_pp_function)))
{
- 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))))));
- /* tbig: (* wr (vector-ref|float-vector-ref|int-vector-ref|hash-table-ref|let-ref rl j))
- * (+ ii (* pw mmax))
- * b: (vref s (vref...)) (-|+ s (* s s))
- */
- if ((is_global(cadr(arg))) && (is_global(cadr(caddr(arg)))))
- {
- if ((opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) &&
- (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp))
- return(fx_vector_ref_g_vector_ref_gs);
- return(fx_c_g_opgsq_direct);
- }
- /* if (opt2_direct(cdr(arg)) == (s7_pointer)multiply_p_pp) return(fx_multiply_s_opssq_direct); */ /* very small gain */
+ set_opt3_pair(arg, cdaddr(arg));
+#if (!WITH_GMP)
+ if ((is_global(cadr(arg))) && (is_global(cadaddr(arg))) &&
+ (opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp))
+ return(fx_vref_g_vref_gs);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)add_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_add_s_vref);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)subtract_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_subtract_s_vref);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)multiply_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_multiply_s_vref);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)geq_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_geq_s_vref);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)is_eq_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_is_eq_s_vref);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)add_p_pp)) return(fx_vref_s_add);
+#endif
return(fx_c_s_opssq_direct);
}
return(fx_c_s_opssq);
-
+
case HOP_SAFE_C_opSSq_S:
- if ((s7_p_pp_function(slot_value(global_slot(car(arg))))) &&
- (s7_p_pp_function(slot_value(global_slot(caadr(arg))))))
+ if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
+ (is_global_and_has_func(caadr(arg), s7_p_pp_function)))
{
/* op_c_opgsq_t */
- 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))))));
+ set_opt3_pair(arg, cdadr(arg));
+#if (!WITH_GMP)
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)add_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_add_vref_s);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)add_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)multiply_p_pp)) return(fx_add_mul_s);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)gt_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)add_p_pp)) return(fx_gt_add_s);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)subtract_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_subtract_vref_s);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)gt_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_gt_vref_s);
+ if ((opt2_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp) && (opt3_direct(cdr(arg)) == (s7_pointer)vector_ref_p_pp)) return(fx_vref_vref_ss_s);
+#endif
return(fx_c_opssq_s_direct);
}
return(fx_c_opssq_s);
@@ -54131,9 +54411,14 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
s7_pointer s1, s2;
s1 = cadr(arg);
s2 = caddr(arg);
- if ((car(s1) == sc->multiply_symbol) && (cadr(s1) == caddr(s1)) &&
- (car(s2) == sc->multiply_symbol) && (cadr(s2) == caddr(s2)))
- return(fx_c_sqr_sqr);
+ if ((car(s1) == sc->multiply_symbol) && (car(s2) == sc->multiply_symbol))
+ {
+ if ((cadr(s1) == caddr(s1)) && (cadr(s2) == caddr(s2))) return(fx_c_sqr_sqr);
+ if (car(arg) == sc->subtract_symbol) return(fx_sub_mul2);
+ if (car(arg) == sc->add_symbol) return(fx_add_mul2);
+ }
+ if ((car(arg) == sc->lt_symbol) && (car(s1) == sc->subtract_symbol) && (car(s2) == sc->subtract_symbol)) return(fx_lt_sub2);
+ if ((car(arg) == sc->subtract_symbol) && (car(s1) == sc->vector_ref_symbol) && (car(s2) == sc->vector_ref_symbol) && (cadr(s1) == cadr(s2))) return(fx_sub_vref2);
return(fx_c_opssq_opssq);
}
#endif
@@ -54260,6 +54545,16 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
#endif
if ((c_callee(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2);
if ((c_callee(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc);
+
+#if (!WITH_GMP)
+ if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && (c_callee(arg) != g_divide_by_2))
+#else
+ if (is_global_and_has_func(car(arg), s7_p_pp_function))
+#endif
+ {
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
+ return(fx_c_sc_direct);
+ }
return(fx_c_sc);
case HOP_SAFE_C_CS:
@@ -54279,19 +54574,18 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
{
if (car(arg) == sc->hash_table_ref_symbol)
{
- set_opt2_sym(cdr(arg), cadr(caddr(arg)));
+ set_opt2_sym(cdr(arg), cadaddr(arg));
return(fx_hash_table_ref_car);
}
- set_opt2_sym(cdr(arg), cadr(caddr(arg)));
+ set_opt2_sym(cdr(arg), cadaddr(arg));
if (car(arg) == sc->add_symbol)
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))))))
+ if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
+ (is_global_and_has_func(caaddr(arg), s7_p_p_function)))
{
- 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);
@@ -54302,7 +54596,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
if ((car(arg) == sc->memq_symbol) &&
(car(cadr(arg)) == sc->car_symbol) &&
(is_proper_quote(sc, caddr(arg))) &&
- (is_pair(cadr(caddr(arg)))))
+ (is_pair(cadaddr(arg))))
{
if (s7_list_length(sc, opt2_con(cdr(arg))) == 2)
return(fx_memq_car_s_2);
@@ -54315,7 +54609,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
(is_proper_quote(sc, caddr(arg))))
{
set_opt3_sym(cdr(arg), cadadr(arg));
- set_opt2_con(cdr(arg), cadr(caddr(arg)));
+ set_opt2_con(cdr(arg), cadaddr(arg));
return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_q : fx_is_eq_caar_q);
}
}
@@ -54337,24 +54631,58 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
if (c_callee(cadr(arg)) == g_is_eq)
{
set_opt2_sym(cdr(arg), cadr(cadr(arg)));
- set_opt3_any(cdr(arg), (is_pair(caddr(cadr(arg)))) ? cadr(caddr(cadr(arg))) : caddr(cadr(arg)));
+ set_opt3_any(cdr(arg), (is_pair(caddadr(arg))) ? cadaddr(cadr(arg)) : caddadr(arg));
return(fx_not_is_eq_sq);
}
return(fx_c_opscq);
}
return(fx_c_opscq);
-
+
+ case HOP_SAFE_C_S_opSCq:
+ if (is_global_and_has_func(car(arg), s7_p_pp_function))
+ {
+ s7_pointer arg2;
+ arg2 = caddr(arg);
+ if ((is_global_and_has_func(car(arg2), s7_p_pi_function)) &&
+ (is_t_integer(caddr(arg2))))
+ {
+ 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_pi_function(slot_value(global_slot(car(arg2))))));
+ set_opt3_sym(arg, cadr(arg2));
+ set_opt1_con(cdr(arg), caddr(arg2));
+ return(fx_c_s_opsiq_direct);
+ }
+ if (is_global_and_has_func(car(arg2), s7_p_pp_function))
+ {
+ 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(car(arg2))))));
+ set_opt3_sym(arg, cadr(arg2));
+ set_opt1_con(cdr(arg), (is_pair(caddr(arg2))) ? cadr(caddr(arg2)) : caddr(arg2));
+ return(fx_c_s_opscq_direct);
+ }
+ }
+ return(fx_c_s_opscq);
+
case HOP_SAFE_C_opSSq:
if (car(arg) == sc->not_symbol)
{
if (c_callee(cadr(arg)) == g_is_eq)
{
set_opt2_sym(cdr(arg), cadr(cadr(arg)));
- set_opt3_sym(cdr(arg), caddr(cadr(arg)));
+ set_opt3_sym(cdr(arg), caddadr(arg));
return(fx_not_is_eq_ss);
}
return(fx_not_opssq);
}
+ if ((is_global_and_has_func(car(arg), s7_p_p_function)) &&
+ (is_global_and_has_func(caadr(arg), s7_p_pp_function)))
+ {
+ set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(slot_value(global_slot(car(arg))))));
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caadr(arg))))));
+ set_opt3_sym(arg, cadadr(arg));
+ set_opt1_sym(cdr(arg), caddadr(arg));
+ return(fx_c_opssq_direct);
+ }
return(fx_c_opssq);
case HOP_SAFE_C_C_opSSq:
@@ -54366,32 +54694,61 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
return(fx_c_c_sqr);
}
#endif
- if (has_direct_opt(arg)) return(direct_c_c_opssq);
+ if ((is_real(cadr(arg))) &&
+ (is_global_and_has_func(car(arg), s7_p_dd_function)) &&
+ (is_global_and_has_func(caaddr(arg), s7_d_pd_function)))
+ {
+ set_opt3_direct(cdr(arg), s7_d_pd_function(slot_value(global_slot(caaddr(arg)))));
+ set_opt2_direct(cdr(arg), s7_p_dd_function(slot_value(global_slot(car(arg)))));
+ set_opt3_sym(arg, cadaddr(arg));
+ set_opt1_sym(cdr(arg), caddaddr(arg));
+ return(fx_c_d_opssq_direct);
+ }
+ if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
+ (is_global_and_has_func(caaddr(arg), s7_p_pp_function)))
+ {
+ set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(arg))))));
+ set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(arg))))));
+ set_opt3_sym(arg, cadaddr(arg));
+ set_opt1_sym(cdr(arg), caddaddr(arg));
+ return(fx_c_c_opssq_direct);
+ }
return(fx_c_c_opssq);
case HOP_SAFE_C_opSq_opSq:
- if (has_direct_opt(arg)) return(direct_c_opsq_opsq);
+ if ((is_global_and_has_func(car(arg), s7_p_pp_function)) &&
+ (is_global_and_has_func(caadr(arg), s7_p_p_function)) &&
+ (is_global_and_has_func(caaddr(arg), s7_p_p_function)))
+ {
+ 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_p_function(slot_value(global_slot(caaddr(arg))))));
+ return(fx_c_opsq_opsq_direct);
+ }
return(fx_c_opsq_opsq);
+
+ case HOP_SAFE_C_op_S_opSqq:
+ if (car(arg) == sc->not_symbol) return(fx_not_op_s_opsqq);
+ return(fx_c_op_s_opsqq);
- case HOP_SAFE_C_op_opSq_q:
- if ((car(arg) == sc->not_symbol) && /* (not (eq? (car s) 's)) */
+ case HOP_SAFE_C_op_opSq_Cq:
+ if ((car(arg) == sc->not_symbol) && /* (not (eq? (car s) 's)) */
(c_callee(cadr(arg)) == g_is_eq) &&
(c_callee(cadadr(arg)) == g_car) &&
(is_symbol(cadr(cadadr(arg)))) &&
- (is_proper_quote(sc, caddr(cadr(arg)))))
+ (is_proper_quote(sc, caddadr(arg))))
{
set_opt2_sym(cdr(arg), cadr(cadr(cadr(arg))));
- set_opt3_any(cdr(arg), cadr(caddr(cadr(arg))));
+ set_opt3_any(cdr(arg), cadaddr(cadr(arg)));
return(fx_not_is_eq_car_q);
}
- return(fx_c_op_opsq_q);
+ return(fx_c_op_opsq_cq);
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)))))));
@@ -54399,31 +54756,29 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
}
return(fx_c_s_op_s_opssqq);
- case HOP_SAFE_C_op_opSSq_q_S:
+ case HOP_SAFE_C_op_opSSqq_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_opssqq_s_direct);
}
- return(fx_c_op_opssq_q_s);
+ return(fx_c_op_opssqq_s);
- case HOP_SAFE_C_op_opSq_q_C:
- if ((c_callee(arg) == g_string_ref) && (integer(caddr(arg)) == 0) && (c_callee(cadr(arg)) == g_symbol_to_string_uncopied))
+ case HOP_SAFE_C_op_opSqq_C:
+ if ((c_callee(arg) == g_string_ref) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0) &&
+ (c_callee(cadr(arg)) == g_symbol_to_string_uncopied))
{
set_opt3_any(arg, cadadr(arg));
return(fx_string_ref_0_symbol_a);
}
- return(fx_c_op_opsq_q_c);
+ return(fx_c_op_opsqq_c);
case HOP_SAFE_C_A:
if (car(arg) == sc->not_symbol) return(fx_not_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:
@@ -54455,19 +54810,15 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
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_and_pair_closure_s); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */
+ return(fx_and_2_closure_s);
}
-
- if (is_h_safe_c_d(body))
- return(fx_safe_closure_s_d);
-
if (optimize_op(body) == HOP_SAFE_C_opSq_C)
{
if ((c_callee(body) == g_lint_let_ref) &&
(cadadr(body) == car(closure_args(opt1_lambda(arg)))))
{
- set_opt2_sym(cdr(arg), cadr(caddr(body)));
+ set_opt2_sym(cdr(arg), cadaddr(body));
return(fx_lint_let_ref); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */
}
}
@@ -54476,7 +54827,7 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
}
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)); */
+ /* 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)]);
}
} /* is_optimized */
@@ -54488,16 +54839,18 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer e, saf
return(NULL);
}
-#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);
}
+#define WITH_FX_TREE 0
+#if WITH_FX_TREE
+static const char *fx_name(s7_scheme *sc, s7_pointer p);
+static bool fx_tu_name(s7_scheme *sc, s7_pointer p);
+#endif
+
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;
@@ -54507,9 +54860,8 @@ 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))
{
- if (s7_p_pp_function(slot_value(global_slot(car(p)))))
+ if (s7_p_pp_function(slot_value(global_slot(car(p))))) /* dup (vector-ref unique j), envir=out(out(envir)) then lookup "unique" */
{
- 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));
}
@@ -54521,7 +54873,7 @@ 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\n", __func__, __LINE__, DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree), DISPLAY(tree)); */
+ /* fprintf(stderr, "%s[%d] %s %s %d: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", has_fx(tree), display(tree)); */
p = car(tree);
if (is_symbol(p))
{
@@ -54544,71 +54896,55 @@ static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_poin
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) 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)))
+ else
{
- if (caddr(p) == var1)
+ if (cadr(p) == var2)
{
-#if (!WITH_GMP)
- 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_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 (caddr(p) == var2)
+ else
{
- if (c_callee(tree) == fx_c_ts) return(with_c_call(tree, fx_c_tU));
+ if (is_pair(cddr(p)))
+ {
+ if (caddr(p) == var1)
+ {
#if (!WITH_GMP)
- if (c_callee(tree) == fx_lt_ts) return(with_c_call(tree, fx_lt_tU));
+ 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));
+ if (c_callee(tree) == fx_geq_ts) return(with_c_call(tree, fx_geq_tT));
#endif
- if (c_callee(tree) == fx_cons_ts) return(with_c_call(tree, fx_cons_tU));
- }
- }
+ }
+ else
+ {
+ if (caddr(p) == var2)
+ {
+ if (c_callee(tree) == fx_c_ts) return(with_c_call(tree, fx_c_tU));
+ if (c_callee(tree) == fx_c_ts_direct) return(with_c_call(tree, fx_c_tU));
+#if (!WITH_GMP)
+ if (c_callee(tree) == fx_lt_ts) return(with_c_call(tree, fx_lt_tU));
+#endif
+ }}}}}
}
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_normal_symbol(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 %s, fx: %d\n", __func__, __LINE__, DISPLAY(tree), DISPLAY(var1), (var2) ? DISPLAY(var2) : "", has_fx(tree)); */
- /* 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)); */
+ /* fprintf(stderr, "%s[%d] %s %s %s, fx: %d\n", __func__, __LINE__, display(tree), display(var1), (var2) ? display(var2) : "", has_fx(tree)); */
+ /* 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) : "");
+ 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))
{
@@ -54625,8 +54961,9 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
if (cadr(p) == var1)
{
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_s_direct) return(with_c_call(tree, fx_c_t_direct));
if (c_callee(tree) == fx_c_ss) return(with_c_call(tree, fx_c_ts));
+ if (c_callee(tree) == fx_c_ss_direct) return(with_c_call(tree, fx_c_ts_direct));
if (c_callee(tree) == fx_c_scs) return(with_c_call(tree, fx_c_tcs));
#if (!WITH_GMP)
@@ -54634,9 +54971,8 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
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)
+ if ((c_callee(tree) == fx_c_sc) || (c_callee(tree) == fx_c_sc_direct))
{
- 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) return(with_c_call(tree, fx_lt_tf));
@@ -54645,16 +54981,14 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
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))))))
+#endif
+ if (c_callee(tree) == fx_c_sc_direct)
{
- 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);
+ return(with_c_call(tree, fx_vector_ref_direct));
+ return(with_c_call(tree, fx_c_tc_direct));
}
-#endif
- return(true); /* fx_c_tc as default above */
+ return(with_c_call(tree, fx_c_tc));
}
if (c_callee(tree) == fx_car_s) return(with_c_call(tree, fx_car_t));
@@ -54664,6 +54998,7 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
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_eof_s) return(with_c_call(tree, fx_is_eof_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));
@@ -54675,10 +55010,13 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
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 ((c_callee(tree) == fx_c_s_opscq) && (cadr(caddr(p)) == var2)) return(with_c_call(tree, fx_c_t_opucq));
+ if ((c_callee(tree) == fx_c_s_opsq_direct) && (cadaddr(p) == var2)) return(with_c_call(tree, fx_c_t_opuq_direct));
+ if (c_callee(tree) == fx_c_s_opscq_direct)
+ {
+ if (cadaddr(p) == var2) return(with_c_call(tree, fx_c_t_opucq_direct));
+ return(with_c_call(tree, fx_c_t_opscq_direct));
+ }
#if (!WITH_GMP)
if (c_callee(tree) == fx_num_eq_ss)
{
@@ -54694,20 +55032,17 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
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_safe_optimize_op(p, OP_SAFE_C_TUS); return(with_c_call(tree, fx_c_tus));}
- }
- else
- {
- 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_c_sss) || (c_callee(tree) == fx_c_sss_direct)) {set_safe_optimize_op(p, OP_SAFE_C_TUS); return(with_c_call(tree, fx_c_tus));}
}
+ 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) 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));
if (c_callee(tree) == fx_sqr_ss) return(with_c_call(tree, fx_sqr_tt));
#endif
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 ((c_callee(tree) == fx_c_s_car_s) && (cadaddr(p) == var2)) return(with_c_call(tree, fx_c_t_car_u));
if (c_callee(tree) == fx_lint_let_ref) return(with_c_call(tree, fx_lint_let_ref_t));
}
else
@@ -54716,22 +55051,23 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
{
if (c_callee(tree) == fx_c_s)
{
- if ((is_global(car(p))) && (s7_p_p_function(slot_value(global_slot(car(p))))))
+ if (is_global_and_has_func(car(p), s7_p_p_function))
{
- 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));
}
- if (c_callee(tree) == fx_o_p_p_s) return(with_c_call(tree, fx_o_p_p_u));
+ if (c_callee(tree) == fx_c_s_direct) return(with_c_call(tree, fx_c_u_direct));
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 (c_callee(tree) == fx_is_type_s) return(with_c_call(tree, fx_is_type_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));
+ if ((c_callee(tree) == fx_add_s_car_s) && (cadaddr(p) == var1)) return(with_c_call(tree, fx_add_u_car_t));
+ if (c_callee(tree) == fx_geq_ss) return(with_c_call(tree, fx_geq_us));
#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));
@@ -54745,23 +55081,23 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
{
if (c_callee(tree) == fx_c_opssq)
{
- if (caddr(cadr(p)) == var1)
+ if (caddadr(p) == var1) return(with_c_call(tree, fx_c_opstq));
+ if ((cadr(cadr(p)) == var1) && (caddadr(p) == var2)) return(with_c_call(tree, fx_c_optuq));
+ }
+ if (c_callee(tree) == fx_c_opssq_direct)
+ {
+ if (caddadr(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 (!WITH_GMP)
+ if ((opt2_direct(cdr(p)) == (s7_pointer)is_zero_p_p) && (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pp))
+ return(with_c_call(tree, fx_is_zero_remainder_1));
+#endif
+ return(with_c_call(tree, fx_c_opstq_direct)); /* oputq never happens */
}
- 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 ((c_callee(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) return(with_c_call(tree, fx_c_opstq_c));
+ if ((c_callee(tree) == fx_vref_vref_ss_s) && (cadadr(p) == var1) && (caddadr(p) == var2)) return(with_c_call(tree, fx_vref_vref_tu_s));
+
if (is_pair(cdadr(p)))
{
if (cadadr(p) == var1)
@@ -54770,11 +55106,9 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
{
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))))))
+ if ((is_global_and_has_func(car(p), s7_p_pp_function)) &&
+ (is_global_and_has_func(caadr(p), s7_p_p_function)))
{
- 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))))));
@@ -54795,20 +55129,18 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
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_is_type_car_s)
+ return(with_c_call(tree, (car(p) == sc->is_symbol_symbol) ? fx_is_symbol_car_t : 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))))))
+ if ((is_global_and_has_func(car(p), s7_p_p_function)) &&
+ (is_global_and_has_func(caadr(p), s7_p_p_function)))
{
- 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);
+ return(with_c_call(tree, fx_c_optq_direct));
}
- else set_c_call(tree, fx_c_optq);
- return(true);
+ return(with_c_call(tree, fx_c_optq));
}
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));
@@ -54816,14 +55148,35 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
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 (c_callee(tree) == fx_c_opsq_s)
+ {
+ if ((is_global_and_has_func(car(p), s7_p_pp_function)) &&
+ (is_global_and_has_func(caadr(p), s7_p_p_function)))
+ {
+ set_opt2_direct(cdr(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))))));
+ return(with_c_call(tree, fx_c_optq_s_direct));
+ }
+ return(with_c_call(tree, fx_c_optq_s));
+ }
+ if (c_callee(tree) == fx_c_opsq_s_direct) return(with_c_call(tree, fx_c_optq_s_direct));
+ if (c_callee(tree) == fx_and_3)
+ {
+ if ((c_callee(cdr(p)) == fx_is_pair_t) && (c_callee(cddr(p)) == fx_is_pair_cdr_t))
+ {
+ if (c_callee(cdddr(p)) == fx_is_null_cddr_t)
+ return(with_c_call(tree, fx_len2));
+ if (c_callee(cdddr(p)) == fx_is_pair_cddr_t)
+ return(with_c_call(tree, fx_len3));
+ }
+ }
}
if (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(tree) == fx_not_opssq) && (caddadr(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);
@@ -54831,17 +55184,17 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
#endif
if ((c_callee(tree) == fx_c_opsq_s) && (caddr(p) == var1))
{
- 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))))))
+ if ((is_global_and_has_func(car(p), s7_p_pp_function)) &&
+ (is_global_and_has_func(caadr(p), s7_p_p_function))) /* (memq (car sequence) items) lint */
{
- set_direct_opt(p);
set_opt2_direct(cdr(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_opuq_t_direct);
+ return(with_c_call(tree, (car(p) == sc->cons_symbol) ? fx_cons_opuq_t : fx_c_opuq_t_direct));
}
- else return(with_c_call(tree, fx_c_opuq_t));
+ return(with_c_call(tree, fx_c_opuq_t));
}
+ if ((c_callee(tree) == fx_c_opsq_s_direct) && (caddr(p) == var1))
+ return(with_c_call(tree, (car(p) == sc->cons_symbol) ? fx_cons_opuq_t : fx_c_opuq_t_direct));
if (c_callee(tree) == fx_c_car_s) return(with_c_call(tree, fx_c_car_u));
}
#if (!WITH_GMP)
@@ -54859,9 +55212,8 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
{
if (c_callee(tree) == fx_c_cs)
{
- if ((is_global(car(p))) && (s7_p_pp_function(slot_value(global_slot(car(p))))))
+ if (is_global_and_has_func(car(p), s7_p_pp_function))
{
- 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))))));
@@ -54871,26 +55223,19 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point
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_c_ss_direct) {/* fprintf(stderr, "gt/st\n"); */ 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)))))
- {
- if ((opt2_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) &&
- (opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp))
- return(with_c_call(tree, fx_vector_ref_vector_ref_gs_t));
- return(with_c_call(tree, fx_c_opgsq_t_direct));
- }
+ if ((c_callee(tree) == fx_vref_vref_ss_s) && (is_global(cadr(cadr(p))))) return(with_c_call(tree, fx_vref_vref_gs_t));
}
if (is_pair(caddr(p)))
{
- if ((c_callee(tree) == fx_c_opsq_opssq) && (cadr(caddr(p)) == var1) && (caddr(caddr(p)) == var2))
+ if ((c_callee(tree) == fx_c_opsq_opssq) && (cadaddr(p) == var1) && (caddaddr(p) == var2))
{
- if ((is_global(car(p))) && (is_global(caadr(p))) && (is_global(caaddr(p))) &&
- (s7_p_pp_function(slot_value(global_slot(car(p))))) &&
- (s7_p_p_function(slot_value(global_slot(caadr(p))))) &&
- (s7_p_pp_function(slot_value(global_slot(caaddr(p))))))
+ if ((is_global_and_has_func(car(p), s7_p_pp_function)) &&
+ (is_global_and_has_func(caadr(p), s7_p_p_function)) &&
+ (is_global_and_has_func(caaddr(p), s7_p_pp_function)))
{
- set_direct_opt(p);
set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(slot_value(global_slot(car(p))))));
set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(slot_value(global_slot(caadr(p))))));
set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(slot_value(global_slot(caaddr(p))))));
@@ -54914,9 +55259,9 @@ static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer
#if 0
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",
+ display_80(tree), (is_optimized(tree)) ? op_names[optimize_op(tree)] : "unopt",
has_fx(tree), /* (has_fx(tree)) ? fx_name(sc, tree) : "", */
- DISPLAY(var1), (var2) ? DISPLAY(var2) : "");
+ display(var1), (var2) ? display(var2) : "");
#endif
if ((!is_pair(tree)) ||
((is_symbol(car(tree))) &&
@@ -54930,7 +55275,7 @@ static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer
static void fx_tree_outer(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2)
{
- /* if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, DISPLAY_80(tree), has_fx(tree), DISPLAY(var1), (var2) ? DISPLAY(var2) : ""); */
+ /* if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display_80(tree), has_fx(tree), display(var1), (var2) ? display(var2) : ""); */
if ((!is_pair(tree)) ||
((is_symbol(car(tree))) &&
(is_definer_or_binder(car(tree)))))
@@ -54995,7 +55340,7 @@ static void add_opt_func(s7_pointer f, opt_func_t typ, void *func)
#if S7_DEBUGGING
else
{
- fprintf(stderr, "%s[%d]: 'f' is not a c_function\n", __func__, __LINE__);
+ fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, s7_object_to_c_string(cur_sc, f));
if (cur_sc->stop_at_error) abort();
}
#endif
@@ -55010,9 +55355,6 @@ static void *opt_func(s7_pointer f, opt_func_t typ)
if (p->typ == typ)
return(p->func);
}
-#if S7_DEBUGGING
- else fprintf(stderr, "%s[%d]: 'f' is not a c_function\n", __func__, __LINE__);
-#endif
return(NULL);
}
@@ -55370,10 +55712,8 @@ static bool oo_set_type_4_1(opt_info *p, int slot1, int slot2, int slot3, int sl
}
#if S7_DEBUGGING
-#define alloc_opo(Sc, Expr) alloc_opo_2(Sc, Expr, __func__, __LINE__)
static opt_info *alloc_opo_2(s7_scheme *sc, s7_pointer expr, const char *func, int line)
#else
-#define alloc_opo(Sc, Expr) alloc_opo_1(Sc)
static opt_info *alloc_opo_1(s7_scheme *sc)
#endif
{
@@ -55381,7 +55721,7 @@ static opt_info *alloc_opo_1(s7_scheme *sc)
if (sc->pc >= OPTS_SIZE)
{
#if S7_DEBUGGING
- fprintf(stderr, "opts overflow: %s (pc: %d)\n", DISPLAY(expr), sc->pc);
+ fprintf(stderr, "opts overflow: %s (pc: %d)\n", display(expr), sc->pc);
#endif
longjmp(sc->opt_exit, 1);
}
@@ -55395,7 +55735,7 @@ static opt_info *alloc_opo_1(s7_scheme *sc)
o = sc->opts[sc->pc++];
o->v[O_WRAP].fd = NULL; /* see bool_optimize -- this is a kludge */
#if S7_DEBUGGING
- o->vexpr = expr;
+ o->expr = expr;
o->func = func;
o->line = line;
#endif
@@ -55410,7 +55750,7 @@ static opt_info *alloc_opo_1(s7_scheme *sc)
static bool return_false(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line)
{
if (expr)
- fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT, func, line, UNBOLD_TEXT, DISPLAY_80(expr));
+ fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT, func, line, UNBOLD_TEXT, display_80(expr));
else fprintf(stderr, " %s%s[%d]%s: false\n", BOLD_TEXT, func, line, UNBOLD_TEXT);
return(false);
}
@@ -55484,55 +55824,19 @@ static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sy
return(NULL);
}
-static s7_double opt_float_any(s7_scheme *sc, s7_pointer expr)
-{
- /* caller for s7_float_optimize */
- sc->pc = 0;
- return(sc->opts[0]->v[0].fd(sc->opts[0]));
-}
-
-static s7_pointer opt_bool_any(s7_scheme *sc, s7_pointer expr)
-{
- /* caller for s7_bool_optimize */
- sc->pc = 0;
- return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);
-}
-
-static s7_pointer opt_float_any_nr(s7_scheme *sc, s7_pointer expr)
-{
- sc->pc = 0;
- sc->opts[0]->v[0].fd(sc->opts[0]);
- return(NULL);
-}
-
-static s7_pointer opt_int_any_nr(s7_scheme *sc, s7_pointer expr)
-{
- sc->pc = 0;
- sc->opts[0]->v[0].fi(sc->opts[0]);
- return(NULL);
-}
-
-static s7_pointer opt_cell_any_nr(s7_scheme *sc, s7_pointer expr)
-{
- sc->pc = 0;
- return(sc->opts[0]->v[0].fp(sc->opts[0])); /* faster than returning NULL */
-}
-
-static s7_pointer opt_bool_any_nr(s7_scheme *sc, s7_pointer expr)
-{
- sc->pc = 0;
- sc->opts[0]->v[0].fb(sc->opts[0]);
- return(NULL);
-}
-
+static s7_double opt_float_any(s7_scheme *sc, s7_pointer expr) {return(sc->opts[0]->v[0].fd(sc->opts[0]));}
+static s7_pointer opt_bool_any(s7_scheme *sc, s7_pointer expr) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);}
+static s7_pointer opt_float_any_nr(s7_scheme *sc, s7_pointer expr) {sc->opts[0]->v[0].fd(sc->opts[0]); return(NULL);}
+static s7_pointer opt_int_any_nr(s7_scheme *sc, s7_pointer expr) {sc->opts[0]->v[0].fi(sc->opts[0]); return(NULL);}
+static s7_pointer opt_cell_any_nr(s7_scheme *sc, s7_pointer expr) {return(sc->opts[0]->v[0].fp(sc->opts[0]));}
+static s7_pointer opt_bool_any_nr(s7_scheme *sc, s7_pointer expr) {sc->opts[0]->v[0].fb(sc->opts[0]); return(NULL);}
/* callers for s7_optimize */
-static s7_pointer opt_wrap_float(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return(make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0])));}
-static s7_pointer opt_wrap_int(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return(make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0])));}
-static s7_pointer opt_wrap_cell(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return( sc->opts[0]->v[0].fp(sc->opts[0]));}
-static s7_pointer opt_wrap_bool(s7_scheme *sc, s7_pointer expr) {sc->pc = 0; return(( sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);}
+static s7_pointer opt_wrap_float(s7_scheme *sc, s7_pointer expr) {return(make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0])));}
+static s7_pointer opt_wrap_int(s7_scheme *sc, s7_pointer expr) {return(make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0])));}
+static s7_pointer opt_wrap_cell(s7_scheme *sc, s7_pointer expr) {return(sc->opts[0]->v[0].fp(sc->opts[0]));}
+static s7_pointer opt_wrap_bool(s7_scheme *sc, s7_pointer expr) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);}
-/* static s7_pointer b_to_p(opt_info *o) {return((o->v[O_WRAP].fb(o)) ? o->sc->T : o->sc->F);} */
static bool p_to_b(opt_info *o) {return(o->v[O_WRAP].fp(o) != o->sc->F);}
static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, o->v[O_WRAP].fd(o)));}
static s7_pointer d_to_p_nr(opt_info *o) {o->v[O_WRAP].fd(o); return(NULL);}
@@ -55578,10 +55882,10 @@ static s7_int opt_i_7i_s(opt_info *o) {return(o->v[2].i_7i_f(o->sc, integer(slot
static s7_int opt_i_d_c(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[1].x));}
static s7_int opt_i_d_s(opt_info *o) {return(o->v[2].i_7d_f(o->sc, real(slot_value(o->v[1].p))));}
-static s7_int opt_i_i_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_i_f(o->v[4].fi(o->v[3].o1)));}
-static s7_int opt_i_7i_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_7i_f(o->sc, o->v[4].fi(o->v[3].o1)));}
-static s7_int opt_i_7d_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_7d_f(o->sc, o->v[4].fd(o->v[3].o1)));}
-static s7_int opt_i_7p_f(opt_info *o) {o->sc->pc++; return(o->v[2].i_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
+static s7_int opt_i_i_f(opt_info *o) {return(o->v[2].i_i_f(o->v[4].fi(o->v[3].o1)));}
+static s7_int opt_i_7i_f(opt_info *o) {return(o->v[2].i_7i_f(o->sc, o->v[4].fi(o->v[3].o1)));}
+static s7_int opt_i_7d_f(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[4].fd(o->v[3].o1)));}
+static s7_int opt_i_7p_f(opt_info *o) {return(o->v[2].i_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -55669,7 +55973,7 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
static s7_int opt_i_7pi_ss(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
static s7_int ivref_7pi_ss(opt_info *o) {return(int_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
-static s7_int opt_i_7pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_7pi_sf(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -55737,23 +56041,21 @@ static s7_int opt_i_ii_sc_sub(opt_info *o) {return(integer(slot_value(o->v[1].p)
static s7_int opt_i_ii_ss(opt_info *o) {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) {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) {return(make_integer(o->sc, integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p))));}
-static s7_int opt_i_ii_cf(opt_info *o) {o->sc->pc++; return(o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1)));}
-static s7_int opt_i_ii_sf(opt_info *o) {o->sc->pc++; return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));}
-static s7_int opt_i_ii_sf_add(opt_info *o) {o->sc->pc++; return(integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1));}
+static s7_int opt_i_ii_cf(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_ii_sf(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_ii_sf_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1));}
static s7_int opt_i_ii_ff(opt_info *o)
{
s7_int i1, i2;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
return(o->v[3].i_ii_f(i1, i2));
}
-static s7_int opt_i_ii_fc(opt_info *o) {o->sc->pc++; return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));}
-static s7_int opt_i_ii_fc_add(opt_info *o) {o->sc->pc++; return(o->v[11].fi(o->v[10].o1) + o->v[2].i);}
-static s7_int opt_i_7ii_fc(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, o->v[11].fi(o->v[10].o1), o->v[2].i));}
+static s7_int opt_i_ii_fc(opt_info *o) {return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));}
+static s7_int opt_i_ii_fc_add(opt_info *o) {return(o->v[11].fi(o->v[10].o1) + o->v[2].i);}
+static s7_int opt_i_7ii_fc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[11].fi(o->v[10].o1), o->v[2].i));}
static s7_int opt_i_ii_fco(opt_info *o) {return(o->v[3].i_ii_f(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));}
static s7_int opt_i_ii_fco_add(opt_info *o){return(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))) + o->v[5].i);}
static s7_int opt_i_7ii_fco(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));}
@@ -55783,23 +56085,21 @@ static bool i_ii_fc_combinable(s7_scheme *sc, opt_info *opc, s7_i_ii_t func)
static s7_int opt_i_7ii_cc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[2].i));}
static s7_int opt_i_7ii_cs(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, integer(slot_value(o->v[2].p))));}
-static s7_int opt_i_7ii_sc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));}
+static s7_int opt_i_7ii_sc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));} /* currently unhittable I think */
static s7_int opt_i_7ii_ss(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
-static s7_int opt_i_7ii_cf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[5].fi(o->v[4].o1)));}
-static s7_int opt_i_7ii_sf(opt_info *o) {o->sc->pc++; return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_7ii_cf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_7ii_sf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));}
static s7_int opt_i_7ii_ff(opt_info *o)
{
s7_int i1, i2;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
return(o->v[3].i_7ii_f(o->sc, i1, i2));
}
#if (!WITH_GMP)
-static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc->default_rng)));}
+static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc->default_rng)));}
static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc->default_rng)) - o->v[2].i);}
#endif
@@ -56046,11 +56346,8 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
static s7_int opt_i_iii_fff(opt_info *o)
{
s7_int i1, i2, i3;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
- o->sc->pc++;
i3 = o->v[5].fi(o->v[4].o1);
return(o->v[3].i_iii_f(i1, i2, i3));
}
@@ -56088,7 +56385,6 @@ static bool i_iii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- i_7pii -------- */
static s7_int opt_i_7pii_ssf(opt_info *o)
{
- o->sc->pc++;
return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1)));
}
@@ -56105,9 +56401,7 @@ static s7_int opt_i_7pii_sss(opt_info *o)
static s7_int opt_i_7pii_sff(opt_info *o)
{
s7_int i1, i2;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2));
}
@@ -56116,7 +56410,6 @@ static s7_int opt_i_7pii_sff(opt_info *o)
/* -------- i_7piii -------- */
static s7_int opt_i_7piii_sssf(opt_info *o)
{
- o->sc->pc++;
return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fi(o->v[10].o1)));
}
@@ -56133,17 +56426,15 @@ static s7_int opt_i_7piii_ssss(opt_info *o)
static s7_int opt_i_7piii_sfff(opt_info *o)
{
s7_int i1, i2, i3;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
- o->sc->pc++;
- i3 = o->v[5].fi(o->v[4].o1);
+ i3 = o->v[6].fi(o->v[4].o1);
return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), i1, i2, i3));
}
static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, opt_type_t otype, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp)
{
+ /* opc->v[5] is the called function (int-vector-set! etc) */
s7_pointer slot;
slot = opt_integer_symbol(sc, car(indexp2));
if (slot)
@@ -56188,7 +56479,7 @@ static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, opt_type_t otype, s7_
opc->v[0].fi = opt_i_7piii_sfff;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
opc->v[9].fi = opc->v[8].o1->v[0].fi;
- opc->v[5].fi = opc->v[4].o1->v[0].fi;
+ opc->v[6].fi = opc->v[4].o1->v[0].fi; /* v[5] is in use */
return(oo_set_type_1(opc, 1, otype));
}}}
return(return_false(sc, indexp1, __func__, __LINE__));
@@ -56376,7 +56667,6 @@ static s7_int opt_i_add_any_f(opt_info *o)
{
opt_info *o1;
o1 = o->v[i + 2].o1;
- o->sc->pc++;
sum += o1->v[0].fi(o1);
}
return(sum);
@@ -56385,66 +56675,48 @@ static s7_int opt_i_add_any_f(opt_info *o)
static s7_int opt_i_add2(opt_info *o)
{
s7_int sum;
- o->sc->pc++;
sum = o->v[6].fi(o->v[2].o1);
- o->sc->pc++;
return(sum + o->v[7].fi(o->v[3].o1));
}
static s7_int opt_i_mul2(opt_info *o)
{
s7_int sum;
- o->sc->pc++;
sum = o->v[6].fi(o->v[2].o1);
- o->sc->pc++;
return(sum * o->v[7].fi(o->v[3].o1));
}
static s7_int opt_i_add3(opt_info *o)
{
s7_int sum;
- o->sc->pc++;
sum = o->v[6].fi(o->v[2].o1);
- o->sc->pc++;
sum += o->v[7].fi(o->v[3].o1);
- o->sc->pc++;
return(sum + o->v[8].fi(o->v[4].o1));
}
static s7_int opt_i_mul3(opt_info *o)
{
s7_int sum;
- o->sc->pc++;
sum = o->v[6].fi(o->v[2].o1);
- o->sc->pc++;
sum *= o->v[7].fi(o->v[3].o1);
- o->sc->pc++;
return(sum * o->v[8].fi(o->v[4].o1));
}
static s7_int opt_i_add4(opt_info *o)
{
s7_int sum;
- o->sc->pc++;
sum = o->v[6].fi(o->v[2].o1);
- o->sc->pc++;
sum += o->v[7].fi(o->v[3].o1);
- o->sc->pc++;
sum += o->v[8].fi(o->v[4].o1);
- o->sc->pc++;
return(sum + o->v[9].fi(o->v[5].o1));
}
static s7_int opt_i_mul4(opt_info *o)
{
s7_int sum;
- o->sc->pc++;
sum = o->v[6].fi(o->v[2].o1);
- o->sc->pc++;
sum *= o->v[7].fi(o->v[3].o1);
- o->sc->pc++;
sum *= o->v[8].fi(o->v[4].o1);
- o->sc->pc++;
return(sum * o->v[9].fi(o->v[5].o1));
}
@@ -56456,7 +56728,6 @@ static s7_int opt_i_multiply_any_f(opt_info *o)
{
opt_info *o1;
o1 = o->v[i + 2].o1;
- o->sc->pc++;
sum *= o1->v[0].fi(o1);
}
return(sum);
@@ -56476,10 +56747,10 @@ static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x)
}
if (is_null(p))
{
- int32_t i;
opc->v[1].i = cur_len;
if (cur_len <= 4)
{
+ int32_t i;
for (i = 0; i < cur_len; i++)
opc->v[i + 6].fi = opc->v[i + 2].o1->v[0].fi;
}
@@ -56508,7 +56779,6 @@ static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x)
static s7_int opt_set_i_i_f(opt_info *o)
{
s7_int x;
- o->sc->pc++;
x = o->v[3].fi(o->v[2].o1);
slot_set_value(o->v[1].p, make_integer(o->sc, x));
return(x);
@@ -56517,7 +56787,6 @@ static s7_int opt_set_i_i_f(opt_info *o)
static s7_int opt_set_i_i_fm(opt_info *o) /* when is this called? */
{
s7_int x;
- o->sc->pc++;
x = o->v[3].fi(o->v[2].o1);
integer(slot_value(o->v[1].p)) = x;
return(x);
@@ -56745,8 +57014,8 @@ static s7_double opt_d_d_c(opt_info *o) {return(o->v[3].d_d_f(o->v[1].x));}
static s7_double opt_d_d_s(opt_info *o) {return(o->v[3].d_d_f(real(slot_value(o->v[1].p))));}
static s7_double opt_d_7d_c(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[1].x));}
static s7_double opt_d_7d_s(opt_info *o) {return(o->v[3].d_7d_f(o->sc, real(slot_value(o->v[1].p))));}
-static s7_double opt_d_d_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));}
-static s7_double opt_d_7d_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_7d_f(o->sc, o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_d_f(opt_info *o) {return(o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_7d_f(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[5].fd(o->v[4].o1)));}
static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -56824,7 +57093,7 @@ static bool d_v_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
/* -------- d_p -------- */
static s7_double opt_d_p_s(opt_info *o) {return(o->v[3].d_p_f(slot_value(o->v[1].p)));}
-static s7_double opt_d_p_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_p_f(o->v[5].fp(o->v[4].o1)));}
+static s7_double opt_d_p_f(opt_info *o) {return(o->v[3].d_p_f(o->v[5].fp(o->v[4].o1)));}
static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -56863,14 +57132,12 @@ static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
static s7_double opt_d_7pi_sc(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));}
static s7_double opt_d_7pi_ss(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
-static s7_double opt_d_7pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1)));}
+static s7_double opt_d_7pi_sf(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1)));}
static s7_double opt_d_7pi_ff(opt_info *o)
{
s7_pointer seq;
- o->sc->pc++;
seq = o->v[5].fp(o->v[4].o1);
- o->sc->pc++;
return(o->v[3].d_7pi_f(o->sc, seq, o->v[9].fi(o->v[8].o1)));
}
@@ -56986,7 +57253,7 @@ static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- d_pd -------- */
-static s7_double opt_d_pd_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1)));}
+static s7_double opt_d_pd_sf(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1)));}
static s7_double opt_d_pd_ss(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), real(slot_value(o->v[2].p))));}
static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
@@ -57028,35 +57295,13 @@ static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- d_vd -------- */
static s7_double opt_d_vd_c(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].x));}
static s7_double opt_d_vd_s(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p))));}
-static s7_double opt_d_vd_f(opt_info *o) {o->sc->pc++; return(o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1)));}
+static s7_double opt_d_vd_f(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1)));}
static s7_double opt_d_vd_o(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));}
-
-static s7_double opt_d_vd_o1_mul(opt_info *o)
-{
- opt_info *o1;
- o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)) * o1->v[0].fd(o1)));
-}
-
-static s7_double opt_d_vd_o1(opt_info *o)
-{
- opt_info *o1;
- o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(real(slot_value(o->v[2].p)), o1->v[0].fd(o1))));
-}
-
+static s7_double opt_d_vd_o1_mul(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)) * o->v[11].fd(o->v[10].o1)));}
+static s7_double opt_d_vd_o1(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))));}
static s7_double opt_d_vd_o2(opt_info *o) {return(o->v[4].d_vd_f(o->v[6].obj, o->v[5].d_vd_f(o->v[2].obj, real(slot_value(o->v[3].p)))));}
static s7_double opt_d_vd_o3(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(o->v[6].x, real(slot_value(o->v[2].p)))));}
-
-static s7_double opt_d_vd_ff(opt_info *o)
-{
- opt_info *o1;
- o->sc->pc += 2;
- o1 = o->sc->opts[o->sc->pc];
- return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].d_vd_f(o->v[4].obj, o1->v[0].fd(o1))));
-}
+static s7_double opt_d_vd_ff(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].d_vd_f(o->v[4].obj, o->v[11].fd(o->v[10].o1))));}
static s7_double opt_d_dd_cs(opt_info *o);
static s7_double opt_d_dd_sf_mul(opt_info *o);
@@ -57104,6 +57349,8 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start)
if (o1->v[0].fd == opt_d_dd_sf_mul)
opc->v[0].fd = opt_d_vd_o1_mul;
else opc->v[0].fd = opt_d_vd_o1;
+ opc->v[11].fd = o1->v[5].fd;
+ opc->v[10].o1 = o1->v[4].o1;
return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_D));
}
if (o1->v[0].fd == opt_d_vd_f)
@@ -57112,12 +57359,13 @@ static bool d_vd_f_combinable(s7_scheme *sc, int32_t start)
opc->v[4].obj = o1->v[5].obj;
opc->v[6].p = o1->v[1].p;
opc->v[0].fd = opt_d_vd_ff;
+ opc->v[11].fd = o1->v[9].fd;
+ opc->v[10].o1 = o1->v[8].o1;
return(oo_set_type_2(opc, 1 + (5 << 4), 6 + ((4 << 4)), OO_V, OO_V));
}
return(return_false(sc, NULL, __func__, __LINE__));
}
-
static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
if (is_symbol(cadr(car_x)))
@@ -57190,7 +57438,7 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- d_id -------- */
-static s7_double opt_d_id_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_id_sf(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));}
static s7_double opt_d_id_sc(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[2].x));}
static s7_double opt_d_id_sfo1(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_v_f(o->v[2].obj)));}
static s7_double opt_d_id_sfo(opt_info *o) {return(o->v[4].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[3].p)))));}
@@ -57271,30 +57519,25 @@ static s7_double opt_d_dd_ss(opt_info *o) {return(o->v[3].d_dd_f(real(slot_v
static s7_double opt_d_dd_ss_add(opt_info *o) {return(real(slot_value(o->v[1].p)) + real(slot_value(o->v[2].p)));}
static s7_double opt_d_dd_ss_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * real(slot_value(o->v[2].p)));}
-static s7_double opt_d_dd_cf(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1)));}
-static s7_double opt_d_dd_fc(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));}
+static s7_double opt_d_dd_cf(opt_info *o) {return(o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_dd_fc(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));}
#if (!WITH_GMP)
static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc->default_rng) - o->v[2].x);}
#endif
-static s7_double opt_d_dd_fc_add(opt_info *o) {o->sc->pc++; return(o->v[5].fd(o->v[4].o1) + o->v[2].x);}
-static s7_double opt_d_dd_fc_subtract(opt_info *o) {o->sc->pc++; return(o->v[5].fd(o->v[4].o1) - o->v[2].x);}
-static s7_double opt_d_dd_sf(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));}
-static s7_double opt_d_dd_sf_mul(opt_info *o) {o->sc->pc++; return(real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));}
+static s7_double opt_d_dd_fc_add(opt_info *o) {return(o->v[5].fd(o->v[4].o1) + o->v[2].x);}
+static s7_double opt_d_dd_fc_subtract(opt_info *o) {return(o->v[5].fd(o->v[4].o1) - o->v[2].x);}
+static s7_double opt_d_dd_sf(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_dd_sf_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));}
static s7_double opt_d_7dd_cc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[2].x));}
static s7_double opt_d_7dd_cs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[2].x, real(slot_value(o->v[1].p))));}
static s7_double opt_d_7dd_sc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[2].x));}
static s7_double opt_d_7dd_ss(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));}
-static s7_double opt_d_7dd_cf(opt_info *o) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[5].fd(o->v[4].o1)));}
-static s7_double opt_d_7dd_fc(opt_info *o) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), o->v[2].x));}
-
-static s7_double opt_d_7dd_sf(opt_info *o)
-{
- o->sc->pc++;
- return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));
-}
+static s7_double opt_d_7dd_cf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_7dd_fc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), o->v[2].x));}
+static s7_double opt_d_7dd_sf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));}
static s7_double opt_d_dd_sfo(opt_info *o)
{
@@ -57335,9 +57578,9 @@ static bool d_dd_sf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
return(return_false(sc, NULL, __func__, __LINE__));
}
-static s7_double opt_d_dd_fs(opt_info *o) {o->sc->pc++; return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));}
-static s7_double opt_d_dd_fs_mul(opt_info *o) {o->sc->pc++; return(o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p)));}
-static s7_double opt_d_7dd_fs(opt_info *o) {o->sc->pc++; return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));}
+static s7_double opt_d_dd_fs(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));}
+static s7_double opt_d_dd_fs_mul(opt_info *o) {return(o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p)));}
+static s7_double opt_d_7dd_fs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));}
static s7_double opt_d_dd_fso(opt_info *o)
{
@@ -57381,82 +57624,63 @@ static bool d_dd_fs_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
static s7_double opt_d_dd_ff(opt_info *o)
{
s7_double x1;
- o->sc->pc++;
x1 = o->v[9].fd(o->v[8].o1);
- o->sc->pc++;
return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_mul(opt_info *o)
{
s7_double x1;
- o->sc->pc++;
x1 = o->v[9].fd(o->v[8].o1);
- o->sc->pc++;
return(x1 * o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_dd_ff_add(opt_info *o)
{
s7_double x1;
- o->sc->pc++;
x1 = o->v[5].fd(o->v[4].o1);
- o->sc->pc++;
return(x1 + o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_dd_ff_add_mul(opt_info *o)
{
s7_double x1, x2;
- o->sc->pc++;
x1 = o->v[5].fd(o->v[4].o1);
- o->sc->pc += 2;
x2 = o->v[9].fd(o->v[8].o1);
- o->sc->pc++;
return(x1 + (x2 * o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_add_fv_ref(opt_info *o)
{
s7_double x1;
- o->sc->pc++;
x1 = o->v[5].fd(o->v[4].o1);
- o->sc->pc += 2;
return(x1 + float_vector_ref_d_7pi(o->sc, slot_value(o->v[6].p), o->v[9].fi(o->v[8].o1)));
}
static s7_double opt_d_dd_ff_sub(opt_info *o)
{
s7_double x1;
- o->sc->pc++;
x1 = o->v[5].fd(o->v[4].o1);
- o->sc->pc++;
return(x1 - o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_7dd_ff(opt_info *o)
{
s7_double x1;
- o->sc->pc++;
x1 = o->v[9].fd(o->v[8].o1);
- o->sc->pc++;
return(o->v[3].d_7dd_f(o->sc, x1, o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_o1(opt_info *o)
{
- opt_info *o2;
s7_double x1;
x1 = o->v[2].d_v_f(o->v[1].obj);
- o2 = o->sc->opts[o->sc->pc += 2];
- return(o->v[3].d_dd_f(x1, o2->v[0].fd(o2)));
+ return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_dd_ff_mul1(opt_info *o)
{
- opt_info *o2;
- o2 = o->sc->opts[o->sc->pc += 2];
- return(o->v[2].d_v_f(o->v[1].obj) * o2->v[0].fd(o2));
+ return(o->v[2].d_v_f(o->v[1].obj) * o->v[11].fd(o->v[10].o1));
}
static s7_double opt_d_dd_ff_o2(opt_info *o)
@@ -57481,9 +57705,7 @@ static s7_double opt_d_dd_ff_o3(opt_info *o)
static s7_double opt_d_dd_fff(opt_info *o)
{
s7_double x1, x2;
- o->sc->pc++;
x1 = o->v[3+4].d_dd_f(o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))), real(slot_value(o->v[3+1].p))); /* dd_fso */
- o->sc->pc++;
x2 = o->v[8+4].d_dd_f(o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))), real(slot_value(o->v[8+1].p))); /* dd_fso */
return(o->v[3].d_dd_f(x1, x2));
}
@@ -57491,9 +57713,7 @@ static s7_double opt_d_dd_fff(opt_info *o)
static s7_double opt_d_mm_fff(opt_info *o)
{
s7_double x1, x2;
- o->sc->pc++;
x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))) * real(slot_value(o->v[3+1].p));
- o->sc->pc++;
x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))) * real(slot_value(o->v[8+1].p));
return(o->v[3].d_dd_f(x1, x2));
}
@@ -57501,9 +57721,7 @@ static s7_double opt_d_mm_fff(opt_info *o)
static s7_double opt_d_dd_fff_rev(opt_info *o) /* faster with o->sc? */
{
s7_double x1, x2;
- o->sc->pc++;
x1 = o->v[3+4].d_dd_f(real(slot_value(o->v[3+1].p)), o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))));
- o->sc->pc++;
x2 = o->v[8+4].d_dd_f(real(slot_value(o->v[8+1].p)), o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))));
return(o->v[3].d_dd_f(x1, x2));
}
@@ -57900,16 +58118,13 @@ static s7_double opt_d_ddd_sss(opt_info *o)
static s7_double opt_d_ddd_ssf(opt_info *o)
{
- o->sc->pc++;
return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_ddd_sff(opt_info *o)
{
s7_double x1, x2;
- o->sc->pc++;
x1 = o->v[11].fd(o->v[10].o1);
- o->sc->pc++;
x2 = o->v[9].fd(o->v[8].o1);
return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), x1, x2));
}
@@ -57917,11 +58132,8 @@ static s7_double opt_d_ddd_sff(opt_info *o)
static s7_double opt_d_ddd_fff(opt_info *o)
{
s7_double x1, x2, x3;
- o->sc->pc++;
x1 = o->v[11].fd(o->v[10].o1);
- o->sc->pc++;
x2 = o->v[9].fd(o->v[8].o1);
- o->sc->pc++;
x3 = o->v[6].fd(o->v[5].o1);
return(o->v[4].d_ddd_f(x1, x2, x3));
}
@@ -57939,9 +58151,7 @@ static s7_double opt_d_ddd_fff2(opt_info *o)
{
s7_double x1, x2, x3;
x1 = o->v[1].d_v_f(o->v[2].obj);
- o->sc->pc += 2;
x2 = o->v[9].fd(o->v[12].o1);
- o->sc->pc++;
x3 = o->v[6].fd(o->v[5].o1);
return(o->v[7].d_ddd_f(x1, x2, x3));
}
@@ -58056,13 +58266,11 @@ static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- d_7pid -------- */
static s7_double opt_d_7pid_ssf(opt_info *o)
{
- o->sc->pc++;
return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));
}
static s7_pointer opt_d_7pid_ssf_nr(opt_info *o)
{
- o->sc->pc++;
o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1));
return(NULL);
}
@@ -58080,9 +58288,7 @@ static s7_double opt_d_7pid_ssc(opt_info *o)
static s7_double opt_d_7pid_sff(opt_info *o)
{
s7_int pos;
- o->sc->pc++;
pos = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), pos, o->v[9].fd(o->v[8].o1)));
}
@@ -58196,7 +58402,6 @@ static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc)
/* -------- d_7piid -------- */
static s7_double opt_d_7piid_sssf(opt_info *o)
{
- o->sc->pc++;
return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[9].fd(o->v[8].o1)));
}
@@ -58207,25 +58412,21 @@ static s7_double opt_d_7piid_sssc(opt_info *o)
static s7_double opt_d_7piid_scsf(opt_info *o)
{
- o->sc->pc++;
return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p)), o->v[11].fd(o->v[10].o1)));
}
static s7_double opt_d_7piid_sfff(opt_info *o)
{
s7_int i1, i2;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
- o->sc->pc++;
return(o->v[5].d_7piid_f(o->sc, slot_value(o->v[1].p), i1, i2, o->v[4].fd(o->v[3].o1)));
}
static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp)
{
s7_pointer settee;
- /* fprintf(stderr, "%s: %s %s %s %s\n", __func__, DISPLAY(v), DISPLAY(indexp1), (indexp2) ? DISPLAY(indexp1) : "null", DISPLAY(valp)); */
+ /* fprintf(stderr, "%s: %s %s %s %s\n", __func__, display(v), display(indexp1), (indexp2) ? display(indexp1) : "null", display(valp)); */
settee = symbol_to_slot(sc, v);
if ((is_slot(settee)) &&
(!is_immutable(slot_value(settee))))
@@ -58354,9 +58555,7 @@ static s7_double opt_d_7pii_scs(opt_info *o)
static s7_double opt_d_7pii_sff(opt_info *o)
{
s7_int i1, i2;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
return(o->v[4].d_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2));
}
@@ -58494,22 +58693,16 @@ static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point
}
/* -------- d_vid -------- */
-static s7_double opt_d_vid_ssf(opt_info *o)
-{
- o->sc->pc++;
- return(o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));
-}
+static s7_double opt_d_vid_ssf(opt_info *o) {return(o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));}
static inline s7_double opt_fmv(opt_info *o)
{
/* d_vid_ssf -> d_dd_ff_o1 -> d_vd_o1 -> d_dd_ff_o3, this is a placeholder */
opt_info *o1, *o2, *o3;
s7_double amp_env, index_env, vib;
- s7_scheme *sc;
- sc = o->sc;
- o1 = sc->opts[sc->pc + 1];
- o2 = sc->opts[sc->pc + 3];
- o3 = sc->opts[sc->pc += 5];
+ o1 = o->v[12].o1; /* o2 below */
+ o2 = o->v[13].o1; /* o3 below */
+ o3 = o->v[14].o1; /* o1 below */
amp_env = o1->v[2].d_v_f(o1->v[1].obj);
vib = real(slot_value(o2->v[2].p));
index_env = o3->v[5].d_v_f(o3->v[1].obj);
@@ -58563,7 +58756,12 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if ((o1->v[0].fd == opt_d_dd_ff_o3) &&
(o1->v[4].d_dd_f == multiply_d_dd) &&
(o3->v[4].d_dd_f == add_d_dd))
- opc->v[0].fd = opt_fmv; /* a placeholder -- see below */
+ {
+ opc->v[0].fd = opt_fmv; /* a placeholder -- see below */
+ opc->v[12].o1 = o2;
+ opc->v[13].o1 = o3;
+ opc->v[14].o1 = o1;
+ }
}
}
return(oo_set_type_2(opc, 1 + (5 << 4), 2, OO_V, OO_I));
@@ -58578,9 +58776,7 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
static s7_double opt_d_vdd_ff(opt_info *o)
{
s7_double x1, x2;
- o->sc->pc++;
x1 = o->v[11].fd(o->v[10].o1);
- o->sc->pc++;
x2 = o->v[9].fd(o->v[8].o1);
return(o->v[4].d_vdd_f(o->v[5].obj, x1, x2));
}
@@ -58626,13 +58822,9 @@ static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
static s7_double opt_d_dddd_ffff(opt_info *o)
{
s7_double x1, x2, x3, x4;
- o->sc->pc++;
x1 = o->v[11].fd(o->v[10].o1);
- o->sc->pc++;
x2 = o->v[9].fd(o->v[8].o1);
- o->sc->pc++;
x3 = o->v[5].fd(o->v[4].o1);
- o->sc->pc++;
x4 = o->v[3].fd(o->v[2].o1);
return(o->v[1].d_dddd_f(x1, x2, x3, x4));
}
@@ -58675,7 +58867,6 @@ static s7_double opt_d_add_any_f(opt_info *o)
{
opt_info *o1;
o1 = o->v[i + 2].o1;
- o->sc->pc++;
sum += o1->v[0].fd(o1);
}
return(sum);
@@ -58689,7 +58880,6 @@ static s7_double opt_d_multiply_any_f(opt_info *o)
{
opt_info *o1;
o1 = o->v[i + 2].o1;
- o->sc->pc++;
sum *= o1->v[0].fd(o1);
}
return(sum);
@@ -58730,7 +58920,6 @@ static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x, int32_t
static s7_double opt_set_d_d_f(opt_info *o)
{
s7_double x;
- o->sc->pc++;
x = o->v[3].fd(o->v[2].o1);
slot_set_value(o->v[1].p, make_real(o->sc, x));
return(x);
@@ -58739,7 +58928,6 @@ static s7_double opt_set_d_d_f(opt_info *o)
static s7_double opt_set_d_d_fm(opt_info *o)
{
s7_double x;
- o->sc->pc++;
x = o->v[3].fd(o->v[2].o1);
real(slot_value(o->v[1].p)) = x;
return(x);
@@ -58898,26 +59086,18 @@ static bool d_implicit_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
/* -------------------------------- bool opts -------------------------------- */
-static bool opt_b_t(opt_info *o) {return(true);}
-static bool opt_b_f(opt_info *o) {return(false);}
static bool opt_b_s(opt_info *o) {return(slot_value(o->v[1].p) != o->sc->F);}
static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x)
{
- opt_info *opc;
s7_pointer p;
if (!is_symbol(car_x))
- {
- if (!s7_is_boolean(car_x))
- return(return_false(sc, car_x, __func__, __LINE__)); /* i.e. use cell_optimize */
- opc = alloc_opo(sc, car_x);
- opc->v[0].fb = ((car_x == sc->F) ? opt_b_f : opt_b_t);
- return(oo_set_type_0(opc));
- }
+ return(return_false(sc, car_x, __func__, __LINE__)); /* i.e. use cell_optimize */
p = opt_simple_symbol(sc, car_x);
if ((p) &&
(s7_is_boolean(slot_value(p))))
{
+ opt_info *opc;
opc = alloc_opo(sc, car_x);
opc->v[1].p = p;
opc->v[0].fb = opt_b_s;
@@ -58928,13 +59108,13 @@ static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x)
/* -------- b_idp -------- */
static bool opt_b_i_s(opt_info *o) {return(o->v[2].b_i_f(integer(slot_value(o->v[1].p))));}
-static bool opt_b_i_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_i_f(o->v[11].fi(o->v[10].o1)));}
+static bool opt_b_i_f(opt_info *o) {return(o->v[2].b_i_f(o->v[11].fi(o->v[10].o1)));}
static bool opt_b_d_s(opt_info *o) {return(o->v[2].b_d_f(real(slot_value(o->v[1].p))));}
-static bool opt_b_d_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_d_f(o->v[11].fd(o->v[10].o1)));}
+static bool opt_b_d_f(opt_info *o) {return(o->v[2].b_d_f(o->v[11].fd(o->v[10].o1)));}
static bool opt_b_p_s(opt_info *o) {return(o->v[2].b_p_f(slot_value(o->v[1].p)));}
-static bool opt_b_p_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));}
+static bool opt_b_p_f(opt_info *o) {return(o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));}
static bool opt_b_7p_s(opt_info *o) {return(o->v[2].b_7p_f(o->sc, slot_value(o->v[1].p)));}
-static bool opt_b_7p_f(opt_info *o) {o->sc->pc++; return(o->v[2].b_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
+static bool opt_b_7p_f(opt_info *o) {return(o->v[2].b_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
#if (!WITH_GMP)
static bool opt_zero_mod(opt_info *o)
@@ -59136,28 +59316,24 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp)
static bool opt_b_pp_ff(opt_info *o)
{
s7_pointer p1;
- o->sc->pc++;
p1 = o->v[9].fp(o->v[8].o1);
- o->sc->pc++;
return(o->v[3].b_pp_f(p1, o->v[11].fp(o->v[10].o1)));
}
static bool opt_b_7pp_ff(opt_info *o)
{
s7_pointer p1;
- o->sc->pc++;
p1 = o->v[9].fp(o->v[8].o1);
- o->sc->pc++;
return(o->v[3].b_7pp_f(o->sc, p1, o->v[11].fp(o->v[10].o1)));
}
-static bool opt_b_pp_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));}
-static bool opt_b_pp_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));}
+static bool opt_b_pp_sf(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));}
+static bool opt_b_pp_fs(opt_info *o) {return(o->v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));}
static bool opt_b_pp_ss(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), slot_value(o->v[2].p)));}
static bool opt_b_pp_sc(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[2].p));}
static bool opt_b_pp_sfo(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));}
-static bool opt_b_7pp_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));}
-static bool opt_b_7pp_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_7pp_f(o->sc, o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));}
+static bool opt_b_7pp_sf(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));}
+static bool opt_b_7pp_fs(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));}
static bool opt_b_7pp_ss(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
static bool opt_lt_b_7pp_ss(opt_info *o) {return(lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
static bool opt_b_7pp_sc(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));}
@@ -59319,11 +59495,7 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- b_pi -------- */
-static bool opt_b_pi_fs(opt_info *o)
-{
- o->sc->pc++;
- return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));
-}
+static bool opt_b_pi_fs(opt_info *o) {return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));}
static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg2)
{
@@ -59355,16 +59527,14 @@ static bool opt_b_dd_sc_lt(opt_info *o) {return(real(slot_value(o->v[1].p)) < o-
static bool opt_b_dd_sc_geq(opt_info *o) {return(real(slot_value(o->v[1].p)) >= o->v[2].x);}
static bool opt_b_dd_sc_eq(opt_info *o) {return(real(slot_value(o->v[1].p)) == o->v[2].x);}
-static bool opt_b_dd_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[11].fd(o->v[10].o1)));}
-static bool opt_b_dd_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), real(slot_value(o->v[1].p))));}
-static bool opt_b_dd_fc(opt_info *o) {o->sc->pc++; return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x));}
+static bool opt_b_dd_sf(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[11].fd(o->v[10].o1)));}
+static bool opt_b_dd_fs(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), real(slot_value(o->v[1].p))));}
+static bool opt_b_dd_fc(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x));}
static bool opt_b_dd_ff(opt_info *o)
{
s7_double x1, x2;
- o->sc->pc++;
x1 = o->v[11].fd(o->v[10].o1);
- o->sc->pc++;
x2 = o->v[9].fd(o->v[8].o1);
return(o->v[3].b_dd_f(x1, x2));
}
@@ -59433,30 +59603,40 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- b_ii -------- */
-static bool opt_b_ii_ss(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
-static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < integer(slot_value(o->v[2].p)));}
-static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > integer(slot_value(o->v[2].p)));}
+static bool opt_b_ii_ss(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
+static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < integer(slot_value(o->v[2].p)));}
+static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > integer(slot_value(o->v[2].p)));}
static bool opt_b_ii_ss_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= integer(slot_value(o->v[2].p)));}
static bool opt_b_ii_ss_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= integer(slot_value(o->v[2].p)));}
-static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == integer(slot_value(o->v[2].p)));}
-static bool opt_b_ii_sc(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));}
-static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < o->v[2].i);}
+static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == integer(slot_value(o->v[2].p)));}
+static bool opt_b_ii_sc(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));}
+static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < o->v[2].i);}
+static bool opt_b_ii_sc_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= o->v[2].i);}
+static bool opt_b_ii_sc_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > o->v[2].i);}
static bool opt_b_ii_sc_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= o->v[2].i);}
-static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[2].i);}
+static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[2].i);}
+static bool opt_b_ii_sc_bit(opt_info *o) {return((integer(slot_value(o->v[1].p)) & ((int64_t)(1LL << o->v[2].i))) != 0);}
+
+/*
+ * fx_c_opssq_s_direct and s_opssq_direct and opssq_opssq (2) with vref inner?
+ * opssq_opssq direct
+ * (* (- ) (- ) in b, (+|- (* ) (* )) in big, (< (- ) (- )) q
+ * fx_c_s_op_opssq_opssqq
+ */
static bool opt_b_ii_ff(opt_info *o)
{
s7_int i1, i2;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
return(o->v[3].b_ii_f(i1, i2));
}
-static bool opt_b_ii_fs(opt_info *o) {o->sc->pc++; return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));}
-static bool opt_b_ii_fc(opt_info *o) {o->sc->pc++; return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));}
-static bool opt_b_ii_sf(opt_info *o) {o->sc->pc++; return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[11].fi(o->v[10].o1)));}
+static bool opt_b_ii_fs(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));}
+static bool opt_b_ii_sf(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[11].fi(o->v[10].o1)));}
+static bool opt_b_ii_sf_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[11].fi(o->v[10].o1));}
+static bool opt_b_ii_fc(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));}
+static bool opt_b_ii_fc_eq(opt_info *o) {return(o->v[11].fi(o->v[10].o1) == o->v[2].i);}
static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2)
{
@@ -59471,41 +59651,31 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (is_symbol(arg2))
{
opc->v[2].p = symbol_to_slot(sc, arg2);
- opc->v[0].fb = opt_b_ii_ss;
- if (bif == lt_b_ii)
- opc->v[0].fb = opt_b_ii_ss_lt;
- else
- {
- if (bif == gt_b_ii)
- opc->v[0].fb = opt_b_ii_ss_gt;
- else
- {
- if (bif == geq_b_ii)
- opc->v[0].fb = opt_b_ii_ss_geq;
- else
- {
- if (bif == leq_b_ii)
- opc->v[0].fb = opt_b_ii_ss_leq;
- else
- {
- if (bif == num_eq_b_ii)
- opc->v[0].fb = opt_b_ii_ss_eq;
- }
- }
- }
- }
+
+ opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt :
+ ((bif == leq_b_ii) ? opt_b_ii_ss_leq :
+ ((bif == gt_b_ii) ? opt_b_ii_ss_gt :
+ ((bif == geq_b_ii) ? opt_b_ii_ss_geq :
+ ((bif == num_eq_b_ii) ? opt_b_ii_ss_eq :
+ opt_b_ii_ss))));
return(oo_set_type_2(opc, 1, 2, OO_I, OO_I));
}
if (is_opt_int(arg2))
{
opc->v[2].i = integer(arg2);
- opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_sc_lt : ((bif == geq_b_ii) ? opt_b_ii_sc_geq : ((bif == num_eq_b_ii) ? opt_b_ii_sc_eq : opt_b_ii_sc));
+ opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_sc_lt :
+ ((bif == leq_b_ii) ? opt_b_ii_sc_leq :
+ ((bif == gt_b_ii) ? opt_b_ii_sc_gt :
+ ((bif == geq_b_ii) ? opt_b_ii_sc_geq :
+ ((bif == num_eq_b_ii) ? opt_b_ii_sc_eq :
+ (((bif == logbit_b_ii) && (integer(arg2) >= 0) && (integer(arg2) < s7_int_bits)) ? opt_b_ii_sc_bit :
+ opt_b_ii_sc)))));
return(oo_set_type_1(opc, 1, OO_I));
}
opc->v[10].o1 = sc->opts[sc->pc];
if (int_optimize(sc, cddr(car_x)))
{
- opc->v[0].fb = opt_b_ii_sf;
+ opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf;
opc->v[11].fi = opc->v[10].o1->v[0].fi;
return(oo_set_type_1(opc, 1, OO_I));
}
@@ -59530,7 +59700,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (is_opt_int(arg2))
{
opc->v[2].i = integer(arg2);
- opc->v[0].fb = opt_b_ii_fc;
+ opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc;
return(oo_set_type_0(opc));
}
opc->v[8].o1 = sc->opts[sc->pc];
@@ -59548,24 +59718,15 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- b_or|and -------- */
static bool opt_and_bb(opt_info *o)
{
- o->sc->pc++;
if (o->v[3].fb(o->v[2].o1))
- {
- o->sc->pc++;
- return(o->v[11].fb(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fb(o->v[10].o1));
return(false);
}
static bool opt_and_bb1(opt_info *o)
{
if (o->v[5].fb(o))
- {
- o->sc->pc += 2;
- return(o->v[11].fb(o->v[10].o1));
- }
- o->sc->pc = o->v[4].i;
+ return(o->v[11].fb(o->v[10].o1));
return(false);
}
@@ -59575,37 +59736,24 @@ static bool opt_and_any_b(opt_info *o)
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o->sc->pc++;
o1 = o->v[i + 3].o1;
if (!o1->v[0].fb(o1))
- {
- o->sc->pc = o->v[2].i;
- return(false);
- }
+ return(false);
}
return(true);
}
static bool opt_or_bb(opt_info *o)
{
- o->sc->pc++;
if (o->v[3].fb(o->v[2].o1))
- {
- o->sc->pc = o->v[1].i;
- return(true);
- }
- o->sc->pc++;
+ return(true);
return(o->v[11].fb(o->v[10].o1));
}
static bool opt_or_bb1(opt_info *o)
{
if (o->v[5].fb(o))
- {
- o->sc->pc = o->v[4].i;
- return(true);
- }
- o->sc->pc += 2;
+ return(true);
return(o->v[11].fb(o->v[10].o1));
}
@@ -59615,13 +59763,9 @@ static bool opt_or_any_b(opt_info *o)
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- o->sc->pc++;
o1 = o->v[i + 3].o1;
if (o1->v[0].fb(o1))
- {
- o->sc->pc = o->v[2].i;
- return(true);
- }
+ return(true);
}
return(false);
}
@@ -59653,7 +59797,6 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i
(o1->v[0].fb == opt_b_7pp_ss) ||
(o1->v[0].fb == opt_lt_b_7pp_ss))
{
- opc->v[4].i = sc->pc - 1;
opc->v[5].fb = o1->v[0].fb;
opc->v[0].fb = (is_and) ? opt_and_bb1 : opt_or_bb1;
opc->v[1].p = o1->v[1].p;
@@ -59662,7 +59805,6 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i
return(oo_set_type_2(opc, 1, 2, OO_P, OO_P));
}
opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb;
- opc->v[1].i = sc->pc - 1;
opc->v[2].o1 = o1;
opc->v[3].fb = o1->v[0].fb;
return(oo_set_type_0(opc));
@@ -59680,7 +59822,6 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i
if (is_null(p))
{
opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b;
- opc->v[2].i = sc->pc - 1;
return(oo_set_type_0(opc));
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -59753,7 +59894,7 @@ static s7_pointer opt_p_7i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_
static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_d_f(o->v[1].x)));}
static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_7d_f(o->sc, o->v[1].x)));}
static s7_pointer opt_p_p_s(opt_info *o) {return(o->v[2].p_p_f(o->sc, slot_value(o->v[1].p)));}
-static s7_pointer opt_p_p_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
+static s7_pointer opt_p_p_f(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
static s7_pointer opt_p_p_f1(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[3].p_p_f(o->sc, slot_value(o->v[1].p))));}
static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc)
@@ -59775,7 +59916,7 @@ static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc)
return(return_false(sc, NULL, __func__, __LINE__));
}
-static s7_pointer opt_p_call_f(opt_info *o) {o->sc->pc++; return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[5].fp(o->v[4].o1))));}
+static s7_pointer opt_p_call_f(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[5].fp(o->v[4].o1))));}
static s7_pointer opt_p_call_s(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, slot_value(o->v[1].p))));}
static s7_pointer opt_p_call_c(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[1].p)));}
@@ -59901,7 +60042,7 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
/* -------- p_i -------- */
static s7_pointer opt_p_i_s(opt_info *o) {return(o->v[2].p_i_f(o->sc, integer(slot_value(o->v[1].p))));}
-static s7_pointer opt_p_i_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_i_f(o->sc, o->v[4].fi(o->v[3].o1)));}
+static s7_pointer opt_p_i_f(opt_info *o) {return(o->v[2].p_i_f(o->sc, o->v[4].fi(o->v[3].o1)));}
static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
{
@@ -59933,14 +60074,12 @@ static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c
/* -------- p_ii -------- */
static s7_pointer opt_p_ii_ss(opt_info *o) {return(o->v[3].p_ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
-static s7_pointer opt_p_ii_fs(opt_info *o) {o->sc->pc++; return(o->v[3].p_ii_f(o->sc, o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_ii_fs(opt_info *o) {return(o->v[3].p_ii_f(o->sc, o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));}
static s7_pointer opt_p_ii_ff(opt_info *o)
{
s7_int i1;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
return(o->v[3].p_ii_f(o->sc, i1, o->v[9].fi(o->v[8].o1)));
}
@@ -59996,7 +60135,7 @@ static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- p_d -------- */
static s7_pointer opt_p_d_s(opt_info *o) {return(o->v[2].p_d_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), "p_d")));}
-static s7_pointer opt_p_d_f(opt_info *o) {o->sc->pc++; return(o->v[2].p_d_f(o->sc, o->v[4].fd(o->v[3].o1)));}
+static s7_pointer opt_p_d_f(opt_info *o) {return(o->v[2].p_d_f(o->sc, o->v[4].fd(o->v[3].o1)));}
static bool p_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
{
@@ -60075,8 +60214,8 @@ static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- p_pi -------- */
static s7_pointer opt_p_pi_ss(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
static s7_pointer opt_p_pi_sc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));}
-static s7_pointer opt_p_pi_sf(opt_info *o) {o->sc->pc++; return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
-static s7_pointer opt_p_pi_fc(opt_info *o) {o->sc->pc++; return(o->v[3].p_pi_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].i));}
+static s7_pointer opt_p_pi_sf(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+static s7_pointer opt_p_pi_fc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].i));}
static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sig, s7_pointer car_x)
{
@@ -60195,17 +60334,15 @@ static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc)
static s7_pointer opt_p_pp_ss(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
static s7_pointer opt_p_pp_sc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));}
static s7_pointer opt_p_pp_cs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[2].p, slot_value(o->v[1].p)));}
-static s7_pointer opt_p_pp_sf(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
-static s7_pointer opt_p_pp_fs(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));}
-static s7_pointer opt_p_pp_fc(opt_info *o) {o->sc->pc++; return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].p));}
+static s7_pointer opt_p_pp_sf(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_fs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));}
+static s7_pointer opt_p_pp_fc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].p));}
static s7_pointer opt_p_pp_cc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[1].p, o->v[2].p));}
static s7_pointer opt_p_pp_ff(opt_info *o)
{
s7_pointer p1;
- o->sc->pc++;
p1 = o->v[11].fp(o->v[10].o1);
- o->sc->pc++;
return(o->v[3].p_pp_f(o->sc, p1, o->v[9].fp(o->v[8].o1)));
}
@@ -60262,7 +60399,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if ((!is_pair(caddr(car_x))) ||
(is_proper_quote(sc, caddr(car_x))))
{
- opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x));
+ opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x);
opc->v[0].fp = opt_p_pp_sc;
return(oo_set_type_1(opc, 1, OO_P));
}
@@ -60286,7 +60423,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
((!is_pair(caddr(car_x))) ||
(is_proper_quote(sc, caddr(car_x)))))
{
- opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x));
+ opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x);
opc->v[0].fp = opt_p_pp_cc;
return(oo_set_type_0(opc));
}
@@ -60340,7 +60477,7 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
return(true);
}
}
- opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadr(caddr(car_x));
+ opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x);
opc->v[0].fp = opt_p_pp_fc;
opc->v[4].o1 = o1;
opc->v[5].fp = o1->v[0].fp;
@@ -60371,9 +60508,7 @@ static s7_pointer opt_p_call_ff(opt_info *o)
#if S7_DEBUGGING
if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
- sc->pc++;
gc_protect_direct(sc, o->v[11].fp(o->v[10].o1));
- sc->pc++;
po2 = o->v[9].fp(o->v[8].o1);
po2 = o->v[3].call(sc, set_plist_2(sc, sc->stack_end[-2], po2));
sc->stack_end -= 4;
@@ -60383,7 +60518,6 @@ static s7_pointer opt_p_call_ff(opt_info *o)
static s7_pointer opt_p_call_fs(opt_info *o)
{
s7_pointer po1;
- o->sc->pc++;
po1 = o->v[11].fp(o->v[10].o1);
return(o->v[3].call(o->sc, set_plist_2(o->sc, po1, slot_value(o->v[1].p))));
}
@@ -60391,7 +60525,6 @@ static s7_pointer opt_p_call_fs(opt_info *o)
static s7_pointer opt_p_call_sf(opt_info *o)
{
s7_pointer po1;
- o->sc->pc++;
po1 = o->v[11].fp(o->v[10].o1);
return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), po1)));
}
@@ -60477,33 +60610,15 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi
/* -------- p_pip --------*/
-static s7_pointer opt_p_pip_ssf(opt_info *o)
-{
- o->sc->pc++;
- return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));
-}
-
-static s7_pointer opt_p_pip_sss(opt_info *o)
-{
- return(o->v[4].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));
-}
-
-static s7_pointer opt_p_pip_ssc(opt_info *o)
-{
- return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p));
-}
-
-static s7_pointer opt_p_pip_c(opt_info *o)
-{
- return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].p_p_f(o->sc, o->v[4].p)));
-}
+static s7_pointer opt_p_pip_ssf(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pip_sss(opt_info *o) {return(o->v[4].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));}
+static s7_pointer opt_p_pip_ssc(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p));}
+static s7_pointer opt_p_pip_c(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].p_p_f(o->sc, o->v[4].p)));}
static s7_pointer opt_p_pip_sff(opt_info *o)
{
s7_int i1;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), i1, o->v[9].fp(o->v[8].o1)));
}
@@ -60517,7 +60632,6 @@ static s7_pointer opt_p_pip_sso(opt_info *o)
static s7_pointer opt_p_pip_ssf1(opt_info *o)
{
- o->sc->pc += 2;
return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p_p_f(o->sc, o->v[6].fp(o->v[5].o1))));
}
@@ -60733,7 +60847,6 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
/* -------- p_piip -------- */
static s7_pointer opt_p_piip_sssf(opt_info *o)
{
- o->sc->pc++;
return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fp(o->v[10].o1)));
}
@@ -60745,11 +60858,8 @@ static s7_pointer opt_p_piip_sssc(opt_info *o)
static s7_pointer opt_p_piip_sfff(opt_info *o)
{
s7_int i1, i2;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
- o->sc->pc++;
return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), i1, i2, o->v[3].fp(o->v[4].o1))); /* v[3] because v[5] is already in use */
}
@@ -60774,7 +60884,7 @@ static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_po
opc->v[0].fp = opt_p_piip_sssf;
return(oo_set_type_3(opc, 1, 2, 3, (is_typed_vector(obj)) ? OO_TV : OO_PV, OO_I, OO_I));
}
- return(return_false(sc, car_x, __func__, __LINE__));
+ return(return_false(sc, indexp1, __func__, __LINE__));
}
opc->v[0].fp = opt_p_piip_sssc;
opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp);
@@ -60795,7 +60905,7 @@ static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_po
opc->v[0].fp = opt_p_piip_sfff;
return(oo_set_type_1(opc, 1, (is_typed_vector(obj)) ? OO_TV : OO_PV));
}}}}
- return(return_false(sc, car_x, __func__, __LINE__));
+ return(return_false(sc, indexp1, __func__, __LINE__));
}
static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
@@ -60833,9 +60943,7 @@ static s7_pointer opt_p_pii_sss(opt_info *o)
static s7_pointer opt_p_pii_sff(opt_info *o)
{
s7_int i1, i2;
- o->sc->pc++;
i1 = o->v[11].fi(o->v[10].o1);
- o->sc->pc++;
i2 = o->v[9].fi(o->v[8].o1);
return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), i1, i2));
}
@@ -60889,11 +60997,7 @@ static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- p_ppi -------- */
-static s7_pointer opt_p_ppi_psf(opt_info *o)
-{
- o->sc->pc++;
- return(o->v[3].p_ppi_f(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));
-}
+static s7_pointer opt_p_ppi_psf(opt_info *o) {return(o->v[3].p_ppi_f(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
{
@@ -60926,9 +61030,9 @@ static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
}
/* -------- p_ppp -------- */
-static s7_pointer opt_p_ppp_ssf(opt_info *o) {o->sc->pc++; return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].fp(o->v[4].o1)));}
-static s7_pointer opt_p_ppp_hash_increment(opt_info *o) {o->sc->pc = o->v[4].i; return(fx_hash_increment_1(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].p));}
-static s7_pointer opt_p_ppp_sfs(opt_info *o) {o->sc->pc++; return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)));}
+static s7_pointer opt_p_ppp_ssf(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_ppp_hash_increment(opt_info *o) {return(fx_hash_increment_1(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].p));}
+static s7_pointer opt_p_ppp_sfs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)));}
static s7_pointer opt_p_ppp_scs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));}
static s7_pointer opt_p_ppp_sss(opt_info *o) {return(o->v[4].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));}
static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[4].p));}
@@ -60936,9 +61040,7 @@ static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot
static s7_pointer opt_p_ppp_sff(opt_info *o)
{
s7_pointer po1;
- o->sc->pc++;
po1 = o->v[11].fp(o->v[10].o1);
- o->sc->pc++;
return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), po1, o->v[9].fp(o->v[8].o1)));
}
@@ -60950,11 +61052,8 @@ static s7_pointer opt_p_ppp_fff(opt_info *o)
#if S7_DEBUGGING
if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
- sc->pc++;
gc_protect_direct(sc, T_Pos(o->v[11].fp(o->v[10].o1)));
- sc->pc++;
sc->stack_end[-4] = T_Pos(o->v[9].fp(o->v[8].o1));
- sc->pc++;
res = o->v[3].p_ppp_f(sc, sc->stack_end[-2], sc->stack_end[-4], o->v[5].fp(o->v[4].o1));
sc->stack_end -= 4;
return(res);
@@ -61053,7 +61152,6 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer
if (optimize_op(car_x) == OP_HASH_INCREMENT)
{
opc->v[0].fp = opt_p_ppp_hash_increment;
- opc->v[4].i = sc->pc - 1;
opc->v[5].p = car_x;
return(oo_set_type_2(opc, 1, 2, op2, OO_P));
}
@@ -61145,7 +61243,6 @@ static s7_pointer opt_p_call_sss(opt_info *o)
static s7_pointer opt_p_call_ssf(opt_info *o)
{
- o->sc->pc++;
return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[6].fp(o->v[5].o1))));
}
@@ -61154,14 +61251,11 @@ static s7_pointer opt_p_call_ppp(opt_info *o)
s7_pointer res;
s7_scheme *sc;
sc = o->sc;
- sc->pc++;
#if S7_DEBUGGING
if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
gc_protect_direct(sc, o->v[4].fp(o->v[3].o1));
- sc->pc++;
sc->stack_end[-4] = o->v[6].fp(o->v[5].o1);
- sc->pc++;
res = o->v[11].fp(o->v[10].o1); /* not combinable into next */
res = o->v[2].call(sc, set_plist_3(sc, sc->stack_end[-2], sc->stack_end[-4], res));
sc->stack_end -= 4;
@@ -61235,16 +61329,15 @@ static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po
opc->v[10].o1 = o3;
opc->v[11].fp = o3->v[0].fp;
return(oo_set_type_0(opc));
- }
- }
- }
- }
+ }}}}
pc_fallback(sc, start);
return(return_false(sc, car_x, __func__, __LINE__));
}
/* -------- p_call_any -------- */
+#define P_CALL_O1 3
+
static s7_pointer opt_p_call_any(opt_info *o)
{
s7_pointer arg, val;
@@ -61257,7 +61350,7 @@ static s7_pointer opt_p_call_any(opt_info *o)
for (i = 0, arg = val; i < o->v[1].i; i++, arg = cdr(arg))
{
opt_info *o1;
- o1 = sc->opts[++sc->pc]; /* 3..15 */
+ o1 = o->v[i + P_CALL_O1].o1;
set_car(arg, o1->v[0].fp(o1));
}
arg = o->v[2].call(sc, val);
@@ -61273,15 +61366,20 @@ static s7_pointer opt_p_call_any(opt_info *o)
static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t len)
{
- if ((is_safe_procedure(s_func)) &&
+ if ((len < 12) &&
+ (is_safe_procedure(s_func)) &&
(c_function_required_args(s_func) <= (len - 1)) &&
(c_function_all_args(s_func) >= (len - 1)))
{
s7_pointer p; /* (vector-set! v k i 2) gets here */
+ int32_t pctr;
opc->v[1].i = (len - 1);
- for (p = cdr(car_x); is_pair(p); p = cdr(p))
- if (!cell_optimize(sc, p))
- break;
+ for (pctr = P_CALL_O1, p = cdr(car_x); is_pair(p); pctr++, p = cdr(p))
+ {
+ opc->v[pctr].o1 = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ break;
+ }
if (is_null(p))
{
opc->v[0].fp = opt_p_call_any;
@@ -61483,25 +61581,31 @@ static bool p_implicit(s7_scheme *sc, s7_pointer car_x, int32_t len)
pc_fallback(sc, start);
}
- opc->v[1].i = len;
- for (p = car_x; is_pair(p); p = cdr(p))
- if (!cell_optimize(sc, p))
- break;
- if (is_null(p))
+ if (len < 11) /* mimic p_call_any_ok */
{
- opc->v[0].fp = opt_p_call_any;
- switch (type(obj)) /* string can't happen here (no multidimensional strings) */
+ int32_t pctr;
+ opc->v[1].i = len;
+ for (pctr = 3, p = car_x; is_pair(p); pctr++, p = cdr(p))
{
- case T_PAIR: opc->v[2].call = g_list_ref; break;
- case T_HASH_TABLE: opc->v[2].call = g_hash_table_ref; break;
- /* case T_LET: opc->v[2].call = g_let_ref; break; */ /* this doesn't handle implicit indices via g_let_ref! apply_let */
- case T_INT_VECTOR: opc->v[2].call = g_int_vector_ref; break;
- case T_FLOAT_VECTOR: opc->v[2].call = g_float_vector_ref; break;
- case T_VECTOR: opc->v[2].call = g_vector_ref; break;
- default: return(return_false(sc, car_x, __func__, __LINE__));
+ opc->v[pctr].o1 = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ break;
}
- return(oo_set_type_0(opc));
- }}}
+ if (is_null(p))
+ {
+ opc->v[0].fp = opt_p_call_any;
+ switch (type(obj)) /* string can't happen here (no multidimensional strings) */
+ {
+ case T_PAIR: opc->v[2].call = g_list_ref; break;
+ case T_HASH_TABLE: opc->v[2].call = g_hash_table_ref; break;
+ /* case T_LET: opc->v[2].call = g_let_ref; break; */ /* this doesn't handle implicit indices via g_let_ref! apply_let */
+ case T_INT_VECTOR: opc->v[2].call = g_int_vector_ref; break;
+ case T_FLOAT_VECTOR: opc->v[2].call = g_float_vector_ref; break;
+ case T_VECTOR: opc->v[2].call = g_vector_ref; break;
+ default: return(return_false(sc, car_x, __func__, __LINE__));
+ }
+ return(oo_set_type_0(opc));
+ }}}}
} /* obj is sequence */
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -61523,7 +61627,6 @@ static bool opt_cell_quote(s7_scheme *sc, s7_pointer car_x)
static s7_pointer opt_set_p_p_f(opt_info *o)
{
s7_pointer x;
- o->sc->pc++;
x = o->v[4].fp(o->v[3].o1);
slot_set_value(o->v[1].p, x);
return(x);
@@ -61542,7 +61645,6 @@ static s7_pointer opt_set_p_i_s(opt_info *o)
static s7_pointer opt_set_p_i_f(opt_info *o)
{
s7_pointer x;
- o->sc->pc++;
x = make_integer(o->sc, o->v[6].fi(o->v[5].o1));
slot_set_value(o->v[1].p, x);
return(x);
@@ -61561,7 +61663,6 @@ static s7_pointer opt_set_p_d_s(opt_info *o)
static s7_pointer opt_set_p_d_f(opt_info *o)
{
s7_pointer x;
- o->sc->pc++;
x = make_real(o->sc, o->v[5].fd(o->v[4].o1));
slot_set_value(o->v[1].p, x);
return(x);
@@ -61703,7 +61804,7 @@ static bool is_some_number(s7_scheme *sc, s7_pointer tp)
static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer car_x, opt_info *opc, int32_t start_pc)
{
- /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */
+ /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */
/* maybe the type uncertainty is not a problem */
if ((is_pair(sc->code)) && /* t101-aux-14: (vector-set! !v! 0 (do ((x (list 1 2 3) (cdr x)) (j -1)) ((null? x) j) (set! j (car x)))) */
@@ -61745,7 +61846,6 @@ static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer
}
}
}
- /* fprintf(stderr, "unhappy %s\n", DISPLAY_80(sc->code)); */
return(return_false(sc, car_x, __func__, __LINE__));
}
@@ -61785,7 +61885,6 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
{
opc->v[2].p = val_slot;
opc->v[0].fp = opt_set_p_i_s;
- fprintf(stderr, "expr: %s\n", DISPLAY(car_x));
return(oo_set_type_2(opc, 1, 2, OO_I, OO_I));
}
}
@@ -61977,6 +62076,26 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
if (is_pair(cddr(target))) return(return_false(sc, car_x, __func__, __LINE__));
op2 = OO_L;
opc->v[3].p_pip_f = list_set_p_pip_direct;
+
+ /* an experiment -- is this ever hit in normal code? */
+ {
+ s7_pointer val;
+ val = caddr(car_x);
+ if ((is_pair(val)) && (car(val) == sc->add_symbol) && (is_t_integer(caddr(val))) && (is_null(cdddr(val))) && (is_symbol(cadr(target))) &&
+ (car(target) == (caadr(val))) && (is_pair(cdadr(val))) && (is_null(cddadr(val))) && (cadr(target) == cadadr(val)))
+ {
+ s7_pointer slot;
+ index = cadr(target);
+ slot = opt_simple_symbol(sc, index);
+ if ((slot) && (is_opt_int(slot_value(slot))))
+ {
+ opc->v[2].p = slot;
+ opc->v[3].p = caddr(val);
+ opc->v[0].fp = list_increment_p_pip_direct;
+ return(oo_set_type_2(opc, 1, 2, op2, OO_I));
+ }
+ }
+ }
break;
case T_HASH_TABLE:
@@ -62075,7 +62194,7 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
{
if (!is_pair(caddr(car_x)))
opc->v[4].p = caddr(car_x);
- else opc->v[4].p = cadr(caddr(car_x));
+ else opc->v[4].p = cadaddr(car_x);
if ((is_string(obj)) ||
(is_any_vector(obj)) ||
(is_pair(obj)))
@@ -62176,34 +62295,20 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy
static s7_pointer opt_begin_p(opt_info *o)
{
opt_info *o1;
- s7_int i, k, len;
- s7_scheme *sc;
- sc = o->sc;
- len = o->v[1].i; /* len = 1 if 2 exprs, etc */
- if (len < 5)
- {
- for (i = 0, k = 2; i < len; i++, k += 2)
- {
- sc->pc++;
- o->v[k + 1].fp(o->v[k].o1);
- }
- sc->pc++;
- return(o->v[k + 1].fp(o->v[k].o1));
- }
+ s7_int i, len;
+ len = o->v[1].i; /* len = 1 if 2 exprs, etc */
for (i = 0; i < len; i++)
{
- o1 = sc->opts[++sc->pc]; /* 2..15 or does it collide above? */
+ o1 = o->v[i + 2].o1;
o1->v[0].fp(o1);
}
- o1 = sc->opts[++sc->pc];
+ o1 = o->v[i + 2].o1;
return(o1->v[0].fp(o1));
}
static s7_pointer opt_begin_p_1(opt_info *o)
{
- o->sc->pc++;
o->v[3].fp(o->v[2].o1);
- o->sc->pc++;
return(o->v[5].fp(o->v[4].o1));
}
@@ -62238,8 +62343,10 @@ static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len)
int32_t i;
opt_info *opc;
s7_pointer p;
+ if (len > 12)
+ return(return_false(sc, car_x, __func__, __LINE__));
opc = alloc_opo(sc, car_x);
- for (i = 2, p = cdr(car_x); is_pair(p); i += 2, p = cdr(p))
+ for (i = 2, p = cdr(car_x); is_pair(p); i++, p = cdr(p))
{
opt_info *start;
start = sc->opts[sc->pc];
@@ -62247,88 +62354,78 @@ static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len)
return(return_false(sc, car_x, __func__, __LINE__));
if (is_pair(cdr(p)))
oo_idp_nr_fixup(start);
- if (i < 12)
- {
- opc->v[i].o1 = start;
- opc->v[i + 1].fp = start->v[0].fp;
- }
+ opc->v[i].o1 = start;
}
opc->v[1].i = len - 2;
- opc->v[0].fp = (len == 3) ? opt_begin_p_1 : opt_begin_p;
+ if (len == 3)
+ {
+ opc->v[0].fp = opt_begin_p_1;
+ opc->v[4].o1 = opc->v[3].o1;
+ opc->v[5].fp = opc->v[4].o1->v[0].fp;
+ opc->v[3].fp = opc->v[2].o1->v[0].fp;
+ }
+ else opc->v[0].fp = opt_begin_p;
return(oo_set_type_0(opc));
}
/* -------- cell_when|unless -------- */
static s7_pointer opt_when_p_2(opt_info *o)
{
- s7_scheme *sc;
- sc = o->sc;
- sc->pc++;
- if (o->v[11].fb(o->v[10].o1))
+ if (o->v[4].fb(o->v[3].o1))
{
- opt_info *o1;
- o1 = sc->opts[++sc->pc];
- o1->v[0].fp(o1);
- o1 = sc->opts[++sc->pc];
- return(o1->v[0].fp(o1));
+ o->v[6].fp(o->v[5].o1);
+ return(o->v[8].fp(o->v[7].o1));
}
- sc->pc = o->v[3].i;
- return(sc->unspecified);
+ return(o->sc->unspecified);
}
static s7_pointer opt_when_p(opt_info *o)
{
- s7_scheme *sc;
- sc = o->sc;
- sc->pc++;
- if (o->v[11].fb(o->v[10].o1))
+ if (o->v[4].fb(o->v[3].o1))
{
int32_t i, len;
opt_info *o1;
len = o->v[1].i - 1;
for (i = 0; i < len; i++)
{
- o1 = sc->opts[++sc->pc]; /* 4..15 */
+ o1 = o->v[i + 5].o1;
o1->v[0].fp(o1);
}
- o1 = sc->opts[++sc->pc];
+ o1 = o->v[i + 5].o1;
return(o1->v[0].fp(o1));
}
- sc->pc = o->v[3].i;
- return(sc->unspecified);
+ return(o->sc->unspecified);
}
static s7_pointer opt_unless_p(opt_info *o)
{
opt_info *o1;
int32_t i, len;
- s7_scheme *sc;
- sc = o->sc;
- sc->pc++;
- if (o->v[11].fb(o->v[10].o1))
- {
- sc->pc = o->v[3].i;
- return(sc->unspecified);
- }
+
+ if (o->v[4].fb(o->v[3].o1))
+ return(o->sc->unspecified);
len = o->v[1].i - 1;
for (i = 0; i < len; i++)
{
- o1 = sc->opts[++sc->pc]; /* 4..15 */
+ o1 = o->v[i + 5].o1;
o1->v[0].fp(o1);
}
- o1 = sc->opts[++sc->pc];
+ o1 = o->v[i + 5].o1;
return(o1->v[0].fp(o1));
}
static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
s7_pointer p;
+ int32_t k;
opt_info *opc;
+ if (len > 9)
+ return(return_false(sc, car_x, __func__, __LINE__));
opc = alloc_opo(sc, car_x);
- opc->v[10].o1 = sc->opts[sc->pc];
+ opc->v[3].o1 = sc->opts[sc->pc];
if (!bool_optimize(sc, cdr(car_x)))
return(return_false(sc, car_x, __func__, __LINE__));
- for (p = cddr(car_x); is_pair(p); p = cdr(p))
+ for (k = 5, p = cddr(car_x); is_pair(p); k++, p = cdr(p))
{
opt_info *start;
start = sc->opts[sc->pc];
@@ -62336,91 +62433,88 @@ static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len)
return(return_false(sc, car_x, __func__, __LINE__));
if (is_pair(cdr(p)))
oo_idp_nr_fixup(start);
+ opc->v[k].o1 = start;
}
- opc->v[11].fb = opc->v[10].o1->v[0].fb;
+ opc->v[4].fb = opc->v[3].o1->v[0].fb;
opc->v[1].i = len - 2;
- opc->v[3].i = sc->pc - 1;
- opc->v[0].fp = ((car(car_x) == sc->when_symbol) ? ((len == 4) ? opt_when_p_2 : opt_when_p) : opt_unless_p);
+ if (car(car_x) == sc->when_symbol)
+ {
+ if (len == 4)
+ {
+ opc->v[0].fp = opt_when_p_2;
+ opc->v[7].o1 = opc->v[6].o1;
+ opc->v[8].fp = opc->v[7].o1->v[0].fp;
+ opc->v[6].fp = opc->v[5].o1->v[0].fp;
+ }
+ else opc->v[0].fp = opt_when_p;
+ }
+ else opc->v[0].fp = opt_unless_p;
return(oo_set_type_0(opc));
}
/* -------- cell_cond -------- */
-static s7_pointer opt_cond(opt_info *o)
-{
- o->v[2].p = o->sc->unspecified;
- while (o->sc->pc < o->v[1].i)
- {
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc]; /* 3..15? */
- o1->v[0].fp(o1);
- }
- return(o->v[2].p);
-}
-static s7_pointer case_value(opt_info *o)
+#define COND_O1 3
+#define COND_CLAUSE_O1 5
+
+static s7_pointer cond_value(opt_info *o)
{
- opt_info *top, *o1;
+ opt_info *o1;
int32_t i, len;
- s7_scheme *sc;
- sc = o->sc;
- top = (opt_info *)(o->v[5].obj);
len = o->v[1].i - 1;
for (i = 0; i < len; i++)
{
- o1 = sc->opts[++sc->pc]; /* 6..15 */
+ o1 = o->v[i + COND_CLAUSE_O1].o1;
o1->v[0].fp(o1);
}
- o1 = sc->opts[++sc->pc];
- top->v[2].p = o1->v[0].fp(o1);
- sc->pc = top->v[1].i;
- return(top->v[2].p);
+ o1 = o->v[i + COND_CLAUSE_O1].o1;
+ return(o1->v[0].fp(o1));
}
-static s7_pointer opt_cond_clause(opt_info *o)
+static s7_pointer opt_cond(opt_info *top)
{
- /* top->p1 gets result, top->i1 is end index, o->v[3].i is end of current clause, o->v[1].i = body len */
- opt_info *o1;
- o1 = o->sc->opts[++o->sc->pc];
- if (o1->v[0].fb(o1))
- return(case_value(o));
- o->sc->pc = o->v[3].i;
- return(o->sc->unspecified);
+ int32_t clause, len;
+ len = top->v[2].i;
+ for (clause = 0; clause < len; clause++)
+ {
+ opt_info *o1, *o2;
+ o1 = top->v[clause + COND_O1].o1;
+ o2 = o1->v[4].o1;
+ if (o2->v[0].fb(o2))
+ {
+ s7_pointer res;
+ res = cond_value(o1);
+ return(res);
+ }
+ }
+ return(top->sc->unspecified);
}
static s7_pointer opt_cond_1(opt_info *o) /* cond as when */
{
- o->sc->pc += 2;
if (o->v[5].fb(o->v[4].o1))
- return(case_value(o->v[6].o1));
- o->sc->pc = o->v[3].i;
+ return(cond_value(o->v[6].o1));
return(o->sc->unspecified);
}
-static s7_pointer opt_cond_2(opt_info *o)
+static s7_pointer opt_cond_2(opt_info *o) /* 2 branches, results 1 expr, else */
{
- /* 2 branches, results 1 expr, else */
- opt_info *o1, *o2;
+ opt_info *o1;
s7_pointer res;
- s7_scheme *sc;
- sc = o->sc;
- sc->pc += 2;
- o2 = sc->opts[sc->pc]; /* this is the boolean expr of the first clause */
- if (!o2->v[0].fb(o2))
- sc->pc = o->v[3].i; /* jump over first clause and #t */
- o1 = sc->opts[++sc->pc];
+ if (!o->v[5].fb(o->v[4].o1))
+ o1 = o->v[7].o1;
+ else o1 = o->v[6].o1;
res = o1->v[0].fp(o1);
- sc->pc = o->v[1].i; /* end of cond index */
return(res);
}
static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x)
{
- /* top->v[2].p gets result, top->v[1].i is end index, clause->v[3].i is end of current clause,
- * clause->v[1].i = clause result len, clause->v[5].obj = top
- */
+ /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */
s7_pointer p, last_clause = NULL;
opt_info *top;
int32_t branches = 0, max_blen = 0, start_pc;
+
top = alloc_opo(sc, car_x);
start_pc = sc->pc;
for (p = cdr(car_x); is_pair(p); p = cdr(p), branches++)
@@ -62429,40 +62523,33 @@ static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x)
s7_pointer clause, cp;
int32_t blen;
clause = car(p);
- if ((!is_pair(clause)) ||
+ if ((branches > 12) ||
+ (!is_pair(clause)) ||
(!is_pair(cdr(clause))) || /* leave the test->result case for later */
(cadr(clause) == sc->feed_to_symbol))
return(return_false(sc, clause, __func__, __LINE__));
last_clause = clause;
+ top->v[branches + COND_O1].o1 = sc->opts[sc->pc];
opc = alloc_opo(sc, car_x);
oo_set_type_0(opc);
- if ((car(clause) == sc->else_symbol) ||
- (car(clause) == sc->T))
- {
- opt_info *opb;
- opb = alloc_opo(sc, clause);
- opb->v[0].fb = opt_b_t;
- oo_set_type_0(opb);
- }
- else
+ opc->v[4].o1 = sc->opts[sc->pc];
+
+ if (!bool_optimize(sc, clause))
+ return(return_false(sc, clause, __func__, __LINE__));
+
+ for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp))
{
- if (!bool_optimize(sc, clause))
- return(return_false(sc, clause, __func__, __LINE__));
+ opc->v[blen + COND_CLAUSE_O1].o1 = sc->opts[sc->pc];
+ if (!cell_optimize(sc, cp))
+ return(return_false(sc, cp, __func__, __LINE__));
}
- for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp))
- if (!cell_optimize(sc, cp))
- return(return_false(sc, cp, __func__, __LINE__));
if (!is_null(cp))
return(return_false(sc, cp, __func__, __LINE__));
opc->v[1].i = blen;
if (max_blen < blen) max_blen = blen;
- opc->v[3].i = sc->pc - 1;
- opc->v[5].obj = (void *)top;
- opc->v[0].fp = opt_cond_clause;
+ opc->v[0].fp = opt_cond; /* a placeholder */
}
- top->v[1].i = sc->pc - 1;
- top->v[0].fp = opt_cond;
if (branches == 1)
{
opt_info *o1;
@@ -62480,24 +62567,26 @@ static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x)
(car(last_clause) == sc->T)))
{
opt_info *o1;
- o1 = sc->opts[start_pc];
- top->v[3].i = o1->v[3].i + 2;
+ top->v[6].o1 = top->v[COND_O1].o1->v[COND_CLAUSE_O1].o1;
+ top->v[7].o1 = top->v[1 + COND_O1].o1->v[COND_CLAUSE_O1].o1;
+
+ o1 = sc->opts[start_pc + 1];
+ top->v[4].o1 = o1;
+ top->v[5].fb = o1->v[0].fb;
top->v[0].fp = opt_cond_2;
+ return(oo_set_type_0(top));
}
}
+ top->v[2].i = branches;
+ top->v[0].fp = opt_cond;
return(oo_set_type_0(top));
}
/* -------- cell_and|or -------- */
static s7_pointer opt_and_pp(opt_info *o)
{
- o->sc->pc++;
if (o->v[11].fp(o->v[10].o1) == o->sc->F)
- {
- o->sc->pc = o->v[1].i;
- return(o->sc->F);
- }
- o->sc->pc++;
+ return(o->sc->F);
return(o->v[9].fp(o->v[8].o1));
}
@@ -62509,18 +62598,10 @@ static s7_pointer opt_and_any_p(opt_info *o)
for (i = 0; i < o->v[1].i; i++)
{
opt_info *o1;
- /* o1 = o->sc->opts[++o->sc->pc]; *//* 3..15? */
- o->sc->pc++;
o1 = o->v[i + 3].o1;
-#if S7_DEBUGGING
- if (o1 != o->sc->opts[o->sc->pc]) fprintf(stderr, "and o1 != opts\n");
-#endif
val = o1->v[0].fp(o1);
if (val == o->sc->F)
- {
- o->sc->pc = o->v[2].i;
- return(o->sc->F);
- }
+ return(o->sc->F);
}
return(val);
}
@@ -62528,14 +62609,9 @@ static s7_pointer opt_and_any_p(opt_info *o)
static s7_pointer opt_or_pp(opt_info *o)
{
s7_pointer val;
- o->sc->pc++;
val = o->v[11].fp(o->v[10].o1);
if (val != o->sc->F)
- {
- o->sc->pc = o->v[1].i;
- return(val);
- }
- o->sc->pc++;
+ return(val);
return(o->v[9].fp(o->v[8].o1));
}
@@ -62546,24 +62622,14 @@ static s7_pointer opt_or_any_p(opt_info *o)
{
s7_pointer val;
opt_info *o1;
- o->sc->pc++;
o1 = o->v[i + 3].o1;
-#if S7_DEBUGGING
- if (o1 != o->sc->opts[o->sc->pc]) fprintf(stderr, "or o1 != opts\n");
-#endif
- /* o1 = o->sc->opts[++o->sc->pc]; */ /* 3..15? */
val = o1->v[0].fp(o1);
if (val != o->sc->F)
- {
- o->sc->pc = o->v[2].i;
- return(val);
- }
+ return(val);
}
return(o->sc->F);
}
-/* static s7_pointer b_to_p_0(opt_info *o) {return((o->v[0].fb(o)) ? o->sc->T : o->sc->F);} */
-
static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
opt_info *opc;
@@ -62581,8 +62647,6 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len)
if (!cell_optimize(sc, cddr(car_x)))
return(return_false(sc, car_x, __func__, __LINE__));
opc->v[9].fp = opc->v[8].o1->v[0].fp;
-
- opc->v[1].i = sc->pc - 1;
return(oo_set_type_0(opc));
}
@@ -62599,8 +62663,6 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len)
if (!cell_optimize(sc, p))
return(return_false(sc, car_x, __func__, __LINE__));
}
-
- opc->v[2].i = sc->pc - 1;
return(oo_set_type_0(opc));
}
return(return_false(sc, car_x, __func__, __LINE__));
@@ -62609,166 +62671,99 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len)
/* -------- cell_if -------- */
static s7_pointer opt_if_bp(opt_info *o)
{
- o->sc->pc++;
if (o->v[3].fb(o->v[2].o1))
- {
- o->sc->pc++;
- return(o->v[5].fp(o->v[4].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[5].fp(o->v[4].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_bp_nr(opt_info *o)
{
- o->sc->pc++;
if (o->v[3].fb(o->v[2].o1))
- {
- o->sc->pc++;
- return(o->v[5].fp(o->v[4].o1));
- }
+ return(o->v[5].fp(o->v[4].o1));
return(NULL);
}
static s7_pointer opt_if_bp_pb(opt_info *o) /* p_to_b at outer */
{
- o->sc->pc++;
if (o->v[3].fp(o->v[2].o1) != o->sc->F) /* this is p_to_b expanded and moved to o[3] */
- {
- o->sc->pc++;
- return(o->v[5].fp(o->v[4].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[5].fp(o->v[4].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_bp_ii_fc(opt_info *o)
{
- o->sc->pc += 2;
if (o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i))
- {
- o->sc->pc++;
- return(o->v[5].fp(o->v[4].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[5].fp(o->v[4].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_nbp(opt_info *o)
{
- o->sc->pc++;
if (!o->v[5].fb(o->v[4].o1))
- {
- o->sc->pc++;
- return(o->v[11].fp(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fp(o->v[10].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_nbp_s(opt_info *o)
{
if (!(o->v[2].b_p_f(slot_value(o->v[3].p))))
- {
- o->sc->pc += 2;
- return(o->v[11].fp(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fp(o->v[10].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */
{
if (!(o->v[3].b_pp_f(slot_value(o->v[2].p), o->v[4].p)))
- {
- o->sc->pc += 2;
- return(o->v[11].fp(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fp(o->v[10].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */
{
if (!(o->v[3].b_7pp_f(o->sc, slot_value(o->v[2].p), o->v[4].p)))
- {
- o->sc->pc += 2;
- return(o->v[11].fp(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fp(o->v[10].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */
{
if (!(o->v[3].b_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[4].p)))))
- {
- o->sc->pc += 2;
- return(o->v[11].fp(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fp(o->v[10].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_nbp_fs(opt_info *o)
{
- o->sc->pc += 2;
if (!(o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) /* b_pi_fs */
- {
- o->sc->pc++;
- return(o->v[11].fp(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fp(o->v[10].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_nbp_fs_nr(opt_info *o)
{
- /* not o->sc->pc += 2 as above because sc->pc is preset to 2 (far) below */
if (!(o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) /* b_pi_fs */
- {
- o->sc->pc++;
- return(o->v[11].fp(o->v[10].o1));
- }
+ return(o->v[11].fp(o->v[10].o1));
return(NULL);
}
static s7_pointer opt_if_nbp_sf(opt_info *o)
{
- o->sc->pc += 2;
if (!(o->v[2].b_pp_f(slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1)))) /* b_pp_sf */
- {
- o->sc->pc++;
- return(o->v[11].fp(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fp(o->v[10].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_nbp_7sf(opt_info *o)
{
- o->sc->pc += 2;
if (!(o->v[2].b_7pp_f(o->sc, slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1)))) /* b_7pp_sf */
- {
- o->sc->pc++;
- return(o->v[11].fp(o->v[10].o1));
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[11].fp(o->v[10].o1));
return(o->sc->unspecified);
}
static s7_pointer opt_if_bpp(opt_info *o)
{
- o->sc->pc++;
if (o->v[5].fb(o->v[4].o1))
- {
- s7_pointer val;
- o->sc->pc++;
- val = o->v[9].fp(o->v[8].o1);
- o->sc->pc = o->v[3].i;
- return(val);
- }
- o->sc->pc = o->v[1].i;
+ return(o->v[9].fp(o->v[8].o1));
return(o->v[11].fp(o->v[10].o1));
}
@@ -62787,7 +62782,6 @@ static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len)
top = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x)))
{
- opc->v[1].i = sc->pc - 1;
opc->v[10].o1 = top;
opc->v[11].fp = top->v[0].fp;
@@ -62867,7 +62861,6 @@ static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len)
top = sc->opts[sc->pc];
if (cell_optimize(sc, cddr(car_x)))
{
- opc->v[1].i = sc->pc - 1;
opc->v[2].o1 = bop;
opc->v[4].o1 = top;
opc->v[5].fp = top->v[0].fp;
@@ -62904,10 +62897,8 @@ static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len)
opt_info *o3;
o3 = sc->opts[sc->pc];
opc->v[0].fp = opt_if_bpp;
- opc->v[1].i = sc->pc;
if (cell_optimize(sc, cdddr(car_x)))
{
- opc->v[3].i = sc->pc - 1;
opc->v[4].o1 = bop;
opc->v[5].fb = bop->v[0].fb;
opc->v[8].o1 = top;
@@ -62935,43 +62926,56 @@ static bool case_memv(s7_scheme *sc, s7_pointer x, s7_pointer y)
return(false);
}
-static s7_pointer opt_case(opt_info *o)
+#define CASE_O1 3
+#define CASE_SEL 2
+#define CASE_CLAUSE_O1 4
+#define CASE_CLAUSE_KEYS 2
+
+static s7_pointer case_value(s7_scheme *sc, opt_info *top, opt_info *o)
{
opt_info *o1;
- o->v[2].p = o->sc->unspecified;
- o1 = o->sc->opts[++o->sc->pc];
- o->v[4].p = o1->v[0].fp(o1);
- while (o->sc->pc < o->v[1].i)
+ int32_t i, len;
+ len = o->v[1].i - 1;
+ for (i = 0; i < len; i++)
{
- o1 = o->sc->opts[++o->sc->pc]; /* 5..15? */
+ o1 = o->v[i + CASE_CLAUSE_O1].o1;
o1->v[0].fp(o1);
}
- return(o->v[2].p);
+ o1 = o->v[i + CASE_CLAUSE_O1].o1;
+ return(o1->v[0].fp(o1));
}
-static s7_pointer opt_case_clause(opt_info *o)
+static s7_pointer opt_case(opt_info *o)
{
- /* top->v[2].p gets result, top->i1 is end index, top->v[4].p is selector, o->v[3].i is end of current clause, o->v[1].i = body len */
- opt_info *top;
- top = (opt_info *)(o->v[5].obj);
- if ((o->v[2].p == o->sc->else_symbol) ||
- (case_memv(o->sc, top->v[4].p, o->v[2].p)))
- return(case_value(o));
- o->sc->pc = o->v[3].i;
+ opt_info *o1;
+ int32_t ctr, lim;
+ s7_pointer selector;
+
+ o1 = o->v[CASE_SEL].o1;
+ selector = o1->v[0].fp(o1);
+ lim = o->v[1].i;
+
+ for (ctr = CASE_O1; ctr < lim; ctr++)
+ {
+ o1 = o->v[ctr].o1;
+ if ((o1->v[CASE_CLAUSE_KEYS].p == o->sc->else_symbol) ||
+ (case_memv(o->sc, selector, o1->v[CASE_CLAUSE_KEYS].p)))
+ return(case_value(o->sc, o, o1));
+ }
return(o->sc->unspecified);
}
static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x)
{
- /* top->v[2].p gets result, top->v[1].i is end index, clause->v[3].i is end of current clause,
- * clause->v[1].i = clause result len, clause->v[5].obj = top
- */
+ /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */
opt_info *top;
top = alloc_opo(sc, car_x);
+ top->v[CASE_SEL].o1 = sc->opts[sc->pc];
if (cell_optimize(sc, cdr(car_x))) /* selector */
{
s7_pointer p;
- for (p = cddr(car_x); is_pair(p); p = cdr(p))
+ int32_t ctr;
+ for (ctr = CASE_O1, p = cddr(car_x); (is_pair(p)) && (ctr < 15); ctr++, p = cdr(p))
{
opt_info *opc;
s7_pointer clause, cp;
@@ -62984,33 +62988,35 @@ static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x)
return(return_false(sc, clause, __func__, __LINE__));
opc = alloc_opo(sc, car_x);
+ top->v[ctr].o1 = opc;
if (car(clause) == sc->else_symbol)
{
if (!is_null(cdr(p)))
return(return_false(sc, clause, __func__, __LINE__));
- opc->v[2].p = sc->else_symbol;
+ opc->v[CASE_CLAUSE_KEYS].p = sc->else_symbol;
}
else
{
if (!s7_is_proper_list(sc, car(clause)))
return(return_false(sc, clause, __func__, __LINE__));
- opc->v[2].p = car(clause);
+ opc->v[CASE_CLAUSE_KEYS].p = car(clause);
+ }
+
+ for (blen = 0, cp = cdr(clause); (is_pair(cp)) && (blen < 12); blen++, cp = cdr(cp))
+ {
+ opc->v[blen + CASE_CLAUSE_O1].o1 = sc->opts[sc->pc];
+ if (!cell_optimize(sc, cp))
+ return(return_false(sc, cp, __func__, __LINE__));
}
-
- for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp))
- if (!cell_optimize(sc, cp))
- return(return_false(sc, cp, __func__, __LINE__));
if (!is_null(cp))
return(return_false(sc, cp, __func__, __LINE__));
opc->v[1].i = blen;
- opc->v[3].i = sc->pc - 1;
- opc->v[5].obj = (void *)top;
- opc->v[0].fp = opt_case_clause;
+ opc->v[0].fp = opt_case; /* just a placeholder I hope */
oo_set_type_0(opc);
}
if (!is_null(p))
return(return_false(sc, p, __func__, __LINE__));
- top->v[1].i = sc->pc - 1;
+ top->v[1].i = ctr;
top->v[0].fp = opt_case;
return(oo_set_type_0(top));
}
@@ -63018,34 +63024,35 @@ static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x)
}
/* -------- cell_let_temporarily -------- */
+
+#define LET_TEMP_O1 5
+
static s7_pointer opt_let_temporarily(opt_info *o)
{
opt_info *o1;
int32_t i, len;
s7_pointer result;
+
#if S7_DEBUGGING
if (cur_sc->stack_end >= cur_sc->stack_resize_trigger) fprintf(stderr, "%s[%d]: skipped stack resize\n", __func__, __LINE__);
#endif
- o1 = o->sc->opts[++o->sc->pc];
- o->v[4].p = slot_value(o->v[1].p); /* save and protect old value */
- gc_protect_direct(o->sc, o->v[4].p);
-
if (is_immutable_slot(o->v[1].p))
immutable_object_error(o->sc, set_elist_3(o->sc, immutable_error_string, o->sc->let_temporarily_symbol, slot_symbol(o->v[1].p)));
- slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */
+ o1 = o->v[4].o1;
+ o->v[3].p = slot_value(o->v[1].p); /* save and protect old value */
+ gc_protect_direct(o->sc, o->v[3].p);
+ slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */
len = o->v[2].i - 1;
for (i = 0; i < len; i++)
{
- o1 = o->sc->opts[++o->sc->pc]; /* 5..15? */
+ o1 = o->v[i + LET_TEMP_O1].o1;
o1->v[0].fp(o1);
}
- o1 = o->sc->opts[++o->sc->pc];
+ o1 = o->v[i + LET_TEMP_O1].o1;
result = o1->v[0].fp(o1);
-
- slot_set_value(o->v[1].p, o->v[4].p); /* restore old */
+ slot_set_value(o->v[1].p, o->v[3].p); /* restore old */
o->sc->stack_end -= 4;
-
return(result);
}
@@ -63056,7 +63063,8 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le
return(return_false(sc, car_x, __func__, __LINE__));
vars = cadr(car_x);
- if ((is_proper_list_1(sc, vars)) && /* just one var for now */
+ if ((len < 10) &&
+ (is_proper_list_1(sc, vars)) && /* just one var for now */
(is_proper_list_2(sc, car(vars))) && /* and var is (sym val) */
(is_symbol(caar(vars))) &&
(!is_immutable(caar(vars))) &&
@@ -63064,16 +63072,22 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le
{
s7_pointer p;
opt_info *opc;
+ int32_t i;
opc = alloc_opo(sc, car_x);
opc->v[1].p = symbol_to_slot(sc, caar(cadr(car_x)));
if (!is_slot(opc->v[1].p))
return(return_false(sc, car_x, __func__, __LINE__));
+ opc->v[4].o1 = sc->opts[sc->pc];
if (!cell_optimize(sc, cdar(cadr(car_x))))
return(return_false(sc, car_x, __func__, __LINE__));
- for (p = cddr(car_x); is_pair(p); p = cdr(p))
- if (!cell_optimize(sc, p))
- return(return_false(sc, car_x, __func__, __LINE__));
+
+ for (i = LET_TEMP_O1, p = cddr(car_x); is_pair(p); i++, p = cdr(p))
+ {
+ opc->v[i].o1 = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ return(return_false(sc, car_x, __func__, __LINE__));
+ }
opc->v[2].i = len - 2;
opc->v[0].fp = opt_let_temporarily;
@@ -63084,12 +63098,30 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le
/* -------- cell_do -------- */
+static void let_set_has_pending_value(s7_pointer lt)
+{
+ s7_pointer vp;
+ for (vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp))
+ {
+ if (!slot_pending_value_unchecked(vp))
+ slot_set_pending_value(vp, eof_object);
+ else slot_set_has_pending_value(vp);
+ }
+}
+
+static void let_clear_has_pending_value(s7_pointer lt)
+{
+ s7_pointer vp;
+ for (vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp))
+ slot_clear_has_pending_value(vp);
+}
+
static s7_pointer opt_do_any(opt_info *o)
{
/* o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index */
- opt_info *o1, *ostart;
- int32_t loop, i;
+ opt_info *o1, *ostart, *body, *inits, *steps, *results;
+ int32_t i, k;
s7_pointer vp, old_e, result;
s7_scheme *sc;
@@ -63099,14 +63131,19 @@ static s7_pointer opt_do_any(opt_info *o)
sc->envir = T_Let(o->v[2].p);
/* init */
- for (vp = let_slots(sc->envir); tis_slot(vp); vp = next_slot(vp))
+ inits = o->v[7].o1;
+ for (k = 0, vp = let_slots(sc->envir); tis_slot(vp); k++, vp = next_slot(vp))
{
- o1 = sc->opts[++sc->pc];
+ o1 = inits->v[k].o1;
slot_set_value(vp, o1->v[0].fp(o1));
}
- loop = ++sc->pc;
- ostart = sc->opts[loop];
+ ostart = o->v[12].o1;
+ body = o->v[10].o1;
+ results = o->v[11].o1;
+ steps = o->v[13].o1;
+ let_set_has_pending_value(sc->envir);
+
while (true)
{
/* end */
@@ -63116,33 +63153,30 @@ static s7_pointer opt_do_any(opt_info *o)
/* body */
for (i = 0; i < o->v[3].i; i++)
{
- o1 = sc->opts[++sc->pc];
+ o1 = body->v[i].o1;
o1->v[0].fp(o1);
}
/* step (let not let*) */
- for (vp = let_slots(sc->envir); tis_slot(vp); vp = next_slot(vp))
+ for (k = 0, vp = let_slots(sc->envir); tis_slot(vp); k++, vp = next_slot(vp))
if (has_stepper(vp))
{
- o1 = sc->opts[++sc->pc];
- slot_set_pending_value(vp, o1->v[0].fp(o1));
+ o1 = steps->v[k].o1;
+ slot_simply_set_pending_value(vp, o1->v[0].fp(o1));
}
for (vp = let_slots(sc->envir); tis_slot(vp); vp = next_slot(vp))
if (has_stepper(vp))
slot_set_value(vp, slot_pending_value(vp));
-
- sc->pc = loop;
}
- sc->pc = o->v[1].i;
/* result */
result = sc->T;
for (i = 0; i < o->v[4].i; i++)
{
- o1 = sc->opts[++sc->pc];
+ o1 = results->v[i].o1;
result = o1->v[0].fp(o1);
}
- sc->pc = o->v[5].i;
+ let_clear_has_pending_value(sc->envir);
unstack(sc);
sc->envir = old_e;
return(result);
@@ -63151,8 +63185,8 @@ static s7_pointer opt_do_any(opt_info *o)
static s7_pointer opt_do_step_1(opt_info *o)
{
/* 1 stepper (multi inits perhaps), 1 body, 1 rtn */
- opt_info *o1, *ostart, *ostep;
- int32_t loop;
+ opt_info *o1, *ostart, *ostep, *inits, *body;
+ int32_t k;
s7_pointer vp, old_e, result, stepper = NULL;
s7_scheme *sc;
@@ -63162,28 +63196,25 @@ static s7_pointer opt_do_step_1(opt_info *o)
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = T_Let(o->v[2].p);
- for (vp = let_slots(sc->envir); tis_slot(vp); vp = next_slot(vp))
+ inits = o->v[7].o1;
+ for (k = 0, vp = let_slots(sc->envir); tis_slot(vp); k++, vp = next_slot(vp))
{
- o1 = sc->opts[++sc->pc];
+ o1 = inits->v[k].o1;
slot_set_value(vp, o1->v[0].fp(o1));
if (has_stepper(vp)) stepper = vp;
}
- loop = ++sc->pc;
- ostart = sc->opts[loop];
+ ostart = o->v[12].o1;
+ body = o->v[10].o1;
+
while (true)
{
if (ostart->v[0].fb(ostart)) break;
- o1 = sc->opts[++sc->pc];
- o1->v[0].fp(o1);
- sc->pc++;
+ body->v[0].fp(body);
slot_set_value(stepper, ostep->v[0].fp(ostep));
- sc->pc = loop;
}
- sc->pc = o->v[1].i;
- o1 = sc->opts[++sc->pc];
+ o1 = o->v[11].o1;
result = o1->v[0].fp(o1);
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(result);
@@ -63191,44 +63222,41 @@ static s7_pointer opt_do_step_1(opt_info *o)
static s7_pointer opt_do_no_vars(opt_info *o)
{
- /* no vars, no return, o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index */
+ /* no vars, no return, o->v[2].p=frame, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length=0, o->v[5].i=end index, 6=end test */
opt_info *ostart;
- int32_t loop, len;
+ int32_t len;
s7_pointer old_e;
s7_scheme *sc;
+ bool (*fb)(opt_info *o);
sc = o->sc;
old_e = sc->envir;
push_stack_no_let_no_code(sc, OP_GC_PROTECT, old_e);
sc->envir = o->v[2].p;
len = o->v[3].i;
+ ostart = o->v[6].o1;
+ fb = ostart->v[0].fb;
- loop = ++sc->pc;
- ostart = sc->opts[loop];
- if (len == 0)
+ if (len == 0) /* titer */
{
- while (true)
- {
- if (ostart->v[0].fb(ostart)) break;
- sc->pc = loop;
- }
+ while (true) {if (fb(ostart)) break;}
}
else
{
- while (true)
+ opt_info *body;
+ body = o->v[7].o1;
+ while (true) /* tshoot, tfft */
{
int32_t i;
- if (ostart->v[0].fb(ostart)) break;
+ if (fb(ostart)) break;
for (i = 0; i < len; i++)
{
opt_info *o1;
- o1 = sc->opts[++sc->pc];
+ o1 = body->v[i].o1;
o1->v[0].fp(o1);
}
- sc->pc = loop;
}
}
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(sc->T);
@@ -63237,8 +63265,7 @@ static s7_pointer opt_do_no_vars(opt_info *o)
static s7_pointer opt_do_1(opt_info *o)
{
/* 1 var, 1 expr, no return */
- opt_info *o1, *ostart, *ostep; /* o->v[2].p=frame, o->v[5].i=end index */
- int32_t loop;
+ opt_info *o1, *ostart, *ostep, *body; /* o->v[2].p=frame, o->v[5].i=end index */
s7_pointer vp, old_e;
s7_scheme *sc;
sc = o->sc;
@@ -63249,16 +63276,15 @@ static s7_pointer opt_do_1(opt_info *o)
ostep = o->v[9].o1;
vp = let_slots(o->v[2].p);
- o1 = sc->opts[++sc->pc];
+ o1 = o->v[11].o1;
slot_set_value(vp, o1->v[0].fp(o1));
-
- loop = ++sc->pc;
- ostart = sc->opts[loop];
+ ostart = o->v[12].o1;
+ body = o->v[10].o1;
if ((o->v[8].i == 1) &&
(is_t_integer(slot_value(vp))))
{
- if (ostep->v[0].fp == opt_p_ii_ss_add)
+ if (ostep->v[0].fp == opt_p_ii_ss_add) /* tmap */
{
s7_pointer step_val;
step_val = make_mutable_integer(sc, integer(slot_value(vp)));
@@ -63266,12 +63292,9 @@ static s7_pointer opt_do_1(opt_info *o)
while (true)
{
if (ostart->v[0].fb(ostart)) break;
- o1 = sc->opts[++sc->pc];
- o1->v[0].fp(o1);
+ body->v[0].fp(body);
integer(step_val) = opt_i_ii_ss_add(ostep);
- sc->pc = loop;
}
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(sc->T);
@@ -63279,22 +63302,17 @@ static s7_pointer opt_do_1(opt_info *o)
else
{
#if S7_DEBUGGING && (0)
- fprintf(stderr, "%s: not add: %s\n", __func__, DISPLAY(o->vexpr));
+ fprintf(stderr, "%s: not add: %s\n", __func__, display(o->expr));
#endif
o->v[8].i = 2;
}
}
-
- while (true)
+ while (true) /* s7test tref */
{
if (ostart->v[0].fb(ostart)) break;
- o1 = sc->opts[++sc->pc];
- o1->v[0].fp(o1);
- sc->pc++;
+ body->v[0].fp(body);
slot_set_value(vp, ostep->v[0].fp(ostep));
- sc->pc = loop;
}
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(sc->T);
@@ -63303,8 +63321,8 @@ static s7_pointer opt_do_1(opt_info *o)
static s7_pointer opt_do_n(opt_info *o)
{
/* 1 var, no return */
- opt_info *o1, *ostart, *ostep; /* o->v[2].p=frame, o->v[3].i=body length, o->v[5].i=end index */
- int32_t loop, len;
+ opt_info *o1, *ostart, *ostep, *body; /* o->v[2].p=frame, o->v[3].i=body length, o->v[5].i=end index */
+ int32_t len;
s7_pointer vp, old_e;
s7_scheme *sc;
sc = o->sc;
@@ -63316,44 +63334,37 @@ static s7_pointer opt_do_n(opt_info *o)
len = o->v[3].i;
vp = let_slots(o->v[2].p);
- o1 = sc->opts[++sc->pc];
+ o1 = o->v[11].o1;
slot_set_value(vp, o1->v[0].fp(o1));
+ ostart = o->v[12].o1;
+ body = o->v[7].o1;
- loop = ++sc->pc;
- ostart = sc->opts[loop];
- if (len == 2)
+ if (len == 2) /* tmac tshoot */
{
opt_info *e1, *e2;
- e1 = o->v[10].o1;
- e2 = o->v[11].o1;
+ e1 = body->v[0].o1;
+ e2 = body->v[1].o1;
while (true)
{
if (ostart->v[0].fb(ostart)) break;
- sc->pc++;
e1->v[0].fp(e1);
- sc->pc++;
e2->v[0].fp(e2);
- sc->pc++;
slot_set_value(vp, ostep->v[0].fp(ostep));
- sc->pc = loop;
}
}
else
{
- while (!ostart->v[0].fb(ostart))
+ while (!ostart->v[0].fb(ostart)) /* tfft teq */
{
int32_t i;
for (i = 0; i < len; i++)
{
- o1 = sc->opts[++sc->pc];
+ o1 = body->v[i].o1;
o1->v[0].fp(o1);
}
- sc->pc++;
slot_set_value(vp, ostep->v[0].fp(ostep));
- sc->pc = loop;
}
}
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(sc->T);
@@ -63362,8 +63373,8 @@ static s7_pointer opt_do_n(opt_info *o)
static s7_pointer opt_dotimes_2(opt_info *o)
{
/* 1 var, no return */
- opt_info *o1; /* o->v[2].p=frame, o->v[3].i=body length, o->v[4].i=return length, o->v[5].i=end index, v6.i=end if int32_t */
- int32_t loop, len;
+ opt_info *o1, *body; /* o->v[2].p=frame, o->v[3].i=body length, o->v[4].i=return length=0, o->v[5].i=end index, v6.i=end, v7=init */
+ int32_t len;
s7_int end;
s7_pointer vp, old_e;
s7_scheme *sc;
@@ -63379,40 +63390,35 @@ static s7_pointer opt_dotimes_2(opt_info *o)
end = integer(slot_value(let_dox_slot2(o->v[2].p)));
else end = o->v[6].i;
- o1 = sc->opts[++sc->pc];
+ o1 = o->v[11].o1;
integer(vp) = integer(o1->v[0].fp(o1));
+ body = o->v[7].o1;
- loop = o->v[4].i - 1;
- if (len == 2)
+ if (len == 2) /* tmac tmisc */
{
opt_info *e1, *e2;
- loop++;
- e1 = o->v[10].o1;
- e2 = o->v[11].o1;
+ e1 = body->v[0].o1;
+ e2 = body->v[1].o1;
while (integer(vp) < end)
{
- sc->pc = loop;
e1->v[0].fp(e1);
- sc->pc++;
e2->v[0].fp(e2);
integer(vp)++;
}
}
else
{
- while (integer(vp) < end)
+ while (integer(vp) < end) /* tbig sg */
{
int32_t i;
- sc->pc = loop;
for (i = 0; i < len; i++)
{
- o1 = sc->opts[++sc->pc];
+ o1 = body->v[i].o1;
o1->v[0].fp(o1);
}
integer(vp)++;
}
}
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(sc->T);
@@ -63422,7 +63428,6 @@ static s7_pointer opt_do_list_simple(opt_info *o)
{
/* 1 var, 1 expr, no return, step by cdr, end=null? */
opt_info *o1; /* o->v[2].p=frame, o->v[5].i=end index */
- int32_t loop;
s7_pointer vp, old_e;
s7_scheme *sc;
s7_pointer (*fp)(opt_info *o);
@@ -63433,21 +63438,17 @@ static s7_pointer opt_do_list_simple(opt_info *o)
sc->envir = o->v[2].p;
vp = let_slots(o->v[2].p);
- o1 = sc->opts[++sc->pc];
+ o1 = o->v[11].o1;
slot_set_value(vp, o1->v[0].fp(o1));
-
- loop = sc->pc + 2;
- o1 = sc->opts[loop];
+ o1 = o->v[10].o1;
fp = o1->v[0].fp;
if (fp == opt_if_bp) fp = opt_if_bp_nr;
while (!is_null(slot_value(vp)))
{
- sc->pc = loop;
fp(o1);
slot_set_value(vp, cdr(slot_value(vp)));
}
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(sc->T);
@@ -63457,7 +63458,7 @@ static s7_pointer opt_do_very_simple(opt_info *o)
{
/* like simple but step can be direct, v[2].p is a let */
opt_info *o1;
- s7_int end, loop;
+ s7_int end;
s7_pointer vp, old_e;
s7_pointer (*f)(opt_info *o);
s7_scheme *sc;
@@ -63470,21 +63471,19 @@ static s7_pointer opt_do_very_simple(opt_info *o)
if (is_slot(let_dox_slot2_unchecked(o->v[2].p)))
end = integer(slot_value(let_dox_slot2(o->v[2].p)));
else end = o->v[3].i;
- o1 = sc->opts[++sc->pc];
+
+ o1 = o->v[11].o1;
integer(vp) = integer(o1->v[0].fp(o1));
- loop = o->v[4].i;
- sc->pc = loop;
- o1 = sc->opts[loop]; /* the body */
+ o1 = o->v[10].o1;
f = o1->v[0].fp;
- if (f == opt_p_pip_ssf)
+ if (f == opt_p_pip_ssf) /* tref.scm */
{
opt_info *o;
o = o1;
- o1 = sc->opts[++loop];
+ o1 = o->v[4].o1;
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)++;
}
@@ -63497,44 +63496,43 @@ static s7_pointer opt_do_very_simple(opt_info *o)
{
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) &&
+ if ((f == opt_set_p_i_f) && /* tvect.scm */
(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;
+ s7_int (*fi)(opt_info *o);
ival = make_mutable_integer(sc, integer(slot_value(o1->v[1].p)));
slot_set_value(o1->v[1].p, ival);
- o2 = sc->opts[++loop];
+ o2 = o1->v[5].o1; /* set_p_i_f: x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); */
+ fi = o2->v[0].fi;
while (integer(vp) < end)
{
- sc->pc = loop;
- integer(ival) = o2->v[0].fi(o2);
+ integer(ival) = fi(o2);
integer(vp)++;
}
slot_set_value(o1->v[1].p, make_integer(sc, integer(slot_value(o1->v[1].p))));
}
else
{
- if ((f == opt_d_7pid_ssf_nr) &&
+ if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */
(o1->v[4].d_7pid_f == float_vector_set_unchecked))
{
s7_pointer fv, ind;
opt_info *o2;
s7_double (*fd)(opt_info *o);
- o2 = sc->opts[++loop];
+ o2 = o1->v[10].o1;
fv = slot_value(o1->v[1].p);
ind = o1->v[2].p;
fd = o2->v[0].fd;
while (integer(vp) < end)
{
- sc->pc = loop;
float_vector_set_unchecked(sc, fv, integer(slot_value(ind)), fd(o2));
integer(vp)++;
}
@@ -63544,10 +63542,8 @@ static s7_pointer opt_do_very_simple(opt_info *o)
while (integer(vp) < end)
{
f(o1);
- sc->pc = loop;
integer(vp)++;
}}}}}
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(sc->T);
@@ -63569,14 +63565,14 @@ static s7_pointer opt_do_prepackaged(opt_info *o)
if (is_slot(let_dox_slot2_unchecked(o->v[2].p)))
end = integer(slot_value(let_dox_slot2(o->v[2].p)));
else end = o->v[3].i;
- o1 = sc->opts[++sc->pc];
+
+ o1 = o->v[11].o1;
integer(vp) = integer(o1->v[0].fp(o1));
o->v[6].p = vp;
o->v[1].i = end;
- o->v[7].fp(o);
+ o->v[7].fp(o); /* call opt_do_i|dpnr below */
- sc->pc = o->v[5].i;
unstack(sc);
sc->envir = old_e;
return(sc->T);
@@ -63585,21 +63581,16 @@ static s7_pointer opt_do_prepackaged(opt_info *o)
static s7_pointer opt_do_dpnr(opt_info *o)
{
opt_info *o1;
- int32_t loop;
s7_pointer vp;
s7_int end;
s7_double (*f)(opt_info *o);
- s7_scheme *sc;
- sc = o->sc;
end = o->v[1].i;
vp = o->v[6].p;
- loop = o->v[4].i;
- o1 = sc->opts[loop]; /* the body */
+ o1 = o->v[10].o1; /* the body */
f = o1->v[O_WRAP].fd;
while (integer(vp) < end)
{
- sc->pc = loop;
f(o1);
integer(vp)++;
}
@@ -63609,53 +63600,22 @@ static s7_pointer opt_do_dpnr(opt_info *o)
static s7_pointer opt_do_ipnr(opt_info *o)
{
opt_info *o1;
- int32_t loop;
s7_pointer vp;
s7_int end;
s7_int (*f)(opt_info *o);
- s7_scheme *sc;
- sc = o->sc;
end = o->v[1].i;
vp = o->v[6].p;
- loop = o->v[4].i;
- o1 = sc->opts[loop]; /* the body */
+ o1 = o->v[10].o1; /* the body */
f = o1->v[O_WRAP].fi;
while (integer(vp) < end)
{
- sc->pc = loop;
f(o1);
integer(vp)++;
}
return(NULL);
}
-static s7_pointer opt_do_setpif(opt_info *o)
-{
- opt_info *o1;
- int32_t loop;
- s7_pointer vp, val, slot;
- s7_int end, arg2;
- s7_scheme *sc;
- sc = o->sc;
- end = o->v[1].i;
- vp = o->v[6].p;
- loop = o->v[4].i;
- o1 = sc->opts[loop];
- arg2 = o->v[3].i;
- slot = o1->v[2].p;
-
- val = make_mutable_integer(sc, integer(slot_value(o1->v[1].p)));
- slot_set_value(o1->v[1].p, val);
- while (integer(vp) < end)
- {
- integer(val) = o1->v[4].i_ii_f(integer(slot_value(slot)), arg2);
- integer(vp)++;
- }
- clear_mutable_integer(val);
- return(NULL);
-}
-
static bool stop_is_safe(s7_scheme *sc, s7_pointer stop, s7_pointer body)
{
/* this could be folded into the cell_optimize traveral */
@@ -63684,14 +63644,15 @@ static bool tree_has_setters(s7_scheme *sc, s7_pointer tree)
static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_pointer var_list, bool *has_set);
+#define SIZE_O NUM_VUNIONS
+
static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
opt_info *opc;
- s7_pointer p, end, frame = NULL, old_e, slot, stop, ind, ind_step, var;
- int32_t i, var_len, body_len, body_index, step_len, rtn_len, step_pc;
+ s7_pointer p, end, frame = NULL, old_e, slot, stop, ind, ind_step;
+ int32_t i, k, var_len, body_len, body_index, step_len, rtn_len, step_pc, init_pc, end_test_pc;
bool has_set = false;
-
- /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY_80(car_x)); */
+ opt_info *init_o[SIZE_O], *step_o[SIZE_O], *body_o[SIZE_O], *return_o[SIZE_O];
if (len < 3)
return(return_false(sc, car_x, __func__, __LINE__));
@@ -63701,6 +63662,8 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
var_len = safe_list_length(cadr(car_x));
step_len = var_len;
body_len = len - 3;
+ if (body_len > SIZE_O)
+ return(return_false(sc, car_x, __func__, __LINE__));
end = caddr(car_x);
if (!is_pair(end))
return(return_false(sc, car_x, __func__, __LINE__));
@@ -63739,10 +63702,13 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
if (tis_slot(let_slots(frame)))
let_set_slots(frame, reverse_slots(sc, let_slots(frame)));
- for (p = cadr(car_x), slot = let_slots(frame); is_pair(p); p = cdr(p), slot = next_slot(slot))
+ /* inits */
+ init_pc = sc->pc;
+ for (k = 0, p = cadr(car_x), slot = let_slots(frame); (is_pair(p)) && (k < SIZE_O); k++, p = cdr(p), slot = next_slot(slot))
{
s7_pointer var;
var = car(p);
+ init_o[k] = sc->opts[sc->pc];
if (!cell_optimize(sc, cdr(var))) /* opt init in outer env */
return(return_false(sc, car_x, __func__, __LINE__));
if (is_pair(cddr(var)))
@@ -63795,7 +63761,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
(opt_arg_type(sc, cddr(var)) != init_type))
{
#if OPT_PRINT
- fprintf(stderr, "%s[%d]: init_type: %s, but opt_arg: %s\n", __func__, __LINE__, DISPLAY(init_type), DISPLAY(opt_arg_type(sc, cddr(var))));
+ fprintf(stderr, "%s[%d]: init_type: %s, but opt_arg: %s\n", __func__, __LINE__, display(init_type), display(opt_arg_type(sc, cddr(var))));
#endif
unstack(sc); /* not pop_stack! */
sc->envir = old_e;
@@ -63803,7 +63769,10 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
}
}
}
+ if (k != var_len) fprintf(stderr, "inits: %d %d\n", k, var_len);
+ /* end test */
+ end_test_pc = sc->pc;
if (!bool_optimize_nw(sc, end))
{
unstack(sc); /* not pop_stack! */
@@ -63872,18 +63841,18 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
}
}
- /* opt body */
+ /* body */
body_index = sc->pc;
- for (i = 3, p = cdddr(car_x); i < len; i++, p = cdr(p))
+ for (k = 0, i = 3, p = cdddr(car_x); i < len; k++, i++, p = cdr(p))
{
opt_info *start;
start = sc->opts[sc->pc];
+ body_o[k] = start;
if (i < 5) opc->v[i + 7].o1 = start;
if (!cell_optimize(sc, p))
break;
oo_idp_nr_fixup(start);
}
-
if (!is_null(p))
{
unstack(sc);
@@ -63894,17 +63863,17 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
/* we faked up sc->envir above, so s7_optimize_1 (float_optimize) isn't safe here
* this means if clm nested loops get here, they aren't fully optimized -- fallback into dox would be better
*/
+ /* steps */
step_pc = sc->pc;
- for (p = cadr(car_x); is_pair(p); p = cdr(p))
+ for (k = 0, p = cadr(car_x); is_pair(p); k++, p = cdr(p))
{
s7_pointer var;
var = car(p);
- opc->v[9].i = sc->pc;
+ step_o[k] = sc->opts[sc->pc];
if ((is_pair(cddr(var))) &&
(!cell_optimize(sc, cddr(var))))
break;
}
-
if (!is_null(p))
{
unstack(sc);
@@ -63912,35 +63881,48 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
return(return_false(sc, car_x, __func__, __LINE__));
}
- rtn_len = 0;
- opc->v[1].i = sc->pc - 1;
+ /* result */
+ /* rtn_len = 0; */
if (!is_list(cdr(end)))
{
unstack(sc);
sc->envir = old_e;
return(return_false(sc, car_x, __func__, __LINE__));
}
- for (p = cdr(end); is_pair(p); p = cdr(p), rtn_len++)
- if (!cell_optimize(sc, p))
- break;
+ for (rtn_len = 0, p = cdr(end); (is_pair(p)) && (rtn_len < SIZE_O); p = cdr(p), rtn_len++)
+ {
+ return_o[rtn_len] = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ break;
+ }
if (!is_null(p))
{
unstack(sc);
sc->envir = old_e;
return(return_false(sc, car_x, __func__, __LINE__));
}
+
opc->v[2].p = frame;
opc->v[3].i = len - 3; /* body_len */
opc->v[4].i = rtn_len;
- opc->v[5].i = sc->pc - 1;
opc->v[9].o1 = sc->opts[step_pc];
sc->envir = old_e;
if ((var_len == 0) && (rtn_len == 0))
{
+ opt_info *body;
+ opc->v[6].o1 = sc->opts[end_test_pc];
opc->v[0].fp = opt_do_no_vars;
+ if (body_len > 0)
+ {
+ body = alloc_opo(sc, car_x);
+ for (k = 0; k < body_len; k++)
+ body->v[k].o1 = body_o[k];
+ opc->v[7].o1 = body;
+ }
return(oo_set_type_0(opc));
}
+
opc->v[8].i = 0;
if (body_len == 1)
{
@@ -63955,19 +63937,66 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
}
if ((var_len != 1) || (step_len != 1) || (rtn_len != 0))
{
+ opt_info *inits;
+
opc->v[0].fp = ((step_len == 1) && (body_len == 1) && (rtn_len == 1)) ? opt_do_step_1 : opt_do_any;
/* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) tmat */
+ opc->v[12].o1 = sc->opts[end_test_pc];
+
+ inits = alloc_opo(sc, car_x);
+ for (k = 0; k < var_len; k++)
+ inits->v[k].o1 = init_o[k];
+ opc->v[7].o1 = inits;
+
+ if (opc->v[0].fp == opt_do_any)
+ {
+ opt_info *body, *result, *step;
+
+ body = alloc_opo(sc, car_x);
+ for (k = 0; k < body_len; k++)
+ body->v[k].o1 = body_o[k];
+ opc->v[10].o1 = body;
+
+ result = alloc_opo(sc, car_x);
+ for (k = 0; k < rtn_len; k++)
+ result->v[k].o1 = return_o[k];
+ opc->v[11].o1 = result;
+
+ step = alloc_opo(sc, car_x);
+ for (k = 0; k < var_len; k++)
+ step->v[k].o1 = step_o[k];
+ opc->v[13].o1 = step;
+ }
+ else
+ {
+ opc->v[10].o1 = sc->opts[body_index];
+ opc->v[11].o1 = return_o[0];
+ }
+
return(oo_set_type_0(opc));
}
opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n;
-
- var = caadr(car_x);
- ind = car(var);
- ind_step = caddr(var);
+ p = caadr(car_x);
+ ind = car(p);
+ ind_step = caddr(p);
end = caaddr(car_x);
slot = let_slots(frame);
+ if (body_len == 1)
+ opc->v[10].o1 = sc->opts[body_index];
+ else
+ {
+ opt_info *body;
+ body = alloc_opo(sc, car_x);
+ for (k = 0; k < body_len; k++)
+ body->v[k].o1 = body_o[k];
+ opc->v[7].o1 = body;
+ }
+ opc->v[11].o1 = sc->opts[init_pc];
+ opc->v[12].o1 = sc->opts[end_test_pc];
+ opc->v[13].o1 = sc->opts[step_pc];
+
if ((is_pair(end)) && /* (= i len|100) */
(cadr(end) == ind) &&
(is_pair(ind_step))) /* (+ i 1) */
@@ -63991,12 +64020,9 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
opc->v[0].fp = opt_do_very_simple;
if (is_t_integer(caddr(end)))
opc->v[3].i = integer(caddr(end));
-
o1 = sc->opts[body_index];
- /* v0..v7 are in use */
- if (o1->v[0].fp == d_to_p_nr)
+ if (o1->v[0].fp == d_to_p_nr) /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */
{
- /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */
opc->v[0].fp = opt_do_prepackaged;
opc->v[7].fp = opt_do_dpnr;
}
@@ -64007,13 +64033,8 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
opc->v[0].fp = opt_do_prepackaged;
opc->v[7].fp = opt_do_ipnr;
}
- else
- {
- if (o1->v[0].fp == opt_set_p_i_fo1)
- {
- opc->v[0].fp = opt_do_prepackaged;
- opc->v[7].fp = opt_do_setpif;
- }}}}
+ }
+ }
else
{
opc->v[0].fp = opt_dotimes_2;
@@ -64040,7 +64061,8 @@ static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len)
{
opcode_t op;
s7_pointer func;
- func = slot_value(global_slot(car(car_x)));
+ /* func = slot_value(global_slot(car(car_x))); */
+ func = lookup_global(sc, car(car_x));
op = (opcode_t)syntax_opcode(func);
switch (op)
{
@@ -64100,6 +64122,7 @@ static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len)
static bool float_optimize(s7_scheme *sc, s7_pointer expr)
{
s7_pointer car_x, head;
+
#if (WITH_GMP)
return(return_false(sc, car_x, __func__, __LINE__));
#endif
@@ -64190,7 +64213,7 @@ static bool float_optimize(s7_scheme *sc, s7_pointer expr)
static bool int_optimize(s7_scheme *sc, s7_pointer expr)
{
s7_pointer car_x, head;
- /* fprintf(stderr, "%s: %s\n", __func__, DISPLAY(expr)); */
+ /* fprintf(stderr, "%s: %s\n", __func__, display(expr)); */
#if (WITH_GMP)
return(return_false(sc, car_x, __func__, __LINE__));
#endif
@@ -64270,7 +64293,7 @@ static bool int_optimize(s7_scheme *sc, s7_pointer expr)
static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
{
s7_pointer car_x, head;
- /* fprintf(stderr, "%s: %s, %d\n", __func__, DISPLAY(expr), sc->pc); */
+ /* fprintf(stderr, "%s: %s, %d\n", __func__, display(expr), sc->pc); */
car_x = car(expr);
if (!is_pair(car_x)) /* wrap constants/symbols */
@@ -64343,10 +64366,7 @@ static bool cell_optimize(s7_scheme *sc, s7_pointer expr)
opc->v[O_WRAP].fd = opc->v[0].fd;
opc->v[0].fp = d_to_p;
return(true);
- }
- }
- }
- }
+ }}}}
pc_fallback(sc, pstart);
}
@@ -64584,7 +64604,6 @@ static s7_function s7_bool_optimize(s7_scheme *sc, s7_pointer expr)
if (setjmp(sc->opt_exit) == 0)
{
sc->pc = 0;
- reset_opts(sc);
if (bool_optimize(sc, expr))
return(opt_bool_any);
}
@@ -64599,7 +64618,6 @@ s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr)
if (setjmp(sc->opt_exit) == 0)
{
sc->pc = 0;
- reset_opts(sc);
if (float_optimize(sc, expr))
return(opt_float_any);
}
@@ -64617,7 +64635,6 @@ static s7_function s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nr)
if (setjmp(sc->opt_exit) == 0)
{
sc->pc = 0;
- reset_opts(sc);
if (!no_int_opt(expr))
{
if (int_optimize(sc, expr))
@@ -64641,7 +64658,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); /* checked elsewhere */
+ set_no_cell_opt(expr); /* checked above */
}
return(NULL);
}
@@ -64668,7 +64685,6 @@ static s7_function s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nr)
if (setjmp(sc->opt_exit) == 0)
{
sc->pc = 0;
- reset_opts(sc);
if (cell_optimize(sc, expr))
return((nr) ? opt_cell_any_nr : opt_wrap_cell);
}
@@ -65012,7 +65028,7 @@ static bool op_for_each(s7_scheme *sc)
return(true);
}
}
- push_stack(sc, OP_FOR_EACH, sc->args, sc->code);
+ push_stack_direct(sc, OP_FOR_EACH, sc->args, sc->code);
sc->args = saved_args;
if (needs_copied_args(sc->code))
sc->args = copy_list(sc, sc->args);
@@ -65091,9 +65107,9 @@ static inline bool op_for_each_2(s7_scheme *sc)
sc->args = sc->nil;
return(true);
}
- push_stack(sc, OP_FOR_EACH_2, c, code);
+ push_stack_direct(sc, OP_FOR_EACH_2, sc->args, sc->code);
}
- else push_stack(sc, OP_FOR_EACH_3, c, code);
+ else push_stack_direct(sc, OP_FOR_EACH_3, sc->args, sc->code);
if (counter_capture(c) != sc->capture_let_counter)
{
new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), arg);
@@ -65369,7 +65385,7 @@ static bool op_map(s7_scheme *sc)
sc->x = cons(sc, x, sc->x);
}
sc->x = safe_reverse_in_place(sc, sc->x);
- push_stack(sc, OP_MAP_GATHER, sc->args, sc->code);
+ push_stack_direct(sc, OP_MAP_GATHER, sc->args, sc->code);
sc->args = sc->x;
sc->x = sc->nil;
@@ -65394,7 +65410,7 @@ static bool op_map_1(s7_scheme *sc)
sc->args = sc->nil;
return(true);
}
- push_stack(sc, OP_MAP_GATHER_1, args, code);
+ push_stack_direct(sc, OP_MAP_GATHER_1, sc->args, sc->code);
if (counter_capture(args) != sc->capture_let_counter)
{
new_frame_with_slot(sc, closure_let(code), sc->envir, car(closure_args(code)), x);
@@ -65446,9 +65462,9 @@ static bool op_map_2(s7_scheme *sc)
sc->args = sc->nil;
return(true);
}
- push_stack(sc, OP_MAP_GATHER_2, c, code);
+ push_stack_direct(sc, OP_MAP_GATHER_2, sc->args, sc->code);
}
- else push_stack(sc, OP_MAP_GATHER_3, c, code);
+ else push_stack_direct(sc, OP_MAP_GATHER_3, sc->args, sc->code);
if (counter_capture(c) != sc->capture_let_counter)
{
@@ -65474,7 +65490,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
s7_pointer x;
top = s7_stack_top(sc) - 1; /* stack_end - stack_start if negative, we're in big trouble */
#if SHOW_EVAL_OPS
- safe_print(fprintf(stderr, "splice %s %s\n", op_names[stack_op(sc->stack, top)], DISPLAY_80(sc->args)));
+ safe_print(fprintf(stderr, "splice %s %s\n", op_names[stack_op(sc->stack, top)], display_80(sc->args)));
#endif
switch (stack_op(sc->stack, top))
@@ -65526,11 +65542,8 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SSP_MV_1;
return(args);
- case OP_SAFE_C_SP_1:
- case OP_SAFE_CONS_SP_1:
- case OP_SAFE_ADD_SP_1:
- case OP_SAFE_SUBTRACT_SP_1:
- case OP_SAFE_MULTIPLY_SP_1:
+ case OP_SAFE_C_SP_1: case OP_SAFE_CONS_SP_1:
+ case OP_SAFE_ADD_SP_1: case OP_SAFE_SUBTRACT_SP_1: case OP_SAFE_MULTIPLY_SP_1:
stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SP_MV;
return(args);
@@ -65556,20 +65569,12 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
stack_element(sc->stack, top) = (s7_pointer)OP_C_AP_MV;
return(args);
- case OP_SAFE_CLOSURE_P_1:
- case OP_CLOSURE_P_1:
- stack_element(sc->stack, top) = (s7_pointer)OP_CLOSURE_P_MV;
- return(args);
-
- case OP_SAFE_CLOSURE_AP_1:
- case OP_CLOSURE_AP_1:
- stack_element(sc->stack, top) = (s7_pointer)OP_CLOSURE_AP_MV;
- return(args);
-
- case OP_SAFE_CLOSURE_PA_1:
- case OP_CLOSURE_PA_1:
- stack_element(sc->stack, top) = (s7_pointer)OP_CLOSURE_PA_MV;
- return(args);
+ case OP_SAFE_CLOSURE_P_1: case OP_CLOSURE_P_1:
+ case OP_SAFE_CLOSURE_AP_1: case OP_CLOSURE_AP_1:
+ case OP_SAFE_CLOSURE_PP_1: case OP_CLOSURE_PP_1:
+ case OP_SAFE_CLOSURE_PA_1: case OP_CLOSURE_PA_1: /* arity is 2, we have 2 args, this has to be an error (see optimize_func_dotted_args) */
+ case OP_SAFE_OR_UNSAFE_CLOSURE_3P_1: case OP_SAFE_OR_UNSAFE_CLOSURE_3P_2: case OP_SAFE_OR_UNSAFE_CLOSURE_3P_3:
+ return(s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, stack_code(sc->stack, top), sc->value)));
case OP_SAFE_C_PP_1:
stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_3_MV;
@@ -65601,8 +65606,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args)
/* look for errors here rather than glomming up the set! and let code. */
case OP_SET_SAFE: /* symbol is sc->code after pop */
case OP_SET1: /* (set! var (values 1 2 3)) */
- eval_error_with_caller2(sc, "~A: can't set '~A to ~S", 23, sc->set_symbol,
- stack_code(sc->stack, top), cons(sc, sc->values_symbol, args));
+ eval_error_with_caller2(sc, "~A: can't set '~A to ~S", 23, sc->set_symbol, stack_code(sc->stack, top), cons(sc, sc->values_symbol, args));
case OP_SET_PAIR_P_1:
eval_error(sc, "too many values to set! ~S", 26, cons(sc, sc->values_symbol, args));
@@ -65799,6 +65803,7 @@ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args)
* 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
+ * we can't optimize this to list if only constants/symbols in the list because a symbol's value can be #<no-values>
*/
/* splice out #<values>, (list-values (apply-values ())) -> () etc */
@@ -65927,7 +65932,22 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -
*/
if (((check_cycles) && (tree_is_cyclic(sc, form))) ||
(is_simple_code(sc, form)))
- return(list_2(sc, sc->quote_symbol, form));
+ {
+ if ((!is_global(sc->quote_symbol)) && (is_let(sc->envir))) /* in the reader sc->envir can be junk */
+ {
+ s7_pointer quote_val;
+ quote_val = lookup(sc, sc->quote_symbol);
+ if (((is_global(sc->quasiquote_symbol)) &&
+ (quote_val == slot_value(global_slot(sc->quasiquote_symbol)))) ||
+ (quote_val == lookup(sc, sc->quasiquote_symbol)))
+ s7_error(sc, s7_make_symbol(sc, "infinite loop"),
+ set_elist_2(sc, wrap_string(sc, "quote's value is quasiquote, so '~S is trouble", 46), form));
+ /* (member quasiquote (list 1) (lambda 'ho '(1 2))) so '(1 2) -> `(1 2) -> '(1 2)...
+ * but if we use #_quote above, cycle checks elsewhere get confused (they ignore pairs starting with sc->quote_symbol).
+ */
+ }
+ return(list_2(sc, sc->quote_symbol, form));
+ }
{
s7_int len, i;
@@ -66085,10 +66105,24 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
dig = digits[d];
if (dig >= 10) break;
dims = dig + (dims * 10);
- if ((dims <= 0) ||
- (dims > S7_SHORT_MAX))
- s7_error(sc, sc->read_error_symbol,
- set_elist_2(sc, wrap_string(sc, "overflow while reading #nD: ~A", 30), wrap_integer1(sc, dims)));
+ if (dims <= 0)
+ {
+ sc->strbuf[loc++] = (unsigned char)d;
+ s7_error(sc, sc->read_error_symbol,
+ set_elist_3(sc, wrap_string(sc, "reading #~A...: ~A must be a positive integer", 37),
+ wrap_string(sc, sc->strbuf, loc),
+ wrap_integer1(sc, dims)));
+ }
+ if (dims > sc->max_vector_dimensions)
+ {
+ sc->strbuf[loc++] = (unsigned char)d;
+ sc->strbuf[loc + 1] = '\0';
+ s7_error(sc, sc->read_error_symbol,
+ set_elist_4(sc, wrap_string(sc, "reading #~A...: ~A is too large, (*s7* 'max-vector-dimensions): ~A", 66),
+ wrap_string(sc, sc->strbuf, loc),
+ wrap_integer1(sc, dims),
+ wrap_integer2(sc, sc->max_vector_dimensions)));
+ }
sc->strbuf[loc++] = (unsigned char)d;
}
sc->strbuf[loc++] = d;
@@ -66960,7 +66994,7 @@ static s7_pointer g_format_as_objstr(s7_scheme *sc, s7_pointer args)
obj = caddr(args);
if ((!has_active_methods(sc, obj)) ||
- ((func = find_method(sc, find_let(sc, obj), sc->format_symbol)) == sc->undefined))
+ ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined))
return(s7_object_to_string(sc, obj, false));
return(s7_apply_function(sc, func, list_3(sc, sc->F, cadr(args), obj)));
@@ -67100,7 +67134,6 @@ static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer f, int32_t ar
(cadr(or1) == cadr(expr)) && (caddr(or1) == caddr(expr)))
{
/* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) -- ssa_direct and hop_safe_c_ss */
- /* fprintf(stderr, "%s: %s %s\n", DISPLAY(expr), op_names[optimize_op(expr)], op_names[optimize_op(or1)]); */
set_optimize_op(expr, OP_HASH_INCREMENT);
}
}
@@ -67495,7 +67528,9 @@ static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const
int32_t required_args, int32_t optional_args, bool rest_arg)
{
s7_pointer uf;
- /* the "safe_function" business here doesn't matter -- this is after the optimizer decides what is safe */
+#if S7_DEBUGGING
+ if (!is_safe_procedure(slot_value(global_slot(s7_make_symbol(sc, name))))) fprintf(stderr, "%s unsafe: %s\n", __func__, name);
+#endif
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);
@@ -67775,6 +67810,7 @@ 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;
+ /* fprintf(stderr, " %s: %s\n", __func__, display_80(arg)); */
if (has_fx(arg)) return;
fx = fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe);
if (fx) set_c_call(arg, fx);
@@ -67788,6 +67824,7 @@ static void annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e)
s7_pointer p;
for (p = args; is_pair(p); p = cdr(p))
{
+ /* if (is_unquoted_pair(car(p))) annotate_args(sc, car(p), e); */
#if S7_DEBUGGING
annotate_arg(sc, p, e);
#else
@@ -67799,7 +67836,7 @@ static void annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e)
static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e)
{
#if OPTIMIZE_PRINT
- fprintf(stderr, "%s: %s %d\n", __func__, DISPLAY(expr), hop);
+ fprintf(stderr, "%s: %s %d\n", __func__, display(expr), hop);
#endif
if (is_constant_symbol(sc, car(expr))) hop = 1;
@@ -67872,7 +67909,7 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int
static opt_t optimize_func_dotted_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e)
{
- if (fx_count(sc, expr) == args) /* fx_count starts at cdr */
+ if (fx_count(sc, expr) == args) /* fx_count starts at cdr, args here is the number of exprs in cdr(expr) -- so this means "are all args fxable" */
{
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, small_int(args));
@@ -67899,9 +67936,10 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq);
case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq);
case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq);
- case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSq_q);
- case OP_SAFE_C_S_opSq: return(OP_SAFE_C_op_S_opSq_q);
- case OP_SAFE_C_opSq_S: return(OP_SAFE_C_op_opSq_S_q);
+ case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSqq);
+ case OP_SAFE_C_opSq_C: return(OP_SAFE_C_op_opSq_Cq);
+ case OP_SAFE_C_S_opSq: return(OP_SAFE_C_op_S_opSqq);
+ case OP_SAFE_C_opSq_S: return(OP_SAFE_C_op_opSq_Sq);
case OP_SAFE_C_A: return(OP_SAFE_C_opAq);
case OP_SAFE_C_AA: return(OP_SAFE_C_opAAq);
case OP_SAFE_C_AAA: return(OP_SAFE_C_opAAAq);
@@ -67959,7 +67997,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
case OP_SAFE_C_A: return(OP_SAFE_C_opAq_S);
case OP_SAFE_C_opSSq:
set_opt1_pair(cdr(expr), cadadr(expr));
- return(OP_SAFE_C_op_opSSq_q_S);
+ return(OP_SAFE_C_op_opSSqq_S);
case OP_SAFE_C_opSSq_S:
set_opt3_pair(expr, cadadr(expr));
return(OP_SAFE_C_op_opSSq_Sq_S);
@@ -67977,8 +68015,8 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
return(OP_SAFE_C_opSq_C);
case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_C);
case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq_C);
- case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSq_q_C);
- case OP_SAFE_C_opSSq: return(OP_SAFE_C_op_opSSq_q_C);
+ case OP_SAFE_C_opSq: return(OP_SAFE_C_op_opSqq_C);
+ case OP_SAFE_C_opSSq: return(OP_SAFE_C_op_opSSqq_C);
case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq_C);
}
set_opt2_con(cdr(expr), caddr(expr));
@@ -68008,22 +68046,8 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
return(OP_SAFE_C_C_opSCq);
case OP_SAFE_C_SS:
- set_opt1_sym(cdr(expr), cadr(arg));
- if ((is_real(e1)) &&
- (symbol_id(car(arg)) == 0) &&
- (s7_d_pd_function(slot_value(global_slot(car(arg))))))
- {
- s7_p_dd_t fp;
- fp = s7_p_dd_function(func);
- if (fp)
- {
- /* 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);
+ set_opt1_sym(cdr(expr), cadr(arg));
+ return(OP_SAFE_C_C_opSSq);
}
return(OP_SAFE_C_CP);
@@ -68034,22 +68058,7 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
{
case OP_SAFE_C_S:
if (is_safe_c_s(e1))
- {
- s7_p_dd_t fp;
- fp = s7_p_dd_function(func);
- if (fp)
- {
- 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(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);
- }
+ return(OP_SAFE_C_opSq_opSq);
if (optimize_op_match(e1, OP_SAFE_C_SS))
return(OP_SAFE_C_opSSq_opSq);
break;
@@ -68066,7 +68075,6 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer func, s7_pointer expr, comb
default:
break;
}
- /* fprintf(stderr, "%s[%d]: unopt %s\n", __func__, __LINE__, DISPLAY(expr)); */
return(OP_UNOPT);
}
@@ -68117,7 +68125,7 @@ static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int3
return(OPT_F);
}
if ((is_closure_star(func)) &&
- (lambda_has_simple_defaults(closure_body(func))) &&
+ (lambda_has_simple_defaults(func)) &&
(closure_star_arity_to_int(sc, func) >= n_args) &&
(!arglist_has_rest(sc, closure_args(func))))
{
@@ -68149,7 +68157,7 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin
{
if (func_is_safe) /* safe c function */
{
- set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_D : (OP_SAFE_C_S)));
+ set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_D : OP_SAFE_C_S));
choose_c_function(sc, expr, func, 1);
return(OPT_T);
}
@@ -68177,20 +68185,12 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin
{
int32_t op;
op = combine_ops(sc, func, expr, E_C_P, arg1, NULL);
- if ((hop == 1) &&
- (is_not_h_optimized(arg1)))
- hop = 0;
set_safe_optimize_op(expr, hop + op);
- if ((!hop) && (is_h_optimized(arg1)))
- clear_hop(arg1);
- else
+ if ((op == OP_SAFE_C_P) &&
+ (is_fxable(sc, arg1)))
{
- if ((op == OP_SAFE_C_P) &&
- (is_fxable(sc, arg1)))
- {
- set_optimize_op(expr, hop + OP_SAFE_C_A);
- annotate_arg(sc, cdr(expr), e);
- }
+ set_optimize_op(expr, hop + OP_SAFE_C_A);
+ annotate_arg(sc, cdr(expr), e);
}
choose_c_function(sc, expr, func, 1);
return(OPT_T);
@@ -68280,9 +68280,7 @@ static const char *pretty_print(s7_scheme *sc, s7_pointer obj) /* (pretty-print
static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
{
if (!is_pair(body)) return(false);
- /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, DISPLAY(name), vars, DISPLAY(args), DISPLAY(body)); */
-
- /* if (vars == 3) fprintf(stderr, "%s[%d] vars=3: %s\n", __func__, __LINE__, DISPLAY(body)); */
+ /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display(name), vars, display(args), display(body)); */
if (((vars == 1) || (vars == 2)) &&
((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) &&
@@ -68292,28 +68290,33 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
{
s7_pointer orx;
orx = caddr(body);
- if ((is_proper_list_3(sc, orx)) &&
- ((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol)) &&
+ if (((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol)) &&
(car(body) != car(orx)) &&
(is_fxable(sc, cadr(orx))))
{
- s7_pointer tc;
- tc = caddr(orx);
- if ((is_pair(tc)) &&
- (car(tc) == name) &&
- (is_pair(cdr(tc))) &&
- (is_fxable(sc, cadr(tc))) &&
- (((vars == 1) && (is_null(cddr(tc)))) ||
- ((vars == 2) && (is_pair(cddr(tc))) && (is_null(cdddr(tc))) && (is_fxable(sc, caddr(tc))))))
- {
- if (vars == 1)
- set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LA : OP_TC_OR_A_AND_A_LA);
- else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LAA : OP_TC_OR_A_AND_A_LAA);
- annotate_arg(sc, cdr(body), args);
- annotate_arg(sc, cdr(orx), args);
- annotate_args(sc, cdr(tc), args);
- fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args));
- return(true);
+ s7_int len;
+ len = safe_list_length(orx);
+ if ((len == 3) || ((vars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1)))
+ {
+ s7_pointer tc;
+ tc = (len == 3) ? caddr(orx) : cadddr(orx);
+ if ((is_pair(tc)) &&
+ (car(tc) == name) &&
+ (is_pair(cdr(tc))) &&
+ (is_fxable(sc, cadr(tc))) &&
+ (((vars == 1) && (is_null(cddr(tc)))) ||
+ ((vars == 2) && (is_pair(cddr(tc))) && (is_null(cdddr(tc))) && (is_fxable(sc, caddr(tc))))))
+ {
+ if (vars == 1)
+ set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? ((len == 3) ? OP_TC_AND_A_OR_A_LA : OP_TC_AND_A_OR_A_A_LA) : OP_TC_OR_A_AND_A_LA);
+ else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LAA : OP_TC_OR_A_AND_A_LAA);
+ annotate_arg(sc, cdr(body), args);
+ annotate_arg(sc, cdr(orx), args);
+ if (len == 4) annotate_arg(sc, cddr(orx), args);
+ annotate_args(sc, cdr(tc), args);
+ fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args));
+ return(true);
+ }
}
}
else
@@ -68350,6 +68353,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
}
}
}
+
if ((vars == 3) &&
(((car(body) == sc->or_symbol) && (is_proper_list_2(sc, cdr(body)))) ||
((car(body) == sc->if_symbol) && (is_proper_list_3(sc, cdr(body))) && (caddr(body) == sc->T))) &&
@@ -68381,7 +68385,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
}
}
- if (((vars == 1) || (vars == 2)) &&
+ if (((vars >= 1) && (vars <= 3)) &&
(car(body) == sc->if_symbol) &&
(safe_list_length(body) == 4))
/* (tree_count(sc, name, body, 0) == 1)) */
@@ -68445,8 +68449,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
set_optimized(body);
return(true);
}
- return(false);
-
+ return(false);
}
if ((is_proper_list_3(sc, true_p)) &&
(car(true_p) == name) &&
@@ -68466,20 +68469,55 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
}
}
+ if (vars == 3)
+ {
+ if ((is_proper_list_4(sc, false_p)) &&
+ (car(false_p) == name) &&
+ (is_fxable(sc, cadr(false_p))) && (is_fxable(sc, caddr(false_p))) && (is_fxable(sc, cadddr(false_p))))
+ {
+ set_optimize_op(body, OP_TC_IF_A_Z_L3A);
+ annotate_args(sc, cdr(false_p), args);
+ if (is_fxable(sc, true_p))
+ {
+ annotate_arg(sc, cddr(body), args);
+ fx_tree(sc, cdr(body), car(args), cadr(args));
+ set_optimized(body);
+ return(true);
+ }
+ return(false);
+ }
+ if ((is_proper_list_4(sc, true_p)) &&
+ (car(true_p) == name) &&
+ (is_fxable(sc, cadr(true_p))) && (is_fxable(sc, caddr(true_p))) && (is_fxable(sc, cadddr(true_p))))
+ {
+ set_optimize_op(body, OP_TC_IF_A_L3A_Z);
+ annotate_args(sc, cdr(true_p), args);
+ if (is_fxable(sc, false_p))
+ {
+ annotate_arg(sc, cdddr(body), args);
+ fx_tree(sc, cdr(body), car(args), cadr(args));
+ set_optimized(body);
+ return(true);
+ }
+ return(false);
+ }
+ }
+
if ((is_proper_list_4(sc, false_p)) &&
(car(false_p) == sc->if_symbol))
{
s7_pointer in_test, in_true, in_false;
in_test = cadr(false_p);
in_true = caddr(false_p);
- in_false = cadddr(false_p); /* la */
+ in_false = cadddr(false_p);
+
if (is_fxable(sc, in_test))
{
s7_pointer la = NULL, z;
if ((is_pair(in_false)) &&
(car(in_false) == name) &&
- (is_pair(cdr(in_false))) &&
- (is_fxable(sc, cadr(in_false))))
+ (is_pair(cdr(in_false))) &&
+ (is_fxable(sc, cadr(in_false))))
{
la = in_false;
z = cddr(false_p);
@@ -68495,24 +68533,36 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
z = cdddr(false_p);
}
}
- /* 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 ((la) && ((vars == 3) || (!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)))))
+ ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))) ||
+ ((vars == 3) && (is_proper_list_4(sc, in_true)) && (car(in_true) == name) &&
+ (is_proper_list_4(sc, in_false)) && (is_fxable(sc, caddr(la))) && (is_fxable(sc, cadddr(la))) &&
+ (is_fxable(sc, cadr(in_true))) && (is_fxable(sc, caddr(in_true))) && (is_fxable(sc, cadddr(in_true)))))
{
bool zs_fxable = true;
if (vars == 1)
set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LA : OP_TC_IF_A_Z_IF_A_LA_Z);
- else set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LAA : OP_TC_IF_A_Z_IF_A_LAA_Z);
+ else
+ {
+ if (vars == 2)
+ set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LAA : OP_TC_IF_A_Z_IF_A_LAA_Z);
+ else set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L3A_L3A);
+ }
if (is_fxable(sc, true_p)) /* outer (z) result */
annotate_arg(sc, cddr(body), args);
else zs_fxable = false;
annotate_arg(sc, cdr(false_p), args); /* inner test */
annotate_args(sc, cdr(la), args); /* la arg(s) */
- if (is_fxable(sc, car(z)))
- annotate_arg(sc, z, args); /* inner (z) result */
- else zs_fxable = false;
+ if (vars == 3)
+ annotate_args(sc, cdr(in_true), args);
+ else
+ {
+ if (is_fxable(sc, car(z)))
+ annotate_arg(sc, z, args); /* inner (z) result */
+ else zs_fxable = false;
+ }
if ((has_fx(cddr(body))) && (has_fx(z)))
fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args));
if (zs_fxable) set_optimized(body);
@@ -68529,13 +68579,12 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
let_body = caddr(body);
if ((vars == 2) &&
((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol)))
- /* (tree_count(sc, name, body, 0) == 1)) */
{
s7_pointer test_expr;
test_expr = cadr(let_body);
if (is_fxable(sc, test_expr))
{
- if (car(let_body) == sc->if_symbol)
+ if ((car(let_body) == sc->if_symbol) && (is_pair(cdddr(let_body))))
{
s7_pointer laa;
laa = cadddr(let_body);
@@ -68675,33 +68724,39 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
else_clause = car(else_p);
if ((is_proper_list_2(sc, else_clause)) &&
((car(else_clause) == sc->else_symbol) || (car(else_clause) == sc->T)) &&
- (is_proper_list_3(sc, cadr(else_clause))) &&
+ (is_pair(cadr(else_clause))) &&
(caadr(else_clause) == name) &&
- (is_fxable(sc, cadr(cadr(else_clause)))) &&
- (is_fxable(sc, caddr(cadr(else_clause)))))
+ (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadr(cadr(else_clause)))) &&
+ (((vars == 1) && (is_null(cddadr(else_clause)))) ||
+ ((vars == 2) && (is_proper_list_3(sc, cadr(else_clause))) && (is_fxable(sc, caddadr(else_clause))))))
{
bool zs_fxable = true;
- if ((is_proper_list_3(sc, cadr(clause2))) &&
- (caadr(clause2) == name) &&
- (is_fxable(sc, cadr(cadr(clause2)))) &&
- (is_fxable(sc, caddr(cadr(clause2)))))
+ if (vars == 1)
+ set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LA);
+ else
{
- set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA);
- if (is_fxable(sc, cadr(clause1)))
- annotate_args(sc, clause1, args);
- else
+ if ((is_proper_list_3(sc, cadr(clause2))) &&
+ (caadr(clause2) == name) &&
+ (is_fxable(sc, cadr(cadr(clause2)))) &&
+ (is_fxable(sc, caddadr(clause2))))
{
- annotate_arg(sc, clause1, args);
- zs_fxable = false;
+ set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA);
+ if (is_fxable(sc, cadr(clause1)))
+ annotate_args(sc, clause1, args);
+ else
+ {
+ annotate_arg(sc, clause1, args);
+ zs_fxable = false;
+ }
+ annotate_arg(sc, clause2, args);
+ annotate_args(sc, cdadr(clause2), args);
+ annotate_args(sc, cdadr(else_clause), args);
+ fx_tree(sc, cdr(body), car(args), cadr(args));
+ if (zs_fxable) set_optimized(body);
+ return(zs_fxable);
}
- annotate_arg(sc, clause2, args);
- annotate_args(sc, cdadr(clause2), args);
- annotate_args(sc, cdadr(else_clause), args);
- fx_tree(sc, cdr(body), car(args), cadr(args));
- if (zs_fxable) set_optimized(body);
- return(zs_fxable);
+ set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA);
}
- set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA);
if (is_fxable(sc, cadr(clause1)))
annotate_args(sc, clause1, args);
else
@@ -68717,7 +68772,7 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
zs_fxable = false;
}
annotate_args(sc, cdadr(else_clause), args);
- fx_tree(sc, cdr(body), car(args), cadr(args));
+ fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL);
if (zs_fxable) set_optimized(body);
return(zs_fxable);
}
@@ -68794,14 +68849,10 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar
if (results_fxable) set_optimized(body);
return(results_fxable);
}
-#if 0
- if (tree_count(sc, name, body, 0) == 1)
- fprintf(stderr, "%s[%d]: %s %d %s\n\n", __func__, __LINE__, DISPLAY(name), vars, DISPLAY(body));
-#endif
return(false);
}
-static bool check_recur_if_one_or_two_vars(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
+static bool check_recur_if(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
{
s7_pointer test;
test = cadr(body);
@@ -68914,11 +68965,20 @@ static bool check_recur_if_one_or_two_vars(s7_scheme *sc, s7_pointer name, int32
else
{
if ((vars == 2) &&
- (is_pair(cddr(la))) &&
- (is_fxable(sc, caddr(la))) &&
+ (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) &&
(is_null(cdddr(la))))
set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opA_LAAq : OP_RECUR_IF_A_opA_LAAq_A);
- else return(false);
+ else
+ {
+ /* fprintf(stderr, "%d: %s\n", __LINE__, display(body)); */
+ if ((vars == 3) &&
+ (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) &&
+ (is_pair(cdddr(la))) && (is_fxable(sc, cadddr(la))) &&
+ (is_null(cddddr(la))) &&
+ (orig == cadddr(body)))
+ set_safe_optimize_op(body, OP_RECUR_IF_A_A_opA_L3Aq);
+ else return(false);
+ }
}
annotate_arg(sc, cdr(body), args);
annotate_arg(sc, obody, args);
@@ -68991,229 +69051,284 @@ static bool check_recur_if_one_or_two_vars(s7_scheme *sc, s7_pointer name, int32
set_opt3_pair(false_p, la3);
return(true);
}}}}}
+
+ if ((vars == 3) &&
+ (is_fxable(sc, test)))
+ {
+ s7_pointer true_p, false_p;
+ true_p = caddr(body);
+ false_p = cadddr(body);
+ if ((is_fxable(sc, true_p)) &&
+ (is_proper_list_4(sc, false_p)) &&
+ (car(false_p) == name))
+ {
+ s7_pointer l3a, la1, la2, la3;
+ l3a = cdr(false_p);
+ la1 = car(l3a);
+ la2 = cadr(l3a);
+ la3 = caddr(l3a);
+ if ((is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)) && (is_proper_list_4(sc, la3)) &&
+ (car(la1) == name) && (car(la2) == name) && (car(la3) == name) &&
+ (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3))) &&
+ (is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))) && (is_fxable(sc, caddr(la3))) &&
+ (is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2))) && (is_fxable(sc, cadddr(la3))))
+ {
+ set_safe_optimize_op(body, OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq);
+ annotate_args(sc, cdr(la1), args);
+ annotate_args(sc, cdr(la2), args);
+ annotate_args(sc, cdr(la3), args);
+ annotate_arg(sc, cdr(body), args);
+ annotate_arg(sc, cddr(body), args);
+ fx_tree(sc, cdr(body), car(args), cadr(args));
+ set_opt3_pair(body, false_p);
+ set_opt3_pair(false_p, la3);
+ return(true);
+ }}}
return(false);
}
static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
{
- /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, DISPLAY(name), vars, DISPLAY(args), DISPLAY(body)); */
+ /* fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display(name), vars, display(args), display(body)); */
if ((car(body) == sc->if_symbol) &&
(safe_list_length(body) == 4))
+ return(check_recur_if(sc, name, vars, args, body));
+
+ if (car(body) == sc->cond_symbol)
{
- if ((vars == 1) || (vars == 2))
- return(check_recur_if_one_or_two_vars(sc, name, vars, args, body));
- if (vars == 3)
+ s7_pointer clause, clause2 = NULL;
+ clause = cadr(body);
+ if ((is_proper_list_1(sc, (cdr(clause)))) &&
+ (is_fxable(sc, car(clause))) &&
+ (is_fxable(sc, cadr(clause))))
{
- s7_pointer test;
- test = cadr(body);
- if (is_fxable(sc, test))
+ s7_pointer la_clause;
+ s7_int len;
+ len = safe_list_length(body);
+ la_clause = caddr(body);
+ if (len == 4)
{
- s7_pointer true_p, false_p;
- true_p = caddr(body);
- false_p = cadddr(body);
- if ((is_fxable(sc, true_p)) &&
- (is_proper_list_4(sc, false_p)) &&
- (car(false_p) == name))
+ if ((is_proper_list_2(sc, la_clause)) &&
+ (is_fxable(sc, car(la_clause))))
{
- s7_pointer l3a, la1, la2, la3;
- l3a = cdr(false_p);
- la1 = car(l3a);
- la2 = cadr(l3a);
- la3 = caddr(l3a);
- if ((is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)) && (is_proper_list_4(sc, la3)) &&
- (car(la1) == name) && (car(la2) == name) && (car(la3) == name) &&
- (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3))) &&
- (is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))) && (is_fxable(sc, caddr(la3))) &&
- (is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2))) && (is_fxable(sc, cadddr(la3))))
- {
- set_safe_optimize_op(body, OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq);
- annotate_args(sc, cdr(la1), args);
- annotate_args(sc, cdr(la2), args);
- annotate_args(sc, cdr(la3), args);
- annotate_arg(sc, cdr(body), args);
- annotate_arg(sc, cddr(body), args);
- fx_tree(sc, cdr(body), car(args), cadr(args));
- set_opt3_pair(body, false_p);
- set_opt3_pair(false_p, la3);
- return(true);
- }
+ clause2 = la_clause;
+ la_clause = cadddr(body);
}
+ else return(false);
}
- }
- }
- else
- {
- if (car(body) == sc->cond_symbol)
- {
- s7_pointer clause, clause2 = NULL;
- clause = cadr(body);
- if ((is_proper_list_1(sc, (cdr(clause)))) &&
- (is_fxable(sc, car(clause))) &&
- (is_fxable(sc, cadr(clause))))
+ if ((is_proper_list_2(sc, la_clause)) &&
+ ((car(la_clause) == sc->else_symbol) || (car(la_clause) == sc->T)) &&
+ (is_pair(cadr(la_clause))))
{
- s7_pointer la_clause;
- s7_int len;
- len = safe_list_length(body);
- la_clause = caddr(body);
- if (len == 4)
- {
- if ((is_proper_list_2(sc, la_clause)) &&
- (is_fxable(sc, car(la_clause))))
- {
- clause2 = la_clause;
- la_clause = cadddr(body);
- }
- else
- {
- /* if (!(sc->got_tc)) fprintf(stderr, "%s[%d]: %s %s\n%s\n\n", __func__, __LINE__, DISPLAY(name), DISPLAY(args), DISPLAY(body)); */
- return(false);
- }
- }
- if ((is_proper_list_2(sc, la_clause)) &&
- ((car(la_clause) == sc->else_symbol) || (car(la_clause) == sc->T)) &&
- (is_pair(cadr(la_clause))))
+ la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a laa) */
+ if (is_proper_list_2(sc, cdr(la_clause)))
{
- la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a laa) */
- if (is_proper_list_2(sc, cdr(la_clause)))
+ if (is_h_optimized(la_clause))
{
- if (is_h_optimized(la_clause))
+ if ((is_fxable(sc, cadr(la_clause))) &&
+ ((len == 3) ||
+ ((len == 4) && (vars == 2) &&
+ (is_proper_list_3(sc, cadr(clause2))) &&
+ (caadr(clause2) == name))))
{
- if ((is_fxable(sc, cadr(la_clause))) &&
- ((len == 3) ||
- ((len == 4) && (vars == 2) &&
- (is_proper_list_3(sc, cadr(clause2))) &&
- (caadr(clause2) == name))))
+ s7_pointer la;
+ la = caddr(la_clause);
+ if ((is_pair(la)) &&
+ (car(la) == name) &&
+ (is_pair(cdr(la))) &&
+ (is_fxable(sc, cadr(la))) &&
+ (((vars == 1) && (is_null(cddr(la)))) ||
+ ((vars == 2) &&
+ (is_pair(cddr(la))) &&
+ (is_fxable(sc, caddr(la))) &&
+ (is_null(cdddr(la))))))
{
- s7_pointer la;
- la = caddr(la_clause);
- if ((is_pair(la)) &&
- (car(la) == name) &&
- (is_pair(cdr(la))) &&
- (is_fxable(sc, cadr(la))) &&
- (((vars == 1) && (is_null(cddr(la)))) ||
- ((vars == 2) &&
- (is_pair(cddr(la))) &&
- (is_fxable(sc, caddr(la))) &&
- (is_null(cdddr(la))))))
+ if (len == 3)
+ set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_COND_A_A_opA_LAq : OP_RECUR_COND_A_A_opA_LAAq);
+ else
{
- if (len == 3)
- set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_COND_A_A_opA_LAq : OP_RECUR_COND_A_A_opA_LAAq);
- else
+ s7_pointer laa;
+ laa = cadr(clause2);
+ if ((is_fxable(sc, cadr(laa))) && /* args to first laa */
+ (is_fxable(sc, caddr(laa))))
{
- s7_pointer laa;
- laa = cadr(clause2);
- if ((is_fxable(sc, cadr(laa))) && /* args to first laa */
- (is_fxable(sc, caddr(laa))))
- {
- set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_opA_LAAq);
- annotate_arg(sc, clause2, args);
- annotate_args(sc, cdr(laa), args);
- }
- else return(false);
+ set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_opA_LAAq);
+ annotate_arg(sc, clause2, args);
+ annotate_args(sc, cdr(laa), args);
}
- annotate_args(sc, clause, args);
- annotate_arg(sc, cdr(la_clause), args);
- annotate_args(sc, cdr(la), args);
- fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args));
- set_opt3_pair(body, la_clause);
- set_opt3_pair(la_clause, la);
- return(true);
+ else return(false);
}
+ annotate_args(sc, clause, args);
+ annotate_arg(sc, cdr(la_clause), args);
+ annotate_args(sc, cdr(la), args);
+ fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args));
+ set_opt3_pair(body, la_clause);
+ set_opt3_pair(la_clause, la);
+ return(true);
}
- else
+ }
+ else
+ {
+ if (len == 4)
{
- if (len == 4)
+ s7_pointer la1, la2;
+ bool happy = false;
+ la1 = cadr(la_clause);
+ la2 = caddr(la_clause);
+
+ if ((vars == 1) &&
+ (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2)) &&
+ (car(la1) == name) && (car(la2) == name) &&
+ (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))))
{
- s7_pointer la1, la2;
- bool happy = false;
- la1 = cadr(la_clause);
- la2 = caddr(la_clause);
-
- if ((vars == 1) &&
- (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2)) &&
- (car(la1) == name) && (car(la2) == name) &&
- (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))))
- {
- set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLA_LAq);
- annotate_arg(sc, cdr(la1), args);
- happy = true;
- }
- else
+ set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLA_LAq);
+ annotate_arg(sc, cdr(la1), args);
+ happy = true;
+ }
+ else
+ {
+ if ((vars == 2) &&
+ (is_fxable(sc, cadr(clause2))) &&
+ (is_proper_list_3(sc, la2)) &&
+ (car(la2) == name) &&
+ (is_fxable(sc, cadr(la2))) &&
+ (is_fxable(sc, caddr(la2))))
{
- if ((vars == 2) &&
- (is_fxable(sc, cadr(clause2))) &&
- (is_proper_list_3(sc, la2)) &&
- (car(la2) == name) &&
- (is_fxable(sc, cadr(la2))) &&
- (is_fxable(sc, caddr(la2))))
+ if (is_fxable(sc, la1))
+ {
+ set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opA_LAAq);
+ annotate_arg(sc, cdr(la_clause), args);
+ happy = true;
+ }
+ else
{
- if (is_fxable(sc, la1))
+ if ((is_proper_list_3(sc, la1)) &&
+ (car(la1) == name) &&
+ (is_fxable(sc, cadr(la1))) &&
+ (is_fxable(sc, caddr(la1))))
{
- set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opA_LAAq);
- annotate_arg(sc, cdr(la_clause), args);
+ set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLAA_LAAq);
+ annotate_args(sc, cdr(la1), args);
happy = true;
}
- else
- {
- if ((is_proper_list_3(sc, la1)) &&
- (car(la1) == name) &&
- (is_fxable(sc, cadr(la1))) &&
- (is_fxable(sc, caddr(la1))))
- {
- set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLAA_LAAq);
- annotate_args(sc, cdr(la1), args);
- happy = true;
- }
- }
}
}
- if (happy)
- {
- set_opt3_pair(la_clause, cdr(la2));
- annotate_args(sc, clause, args);
- annotate_args(sc, clause2, args);
- annotate_args(sc, cdr(la2), args);
- fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args));
- set_opt3_pair(body, la_clause);
- return(true);
- }
+ }
+ if (happy)
+ {
+ set_opt3_pair(la_clause, cdr(la2));
+ annotate_args(sc, clause, args);
+ annotate_args(sc, clause2, args);
+ annotate_args(sc, cdr(la2), args);
+ fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args));
+ set_opt3_pair(body, la_clause);
+ return(true);
}
}
}
- else
+ }
+ else
+ {
+ if (clause2)
{
- if (clause2)
+ s7_pointer laa;
+ laa = cadr(clause2);
+
+ if ((vars == 2) && (len == 4) &&
+ (is_proper_list_3(sc, laa)) &&
+ (car(laa) == name) &&
+ (is_fxable(sc, cadr(laa))) &&
+ (is_fxable(sc, caddr(laa))))
{
- s7_pointer laa;
- laa = cadr(clause2);
-
- if ((vars == 2) && (len == 4) &&
- (is_proper_list_3(sc, laa)) &&
- (car(laa) == name) &&
- (is_fxable(sc, cadr(laa))) &&
- (is_fxable(sc, caddr(laa))))
+ s7_pointer la1, la2;
+ la1 = cadr(la_clause);
+ la2 = caddr(la_clause);
+ if ((is_fxable(sc, la1)) &&
+ (is_proper_list_3(sc, la2)) &&
+ (car(la2) == name) &&
+ (is_fxable(sc, cadr(la2))) &&
+ (is_fxable(sc, caddr(la2))))
{
- s7_pointer la1, la2;
- la1 = cadr(la_clause);
- la2 = caddr(la_clause);
- if ((is_fxable(sc, la1)) &&
- (is_proper_list_3(sc, la2)) &&
- (car(la2) == name) &&
- (is_fxable(sc, cadr(la2))) &&
- (is_fxable(sc, caddr(la2))))
- {
- set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_LopA_LAAq);
- annotate_args(sc, clause, args);
- annotate_arg(sc, clause2, args);
- annotate_args(sc, cdr(laa), args);
- annotate_arg(sc, cdr(la_clause), args);
- annotate_args(sc, cdr(la2), args);
- fx_tree(sc, cdr(body), car(args), cadr(args));
- set_opt3_pair(body, la_clause);
- set_opt3_pair(la_clause, cdr(la2));
- return(true);
- }}}}}}}}}
+ set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_LopA_LAAq);
+ annotate_args(sc, clause, args);
+ annotate_arg(sc, clause2, args);
+ annotate_args(sc, cdr(laa), args);
+ annotate_arg(sc, cdr(la_clause), args);
+ annotate_args(sc, cdr(la2), args);
+ fx_tree(sc, cdr(body), car(args), cadr(args));
+ set_opt3_pair(body, la_clause);
+ set_opt3_pair(la_clause, cdr(la2));
+ return(true);
+ }}}}}}}}
+ return(false);
+}
+
+static opt_t fxify_safe_closure_s(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, bool sym, int32_t hop)
+{
+ s7_pointer body;
+ /* fprintf(stderr, "%s: %s %d\n", __func__, display(expr), hop); */
+
+ body = closure_body(func);
+ annotate_arg(sc, body, e);
+ if (sym)
+ {
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A);
+ if ((is_pair(car(body))) && (is_pair(cdar(body))) && (car(closure_args(func)) == cadar(body)))
+ {
+ if (optimize_op(car(body)) == HOP_SAFE_C_S)
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S);
+ else
+ {
+ if (optimize_op(car(body)) == HOP_SAFE_C_SC)
+ {
+ s7_pointer body_arg2;
+ body_arg2 = caddar(body);
+ set_opt3_any(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2);
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC);
+ }
+ }
+ }
+ }
+ else set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_C_A);
+ set_closure_has_fx(func);
+ fx_tree(sc, body, car(closure_args(func)), NULL);
+ return(OPT_T);
+}
+
+static bool fxify_closure_a(s7_scheme *sc, s7_pointer func, bool one_form, bool safe_case, int32_t hop, s7_pointer expr, s7_pointer e)
+{
+ if (one_form)
+ {
+ if (safe_case)
+ {
+ s7_pointer body;
+ body = closure_body(func);
+ if (is_fxable(sc, car(body)))
+ {
+ annotate_arg(sc, body, e);
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A);
+
+ if (is_pair(car(body)))
+ {
+ if ((optimize_op(car(body)) == HOP_SAFE_C_SC) && (car(closure_args(func)) == cadar(body)))
+ {
+ s7_pointer body_arg2;
+ body_arg2 = caddar(body);
+ set_opt3_any(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2);
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_TO_SC);
+ }
+ }
+
+ set_closure_has_fx(func);
+ fx_tree(sc, body, car(closure_args(func)), NULL);
+ return(true);
+ }
+ set_optimize_op(expr, hop + OP_SAFE_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));
return(false);
}
@@ -69253,33 +69368,7 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer
if (safe_case)
{
if (is_fxable(sc, car(body)))
- {
- annotate_arg(sc, body, e);
- if (sym)
- {
- if (((optimize_op(car(body)) == HOP_SAFE_C_S) || (optimize_op(car(body)) == HOP_SAFE_C_SC)) &&
- (car(closure_args(func)) == cadar(body)))
- {
- if (optimize_op(car(body)) == HOP_SAFE_C_S)
- set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S);
- else
- {
- set_opt3_any(cdr(expr), caddar(body));
- set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC);
- }
- }
- else
- {
- if (car(closure_args(func)) == car(body))
- set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_ID_S);
- else set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A);
- }
- }
- else set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_C_A);
- set_closure_has_fx(func);
- fx_tree(sc, body, car(closure_args(func)), NULL);
- return(OPT_T);
- }
+ return(fxify_safe_closure_s(sc, func, expr, e, sym, hop));
set_optimize_op(expr, hop + ((sym) ? OP_SAFE_CLOSURE_S_P : OP_SAFE_CLOSURE_C_P));
}
else set_optimize_op(expr, hop + ((sym) ? OP_CLOSURE_S_P : OP_CLOSURE_C_P));
@@ -69289,30 +69378,14 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer
return(OPT_F);
}
+ /* fprintf(stderr, "expr: %s, fx: %d, op: %s\n", display(expr), is_fxable(sc, cadr(expr)), op_names[optimize_op(cadr(expr))]); */
if (fx_count(sc, expr) == 1)
{
set_unsafely_optimized(expr);
set_opt1_lambda(expr, func);
annotate_arg(sc, cdr(expr), e);
set_opt3_arglen(expr, small_int(1));
-
- if (one_form)
- {
- if (safe_case)
- {
- if (is_fxable(sc, car(body)))
- {
- annotate_arg(sc, body, e);
- set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A);
- set_closure_has_fx(func);
- fx_tree(sc, body, car(closure_args(func)), NULL);
- return(OPT_T);
- }
- set_optimize_op(expr, hop + OP_SAFE_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));
+ if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, e)) return(OPT_T);
set_unsafely_optimized(expr);
return(OPT_F);
}
@@ -69328,7 +69401,7 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu
s7_pointer arg1;
/* very often, expr is already optimized, quoted stuff is counted under "bad_pairs"! as well as quotes */
#if OPTIMIZE_PRINT
- fprintf(stderr, "%s expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, DISPLAY_80(expr), DISPLAY(func), hop, pairs, symbols, quotes, bad_pairs);
+ fprintf(stderr, "%s expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, display_80(expr), display(func), hop, pairs, symbols, quotes, bad_pairs);
#endif
if (quotes > 0)
{
@@ -69376,16 +69449,22 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu
set_opt1_lambda(expr, func);
set_opt3_arglen(expr, small_int(1));
set_unsafely_optimized(expr);
- if (lambda_has_simple_defaults(closure_body(func)))
- {
- if (arglist_has_rest(sc, closure_args(func)))
- set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX));
- else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A));
- }
+
+ if ((safe_case) && (is_null(cdr(closure_args(func)))))
+ set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); /* TODO: unknown cases + fxify */
else
{
- if (safe_case)
- set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_FX_1);
+ if (lambda_has_simple_defaults(func))
+ {
+ if (arglist_has_rest(sc, closure_args(func)))
+ set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX));
+ else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A));
+ }
+ else
+ {
+ if (safe_case)
+ set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_FX_1);
+ }
}
return(OPT_F);
}
@@ -69441,7 +69520,7 @@ static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer sym
s7_pointer x;
int64_t id;
#if OPTIMIZE_PRINT
- fprintf(stderr, " find %s in %s (in list: %d)\n", DISPLAY(symbol), DISPLAY(e), symbol_is_in_list(sc, symbol));
+ fprintf(stderr, " find %s in %s (in list: %d)\n", display(symbol), display(e), symbol_is_in_list(sc, symbol));
#endif
if ((symbol_is_in_list(sc, symbol)) &&
(let_memq(symbol, e))) /* it's probably a local variable reference */
@@ -69524,7 +69603,7 @@ static bool safe_c_aa_to_ca(s7_scheme *sc, s7_pointer arg, int hop)
{
if (c_callee(cddr(arg)) == fx_c) {set_opt3_any(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);}
if (c_callee(cdr(arg)) == fx_c) {set_opt3_any(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);}
- if (c_callee(cddr(arg)) == fx_q) {set_opt3_any(arg, cadr(caddr(arg))); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);}
+ if (c_callee(cddr(arg)) == fx_q) {set_opt3_any(arg, cadaddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);}
if (c_callee(cdr(arg)) == fx_q) {set_opt3_any(arg, cadadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);}
return(false);
}
@@ -69535,7 +69614,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
s7_pointer arg1, arg2;
#if OPTIMIZE_PRINT
- fprintf(stderr, "%s %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, DISPLAY_80(expr), hop, pairs, symbols, quotes, bad_pairs);
+ fprintf(stderr, "%s %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, display_80(expr), hop, pairs, symbols, quotes, bad_pairs);
#endif
if (quotes > 0)
{
@@ -69675,45 +69754,34 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
{
int32_t op;
op = combine_ops(sc, func, expr, E_C_PP, arg1, arg2);
- if ((hop == 1) &&
- ((is_not_h_optimized(arg1)) || (is_not_h_optimized(arg2))))
- hop = 0;
set_safe_optimize_op(expr, hop + op);
if (op == OP_SAFE_C_PP)
opt_sp_1(sc, c_function_call(func), expr); /* calls set_opt1_any, sets opt1(cdr(expr)) to OP_SAFE_CONS_SP_1 and friends */
- if (!hop)
- {
- if (is_h_optimized(arg1)) clear_hop(arg1);
- if (is_h_optimized(arg2)) clear_hop(arg2);
- }
- else
+ if (op == OP_SAFE_C_PP)
{
- if (op == OP_SAFE_C_PP)
+ if (is_fxable(sc, arg1))
{
- if (is_fxable(sc, arg1))
+ if (is_fxable(sc, arg2))
{
- if (is_fxable(sc, arg2))
- {
- set_optimize_op(expr, hop + OP_SAFE_C_AA);
- annotate_args(sc, cdr(expr), e);
- if (!safe_c_aa_to_ca(sc, expr, hop))
- set_opt3_arglen(expr, small_int(2));
- }
- else
- {
- set_optimize_op(expr, hop + OP_SAFE_C_AP);
- annotate_arg(sc, cdr(expr), e);
- set_opt3_arglen(expr, small_int(2));
- }
+ set_optimize_op(expr, hop + OP_SAFE_C_AA);
+ annotate_args(sc, cdr(expr), e);
+ if (!safe_c_aa_to_ca(sc, expr, hop))
+ set_opt3_arglen(expr, small_int(2));
}
else
{
- if (is_fxable(sc, arg2))
- {
- set_optimize_op(expr, hop + OP_SAFE_C_PA);
- annotate_arg(sc, cddr(expr), e);
- set_opt3_arglen(expr, small_int(2));
- }
+ set_optimize_op(expr, hop + OP_SAFE_C_AP);
+ annotate_arg(sc, cdr(expr), e);
+ set_opt3_arglen(expr, small_int(2));
+ }
+ }
+ else
+ {
+ if (is_fxable(sc, arg2))
+ {
+ set_optimize_op(expr, hop + OP_SAFE_C_PA);
+ annotate_arg(sc, cddr(expr), e);
+ set_opt3_arglen(expr, small_int(2));
}
}
}
@@ -69737,7 +69805,6 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
orig_op = E_C_PS;
else orig_op = E_C_PC;
op = combine_ops(sc, func, expr, orig_op, arg1, arg2);
- if ((!hop) && (is_h_optimized(arg1))) clear_hop(arg1);
}
else
{
@@ -69745,12 +69812,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
orig_op = E_C_SP;
else orig_op = E_C_CP;
op = combine_ops(sc, func, expr, orig_op, arg1, arg2);
- if ((!hop) && (is_h_optimized(arg2))) clear_hop(arg2);
}
- if ((hop == 1) &&
- ((is_not_h_optimized(arg1)) || (is_not_h_optimized(arg2))))
- hop = 0;
-
if ((((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) &&
(is_fxable(sc, arg2))) ||
(((op == OP_SAFE_C_PS) || (op == OP_SAFE_C_PC)) &&
@@ -69881,6 +69943,7 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
set_optimized(expr);
if (is_normal_symbol(arg1))
{
+ /* fprintf(stderr, "%d: %d\n", __LINE__, hop); */
set_optimize_op(expr, hop + OP_SAFE_C_SP);
opt_sp_1(sc, c_function_call(func), expr);
choose_c_function(sc, expr, func, 2);
@@ -70227,9 +70290,12 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer 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);
+ return(set_safe_closure_fp(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_PP));
+
+ set_unsafely_optimized(expr);
+ set_optimize_op(expr, hop + OP_CLOSURE_PP);
+ set_opt1_lambda(expr, func);
+ return(OPT_F);
}
if (is_closure_star(func))
@@ -70237,17 +70303,31 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
if (is_immutable(func)) hop = 1;
if (fx_count(sc, expr) == 2)
{
+ int32_t arity;
+ bool safe_case;
+ s7_pointer par1;
+
+ safe_case = is_safe_closure(func);
+ arity = closure_star_arity_to_int(sc, func);
set_unsafely_optimized(expr);
- if (lambda_has_simple_defaults(closure_body(func)))
- {
- if (closure_star_arity_to_int(sc, func) == 2)
- set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_AA : OP_CLOSURE_STAR_FX));
- else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX));
- }
+ par1 = car(closure_args(func));
+ if (is_pair(par1)) par1 = car(par1);
+
+ if ((arity == 1) && (is_keyword(arg1)) && (keyword_symbol(arg1) == par1))
+ set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_KA : OP_CLOSURE_STAR_KA));
else
{
- if (is_safe_closure(func))
- set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_FX_2);
+ if (lambda_has_simple_defaults(func))
+ {
+ if (arity == 2) /* safe_closure_star_aa_a here is actually slower (overhead > eval reduction) */
+ set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_AA : OP_CLOSURE_STAR_FX));
+ else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX));
+ }
+ else
+ {
+ if (is_safe_closure(func))
+ set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_FX_2);
+ }
}
annotate_args(sc, cdr(expr), e);
set_opt1_lambda(expr, func);
@@ -70284,6 +70364,12 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f
static opt_t set_safe_c_fp(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op)
{
s7_pointer p;
+ /* fprintf(stderr, "%s\n", display(expr)); */
+ /* odd: (list-values '+ (sqrt 9) 4), (list (if (memq op2 gtes) op1 op2) x c1), (list (cadr (assq op1 relops)) c1 x c2), (+ (round pi) 1 1 1 1)
+ * if_opssq_aa
+ * why missed fx_safe_closure_s_a? -- op_*
+ * if op_safe_closure* check for func and call else goto eval? similarly for op_safe_c*
+ */
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));
@@ -70296,7 +70382,7 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
{
s7_pointer arg1, arg2, arg3;
#if OPTIMIZE_PRINT
- fprintf(stderr, "%s: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, DISPLAY_80(expr), DISPLAY(func), hop, pairs, symbols, quotes, bad_pairs);
+ fprintf(stderr, "%s: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad: %d\n", __func__, display_80(expr), display(func), hop, pairs, symbols, quotes, bad_pairs);
#endif
if ((quotes > 0) &&
@@ -70338,7 +70424,7 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
return(OPT_F);
}
if ((is_closure_star(func)) &&
- (lambda_has_simple_defaults(closure_body(func))) &&
+ (lambda_has_simple_defaults(func)) &&
(closure_star_arity_to_int(sc, func) != 0) &&
(closure_star_arity_to_int(sc, func) != 1))
{
@@ -70501,7 +70587,6 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
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);
@@ -70637,14 +70722,32 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
if (symbols == 3)
{
+ s7_pointer body;
+ body = closure_body(func);
set_opt1_lambda(expr, func);
set_opt3_arglen(expr, small_int(3));
- set_unsafe_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)));
+
+ if (is_safe_closure(func))
+ {
+ if ((is_null(cdr(body))) &&
+ (is_fxable(sc, car(body))))
+ {
+ set_opt2_sym(expr, arg2);
+ set_opt3_sym(expr, arg3);
+ 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_3S_A);
+ set_closure_has_fx(func);
+ }
+ else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S);
+ return(OPT_T);
+ }
+ else set_unsafe_optimize_op(expr, hop + ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_3S_P : OP_CLOSURE_3S));
return(OPT_F);
}
#if OPTIMIZE_PRINT
- fprintf(stderr, " closure fx_count: %d, safe: %d\n", fx_count(sc, expr), is_safe_closure(func));
+ fprintf(stderr, " %s closure fx_count: %d, safe: %d\n", display_80(expr), fx_count(sc, expr), is_safe_closure(func));
#endif
if (fx_count(sc, expr) == 3)
@@ -70658,15 +70761,12 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer
set_opt3_arglen(expr, small_int(3));
return(OPT_F);
}
- if (is_safe_closure(func))
- return(set_safe_closure_fp(sc, func, expr, e, 3, hop + OP_SAFE_CLOSURE_FP));
- /* unsafe_closure_fp got few hits and made no difference */
- return(OPT_F);
+ return(set_safe_closure_fp(sc, func, expr, e, 3, hop + OP_SAFE_OR_UNSAFE_CLOSURE_3P));
}
if (is_closure_star(func))
{
- if ((!lambda_has_simple_defaults(closure_body(func))) ||
+ if ((!lambda_has_simple_defaults(func)) ||
(closure_star_arity_to_int(sc, func) == 0) ||
(closure_star_arity_to_int(sc, func) == 1))
return(OPT_F);
@@ -70712,7 +70812,7 @@ static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer e)
static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e)
{
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); */
+ /* fprintf(stderr, "%s[%d]: %s, args: %d, bad: %d, quotes: %d\n", __func__, __LINE__, display_80(expr), args, bad_pairs, quotes); */
if (quotes > 0)
{
@@ -70829,15 +70929,6 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer
annotate_args(sc, cdr(expr), e);
set_opt3_arglen(expr, make_permanent_integer(args));
set_opt1_lambda(expr, func);
-#if 0
- if ((s7_is_equal(sc, closure_args(func), cdar(closure_body(func)))) &&
- (is_null(cdr(closure_body(func)))))
- fprintf(stderr, "same: %s %s\n", DISPLAY(closure_args(func)), DISPLAY(closure_body(func)));
- /* this actually happens: closure_s_to_s in 1-arg case?
- * perhaps 2/3 arg cases too?
- * closure_id_any?
- */
-#endif
if ((symbols == args) &&
(symbols_are_safe(sc, cdr(expr), e)))
@@ -70855,7 +70946,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer
}
if ((is_closure_star(func)) &&
- ((!lambda_has_simple_defaults(closure_body(func))) ||
+ ((!lambda_has_simple_defaults(func)) ||
(closure_star_arity_to_int(sc, func) == 0) ||
(closure_star_arity_to_int(sc, func) == 1)))
return(OPT_F);
@@ -70928,10 +71019,17 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
s7_pointer p, body, vars;
bool body_export_ok = true;
#if OPTIMIZE_PRINT
- fprintf(stderr, "optimize_syntax %s %d %s\n", DISPLAY(expr), hop, DISPLAY(e));
+ fprintf(stderr, "optimize_syntax %s %d %s\n", display(expr), hop, display(e));
#endif
op = (opcode_t)syntax_opcode(func);
+#if 0
+ fprintf(stderr, "op: %s\n", op_names[op]);
+ if ((is_slot(global_slot(car(expr)))) && (op != (opcode_t)symbol_syntax_op_checked(expr)))
+ fprintf(stderr, "%s != %s\n", op_names[op], op_names[(opcode_t)symbol_syntax_op_checked(expr)]);
+#endif
+ /* pair_set_syntax_op(expr, op); */ /* much slower?? */
+
sc->w = e;
body = cdr(expr);
@@ -71407,9 +71505,17 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in
}
else
{
+ if ((c_callee(test) == fx_and_2) && (c_callee(b1) == fx_s))
+ {
+ set_opt1_pair(expr, cdadr(expr));
+ set_opt2_pair(expr, cddadr(expr));
+ set_opt3_sym(expr, car(b1));
+ set_safe_optimize_op(expr, OP_IF_AND2_SA);
+ return(OPT_T);
+ }
set_opt1_pair(expr, b1);
if (is_pair(b2)) set_opt2_pair(expr, b2);
- set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_A_A : OP_IF_A_AA);
+ set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_A_A : ((c_callee(test) == fx_s) ? OP_IF_S_AA : OP_IF_A_AA));
}
}
}
@@ -71427,7 +71533,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7
{
s7_pointer car_expr;
#if OPTIMIZE_PRINT
- fprintf(stderr, "optimize_expression %s %d %s\n", DISPLAY(expr), hop, DISPLAY(e));
+ fprintf(stderr, "optimize_expression %s %d %s\n", display(expr), hop, display(e));
#endif
set_checked(expr);
car_expr = car(expr);
@@ -71444,7 +71550,7 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7
slot = find_uncomplicated_symbol(sc, car_expr, e); /* local vars (recursive calls too??) are considered "complicated" */
#if OPTIMIZE_PRINT
- if (!is_slot(slot)) fprintf(stderr, " %s is not simple\n", DISPLAY(expr));
+ if (!is_slot(slot)) fprintf(stderr, " %s is not simple\n", display(expr));
#endif
if (is_slot(slot))
{
@@ -71564,13 +71670,13 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7
(port_file(p) != stdin) &&
(!port_is_closed(p)) &&
(port_filename(p)))
- s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", DISPLAY(car_expr), port_filename(p), port_line_number(p));
- else s7_warn(sc, 1024, "; %s might be undefined\n", DISPLAY(car_expr));
+ s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", display(car_expr), port_filename(p), port_line_number(p));
+ else s7_warn(sc, 1024, "; %s might be undefined\n", display(car_expr));
symbol_set_tag(car_expr, 1); /* one warning is enough */
}
}
#if OPTIMIZE_PRINT
- fprintf(stderr, " at line %d for %s\n", __LINE__, DISPLAY(car_expr));
+ fprintf(stderr, " at line %d for %s\n", __LINE__, display(car_expr));
#endif
/* car_expr is a symbol but it's not a built-in procedure or a "safe" case = vector etc */
{
@@ -71746,7 +71852,7 @@ static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e)
{
s7_pointer x;
#if OPTIMIZE_PRINT
- fprintf(stderr, "optimize: %s %s\n", DISPLAY_80(code), DISPLAY(e));
+ fprintf(stderr, "optimize: %s %s\n", display_80(code), display(e));
#endif
for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x))
{
@@ -71950,10 +72056,10 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at
s7_pointer expr;
body_t result = VERY_SAFE_BODY;
#if S7_DEBUGGING
- if (!is_pair(x)) {fprintf(stderr, "form_is_safe x is not a pair! %s\n", DISPLAY(x)); abort();}
+ if (!is_pair(x)) {fprintf(stderr, "form_is_safe x is not a pair! %s\n", display(x)); abort();}
#endif
#if OPTIMIZE_PRINT
- fprintf(stderr, "%s[%d]: %s %s %d\n", __func__, __LINE__, DISPLAY(func), DISPLAY(x), at_end);
+ fprintf(stderr, "%s[%d]: %s %s %d\n", __func__, __LINE__, display(func), display(x), at_end);
#endif
expr = car(x);
if (is_syntactic_symbol(expr))
@@ -72369,7 +72475,7 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at
}
}
#if OPTIMIZE_PRINT
- fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(x));
+ fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(x));
#endif
return_unsafe_body(sc);
}
@@ -72381,7 +72487,7 @@ static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool
bool follow = false;
s7_pointer p, sp;
body_t result = VERY_SAFE_BODY;
- /* fprintf(stderr, "%s: %s %s %d\n", __func__, DISPLAY(func), DISPLAY(body), at_end); */
+ /* fprintf(stderr, "%s: %s %s %d\n", __func__, display(func), display(body), at_end); */
for (p = body, sp = body; is_pair(p); p = cdr(p))
{
if (is_pair(car(p)))
@@ -72416,7 +72522,7 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun
len = s7_list_length(sc, body);
#if OPTIMIZE_PRINT
- fprintf(stderr, "%s[%d]: %s %s %ld\n", __func__, __LINE__, DISPLAY(func), DISPLAY(args), len);
+ fprintf(stderr, "%s[%d]: %s %s %ld\n", __func__, __LINE__, display(func), display(args), len);
#endif
if (len < 0) /* (define (hi) 1 . 2) */
@@ -72483,6 +72589,7 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun
clear_all_optimizations(sc, body);
else
{
+ /* fprintf(stderr, "%d %s result: %d\n", __LINE__, display(body), result); */
if (result >= RECUR_BODY) /* (is_safe_closure_body(body)) */
{
int32_t nvars;
@@ -72493,11 +72600,15 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun
if (nvars > 0)
{
annotate_args(sc, body, cleared_args);
+ /* this does not do what we want, but full tree annotation clobbers optimizer settings!
+ * we need a syntax-aware tree walker that does what check* does
+ */
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 (is_null(cdr(body)))
@@ -72514,13 +72625,6 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun
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
}
}
}
@@ -72542,7 +72646,7 @@ static int32_t check_lambda_1(s7_scheme *sc, bool optl)
s7_pointer code, body, form;
int32_t arity = 0;
- /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */
+ /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */
form = sc->code;
if ((sc->safety > NO_SAFETY) &&
@@ -72851,7 +72955,7 @@ static s7_pointer check_case(s7_scheme *sc)
else sc->value = carc;
return(NULL);
}
- push_stack_no_args(sc, OP_CASE_G_G, sc->code);
+ push_stack_no_args_direct(sc, OP_CASE_G_G, sc->code);
sc->code = carc;
return(carc);
}
@@ -73113,7 +73217,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s
{
s7_pointer binding;
#if S7_DEBUGGING
- if (cdr(form) != sc->code) fprintf(stderr, "%s[%d]: form: %s, code: %s\n", __func__, __LINE__, DISPLAY_80(form), DISPLAY_80(sc->code));
+ if (cdr(form) != sc->code) fprintf(stderr, "%s[%d]: form: %s, code: %s\n", __func__, __LINE__, display_80(form), display_80(sc->code));
#endif
binding = car(start);
@@ -73126,7 +73230,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s
if (is_optimized(cadr(binding)))
{
- /* if (not_in_heap(form)) fprintf(stderr, "unheap %s\n", DISPLAY_80(form)); */
+ /* if (not_in_heap(form)) fprintf(stderr, "unheap %s\n", display_80(form)); */
if (is_null(cddr(sc->code))) /* one statement body */
{
@@ -73137,7 +73241,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s
pair_set_syntax_op(form, OP_LET_opSSq_E_OLD);
if (c_callee(cadr(binding)) == g_assq)
pair_set_syntax_op(form, OP_LET_opaSSq_E_OLD);
- set_opt3_sym(cdr(sc->code), caddr(cadr(binding)));
+ set_opt3_sym(cdr(sc->code), caddadr(binding));
return(sc->code);
}
if (is_fxable(sc, cadr(binding)))
@@ -73154,7 +73258,7 @@ static s7_pointer check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer s
if (c_callee(cadr(binding)) == g_assq)
pair_set_syntax_op(form, OP_LET_opaSSq_OLD);
else pair_set_syntax_op(form, OP_LET_opSSq_OLD);
- set_opt3_sym(cdr(sc->code), caddr(cadr(binding)));
+ set_opt3_sym(cdr(sc->code), caddadr(binding));
}
else
{
@@ -73401,7 +73505,7 @@ static bool op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in dec
{
s7_pointer body, x;
s7_int n;
- /* fprintf(stderr, "named: %s: %s\n", DISPLAY_80(sc->code)); */
+ /* fprintf(stderr, "named: %s: %s\n", display_80(sc->code)); */
if (is_null(opt3_lamlet(sc->code)))
{
@@ -73472,6 +73576,11 @@ static bool op_let1(s7_scheme *sc)
while (true)
{
+#if S7_DEBUGGING
+ /* can this be a multiple-value? */
+ if (is_multiple_value(sc->value))
+ fprintf(stderr, "%s[%d]: value is a multiple-value? %s from %s\n", __func__, __LINE__, display(sc->value), display(sc->code));
+#endif
sc->args = cons(sc, sc->value, sc->args);
if (is_pair(sc->code))
{
@@ -73480,7 +73589,7 @@ static bool op_let1(s7_scheme *sc)
sc->value = fx_call(sc, x);
else
{
- push_stack(sc, OP_LET1, sc->args, cdr(sc->code));
+ push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); /* cdr direct? */
sc->code = car(x);
return(false);
}
@@ -73568,7 +73677,7 @@ static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */
sc->value = fx_call(sc, x);
else
{
- push_stack(sc, OP_LET1, sc->args, cdr(sc->code));
+ push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); /* cdr direct? */
sc->code = car(x);
return(false); /* goto EVAL */
}
@@ -74011,36 +74120,43 @@ static bool check_let_star(s7_scheme *sc)
else
{
if (is_null(cdar(sc->code)))
- check_let_one_var(sc, form, car(sc->code)); /* (let* ((var...))...) -> (let ((var...))...) */
- else
{
- pair_set_syntax_op(form, (fxable) ? OP_LET_STAR_FX_OLD : OP_LET_STAR2);
- set_opt2_con(sc->code, cadaar(sc->code));
+ check_let_one_var(sc, form, car(sc->code)); /* (let* ((var...))...) -> (let ((var...))...) */
+ if (optimize_op(form) >= OP_LET_FX_OLD)
+ {
+ 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)));
+ else
+ {
+ set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */
+ set_opt3_let(sc->code, sc->nil);
+ }
+ }
}
- }
- if (optimize_op(form) == OP_LET_STAR_FX_OLD)
- {
- if ((is_null(cddr(sc->code))) &&
- (is_fxable(sc, cadr(sc->code))))
+ else /* multiple variables */
{
- annotate_arg(sc, cdr(sc->code), sc->envir);
- pair_set_syntax_op(form, OP_LET_STAR_FX_A_OLD); /* does this ever happen? */
+ s7_pointer last_var;
+ if (fxable)
+ {
+ pair_set_syntax_op(form, OP_LET_STAR_FX);
+ if ((is_null(cddr(sc->code))) &&
+ (is_fxable(sc, cadr(sc->code))))
+ {
+ annotate_arg(sc, cdr(sc->code), sc->envir);
+ pair_set_syntax_op(form, OP_LET_STAR_FX_A); /* does this ever happen? */
+ }
+ }
+ else pair_set_syntax_op(form, OP_LET_STAR2);
+ set_opt2_con(sc->code, cadaar(sc->code));
+
+ for (last_var = caaar(sc->code), vars = cdar(sc->code); is_pair(vars); last_var = caar(vars), vars = cdr(vars))
+ if (has_fx(cdar(vars)))
+ fx_tree(sc, cdar(vars), last_var, NULL);
}
}
}
- 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
- {
- set_optimize_op(form, optimize_op(form) + 1);
- set_opt3_let(sc->code, sc->nil);
- }
- }
/* let_star_unchecked... */
set_current_code(sc, form);
@@ -74093,9 +74209,19 @@ static inline bool op_let_star1(s7_scheme *sc)
* To get around this requires find_symbol or s7_tree_memq in check_let_star,
* both (much) more expensive than making a useless frame!.
*/
+
+ /* TODO: can this be moved to the first call point above? */
+ uint64_t let_counter = S7_LLONG_MAX;
while (true)
{
- new_frame_with_slot(sc, sc->envir, sc->envir, caar(sc->code), sc->value);
+ if (let_counter == sc->capture_let_counter)
+ make_slot_1(sc, sc->envir, caar(sc->code), sc->value);
+ else
+ {
+ new_frame_with_slot(sc, sc->envir, sc->envir, caar(sc->code), sc->value);
+ let_counter = sc->capture_let_counter;
+ }
+
sc->code = cdr(sc->code);
if (is_pair(sc->code))
{
@@ -74105,7 +74231,7 @@ static inline bool op_let_star1(s7_scheme *sc)
sc->value = fx_call(sc, x);
else
{
- push_stack(sc, OP_LET_STAR1, sc->args, sc->code);
+ push_stack_direct(sc, OP_LET_STAR1, sc->args, sc->code);
sc->code = car(x);
return(true);
}
@@ -74126,40 +74252,44 @@ static inline bool op_let_star1(s7_scheme *sc)
return(false);
}
-static void op_let_star_fx_new(s7_scheme *sc)
+static void op_let_star_fx(s7_scheme *sc)
{
- s7_pointer e, p;
+ /* fx safe does not mean we can dispense with the inner frames (curlet is safe for example) */
+ s7_pointer p;
+ uint64_t let_counter = S7_LLONG_MAX;
start_let(sc);
- new_frame(sc, sc->envir, e);
- /* since each value is fx safe, there are no internal closures over the on-going stack of lets here (so use one frame) */
- sc->envir = e;
for (p = car(sc->code); is_pair(p); p = cdr(p))
- make_slot_1(sc, e, caar(p), fx_call(sc, cdar(p)));
- sc->code = T_Pair(cdr(sc->code));
-}
-
-static void op_let_star_fx_old(s7_scheme *sc)
-{
- start_let(sc);
- activate_permanent_let_star(sc, opt3_let(sc->code), car(sc->code));
+ {
+ s7_pointer val;
+ val = fx_call(sc, cdar(p)); /* eval in outer env */
+ if (let_counter == sc->capture_let_counter)
+ make_slot_1(sc, sc->envir, caar(p), val);
+ else
+ {
+ new_frame_with_slot(sc, sc->envir, sc->envir, caar(p), val);
+ let_counter = sc->capture_let_counter;
+ }
+ }
sc->code = T_Pair(cdr(sc->code));
}
-static void op_let_star_fx_a_old(s7_scheme *sc)
-{
- start_let(sc);
- activate_permanent_let_star(sc, opt3_let(sc->code), car(sc->code));
- sc->value = fx_call(sc, cdr(sc->code));
-}
-
-static void op_let_star_fx_a_new(s7_scheme *sc)
+static void op_let_star_fx_a(s7_scheme *sc)
{
- s7_pointer e, p;
+ s7_pointer p;
+ uint64_t let_counter = S7_LLONG_MAX;
start_let(sc);
- new_frame(sc, sc->envir, e);
- sc->envir = e;
for (p = car(sc->code); is_pair(p); p = cdr(p))
- make_slot_1(sc, e, caar(p), fx_call(sc, cdar(p)));
+ {
+ s7_pointer val;
+ val = fx_call(sc, cdar(p));
+ if (let_counter == sc->capture_let_counter)
+ make_slot_1(sc, sc->envir, caar(p), val);
+ else
+ {
+ new_frame_with_slot(sc, sc->envir, sc->envir, caar(p), val);
+ let_counter = sc->capture_let_counter;
+ }
+ }
sc->value = fx_call(sc, cdr(sc->code));
}
@@ -74264,7 +74394,7 @@ static bool op_letrec_unchecked(s7_scheme *sc)
}
sc->args = let_slots(sc->envir);
if (!(sc->args)) sc->args = sc->nil;
- push_stack(sc, OP_LETREC1, sc->args, sc->code);
+ push_stack_direct(sc, OP_LETREC1, sc->args, sc->code);
sc->code = slot_expression(sc->args);
return(true);
}
@@ -74281,7 +74411,7 @@ static bool op_letrec1(s7_scheme *sc)
sc->args = next_slot(sc->args);
if (tis_slot(sc->args))
{
- push_stack(sc, OP_LETREC1, sc->args, sc->code);
+ push_stack_direct(sc, OP_LETREC1, sc->args, sc->code);
sc->code = slot_expression(sc->args);
return(false);
}
@@ -74335,7 +74465,7 @@ static bool op_letrec_star_unchecked(s7_scheme *sc)
let_set_slots(sc->envir, x);
sc->args = let_slots(sc->envir);
if (!(sc->args)) sc->args = sc->nil;
- push_stack(sc, OP_LETREC_STAR1, sc->args, sc->code);
+ push_stack_direct(sc, OP_LETREC_STAR1, sc->args, sc->code);
sc->code = slot_expression(sc->args);
return(true);
}
@@ -74436,6 +74566,12 @@ static s7_pointer check_let_temporarily(s7_scheme *sc)
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);
+
+ if ((optimize_op(form) == OP_LET_TEMP_FX_1) && (is_pair(cdr(sc->code))) && (is_null(cddr(sc->code))) && (is_fxable(sc, cadr(sc->code))))
+ {
+ annotate_arg(sc, cdr(sc->code), sc->envir);
+ pair_set_syntax_op(form, OP_LET_TEMP_A_A);
+ }
}
else
{
@@ -74466,7 +74602,8 @@ static void op_let_temp_unchecked(s7_scheme *sc)
{
set_current_code(sc, sc->code);
sc->code = cdr(sc->code);
- push_stack(sc, OP_GC_PROTECT, sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil), sc->code);
+ sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil);
+ push_stack_direct(sc, OP_GC_PROTECT, sc->args, sc->code);
/* sc->args: varlist, settees, old_values, new_values */
}
@@ -74488,7 +74625,7 @@ static bool op_let_temp_init1(s7_scheme *sc)
{
if (is_pair(settee))
{
- push_stack(sc, OP_LET_TEMP_INIT1, sc->args, sc->code);
+ push_stack_direct(sc, OP_LET_TEMP_INIT1, sc->args, sc->code);
sc->code = settee;
return(true);
}
@@ -74517,7 +74654,7 @@ static goto_t op_let_temp_init2(s7_scheme *sc)
(symbol_has_setter(settee)) ||
(is_pair(new_value)))
{
- push_stack(sc, OP_LET_TEMP_INIT2, sc->args, sc->code);
+ push_stack_direct(sc, OP_LET_TEMP_INIT2, sc->args, sc->code);
sc->code = list_3(sc, sc->set_symbol, settee, new_value);
return(goto_top_no_pop);
}
@@ -74532,11 +74669,11 @@ static goto_t 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); */ /* we fall into LET_TEMP_DONE below so this seems redundant */
+ /* push_stack_direct(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))
{
- push_stack(sc, OP_LET_TEMP_DONE, sc->args, sc->code);
+ push_stack_direct(sc, OP_LET_TEMP_DONE, sc->args, sc->code);
return(goto_begin);
}
sc->value = sc->nil; /* so (let-temporarily (<vars)) -> () like begin I guess */
@@ -74555,7 +74692,7 @@ static bool op_let_temp_done1(s7_scheme *sc)
if ((!is_symbol(settee)) ||
(symbol_has_setter(settee)))
{
- push_stack(sc, OP_LET_TEMP_DONE1, sc->args, sc->code);
+ push_stack_direct(sc, OP_LET_TEMP_DONE1, sc->args, sc->code);
if ((is_pair(sc->value)) || (is_symbol(sc->value)))
sc->code = list_3(sc, sc->set_symbol, settee, list_2(sc, sc->quote_symbol, sc->value));
else sc->code = list_3(sc, sc->set_symbol, settee, sc->value);
@@ -74604,7 +74741,7 @@ static void op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7*
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);
+ push_stack_direct(sc, OP_EVAL_DONE, sc->args, sc->code);
sc->args = T_Pos(args);
sc->code = code;
sc->envir = let;
@@ -74671,6 +74808,16 @@ static void op_let_temp_fx_1(s7_scheme *sc) /* one entry */
sc->code = cdr(sc->code);
}
+static s7_pointer fx_let_temp_a_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer result;
+ op_let_temp_fx_1(sc);
+ result = fx_call(sc, sc->code);
+ pop_stack(sc);
+ let_temp_unwind(sc, sc->code, sc->args);
+ return(result);
+}
+
static void op_let_temp_setter(s7_scheme *sc)
{
s7_pointer var, slot, sym, e;
@@ -74822,7 +74969,7 @@ static void op_and_safe_aa(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, sc->code);
+ push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST, sc->code);
sc->code = car(sc->code);
}
@@ -74831,7 +74978,7 @@ 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, sc->code);
+ push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST, sc->code);
sc->code = car(sc->code);
return(false);
}
@@ -74969,8 +75116,6 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re
}
if (is_fxable(sc, test))
{
- /* if (one_branch) fprintf(stderr, "%s\n", DISPLAY_80(sc->code)); */
-
if (optimize_op(test) == OP_OR_2)
{
pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case));
@@ -75052,7 +75197,6 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re
{
if (is_safe_symbol(test))
{
- /* if (!not_case) fprintf(stderr, "if_s: %s\n", DISPLAY_80(form)); */
pair_set_syntax_op(form, choose_if_optc(IF_S, one_branch, reversed, not_case));
if ((optimize_op(form) == OP_IF_S_P_P) &&
(is_fxable(sc, caddr(sc->code))))
@@ -75464,7 +75608,7 @@ static s7_pointer check_define(s7_scheme *sc)
if (is_syntactic_symbol(func)) /* (define and a) */
{
if (sc->safety > NO_SAFETY)
- s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", DISPLAY(func));
+ s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", display(func));
set_local(func);
}
if ((is_pair(cadr(sc->code))) && /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */
@@ -75491,7 +75635,7 @@ static s7_pointer check_define(s7_scheme *sc)
if (is_syntactic_symbol(func)) /* (define (and a) a) */
{
if (sc->safety > NO_SAFETY)
- s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", DISPLAY(func));
+ s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", display(func));
set_local(func);
}
if (starred)
@@ -75551,7 +75695,7 @@ static bool op_define_unchecked(s7_scheme *sc)
}
else
{
- s7_pointer x,args;
+ s7_pointer x, args;
/* a closure. If we called this same code earlier (a local define), the only thing
* that is new here is the environment -- we can't blithely save the closure object
* in opt2 somewhere, and pick it up the next time around (since call/cc might take
@@ -75569,7 +75713,7 @@ static bool op_define_unchecked(s7_scheme *sc)
static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_env)
{
s7_pointer new_env, arg;
- /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, DISPLAY(new_func), DISPLAY(func_name), DISPLAY(outer_env)); */
+ /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(new_func), display(func_name), display(outer_env)); */
new_cell_no_check(sc, new_env, T_LET | T_FUNCLET);
let_id(new_env) = ++sc->let_number;
set_outlet(new_env, outer_env);
@@ -75722,7 +75866,7 @@ static void op_define_constant1(s7_scheme *sc)
static inline void define_funchecked(s7_scheme *sc)
{
s7_pointer new_func, code, slot;
- /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, DISPLAY(sc->code)); */
+ /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(sc->code)); */
code = cdr(sc->code);
sc->value = caar(code); /* func name */
@@ -75783,7 +75927,7 @@ static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op)
if (is_syntactic_symbol(x))
{
if (sc->safety > NO_SAFETY)
- s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", DISPLAY(x));
+ s7_warn(sc, 128, "%s: syntactic keywords tend to behave badly if redefined\n", display(x));
set_local(x);
}
if (is_constant_symbol(sc, x))
@@ -76039,7 +76183,7 @@ static goto_t op_macroexpand(s7_scheme *sc)
if (is_pair(caar(sc->code))) /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */
{
- push_stack_no_args(sc, OP_MACROEXPAND_1, sc->code);
+ push_stack_no_args_direct(sc, OP_MACROEXPAND_1, sc->code);
sc->code = caar(sc->code);
return(goto_eval);
}
@@ -76316,7 +76460,7 @@ static bool op_cond_unchecked(s7_scheme *sc)
sc->value = fx_call(sc, car(sc->code)); /* false -> fall through into cond1 */
return(false);
}
- push_stack_no_args(sc, OP_COND1, sc->code); /* true -> push cond1, goto eval */
+ push_stack_no_args_direct(sc, OP_COND1, sc->code); /* true -> push cond1, goto eval */
sc->code = opt3_any(sc->code); /* caar */
return(true);
}
@@ -76330,7 +76474,7 @@ static bool op_cond_simple(s7_scheme *sc) /* no => */
sc->value = fx_call(sc, car(sc->code));
return(false);
}
- push_stack_no_args(sc, OP_COND1_SIMPLE, sc->code);
+ push_stack_no_args_direct(sc, OP_COND1_SIMPLE, sc->code);
sc->code = opt3_any(sc->code); /* caar */
return(true);
}
@@ -76344,7 +76488,7 @@ static bool op_cond_simple_p(s7_scheme *sc) /* no =>, no null or multiform cons
sc->value = fx_call(sc, car(sc->code));
return(false);
}
- push_stack_no_args(sc, OP_COND1_SIMPLE_P, sc->code);
+ push_stack_no_args_direct(sc, OP_COND1_SIMPLE_P, sc->code);
sc->code = opt3_any(sc->code); /* caar */
return(true);
}
@@ -76410,7 +76554,7 @@ static bool op_cond1(s7_scheme *sc)
sc->value = fx_call(sc, car(sc->code));
else
{
- push_stack_no_args(sc, OP_COND1, sc->code);
+ push_stack_no_args_direct(sc, OP_COND1, sc->code);
sc->code = caar(sc->code);
sc->cur_op = optimize_op(sc->code);
return(true);
@@ -76454,7 +76598,7 @@ static bool op_cond1_simple(s7_scheme *sc)
sc->value = fx_call(sc, car(sc->code));
else
{
- push_stack_no_args(sc, OP_COND1_SIMPLE, sc->code);
+ push_stack_no_args_direct(sc, OP_COND1_SIMPLE, sc->code);
sc->code = caar(sc->code);
sc->cur_op = optimize_op(sc->code);
return(true);
@@ -76487,7 +76631,7 @@ static bool op_cond1_simple_p(s7_scheme *sc)
sc->value = fx_call(sc, car(sc->code));
else
{
- push_stack_no_args(sc, OP_COND1_SIMPLE_P, sc->code);
+ push_stack_no_args_direct(sc, OP_COND1_SIMPLE_P, sc->code);
sc->code = caar(sc->code);
return(false);
}
@@ -76579,7 +76723,7 @@ static bool op_cond_feed(s7_scheme *sc)
sc->value = fx_call(sc, car(sc->code));
else
{
- push_stack_no_args(sc, OP_COND_FEED_1, sc->code);
+ push_stack_no_args_direct(sc, OP_COND_FEED_1, sc->code);
sc->code = caar(sc->code);
return(true);
}
@@ -76622,7 +76766,7 @@ static bool feed_to(s7_scheme *sc)
}
sc->args = list_1(sc, sc->value); /* not plist here */
}
- push_stack(sc, OP_FEED_TO_1, sc->args, sc->code);
+ push_stack_direct(sc, OP_FEED_TO_1, sc->args, sc->code);
sc->code = cadr(sc->code); /* need to evaluate the target function */
return(false);
}
@@ -76650,7 +76794,7 @@ static inline s7_pointer check_set(s7_scheme *sc)
{
s7_pointer form;
form = sc->code;
- /* fprintf(stderr, "check_set: %s\n", DISPLAY_80(sc->code)); */
+ /* fprintf(stderr, "check_set: %s\n", display_80(sc->code)); */
sc->code = cdr(sc->code);
if (!is_pair(sc->code))
@@ -76851,6 +76995,7 @@ static inline s7_pointer check_set(s7_scheme *sc)
{
if (settee == cadr(value))
{
+ /* TODO?: +/- via (c_callee(value)) as g_add_2/g_subtract_2 - integer case */
pair_set_syntax_op(form, OP_INCREMENT_SS);
set_opt2_sym(sc->code, caddr(value));
}
@@ -76878,7 +77023,6 @@ static inline s7_pointer check_set(s7_scheme *sc)
{
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
@@ -77332,7 +77476,8 @@ static s7_pointer op_set2(s7_scheme *sc)
if (sc->args != sc->nil)
{
push_op_stack(sc, sc->list_set_function);
- push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), s7_append(sc, cdr(sc->args), sc->code));
+ sc->code = s7_append(sc, cdr(sc->args), sc->code);
+ push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), sc->code);
sc->code = car(sc->args);
}
else eval_error(sc, "list set!: not enough arguments: ~S", 35, sc->code);
@@ -77349,7 +77494,8 @@ static s7_pointer op_set2(s7_scheme *sc)
if (sc->args != sc->nil)
{
push_op_stack(sc, sc->vector_set_function);
- push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), s7_append(sc, cdr(sc->args), sc->code));
+ sc->code = s7_append(sc, cdr(sc->args), sc->code);
+ push_stack(sc, OP_EVAL_ARGS1, list_1(sc, sc->value), sc->code);
sc->code = car(sc->args);
}
else eval_error(sc, "vector set!: not enough arguments: ~S", 37, sc->code);
@@ -77398,7 +77544,7 @@ static bool op_set_with_let_1(s7_scheme *sc)
}
sc->code = e; /* 'e above, an expression we need to evaluate */
sc->args = list_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */
- push_stack(sc, OP_SET_WITH_LET_2, sc->args, sc->code);
+ push_stack_direct(sc, OP_SET_WITH_LET_2, sc->args, sc->code);
sc->cur_op = optimize_op(sc->code);
return(true);
}
@@ -77453,7 +77599,7 @@ static void op_increment_sp(s7_scheme *sc)
sc->code = cdr(sc->code);
sym = symbol_to_slot(sc, car(sc->code));
push_stack(sc, OP_INCREMENT_SP_1, sym, sc->code);
- sc->code = T_Pair(opt2_pair(sc->code)); /* caddr(cadr(sc->code)); */
+ sc->code = T_Pair(opt2_pair(sc->code)); /* caddadr(sc->code); */
}
static void op_increment_sp_1(s7_scheme *sc)
@@ -77552,7 +77698,8 @@ static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer cx)
}
else
{
- push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code)));
+ sc->code = s7_append(sc, cddr(settee), cdr(sc->code));
+ push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), sc->code);
sc->code = cadr(settee);
}
sc->cur_op = optimize_op(sc->code);
@@ -77663,7 +77810,8 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer cx, s7_pointer form)
}
}
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 = s7_append(sc, cddr(settee), cdr(sc->code)); /* i.e. rest(args) + val */
+ push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), sc->code);
sc->code = cadr(settee);
sc->cur_op = optimize_op(sc->code);
return(goto_top_no_pop);
@@ -77808,7 +77956,8 @@ static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer cx) /* code: ((ls
(is_pair(val)))
{
push_op_stack(sc, sc->list_set_function);
- push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), s7_append(sc, cddr(settee), cdr(sc->code)));
+ sc->code = s7_append(sc, cddr(settee), cdr(sc->code));
+ push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), sc->code);
sc->code = index;
sc->cur_op = optimize_op(sc->code);
return(goto_top_no_pop);
@@ -77970,7 +78119,8 @@ static goto_t set_implicit_function(s7_scheme *sc, s7_pointer cx) /* (let ((lst
}
}
push_op_stack(sc, c_function_setter(cx));
- push_stack(sc, OP_EVAL_ARGS1, sc->nil, s7_append(sc, cddar(sc->code), cdr(sc->code)));
+ sc->value = s7_append(sc, cddar(sc->code), cdr(sc->code));
+ push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->value);
sc->code = cadar(sc->code);
}
else
@@ -78032,7 +78182,11 @@ static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer cx)
{
if (is_null(cddar(sc->code)))
push_stack(sc, OP_EVAL_ARGS1, sc->nil, cdr(sc->code));
- else push_stack(sc, OP_EVAL_ARGS1, sc->nil, s7_append(sc, cddar(sc->code), cdr(sc->code)));
+ else
+ {
+ sc->value = s7_append(sc, cddar(sc->code), cdr(sc->code));
+ push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->value);
+ }
sc->code = cadar(sc->code);
}
}
@@ -78089,7 +78243,7 @@ static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer cx)
*/
sc->args = cdar(sc->code);
sc->code = cadr(sc->code);
- push_stack(sc, OP_SET_WITH_LET_1, sc->args, sc->code);
+ push_stack_direct(sc, OP_SET_WITH_LET_1, sc->args, sc->code);
sc->cur_op = optimize_op(sc->code);
return(goto_top_no_pop);
}
@@ -78196,14 +78350,14 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p
{
/* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble */
s7_pointer p;
- if (DO_PRINT) fprintf(stderr, "do_is_safe: %s\n", DISPLAY_80(body));
+ if (DO_PRINT) fprintf(stderr, "do_is_safe: %s\n", display_80(body));
/* sc->code is the complete do form (do ...) */
for (p = body; is_pair(p); p = cdr(p))
{
s7_pointer expr;
expr = car(p);
- if (DO_PRINT) fprintf(stderr, " %s\n", DISPLAY_80(expr));
+ if (DO_PRINT) fprintf(stderr, " %s\n", display_80(expr));
if (is_pair(expr))
{
s7_pointer x;
@@ -78282,15 +78436,15 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p
(!do_is_safe(sc, cdar(vars), steppers, nv, has_set)))
{
sc->x = sc->nil;
- {if (DO_PRINT) fprintf(stderr, "bad stepper %d, step %s\n", __LINE__, DISPLAY_80(cdar(vars))); return(false);}
+ {if (DO_PRINT) fprintf(stderr, "bad stepper %d, step %s\n", __LINE__, display_80(cdar(vars))); return(false);}
}
}
sc->x = sc->nil;
if (!do_is_safe(sc, caddr(expr), steppers, nv, has_set))
- {if (DO_PRINT) fprintf(stderr, "bad init %d: %s\n", __LINE__, DISPLAY(caddr(expr))); return(false);}
+ {if (DO_PRINT) fprintf(stderr, "bad init %d: %s\n", __LINE__, display(caddr(expr))); return(false);}
if ((is_pair(cdddr(expr))) &&
(!do_is_safe(sc, cdddr(expr), steppers, nv, has_set)))
- {if (DO_PRINT) fprintf(stderr, "bad step %d, %s\n", __LINE__, DISPLAY(cadddr(expr))); return(false);}
+ {if (DO_PRINT) fprintf(stderr, "bad step %d, %s\n", __LINE__, display(cadddr(expr))); return(false);}
if (DO_PRINT) fprintf(stderr, "do is ok\n");
break;
}
@@ -78327,7 +78481,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p
if (res)
{
if (DO_PRINT)
- fprintf(stderr, "set! end %d, settee: %s in %s\n", __LINE__, DISPLAY(settee), DISPLAY(caaddr(sc->code)));
+ fprintf(stderr, "set! end %d, settee: %s in %s\n", __LINE__, display(settee), display(caaddr(sc->code)));
return(false);
}
}
@@ -78443,7 +78597,7 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer steppers, s7_p
} /* is_symbol(x=car(expr)) */
else
{
- {if (DO_PRINT) fprintf(stderr, "%d, %s not a symbol\n", __LINE__, DISPLAY_80(x)); return(false);}
+ {if (DO_PRINT) fprintf(stderr, "%d, %s not a symbol\n", __LINE__, display_80(x)); return(false);}
/* car(expr) ("x") is not a symbol: ((mus-data loc) chan) for example
* but that's actually safe since it's just in effect vector-ref
* there are several examples in dlocsig: ((group-speakers group) i) etc
@@ -78552,7 +78706,7 @@ static inline bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree)
(!symbol_is_in_list(sc, cadr(p))))))
{
#if DO_PRINT
- fprintf(stderr, "definer: %s\n", DISPLAY(pp));
+ fprintf(stderr, "definer: %s\n", display(pp));
#endif
return(true);
}
@@ -78574,7 +78728,7 @@ static s7_pointer check_do(s7_scheme *sc)
form = sc->code;
code = cdr(sc->code);
#if DO_PRINT
- fprintf(stderr, "check_do: %s %s\n", DISPLAY_80(form), DISPLAY_80(sc->envir));
+ fprintf(stderr, "check_do: %s %s\n", display_80(form), display_80(sc->envir));
#endif
if ((!is_pair(code)) || /* (do . 1) */
@@ -78641,29 +78795,57 @@ static s7_pointer check_do(s7_scheme *sc)
eval_error(sc, "stray dot in do body? ~A", 24, form);
pair_set_syntax_op(form, OP_DO_UNCHECKED);
-
end = cadr(code);
+
if ((!is_pair(end)) || (!is_fxable(sc, car(end))))
{
#if DO_PRINT
- fprintf(stderr, "%s end unsafe\n", DISPLAY_80(form));
+ fprintf(stderr, "%s end unsafe\n", display_80(form));
if (is_pair(end)) fprintf(stderr, " %d %s\n", is_fxable(sc, car(end)), op_names[optimize_op(car(end))]);
#endif
if (is_null(cddr(code)))
{
- /* no body, end not fxable */
+ /* no body, end not fxable (if eval car(end) might be unopt) */
s7_pointer p;
- fxify_step_exprs(sc, code);
- for (p = car(code); is_pair(p); p = cdr(p))
+ for (p = car(code); is_pair(p); p = cdr(p)) /* gather var names */
{
s7_pointer var;
var = car(p);
- if ((!has_fx(cdr(var))) ||
- ((is_pair(cddr(var))) && (!has_fx(cddr(var)))))
- break;
+ if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */
+ set_match_symbol(car(var));
+ }
+ for (p = car(code); is_pair(p); p = cdr(p)) /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)) */
+ {
+ s7_pointer var, val;
+ var = car(p);
+ val = cddr(var);
+ if (is_pair(val))
+ {
+ clear_match_symbol(car(var)); /* ignore current var */
+ if (tree_match(car(val)))
+ {
+ s7_pointer q;
+ for (q = car(code); is_pair(q); q = cdr(q))
+ clear_match_symbol(caar(q));
+ return(code);
+ }
+ }
+ set_match_symbol(car(var));
}
+ for (p = car(code); is_pair(p); p = cdr(p)) /* clear var names */
+ clear_match_symbol(caar(p));
+
if (is_null(p))
{
+ fxify_step_exprs(sc, code);
+ for (p = car(code); is_pair(p); p = cdr(p))
+ {
+ s7_pointer var;
+ var = car(p);
+ if ((!has_fx(cdr(var))) ||
+ ((is_pair(cddr(var))) && (!has_fx(cddr(var)))))
+ return(code);
+ }
pair_set_syntax_op(form, OP_DO_NO_BODY_FX_VARS);
return(sc->nil);
}
@@ -78814,13 +78996,13 @@ static s7_pointer check_do(s7_scheme *sc)
for (q = vars; q != p; q = cdr(q))
clear_match_symbol(caar(q));
#if DO_PRINT
- fprintf(stderr, " step not fx safe: %s\n ", DISPLAY(var));
+ fprintf(stderr, " step not fx safe: %s\n ", display(var));
if (!is_fxable(sc, cadr(var)))
- fprintf(stderr, "can't fxify %s (%s)\n", DISPLAY(cadr(var)), op_names[optimize_op(cadr(var))]);
+ fprintf(stderr, "can't fxify %s (%s)\n", display(cadr(var)), op_names[optimize_op(cadr(var))]);
if ((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var))))
- fprintf(stderr, "can't fxify %s (%s)\n", DISPLAY(caddr(var)), op_names[optimize_op(caddr(var))]);
+ fprintf(stderr, "can't fxify %s (%s)\n", display(caddr(var)), op_names[optimize_op(caddr(var))]);
if ((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var))))
- fprintf(stderr, "%s is a definer or binder\n", DISPLAY(cadr(var)));
+ fprintf(stderr, "%s is a definer or binder\n", display(cadr(var)));
#endif
return(fxify_step_exprs(sc, code));
}
@@ -78851,7 +79033,7 @@ static s7_pointer check_do(s7_scheme *sc)
for (q = vars; is_pair(q); q = cdr(q))
clear_match_symbol(caar(q));
#if DO_PRINT
- fprintf(stderr, "var matched in %s\n", DISPLAY(car(val)));
+ fprintf(stderr, "var matched in %s\n", display(car(val)));
#endif
if (is_null(body))
got_pending = true;
@@ -78864,7 +79046,7 @@ static s7_pointer check_do(s7_scheme *sc)
clear_match_symbol(caar(p));
/* end and steps look ok! */
- /* TODO: split out the constant cases from OP_DOX so dox_ex is less repetitive
+ /* TODO: split out the constant cases from OP_DOX so op_dox is less repetitive
* 1-var, no body, 1-expr body, steppers=1|2
*/
for (p = vars; is_pair(p); p = cdr(p))
@@ -78980,14 +79162,6 @@ static s7_pointer check_do(s7_scheme *sc)
annotate_arg(sc, body, collect_variables(sc, vars, sc->nil));
fx_tree(sc, body, last_stepper, previous_stepper);
}
-
-#if 0
- {
- bool has_set = false;
- if (do_is_safe(sc, body, (previous_stepper) ? set_plist_2(sc, last_stepper, previous_stepper) : set_plist_1(sc, last_stepper), sc->nil, &has_set))
- fx_tree(sc, body, last_stepper, previous_stepper);
- }
-#endif
}
#if (DO_PRINT)
fprintf(stderr, " dox\n");
@@ -79019,7 +79193,6 @@ static bool has_safe_steppers(s7_scheme *sc, s7_pointer frame)
if (is_t_integer(val))
{
sc->pc = 0;
- reset_opts(sc);
if (int_optimize(sc, step_expr))
set_safe_stepper(slot);
else clear_safe_stepper(slot);
@@ -79029,7 +79202,6 @@ static bool has_safe_steppers(s7_scheme *sc, s7_pointer frame)
if (is_real(val))
{
sc->pc = 0;
- reset_opts(sc);
if (float_optimize(sc, step_expr))
set_safe_stepper(slot);
else clear_safe_stepper(slot);
@@ -79081,7 +79253,7 @@ static bool op_dox_init(s7_scheme *sc)
return(false); /* goto BEGIN */
}
-static goto_t dox_ex(s7_scheme *sc)
+static goto_t op_dox(s7_scheme *sc)
{
/* any number of steppers using dox exprs, end also dox, body and end result arbitrary.
* since all these exprs are local, we don't need to jump until the body
@@ -79127,6 +79299,7 @@ static goto_t dox_ex(s7_scheme *sc)
end = cadr(sc->code);
endp = car(end);
endf = c_callee(end);
+
if (is_true(sc, sc->value = endf(sc, endp)))
{
sc->code = cdr(end);
@@ -79221,7 +79394,6 @@ static goto_t dox_ex(s7_scheme *sc)
}
return(goto_do_end_clauses);
}
-
while (true)
{
s7_pointer slt;
@@ -79274,7 +79446,6 @@ static goto_t dox_ex(s7_scheme *sc)
fd = o->v[0].fd;
while (true)
{
- sc->pc = 0;
fd(o);
slot_set_value(stepper, stepf(sc, stepa));
if (is_true(sc, sc->value = endf(sc, endp)))
@@ -79284,6 +79455,23 @@ static goto_t dox_ex(s7_scheme *sc)
}
}
}
+
+ if ((stepf == fx_add_t1) && (stepper == let_slots(sc->envir)) && (is_t_integer(slot_value(stepper))))
+ {
+ s7_int i;
+ i = integer(slot_value(stepper));
+ while (true)
+ {
+ bodyf(sc, body);
+ slot_set_value(stepper, make_integer(sc, ++i));
+ if (is_true(sc, sc->value = endf(sc, endp)))
+ {
+ sc->code = cdr(end);
+ return(goto_do_end_clauses);
+ }
+ }
+ }
+
while (true)
{
bodyf(sc, body);
@@ -79372,6 +79560,7 @@ static goto_t dox_ex(s7_scheme *sc)
s7_pointer p;
bool use_opts = false;
int32_t body_len = 0;
+ opt_info *body[32];
p = code;
if ((!no_cell_opt(code)) &&
@@ -79379,8 +79568,9 @@ static goto_t dox_ex(s7_scheme *sc)
{
if (setjmp(sc->opt_exit) == 0)
{
+ int32_t k;
sc->pc = 0;
- for (; is_pair(p); p = cdr(p), body_len++)
+ for (k = 0; (is_pair(p)) && (k < 32); k++, p = cdr(p), body_len++)
{
opt_info *start;
start = sc->opts[sc->pc];
@@ -79391,6 +79581,7 @@ static goto_t dox_ex(s7_scheme *sc)
break;
}
oo_idp_nr_fixup(start);
+ body[k] = start;
}
use_opts = is_null(p);
}
@@ -79421,14 +79612,8 @@ static goto_t dox_ex(s7_scheme *sc)
{
if (use_opts)
{
- sc->pc = 0;
for (i = 0; i < body_len; i++)
- {
- opt_info *o;
- o = sc->opts[sc->pc];
- o->v[0].fp(o);
- sc->pc++;
- }
+ body[i]->v[0].fp(body[i]);
}
else
{
@@ -79458,7 +79643,7 @@ static goto_t dox_ex(s7_scheme *sc)
if ((is_syntactic_pair(code)) ||
(is_syntactic_symbol(car(code))))
{
- push_stack_no_args(sc, OP_DOX_STEP_P, sc->code);
+ push_stack_no_args_direct(sc, OP_DOX_STEP_P, sc->code);
if (is_syntactic_pair(code))
sc->cur_op = (opcode_t)optimize_op(code);
@@ -79475,7 +79660,6 @@ static goto_t dox_ex(s7_scheme *sc)
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);
}
@@ -79491,7 +79675,7 @@ static bool op_dox_step(s7_scheme *sc)
sc->code = cdadr(sc->code);
return(true);
}
- push_stack_no_args(sc, OP_DOX_STEP, sc->code);
+ push_stack_no_args_direct(sc, OP_DOX_STEP, sc->code);
sc->code = T_Pair(cddr(sc->code));
return(false);
}
@@ -79508,7 +79692,7 @@ static bool op_dox_step_p(s7_scheme *sc)
sc->code = cdadr(sc->code);
return(true);
}
- push_stack_no_args(sc, OP_DOX_STEP_P, sc->code);
+ push_stack_no_args_direct(sc, OP_DOX_STEP_P, sc->code);
sc->code = caddr(sc->code);
return(false);
}
@@ -79598,6 +79782,8 @@ static void op_dox_pending_no_body(s7_scheme *sc)
sc->envir = frame;
sc->temp10 = sc->nil;
test = cadr(sc->code);
+
+ let_set_has_pending_value(sc->envir);
if ((all_steps) &&
(!tis_slot(next_slot(next_slot(let_slots(frame))))))
{
@@ -79609,24 +79795,27 @@ static void op_dox_pending_no_body(s7_scheme *sc)
if (is_true(sc, sc->value = fx_call(sc, test)))
{
sc->code = cdr(test);
+ let_clear_has_pending_value(sc->envir);
return;
}
- slot_set_pending_value(slot1, fx_call(sc, slot_expression(slot1)));
+ slot_simply_set_pending_value(slot1, fx_call(sc, slot_expression(slot1))); /* use pending_value for GC protection */
slot_set_value(slot2, fx_call(sc, slot_expression(slot2)));
slot_set_value(slot1, slot_pending_value(slot1));
}
}
+
while (true)
{
s7_pointer slt;
if (is_true(sc, sc->value = fx_call(sc, test)))
{
sc->code = cdr(test);
+ let_clear_has_pending_value(sc->envir);
return;
}
for (slt = slots; tis_slot(slt); slt = next_slot(slt))
if (slot_has_expression(slt))
- slot_set_pending_value(slt, fx_call(sc, slot_expression(slt)));
+ slot_simply_set_pending_value(slt, fx_call(sc, slot_expression(slt)));
for (slt = slots; tis_slot(slt); slt = next_slot(slt))
if (slot_has_expression(slt))
slot_set_value(slt, slot_pending_value(slt));
@@ -79637,14 +79826,18 @@ static bool op_do_no_vars(s7_scheme *sc)
{
s7_pointer p, form;
int32_t i;
+ opt_info *body[32];
form = sc->code;
set_current_code(sc, form);
sc->code = cdr(sc->code);
sc->pc = 0;
- reset_opts(sc);
- for (i = 0, p = cddr(sc->code); is_pair(p); i++, p = cdr(p))
- if (!cell_optimize(sc, p))
- break;
+
+ for (i = 0, p = cddr(sc->code); (is_pair(p)) && (i < 32); i++, p = cdr(p))
+ {
+ body[i] = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ break;
+ }
if (is_null(p))
{
s7_pointer end;
@@ -79660,8 +79853,7 @@ static bool op_do_no_vars(s7_scheme *sc)
sc->code = cdr(end);
return(true);
}
- sc->pc = 0;
- sc->opts[0]->v[0].fp(sc->opts[0]);
+ body[0]->v[0].fp(body[0]);
}
}
else
@@ -79685,16 +79877,9 @@ static bool op_do_no_vars(s7_scheme *sc)
sc->code = cdr(end);
return(true);
}
- sc->pc = -1;
for (k = 0; k < i; k++)
- {
- opt_info *o;
- o = sc->opts[++sc->pc];
- o->v[0].fp(o);
- }
- }
- }
- }
+ body[k]->v[0].fp(body[k]);
+ }}}
/* back out */
pair_set_syntax_op(form, OP_DO_NO_VARS_NO_OPT);
sc->envir = new_frame_in_env(sc, sc->envir);
@@ -79704,7 +79889,7 @@ static bool op_do_no_vars(s7_scheme *sc)
sc->code = cdadr(sc->code);
return(true);
}
- push_stack_no_args(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code);
+ push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code);
sc->code = T_Pair(cddr(sc->code));
return(false);
}
@@ -79724,7 +79909,7 @@ static bool op_do_no_vars_no_opt_1(s7_scheme *sc)
sc->code = cdadr(sc->code);
return(true);
}
- push_stack_no_args(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code);
+ push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1, sc->code);
sc->code = T_Pair(cddr(sc->code));
return(false);
}
@@ -79750,7 +79935,7 @@ static void op_do_no_body_fx_vars(s7_scheme *sc)
}
if (steppers == 1) let_set_dox_slot1(frame, stepper);
sc->envir = frame;
- push_stack_no_args(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_FX_VARS_STEP_1 : OP_DO_NO_BODY_FX_VARS_STEP), sc->code);
+ push_stack_no_args_direct(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_FX_VARS_STEP_1 : OP_DO_NO_BODY_FX_VARS_STEP), sc->code);
sc->code = caadr(sc->code);
}
@@ -79766,7 +79951,7 @@ static bool op_do_no_body_fx_vars_step(s7_scheme *sc)
if (slot_has_expression(slot))
slot_set_value(slot, fx_call(sc, slot_expression(slot)));
- push_stack_no_args(sc, OP_DO_NO_BODY_FX_VARS_STEP, sc->code);
+ push_stack_no_args_direct(sc, OP_DO_NO_BODY_FX_VARS_STEP, sc->code);
sc->code = caadr(sc->code);
return(false);
}
@@ -79779,21 +79964,20 @@ static bool op_do_no_body_fx_vars_step_1(s7_scheme *sc)
return(true);
}
slot_set_value(let_dox_slot1(sc->envir), fx_call(sc, slot_expression(let_dox_slot1(sc->envir))));
- push_stack_no_args(sc, OP_DO_NO_BODY_FX_VARS_STEP_1, sc->code);
+ push_stack_no_args_direct(sc, OP_DO_NO_BODY_FX_VARS_STEP_1, sc->code);
sc->code = caadr(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 */
+ 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));
@@ -79805,17 +79989,12 @@ static bool do_step1(s7_scheme *sc)
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);
+ slot_set_pending_value(car(sc->args), sc->value); /* consistently slower if slot_simply_set... here? */
sc->args = cdr(sc->args); /* go to next step var */
}
else
{
- push_stack(sc, OP_DO_STEP2, sc->args, sc->code);
+ push_stack_direct(sc, OP_DO_STEP2, sc->args, sc->code);
sc->code = car(code);
return(false);
}
@@ -79841,7 +80020,7 @@ static bool op_do_step(s7_scheme *sc)
* 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);
+ push_stack_direct(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);
@@ -79924,7 +80103,7 @@ static bool opt_do_copy(s7_scheme *sc, opt_info *o, s7_int start, s7_int stop)
return(false);
}
-static bool simple_do_ex(s7_scheme *sc, s7_pointer code)
+static bool op_simple_do_1(s7_scheme *sc, s7_pointer code)
{
#if (!WITH_GMP)
s7_pointer body, step_expr, step_var, ctr_slot, end_slot;
@@ -79987,7 +80166,6 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code)
for (i = start; i < stop; i++)
{
slot_set_value(ctr_slot, make_integer(sc, i));
- sc->pc = 1;
fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p));
}
}
@@ -79996,7 +80174,6 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code)
for (i = start; i < stop; i++)
{
slot_set_value(ctr_slot, make_integer(sc, i));
- sc->pc = 0;
fp(o);
}
}
@@ -80036,7 +80213,6 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code)
for (i = start; i >= stop; i--)
{
slot_set_value(ctr_slot, make_integer(sc, i));
- sc->pc = 0;
fp(o);
}
}
@@ -80096,7 +80272,7 @@ static bool simple_do_ex(s7_scheme *sc, s7_pointer code)
static bool op_simple_do(s7_scheme *sc)
{
/* body might not be safe in this case, but the step and end exprs are easy
- * simple_do: set up local env, check end (c_c?), goto simple_do_ex
+ * simple_do: set up local env, check end (c_c?), goto op_simple_do_1
* if latter gets s7_optimize, run locally, else goto simple_do_step.
*/
s7_pointer end, code, body;
@@ -80123,9 +80299,9 @@ static bool op_simple_do(s7_scheme *sc)
body = cddr(code);
if ((is_null(cdr(body))) && /* one expr in body */
(is_pair(car(body))) && /* and it is a pair */
- (is_symbol(cadr(caddr(caar(code))))) && /* caar=(i 0 (+ i 1)), caddr=(+ i 1), so this is apparently checking that the stepf is reasonable? */
- (is_t_integer(caddr(caddr(caar(code))))) &&
- (simple_do_ex(sc, sc->code)))
+ (is_symbol(cadaddr(caar(code)))) && /* caar=(i 0 (+ i 1)), caddr=(+ i 1), so this is apparently checking that the stepf is reasonable? */
+ (is_t_integer(caddaddr(caar(code)))) &&
+ (op_simple_do_1(sc, sc->code)))
return(true); /* goto DO_END_CLAUSES */
push_stack(sc, OP_SIMPLE_DO_STEP, sc->args, code);
@@ -80164,7 +80340,7 @@ static bool op_simple_do_step(s7_scheme *sc)
return(true);
}
- push_stack(sc, OP_SIMPLE_DO_STEP, sc->args, code);
+ push_stack_direct(sc, OP_SIMPLE_DO_STEP, sc->args, sc->code);
sc->code = T_Pair(cddr(code));
return(false);
}
@@ -80187,7 +80363,7 @@ static bool op_safe_do_step(s7_scheme *sc)
sc->code = cdadr(sc->code);
return(true);
}
- push_stack(sc, OP_SAFE_DO_STEP, sc->args, sc->code);
+ push_stack_direct(sc, OP_SAFE_DO_STEP, sc->args, sc->code);
sc->code = T_Pair(opt2_pair(sc->code));
return(false);
}
@@ -80203,7 +80379,7 @@ static bool op_safe_dotimes_step(s7_scheme *sc)
sc->code = cdadr(sc->code);
return(true);
}
- push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, sc->code);
+ push_stack_direct(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);
@@ -80221,7 +80397,7 @@ static bool op_safe_dotimes_step_p(s7_scheme *sc)
sc->code = cdadr(sc->code);
return(true);
}
- push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, sc->code);
+ push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, sc->code);
sc->code = opt2_pair(sc->code);
return(false);
}
@@ -80282,7 +80458,7 @@ static inline bool op_dotimes_step_p(s7_scheme *sc)
return(true);
}
}
- push_stack(sc, OP_DOTIMES_STEP_P, sc->args, code);
+ push_stack_direct(sc, OP_DOTIMES_STEP_P, sc->args, sc->code);
sc->code = caddr(code);
return(false);
}
@@ -80290,11 +80466,14 @@ static inline bool op_dotimes_step_p(s7_scheme *sc)
static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool safe_step)
{
s7_int end;
+ /* fprintf(stderr, "opt_dotimes: %s\n", display(code)); */
+
if (safe_step)
set_safe_stepper(sc->args);
else set_safe_stepper(let_dox_slot1(sc->envir));
/* I think safe_step means the stepper is completely unproblematic */
+
if (is_null(cdr(code)))
{
s7_function func;
@@ -80332,10 +80511,9 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
fd = o1->v[0].fd;
end8 = end - 8;
while (integer(stepper) < end8)
- LOOP_8(sc->pc = 1; f0(integer(stepper), fd(o1)); integer(stepper)++);
+ LOOP_8(f0(integer(stepper), fd(o1)); integer(stepper)++);
while (integer(stepper) < end)
{
- sc->pc = 1;
f0(integer(stepper), fd(o1));
integer(stepper)++;
}
@@ -80343,10 +80521,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
else
{
for (; integer(stepper) < end; integer(stepper)++)
- {
- sc->pc = 0;
- fd(o);
- }
+ fd(o);
}
}
else
@@ -80366,22 +80541,15 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
}
else
{
- int32_t first_pc = 0;
if (fp == opt_if_bp)
fp = opt_if_bp_nr;
else
{
if (fp == opt_if_nbp_fs)
- {
- fp = opt_if_nbp_fs_nr;
- first_pc = 2;
- }
+ fp = opt_if_nbp_fs_nr;
}
for (; integer(stepper) < end; integer(stepper)++)
- {
- sc->pc = first_pc;
- fp(o);
- }
+ fp(o);
}
}
}
@@ -80416,12 +80584,9 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
else
{
for (; integer(stepper) < end; integer(stepper)++)
- {
- sc->pc = 0;
- fi(o);
- }
+ fi(o);
/* if fi = opt_i_i_s for example, -> o->v[2].i_i_f(integer(slot_value(o->v[1].p)))
- * and o->v[2].i_i_f can be pulled out leaving a loop of sc->pc = 0; ov2(integer(slot_value(o->v[1].p)));
+ * and o->v[2].i_i_f can be pulled out leaving a loop of ov2(integer(slot_value(o->v[1].p)));
*/
}
}
@@ -80449,7 +80614,6 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
{
while (true)
{
- sc->pc = 0;
fp(o);
step = integer(slot_value(step_slot)) + 1;
slot_set_value(step_slot, make_integer(sc, step));
@@ -80477,16 +80641,21 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
{
s7_pointer p;
s7_int body_len;
+ opt_info *body[32];
+ int32_t k;
body_len = s7_list_length(sc, code);
sc->pc = 0;
- reset_opts(sc);
+ if (body_len >= 32) return(false);
if (!no_float_opt(code))
{
- for (p = code; is_pair(p); p = cdr(p))
- if (!float_optimize(sc, p))
- break;
+ for (k = 0, p = code; is_pair(p); k++, p = cdr(p))
+ {
+ body[k] = sc->opts[sc->pc];
+ if (!float_optimize(sc, p))
+ break;
+ }
if (is_pair(p))
{
pc_fallback(sc, 0);
@@ -80502,12 +80671,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
slot_set_value(sc->args, stepper = make_mutable_integer(sc, integer(slot_value(sc->args))));
for (; integer(stepper) < end; integer(stepper)++)
{
- sc->pc = 0;
for (i = 0; i < body_len; i++)
- {
- sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]);
- sc->pc++;
- }
+ body[i]->v[0].fd(body[i]);
}
clear_mutable_integer(stepper);
}
@@ -80519,13 +80684,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
while (true)
{
s7_int step;
- sc->pc = 0;
for (i = 0; i < body_len; i++)
- {
- sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]);
- sc->pc++;
- }
-
+ body[i]->v[0].fd(body[i]);
step = integer(slot_value(step_slot)) + 1;
slot_set_value(step_slot, make_integer(sc, step));
if (step == integer(slot_value(end_slot))) break;
@@ -80538,7 +80698,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
}
/* not float opt */
- for (p = code; is_pair(p); p = cdr(p))
+ sc->pc = 0;
+ for (k = 0, p = code; is_pair(p); k++, p = cdr(p))
{
opt_info *start;
start = sc->opts[sc->pc];
@@ -80546,6 +80707,7 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
break;
if (start->v[0].fp == d_to_p)
start->v[0].fp = d_to_p_nr;
+ body[k] = start;
}
if (is_null(p))
@@ -80558,14 +80720,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
slot_set_value(sc->args, stepper = make_mutable_integer(sc, integer(slot_value(sc->args))));
for (; integer(stepper) < end; integer(stepper)++)
{
- sc->pc = 0;
for (i = 0; i < body_len; i++)
- {
- opt_info *o;
- o = sc->opts[sc->pc];
- o->v[0].fp(o);
- sc->pc++;
- }
+ body[i]->v[0].fp(body[i]);
}
clear_mutable_integer(stepper);
}
@@ -80577,15 +80733,8 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool saf
while (true)
{
s7_int step;
- sc->pc = 0;
for (i = 0; i < body_len; i++)
- {
- opt_info *o;
- o = sc->opts[sc->pc];
- o->v[0].fp(o);
- sc->pc++;
- }
-
+ body[i]->v[0].fp(body[i]);
step = integer(slot_value(step_slot)) + 1;
slot_set_value(step_slot, make_integer(sc, step));
if (step == integer(slot_value(end_slot))) break;
@@ -80608,6 +80757,11 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
bool let_star;
s7_pointer old_e, stepper;
s7_int body_len, var_len, k, end;
+ #define O_SIZE 32
+ opt_info *body[O_SIZE], *vars[O_SIZE];
+
+ memset((void *)body, 0, O_SIZE * sizeof(opt_info *)); /* placate the damned compiler */
+ memset((void *)vars, 0, O_SIZE * sizeof(opt_info *));
/* do_let with non-float vars doesn't get many fixable hits */
let_code = caddr(scc);
@@ -80615,7 +80769,7 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
return(fall_through);
let_body = cddr(let_code);
body_len = s7_list_length(sc, let_body);
- if (body_len <= 0) return(fall_through);
+ if ((body_len <= 0) || (body_len >= 32)) return(fall_through);
let_star = (symbol_syntax_op_checked(let_code) == OP_LET_STAR);
let_vars = cadr(let_code);
set_safe_stepper(step_slot);
@@ -80628,8 +80782,7 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
return(fall_through);
sc->pc = 0;
- reset_opts(sc);
- for (var_len = 0, p = let_vars; is_pair(p); var_len++, p = cdr(p))
+ for (var_len = 0, p = let_vars; (is_pair(p)) && (var_len < 32); var_len++, p = cdr(p))
{
s7_pointer expr;
if ((!is_pair(car(p))) ||
@@ -80637,6 +80790,7 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
(!is_pair(cdar(p))))
return(fall_through);
expr = cdar(p);
+ vars[var_len] = sc->opts[sc->pc];
if (!float_optimize(sc, expr)) /* each of these needs to set the associated variable */
{
sc->envir = old_e;
@@ -80650,13 +80804,15 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
for (p = let_vars; is_pair(p); p = cdr(p))
make_slot_1(sc, sc->envir, caar(p), s7_make_mutable_real(sc, 1.5));
- for (p = let_body; is_pair(p); p = cdr(p))
- if (!float_optimize(sc, p))
- {
- sc->envir = old_e;
- return(fall_through);
- }
-
+ for (k = 0, p = let_body; is_pair(p); k++, p = cdr(p))
+ {
+ body[k] = sc->opts[sc->pc];
+ if (!float_optimize(sc, p))
+ {
+ sc->envir = old_e;
+ return(fall_through);
+ }
+ }
if (!is_null(p)) /* no hits in s7test or snd-test */
{
sc->envir = old_e;
@@ -80667,12 +80823,13 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
let_set_slots(sc->envir, reverse_slots(sc, let_slots(sc->envir)));
ip = slot_value(step_slot);
+ /* fprintf(stderr, "do_let: %s\n", display(scc)); */
+
if (body_len == 1)
{
if (var_len == 1)
{
s7_pointer xp;
- int32_t pc2;
opt_info *first, *o;
s7_double (*f1)(opt_info *o);
s7_double (*f2)(opt_info *o);
@@ -80680,27 +80837,23 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
first = sc->opts[0];
f1 = first->v[0].fd;
integer(ip) = numerator(stepper);
- sc->pc = 0;
set_real(xp, f1(first));
- pc2 = ++sc->pc;
- o = sc->opts[pc2];
+ o = body[0];
f2 = o->v[0].fd;
f2(o);
if ((f2 == opt_fmv) &&
(f1 == opt_d_dd_ff_o2) &&
(first->v[3].d_dd_f == add_d_dd) &&
- (slot_symbol(step_slot) == slot_symbol(o->v[2].p))) /* and _dv et al throughout (so sc->pc ignored) etc */
+ (slot_symbol(step_slot) == slot_symbol(o->v[2].p)))
{
opt_info *o1, *o2, *o3;
s7_d_v_t vf1, vf2, vf3, vf4;
s7_d_vd_t vf5, vf6;
s7_d_vid_t vf7;
void *obj1, *obj2, *obj3, *obj4, *obj5, *obj6, *obj7;
-
- sc->pc = pc2;
- o1 = o->sc->opts[o->sc->pc + 1];
- o2 = o->sc->opts[o->sc->pc + 3];
- o3 = o->sc->opts[o->sc->pc + 5];
+ o1 = o->v[12].o1;
+ o2 = o->v[13].o1;
+ o3 = o->v[14].o1;
vf1 = first->v[4].d_v_f;
vf2 = first->v[5].d_v_f;
vf3 = o1->v[2].d_v_f;
@@ -80726,12 +80879,11 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
}
else
{
+
for (k = numerator(stepper) + 1; k < end; k++)
{
integer(ip) = k;
- sc->pc = 0;
set_real(xp, f1(first));
- sc->pc = pc2;
f2(o);
}
}
@@ -80743,29 +80895,25 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
s7_pointer s1, s2;
s1 = let_slots(sc->envir);
s2 = next_slot(s1);
+
for (k = numerator(stepper); k < end; k++)
{
integer(ip) = k;
- sc->pc = 0;
- set_real(slot_value(s1), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]));
- sc->pc++;
- set_real(slot_value(s2), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]));
- sc->pc++;
- sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]);
+ set_real(slot_value(s1), vars[0]->v[0].fd(vars[0]));
+ set_real(slot_value(s2), vars[1]->v[0].fd(vars[1]));
+ body[0]->v[0].fd(body[0]);
}
} /* body_len == 1 and var_len == 2 */
else
{
+
for (k = numerator(stepper); k < end; k++)
{
+ int32_t n;
integer(ip) = k;
- sc->pc = 0;
- for (p = let_slots(sc->envir); tis_slot(p); p = next_slot(p))
- {
- set_real(slot_value(p), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]));
- sc->pc++;
- }
- sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]);
+ for (n = 0, p = let_slots(sc->envir); tis_slot(p); n++, p = next_slot(p))
+ set_real(slot_value(p), vars[n]->v[0].fd(vars[n]));
+ body[0]->v[0].fd(body[0]);
}
}
}
@@ -80776,15 +80924,13 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
{
s7_pointer s1;
s1 = let_slots(sc->envir);
+
for (k = numerator(stepper); k < end; k++)
{
integer(ip) = k;
- sc->pc = 0;
- set_real(slot_value(s1), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]));
- sc->pc++;
- sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]);
- sc->pc++;
- sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]);
+ set_real(slot_value(s1), vars[0]->v[0].fd(vars[0]));
+ body[0]->v[0].fd(body[0]);
+ body[1]->v[0].fd(body[1]);
}
}
else
@@ -80793,17 +80939,10 @@ static goto_t do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
{
int32_t i;
integer(ip) = k;
- sc->pc = 0;
- for (p = let_slots(sc->envir); tis_slot(p); p = next_slot(p))
- {
- set_real(slot_value(p), sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]));
- sc->pc++;
- }
+ for (i = 0, p = let_slots(sc->envir); tis_slot(p); i++, p = next_slot(p))
+ set_real(slot_value(p), vars[i]->v[0].fd(vars[i]));
for (i = 0; i < body_len; i++)
- {
- sc->opts[sc->pc]->v[0].fd(sc->opts[sc->pc]);
- sc->pc++;
- }
+ body[i]->v[0].fd(body[i]);
}
}
}
@@ -80825,7 +80964,7 @@ static bool dotimes(s7_scheme *sc, s7_pointer code, bool safe_case)
return(opt_dotimes(sc, cddr(code), code, safe_case));
}
-static goto_t safe_dotimes_ex(s7_scheme *sc)
+static goto_t op_safe_dotimes(s7_scheme *sc)
{
s7_pointer init_val, form;
form = sc->code;
@@ -80898,6 +81037,7 @@ static goto_t safe_dotimes_ex(s7_scheme *sc)
(opt_dotimes(sc, cddr(code), code, true)))
return(goto_safe_do_end_clauses);
set_unsafe_do(code);
+ /* see dotimes-data -- very little comes here that can be handled locally */
push_stack(sc, OP_SAFE_DOTIMES_STEP_P, sc->args, code);
return(goto_eval);
}
@@ -80907,7 +81047,6 @@ static goto_t safe_dotimes_ex(s7_scheme *sc)
(opt_dotimes(sc, sc->code, code, true)))
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);
@@ -80920,7 +81059,7 @@ static goto_t safe_dotimes_ex(s7_scheme *sc)
return(goto_begin);
}
-static goto_t safe_do_ex(s7_scheme *sc)
+static goto_t op_safe_do(s7_scheme *sc)
{
/* body is safe, step = +1, end is = or >=, but stepper and end might be set (or at least indirectly exported) in the body:
* (let ((lst ())) (do ((i 0 (+ i 1))) ((= i 10)) (let ((j (min i 100))) (set! lst (cons j lst)))) lst)
@@ -80994,10 +81133,10 @@ static goto_t safe_do_ex(s7_scheme *sc)
step_slot = let_dox_slot1(sc->envir);
if (slot_symbol(step_slot) != cadr(body))
{
- s7_int step, end;
+ s7_int step, endi;
s7_pointer val_slot, fx_p, step_val;
- end = integer(slot_value(let_dox_slot2(sc->envir)));
+ endi = integer(slot_value(let_dox_slot2(sc->envir)));
val_slot = symbol_to_slot(sc, cadr(body));
fx_p = cddr(body);
step = integer(slot_value(step_slot));
@@ -81007,25 +81146,21 @@ static goto_t safe_do_ex(s7_scheme *sc)
{
slot_set_value(val_slot, fx_call(sc, fx_p));
integer(step_val) = ++step;
- if (step == end) /* geq not needed here -- we're leq end and stepping by +1 all ints */
+ if (step == endi) /* geq not needed here -- we're leq endi and stepping by +1 all ints */
{
clear_mutable_integer(step_val);
sc->value = sc->T;
sc->code = cdadr(code);
return(goto_safe_do_end_clauses);
- }
- }
- }
- }
- }
+ }}}}}
sc->code = cddr(code);
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)) */
+ push_stack(sc, OP_SAFE_DO_STEP, sc->args, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */
return(goto_begin);
}
-static goto_t dotimes_p_ex(s7_scheme *sc)
+static goto_t op_dotimes_p(s7_scheme *sc)
{
s7_pointer end, code, init_val, end_val, slot, form, old_e;
/* (do ... (set! args ...)) -- one line, syntactic */
@@ -81084,8 +81219,7 @@ 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); /* not safe_do here */
slot_set_value(sc->args, old_init);
sc->envir = old_e; /* free_cell(sc, sc->envir) beforehand is not safe */
sc->args = old_args;
@@ -81097,7 +81231,7 @@ static goto_t dotimes_p_ex(s7_scheme *sc)
return(goto_eval);
}
-static goto_t do_init_ex(s7_scheme *sc)
+static goto_t op_do_init_1(s7_scheme *sc)
{
s7_pointer x, y, z;
while (true) /* at start, first value is the loop (for GC protection?), returning sc->value is the next value */
@@ -81114,7 +81248,7 @@ static goto_t do_init_ex(s7_scheme *sc)
init = car(init);
if (is_pair(init))
{
- push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */
+ push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */
sc->code = init;
return(goto_eval);
}
@@ -81164,7 +81298,7 @@ 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);
+ if (op_do_init_1(sc) == goto_eval) return(false);
return(true);
}
@@ -81188,7 +81322,7 @@ static bool do_unchecked(s7_scheme *sc)
sc->args = sc->nil; /* the evaluated var-data */
sc->value = sc->code; /* protect it */
sc->code = car(sc->code); /* the vars */
- return(do_init_ex(sc) == goto_eval);
+ return(op_do_init_1(sc) == goto_eval);
}
static bool op_do_end(s7_scheme *sc)
@@ -81198,7 +81332,7 @@ static bool op_do_end(s7_scheme *sc)
{
if (!has_fx(cdr(sc->args)))
{
- push_stack(sc, OP_DO_END1, sc->args, sc->code);
+ push_stack_direct(sc, OP_DO_END1, sc->args, sc->code);
sc->code = cadr(sc->args); /* evaluate the end expr */
return(true);
}
@@ -81248,8 +81382,8 @@ static goto_t op_do_end1(s7_scheme *sc)
if (is_pair(sc->code))
{
if (is_null(car(sc->args)))
- push_stack(sc, OP_DO_END, sc->args, sc->code);
- else push_stack(sc, OP_DO_STEP, sc->args, sc->code);
+ push_stack_direct(sc, OP_DO_END, sc->args, sc->code);
+ else push_stack_direct(sc, OP_DO_STEP, sc->args, sc->code);
return(goto_begin);
}
if (is_null(car(sc->args))) /* no steppers */
@@ -81267,7 +81401,7 @@ static inline bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type
{
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));
+ 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)) ||
@@ -81284,7 +81418,7 @@ static inline bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t ty
{
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));
+ 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)) ||
@@ -81338,7 +81472,7 @@ static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type
{
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));
+ 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)) ||
@@ -81408,7 +81542,7 @@ static goto_t op_unknown(s7_scheme *sc, s7_pointer f)
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
#if SHOW_EVAL_OPS
- fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+ fprintf(stderr, "%s %s\n", __func__, display(f));
#endif
code = sc->code;
@@ -81468,6 +81602,41 @@ static goto_t op_unknown(s7_scheme *sc, s7_pointer f)
return(fixup_unknown_op(code, f, OP_S));
}
+static bool fxify_closure_star_g(s7_scheme *sc, s7_pointer f, s7_pointer code)
+{
+ if ((!has_methods(f)) &&
+ (closure_star_arity_to_int(sc, f) != 0))
+ {
+ int32_t hop = 0;
+ bool safe_case;
+ if (is_immutable_and_stable(sc, car(code))) hop = 1;
+
+ annotate_arg(sc, cdr(code), sc->envir);
+ set_opt3_arglen(code, small_int(1));
+ safe_case = is_safe_closure(f);
+
+ if ((safe_case) && (is_null(cdr(closure_args(f)))))
+ set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1);
+ else
+ {
+ if (lambda_has_simple_defaults(f))
+ {
+ if (arglist_has_rest(sc, closure_args(f)))
+ fixup_unknown_op(code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX));
+ else fixup_unknown_op(code, f, hop + ((safe_case) ?
+ ((is_null(cdr(closure_args(f)))) ? OP_SAFE_CLOSURE_STAR_A1 : OP_SAFE_CLOSURE_STAR_A) : OP_CLOSURE_STAR_A));
+ return(true);
+ }
+ }
+ if (safe_case)
+ {
+ fixup_unknown_op(code, f, hop + OP_SAFE_CLOSURE_STAR_FX_1);
+ return(true);
+ }
+ }
+ return(false);
+}
+
static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
{
s7_pointer code;
@@ -81475,13 +81644,13 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
#if SHOW_EVAL_OPS
- fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+ fprintf(stderr, "%s %s\n", __func__, display(f));
#endif
code = sc->code;
#if S7_DEBUGGING
if (is_pair(cadr(code)))
- fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, DISPLAY(code));
+ fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code));
#endif
sym_case = is_normal_symbol(cadr(code));
if ((sym_case) &&
@@ -81532,12 +81701,7 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
if (is_null(cdr(body)))
{
if (is_fxable(sc, car(body)))
- {
- annotate_arg(sc, body, sc->envir);
- set_safe_optimize_op(code, hop + ((sym_case) ? OP_SAFE_CLOSURE_S_A : OP_SAFE_CLOSURE_C_A));
- set_closure_has_fx(f);
- fx_tree(sc, body, car(closure_args(f)), NULL);
- }
+ fxify_safe_closure_s(sc, f, code, sc->envir, sym_case, hop);
else
{
/* hop if is_constant(sc, car(code)) is not foolproof here (see t967.scm):
@@ -81561,23 +81725,7 @@ static goto_t op_unknown_g(s7_scheme *sc, s7_pointer f)
break;
case T_CLOSURE_STAR:
- if ((!has_methods(f)) &&
- (closure_star_arity_to_int(sc, f) != 0))
- {
- int32_t hop = 0;
- if (is_immutable_and_stable(sc, car(code))) hop = 1;
-
- annotate_arg(sc, cdr(code), sc->envir);
- set_opt3_arglen(code, small_int(1));
- if (lambda_has_simple_defaults(closure_body(f)))
- {
- if (arglist_has_rest(sc, closure_args(f)))
- return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX)));
- return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)));
- }
- if (is_safe_closure(f))
- return(fixup_unknown_op(code, f, hop + OP_SAFE_CLOSURE_STAR_FX_1));
- }
+ if (fxify_closure_star_g(sc, f, code)) return(goto_eval);
break;
case T_GOTO:
@@ -81649,13 +81797,13 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f)
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
#if SHOW_EVAL_OPS
- fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+ fprintf(stderr, "%s %s\n", __func__, display(f));
#endif
code = sc->code;
#if S7_DEBUGGING
if (!has_fx(cdr(code)))
- fprintf(stderr, "op_unknown_a missing _a support? %s\n", DISPLAY_80(code));
+ fprintf(stderr, "op_unknown_a missing _a support? %s\n", display_80(code));
#endif
switch (type(f))
@@ -81684,27 +81832,7 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f)
safe_case = is_safe_closure(f);
one_form = is_null(cdr(body));
if (is_immutable_and_stable(sc, car(code))) hop = 1;
-
- if (one_form)
- {
- if (safe_case)
- {
- if (is_fxable(sc, car(body)))
- {
- annotate_arg(sc, body, sc->envir);
- set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_A_A);
- set_closure_has_fx(f);
- fx_tree(sc, body, car(closure_args(f)), NULL);
- }
- else
- {
- set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_A_P);
- closure_clear_multiform(f);
- }
- }
- 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));
+ fxify_closure_a(sc, f, one_form, safe_case, hop, code, sc->envir);
/* we might not be in "f" I think, tree_memq(sc, code, body)?? */
if ((safe_case) &&
@@ -81719,20 +81847,7 @@ static goto_t op_unknown_a(s7_scheme *sc, s7_pointer f)
break;
case T_CLOSURE_STAR:
- if ((!has_methods(f)) &&
- (closure_star_arity_to_int(sc, f) != 0))
- {
- int32_t hop = 0;
- if (is_immutable_and_stable(sc, car(code))) hop = 1;
- if (lambda_has_simple_defaults(closure_body(f)))
- {
- if (arglist_has_rest(sc, closure_args(f)))
- return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_FX_1 : OP_CLOSURE_STAR_FX)));
- return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)));
- }
- if (is_safe_closure(f))
- return(fixup_unknown_op(code, f, hop + OP_SAFE_CLOSURE_STAR_FX_1));
- }
+ if (fxify_closure_star_g(sc, f, code)) return(goto_eval);
break;
case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR:
@@ -81778,15 +81893,29 @@ static goto_t fixup_closure_star_aa(s7_scheme *sc, s7_pointer f, s7_pointer code
if (!has_methods(f))
{
int32_t hop = 0;
+ int32_t arity;
+ bool safe_case;
+ s7_pointer arg1, par1;
+
+ safe_case = is_safe_closure(f);
+ arity = closure_star_arity_to_int(sc, f);
+ arg1 = cadr(code);
+ par1 = car(closure_args(f));
+ if (is_pair(par1)) par1 = car(par1);
+
if (is_immutable_and_stable(sc, car(code))) hop = 1;
set_opt3_arglen(code, small_int(2));
- if (lambda_has_simple_defaults(closure_body(f)))
+
+ if ((arity == 1) && (is_keyword(arg1)) && (keyword_symbol(arg1) == par1))
+ return(fixup_unknown_op(code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_KA : OP_CLOSURE_STAR_KA)));
+
+ if (lambda_has_simple_defaults(f))
{
- if (closure_star_arity_to_int(sc, f) == 2)
- return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_AA : OP_CLOSURE_STAR_FX)));
- return(fixup_unknown_op(code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX)));
+ if (arity == 2)
+ return(fixup_unknown_op(code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_AA : OP_CLOSURE_STAR_FX)));
+ return(fixup_unknown_op(code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_FX_2 : OP_CLOSURE_STAR_FX)));
}
- if (is_safe_closure(f))
+ if (safe_case)
return(fixup_unknown_op(code, f, hop + OP_SAFE_CLOSURE_STAR_FX_2));
}
return(fixup_unknown_op(code, f, OP_S_AA));
@@ -81799,13 +81928,13 @@ static goto_t op_unknown_gg(s7_scheme *sc, s7_pointer f)
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
#if SHOW_EVAL_OPS
- fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+ fprintf(stderr, "%s %s\n", __func__, display(f));
#endif
code = sc->code;
#if S7_DEBUGGING
if ((is_pair(cadr(code))) || (is_pair(caddr(code))))
- fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, DISPLAY(code));
+ fprintf(stderr, "%s[%d]: arg is a pair: %s\n", __func__, __LINE__, display(code));
#endif
s1 = is_normal_symbol(cadr(code));
s2 = is_normal_symbol(caddr(code));
@@ -81955,7 +82084,7 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f)
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
#if SHOW_EVAL_OPS
- fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+ fprintf(stderr, "%s %s\n", __func__, display(f));
#endif
code = sc->code;
@@ -82010,7 +82139,7 @@ static goto_t op_unknown_all_s(s7_scheme *sc, s7_pointer f)
case T_CLOSURE_STAR:
if ((!has_methods(f)) &&
- (lambda_has_simple_defaults(closure_body(f))) &&
+ (lambda_has_simple_defaults(f)) &&
((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args)))
{
int32_t hop = 0;
@@ -82039,7 +82168,7 @@ static goto_t op_unknown_aa(s7_scheme *sc, s7_pointer f)
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
#if SHOW_EVAL_OPS
- fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+ fprintf(stderr, "%s %s\n", __func__, display(f));
#endif
code = sc->code;
@@ -82122,7 +82251,7 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f)
if (!f) /* can be NULL if unbound variable */
return(unknown_unknown(sc));
#if SHOW_EVAL_OPS
- fprintf(stderr, "%s %s\n", __func__, DISPLAY(f));
+ fprintf(stderr, "%s %s\n", __func__, display(f));
#endif
code = sc->code;
@@ -82168,7 +82297,7 @@ static goto_t op_unknown_fx(s7_scheme *sc, s7_pointer f)
case T_CLOSURE_STAR:
if ((!has_methods(f)) &&
- (lambda_has_simple_defaults(closure_body(f))) &&
+ (lambda_has_simple_defaults(f)) &&
((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args)))
{
int32_t hop = 0;
@@ -82434,7 +82563,7 @@ static bool op_implicit_vector_set_4(s7_scheme *sc)
return(false);
}
-static void op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) */
+static inline void op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) */
{
s7_pointer val, y;
@@ -82591,7 +82720,7 @@ static void apply_c_macro(s7_scheme *sc) /* -------- C-bas
if (is_multiple_value(sc->code)) /* can this happen? s7_values splices before returning, and `(values ...) is handled later */
{
#if S7_DEBUGGING
- fprintf(stderr, "%d unexpected mv code: %s\n", __LINE__, DISPLAY(sc->code));
+ fprintf(stderr, "%d unexpected mv code: %s\n", __LINE__, display(sc->code));
#endif
push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->code));
sc->code = car(sc->code);
@@ -82988,7 +83117,7 @@ static inline goto_t lambda_star_default(s7_scheme *sc)
}
else
{
- push_stack(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code);
+ push_stack_direct(sc, OP_LAMBDA_STAR_DEFAULT, sc->args, sc->code);
sc->code = val;
return(goto_eval);
}
@@ -83024,7 +83153,7 @@ static inline bool set_star_args(s7_scheme *sc, s7_pointer top)
if (is_slot(sc->args))
{
/* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */
- push_stack(sc, OP_GC_PROTECT, sc->args, sc->code);
+ push_stack_direct(sc, OP_GC_PROTECT, sc->args, sc->code);
if (lambda_star_default(sc) == goto_eval) return(true); /* else fall_through */
pop_stack_no_op(sc); /* get original args and code back */
}
@@ -83035,7 +83164,7 @@ static inline bool set_star_args(s7_scheme *sc, s7_pointer top)
static bool apply_safe_closure_star_1(s7_scheme *sc) /* -------- define* (lambda*) -------- */
{
s7_pointer z;
- /* fprintf(stderr, "%s %s\n", __func__, DISPLAY(sc->code)); */
+ /* fprintf(stderr, "%s %s\n", __func__, display(sc->code)); */
/* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */
sc->envir = closure_let(sc->code);
@@ -83063,7 +83192,7 @@ static bool apply_safe_closure_star_1(s7_scheme *sc) /* ------
static bool apply_unsafe_closure_star_1(s7_scheme *sc)
{
s7_pointer z, car_z, val, top;
- /* fprintf(stderr, "%s %s\n", __func__, DISPLAY(sc->code)); */
+ /* fprintf(stderr, "%s %s\n", __func__, display(sc->code)); */
top = sc->nil;
for (z = closure_args(sc->code); is_pair(z); z = cdr(z))
{
@@ -83178,9 +83307,13 @@ static bool apply_closure_star(s7_scheme *sc)
return(apply_unsafe_closure_star_1(sc));
}
-static void safe_closure_star_a(s7_scheme *sc, s7_pointer code)
+#if WITH_GCC
+static inline s7_pointer safe_closure_star_a1(s7_scheme *sc, s7_pointer code) __attribute__((always_inline));
+#endif
+
+static inline s7_pointer safe_closure_star_a1(s7_scheme *sc, s7_pointer code)
{
- s7_pointer p, val, func;
+ s7_pointer val, func;
func = opt1_lambda(code);
val = fx_call(sc, cdr(code));
if ((is_keyword(val)) &&
@@ -83189,8 +83322,14 @@ static void safe_closure_star_a(s7_scheme *sc, s7_pointer code)
set_elist_4(sc, wrap_string(sc, "~A: keyword argument's value is missing: ~S in ~S", 49),
closure_name(sc, func), val, sc->args));
sc->envir = old_frame_with_slot(sc, closure_let(func), val);
- /* that sets the first arg to the passed symbol value; now set default values, if any */
+ sc->code = T_Pair(closure_body(func));
+ return(func);
+}
+static void safe_closure_star_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer p, func;
+ func = safe_closure_star_a1(sc, code);
p = cdr(closure_args(func));
if (is_pair(p))
{
@@ -83209,32 +83348,39 @@ static void safe_closure_star_a(s7_scheme *sc, s7_pointer code)
symbol_set_local(slot_symbol(x), let_id(sc->envir), x);
}
}
+}
+
+static void safe_closure_star_ka(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer func;
+ /* two args, but k=arg key, key has been checked. no trailing pars */
+ func = opt1_lambda(code);
+ sc->envir = old_frame_with_slot(sc, closure_let(func), fx_call(sc, cddr(code)));
sc->code = T_Pair(closure_body(func));
}
static void safe_closure_star_aa(s7_scheme *sc, s7_pointer code)
{
/* here closure_arity == 2 and we have 2 args */
- s7_pointer arg1, arg2, clet, p;
+ s7_pointer arg1, arg2, func;
- clet = closure_let(opt1_lambda(code));
- p = cdr(code);
- arg1 = fx_call(sc, p);
- arg2 = fx_call(sc, cdr(p));
+ func = opt1_lambda(code);
+ arg1 = fx_call(sc, cdr(code));
+ arg2 = fx_call(sc, cddr(code));
if (is_keyword(arg1))
{
- if (keyword_symbol(arg1) == slot_symbol(let_slots(clet)))
+ if (keyword_symbol(arg1) == slot_symbol(let_slots(closure_let(func))))
{
arg1 = arg2;
- arg2 = cadr(closure_args(opt1_lambda(code)));
+ arg2 = cadr(closure_args(func));
if (is_pair(arg2)) arg2 = (is_pair(cadr(arg2))) ? cadadr(arg2) : cadr(arg2); else arg2 = sc->F;
}
else
{
- if (keyword_symbol(arg1) == slot_symbol(next_slot(let_slots(clet))))
+ if (keyword_symbol(arg1) == slot_symbol(next_slot(let_slots(closure_let(func)))))
{
- arg1 = car(closure_args(opt1_lambda(code)));
+ arg1 = car(closure_args(func));
if (is_pair(arg1)) arg1 = (is_pair(cadr(arg1))) ? cadadr(arg1) : cadr(arg1); else arg1 = sc->F;
}
else
@@ -83242,7 +83388,7 @@ static void safe_closure_star_aa(s7_scheme *sc, s7_pointer code)
if (!sc->accept_all_keyword_arguments)
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc, wrap_string(sc, "~A: unknown keyword argument: ~S in ~S", 38),
- closure_name(sc, opt1_lambda(code)), arg1, code));
+ closure_name(sc, func), arg1, code));
/* arg1 is already the value */
}
}
@@ -83253,10 +83399,10 @@ static void safe_closure_star_aa(s7_scheme *sc, s7_pointer code)
(!sc->accept_all_keyword_arguments))
s7_error(sc, sc->wrong_type_arg_symbol,
set_elist_4(sc, wrap_string(sc, "~A: keyword argument's value is missing: ~S in ~S", 49),
- closure_name(sc, opt1_lambda(code)), arg2, code));
+ closure_name(sc, func), arg2, code));
}
- sc->envir = old_frame_with_two_slots(sc, clet, arg1, arg2);
- sc->code = T_Pair(closure_body(opt1_lambda(code)));
+ sc->envir = old_frame_with_two_slots(sc, closure_let(func), arg1, arg2);
+ sc->code = T_Pair(closure_body(func));
}
static bool safe_closure_star_fx_0(s7_scheme *sc, s7_pointer code)
@@ -83275,7 +83421,7 @@ static bool safe_closure_star_fx_1(s7_scheme *sc, s7_pointer code)
sc->args = safe_list_1(sc);
arglist = sc->args;
set_car(sc->args, fx_call(sc, cdr(code)));
- call_lambda_star(sc); /* this clears list_in_use */
+ call_lambda_star(sc); /* this clears list_in_use, sets target */
sc->args = sc->nil;
return(target);
}
@@ -83320,6 +83466,16 @@ static bool safe_closure_star_fx(s7_scheme *sc, s7_pointer code)
return(target);
}
+static void closure_star_ka(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer val, p, func;
+ val = fx_call(sc, cddr(code));
+ func = opt1_lambda(code);
+ p = car(closure_args(func));
+ new_frame_with_slot(sc, closure_let(func), sc->envir, (is_pair(p)) ? car(p) : p, val);
+ sc->code = T_Pair(closure_body(func));
+}
+
static void closure_star_a(s7_scheme *sc, s7_pointer code)
{
s7_pointer val, p, func;
@@ -83747,7 +83903,7 @@ static void op_closure_c_p(s7_scheme *sc)
static void op_safe_closure_p(s7_scheme *sc)
{
- push_stack(sc, OP_SAFE_CLOSURE_P_1, sc->args, sc->code);
+ push_stack_direct(sc, OP_SAFE_CLOSURE_P_1, sc->args, sc->code);
sc->code = cadr(sc->code);
}
@@ -83795,7 +83951,7 @@ static void op_safe_closure_saa(s7_scheme *sc)
static void op_closure_p(s7_scheme *sc)
{
- push_stack(sc, OP_CLOSURE_P_1, sc->args, sc->code);
+ push_stack_direct(sc, OP_CLOSURE_P_1, sc->args, sc->code);
sc->code = cadr(sc->code);
}
@@ -83807,12 +83963,6 @@ static void op_closure_p_1(s7_scheme *sc)
sc->code = T_Pair(closure_body(sc->code));
}
-static void op_closure_p_mv(s7_scheme *sc)
-{
- 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);
@@ -83878,12 +84028,6 @@ static void op_closure_ap_1(s7_scheme *sc)
sc->code = T_Pair(closure_body(sc->code));
}
-static void op_closure_ap_mv(s7_scheme *sc)
-{
- sc->code = opt1_lambda(sc->code);
- sc->args = cons(sc, sc->args, copy_list(sc, sc->value));
-}
-
static void op_closure_pa(s7_scheme *sc)
{
s7_pointer val, code;
@@ -83901,12 +84045,6 @@ static void op_closure_pa_1(s7_scheme *sc)
sc->code = T_Pair(closure_body(sc->code));
}
-static void op_closure_pa_mv(s7_scheme *sc)
-{
- sc->code = opt1_lambda(sc->code);
- 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)
{
s7_pointer val;
@@ -83935,6 +84073,137 @@ static void op_safe_closure_pa_1(s7_scheme *sc)
sc->code = T_Pair(closure_body(opt1_lambda(sc->code)));
}
+static void op_safe_closure_pp(s7_scheme *sc)
+{
+ push_stack_no_args_direct(sc, OP_SAFE_CLOSURE_PP_1, sc->code);
+ sc->code = cadr(sc->code);
+}
+
+static void op_safe_closure_pp_1(s7_scheme *sc)
+{
+ push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->code);
+ sc->code = caddr(sc->code);
+}
+
+static void op_closure_pp(s7_scheme *sc)
+{
+ push_stack_no_args_direct(sc, OP_CLOSURE_PP_1, sc->code);
+ sc->code = cadr(sc->code);
+}
+
+static void op_closure_pp_1(s7_scheme *sc)
+{
+ push_stack(sc, OP_CLOSURE_AP_1, sc->value, sc->code);
+ sc->code = caddr(sc->code);
+}
+
+static void new_frame_with_three_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3)
+{
+ s7_pointer last_slot;
+ /* may need gc protection here */
+ new_frame_with_two_slots(sc, closure_let(func), sc->envir, car(closure_args(func)), val1, cadr(closure_args(func)), val2);
+ last_slot = next_slot(let_slots(sc->envir));
+ add_slot_at_end(let_id(sc->envir), last_slot, caddr(closure_args(func)), val3);
+}
+
+static void op_safe_or_unsafe_closure_3p(s7_scheme *sc)
+{
+ s7_pointer p, form, val;
+ form = sc->code;
+ p = cdr(sc->code);
+ if (has_fx(p))
+ {
+ sc->value = fx_call(sc, p);
+ p = cdr(p);
+ if (has_fx(p))
+ {
+ s7_pointer old_val;
+ old_val = sc->value;
+ val = cons(sc, old_val, fx_call(sc, p));
+ push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_3, val, form);
+ sc->code = cadr(p);
+ }
+ else
+ {
+ push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_2, sc->value, form);
+ sc->code = car(p);
+ }
+ }
+ else
+ {
+ push_stack_no_args(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_1, form);
+ sc->code = car(p);
+ }
+}
+
+static bool op_safe_or_unsafe_closure_3p_1(s7_scheme *sc)
+{
+ s7_pointer p, val, form;
+ form = sc->code;
+ val = sc->value; /* can be clobbered by fx_call */
+ p = cddr(sc->code);
+ if (has_fx(p))
+ {
+ if (has_fx(cdr(p)))
+ {
+ s7_pointer func, arg1, arg2;
+ arg1 = fx_call(sc, p);
+ sc->args = arg1;
+ arg2 = fx_call(sc, cdr(p));
+ func = opt1_lambda(sc->code);
+ if (is_safe_closure(func))
+ sc->envir = old_frame_with_three_slots(sc, closure_let(func), val, arg1, arg2);
+ else new_frame_with_three_slots(sc, func, val, arg1, arg2);
+ sc->code = T_Pair(closure_body(func));
+ return(true);
+ }
+ val = cons(sc, val, fx_call(sc, p));
+ push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_3, val, form);
+ sc->code = cadr(p);
+ }
+ else
+ {
+ push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_2, val, form);
+ sc->code = car(p);
+ }
+ return(false);
+}
+
+static bool op_safe_or_unsafe_closure_3p_2(s7_scheme *sc)
+{
+ s7_pointer p, val, arg, form;
+ form = sc->code;
+ val = sc->value;
+ arg = sc->args;
+ p = cdddr(sc->code);
+ if (has_fx(p))
+ {
+ s7_pointer func, arg1;
+ arg1 = fx_call(sc, p);
+ sc->args = arg1;
+ func = opt1_lambda(sc->code);
+ if (is_safe_closure(func))
+ sc->envir = old_frame_with_three_slots(sc, closure_let(func), arg, val, arg1);
+ else new_frame_with_three_slots(sc, func, arg, val, arg1);
+ sc->code = T_Pair(closure_body(func));
+ return(true);
+ }
+ val = cons(sc, arg, val);
+ push_stack(sc, OP_SAFE_OR_UNSAFE_CLOSURE_3P_3, val, form);
+ sc->code = car(p);
+ return(false);
+}
+
+static void op_safe_or_unsafe_closure_3p_3(s7_scheme *sc)
+{
+ s7_pointer func;
+ func = opt1_lambda(sc->code);
+ if (is_safe_closure(func))
+ sc->envir = old_frame_with_three_slots(sc, closure_let(func), car(sc->args), cdr(sc->args), sc->value);
+ else new_frame_with_three_slots(sc, func, car(sc->args), cdr(sc->args), sc->value);
+ sc->code = T_Pair(closure_body(func));
+}
+
static void op_safe_closure_sa(s7_scheme *sc)
{
s7_pointer f, args;
@@ -84040,7 +84309,7 @@ static void op_closure_cs(s7_scheme *sc)
sc->code = T_Pair(closure_body(sc->code));
}
-static void op_closure_3s(s7_scheme *sc)
+static void op_closure_3s(s7_scheme *sc) /* inline here (and always_inline) makes gcc unhappy elsewhere */
{
s7_pointer e, p, args, last_slot;
s7_int id;
@@ -84467,6 +84736,37 @@ static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg)
return(sc->value);
}
+static void op_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_and, fx_or1, fx_or2, fx_la, la_slot;
+
+ fx_and = cdr(code); /* first clause of and */
+ fx_or1 = cdadr(fx_and);
+ fx_or2 = cdr(fx_or1);
+ fx_la = cdadr(fx_or2);
+ la_slot = let_slots(sc->envir);
+ while (true)
+ {
+ s7_pointer p;
+ p = fx_call(sc, fx_and);
+ if (p == sc->F) {sc->value = p; return;}
+ p = fx_call(sc, fx_or1);
+ if (p != sc->F) {sc->value = p; return;}
+ p = fx_call(sc, fx_or2);
+ if (p != sc->F) {sc->value = p; return;}
+ slot_set_value(la_slot, fx_call(sc, fx_la));
+ }
+}
+
+static s7_pointer fx_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer arg)
+{
+#if S7_DEBUGGING
+ tc_rec_calls[OP_TC_AND_A_OR_A_A_LA]++;
+#endif
+ op_tc_and_a_or_a_a_la(sc, arg);
+ return(sc->value);
+}
+
static void op_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer code)
{
s7_pointer fx_and1, fx_and2, fx_or1, fx_or2, fx_la, la_slot;
@@ -84520,8 +84820,9 @@ static void op_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer code)
if (p == sc->F) {sc->value = p; return;}
p = fx_call(sc, fx_or);
if (p != sc->F) {sc->value = p; return;}
- slot_set_value(la_slot, fx_call(sc, fx_la));
+ sc->rec_p1 = fx_call(sc, fx_la);
slot_set_value(laa_slot, fx_call(sc, fx_laa));
+ slot_set_value(la_slot, sc->rec_p1);
}
}
@@ -84531,6 +84832,7 @@ static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_AND_A_OR_A_LAA]++;
#endif
op_tc_and_a_or_a_laa(sc, arg);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
@@ -84552,8 +84854,9 @@ static void op_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer code)
if (p != sc->F) {sc->value = p; return;}
p = fx_call(sc, fx_and);
if (p == sc->F) {sc->value = p; return;}
- slot_set_value(la_slot, fx_call(sc, fx_la));
+ sc->rec_p1 = fx_call(sc, fx_la);
slot_set_value(laa_slot, fx_call(sc, fx_laa));
+ slot_set_value(la_slot, sc->rec_p1);
}
}
@@ -84563,6 +84866,7 @@ static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_OR_A_AND_A_LAA]++;
#endif
op_tc_or_a_and_a_laa(sc, arg);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
@@ -84589,9 +84893,11 @@ static void op_tc_or_a_and_a_a_l3a(s7_scheme *sc, bool or_case, s7_pointer code)
if (p == sc->F) {sc->value = p; return;}
p = fx_call(sc, fx_and2);
if (p == sc->F) {sc->value = p; return;}
- slot_set_value(la_slot, fx_call(sc, fx_la));
- slot_set_value(laa_slot, fx_call(sc, fx_laa));
+ sc->rec_p1 = fx_call(sc, fx_la);
+ sc->rec_p2 = fx_call(sc, fx_laa);
slot_set_value(l3a_slot, fx_call(sc, fx_l3a));
+ slot_set_value(la_slot, sc->rec_p1);
+ slot_set_value(laa_slot, sc->rec_p2);
}
}
@@ -84601,6 +84907,8 @@ static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_OR_A_AND_A_A_L3A]++;
#endif
op_tc_or_a_and_a_a_l3a(sc, true, arg);
+ sc->rec_p1 = sc->F;
+ sc->rec_p2 = sc->F;
return(sc->value);
}
@@ -84610,6 +84918,8 @@ static s7_pointer fx_tc_if_a_t_and_a_a_l3a(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_OR_A_AND_A_A_L3A]++;
#endif
op_tc_or_a_and_a_a_l3a(sc, false, arg);
+ sc->rec_p1 = sc->F;
+ sc->rec_p2 = sc->F;
return(sc->value);
}
@@ -84624,7 +84934,6 @@ static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code)
if (is_t_integer(slot_value(la_slot)))
{
sc->pc = 0;
- reset_opts(sc);
if (bool_optimize(sc, if_test))
{
opt_info *o, *o1;
@@ -84636,9 +84945,7 @@ static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code)
slot_set_value(la_slot, val = make_mutable_integer(sc, integer(slot_value(la_slot))));
while (true)
{
- sc->pc = 0;
if (o->v[0].fb(o)) break;
- sc->pc++;
integer(val) = o1->v[0].fi(o1);
}
return(op_tc_z(sc, if_true));
@@ -84673,7 +84980,6 @@ static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code)
if (is_t_integer(slot_value(la_slot)))
{
sc->pc = 0;
- reset_opts(sc);
if (bool_optimize(sc, if_test))
{
opt_info *o, *o1;
@@ -84685,12 +84991,8 @@ static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code)
slot_set_value(la_slot, val = make_mutable_integer(sc, integer(slot_value(la_slot))));
while (true)
{
- sc->pc = 0;
if (o->v[0].fb(o))
- {
- sc->pc++;
- integer(val) = o1->v[0].fi(o1);
- }
+ integer(val) = o1->v[0].fi(o1);
else break;
}
return(op_tc_z(sc, if_false));
@@ -84715,13 +85017,13 @@ static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg)
return(sc->value);
}
-static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code)
+static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first)
{
- s7_pointer if_test, if_true, la, laa, la_slot, laa_slot;
+ s7_pointer if_test, if_z, la, laa, la_slot, laa_slot;
s7_function tf;
if_test = cdr(code);
- if_true = cdr(if_test);
- la = cdadr(if_true);
+ if_z = (z_first) ? cdr(if_test) : cddr(if_test);
+ la = (z_first) ? cdaddr(if_test) : cdadr(if_test);
laa = cdr(la);
la_slot = let_slots(sc->envir);
laa_slot = next_slot(la_slot);
@@ -84729,7 +85031,6 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code)
if (!no_bool_opt(code))
{
sc->pc = 0;
- reset_opts(sc);
if (bool_optimize(sc, if_test))
{
opt_info *o, *o1, *o2;
@@ -84756,7 +85057,7 @@ 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 (!fb(o))
+ while (fb(o) != z_first)
{
s7_int i1;
i1 = fi1(o1);
@@ -84772,7 +85073,7 @@ 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 (!fb(o))
+ while (fb(o) != z_first)
{
s7_double x1;
x1 = fd1(o1);
@@ -84780,7 +85081,7 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code)
real(val1) = x1;
}
}
- return(op_tc_z(sc, if_true));
+ return(op_tc_z(sc, if_z));
}
}
}
@@ -84802,7 +85103,7 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code)
while (true)
{
s7_double x1;
- if (o->v[0].fb(o)) break;
+ if (o->v[0].fb(o) == z_first) break;
x1 = o1->v[0].fd(o1);
real(val2) = o2->v[0].fd(o2);
real(val1) = x1;
@@ -84813,33 +85114,40 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code)
while (true)
{
s7_double x1;
- sc->pc = 0;
- if (o->v[0].fb(o)) break;
- sc->pc++;
+ if (o->v[0].fb(o) == z_first) break;
x1 = o1->v[0].fd(o1);
- sc->pc++;
real(val2) = o2->v[0].fd(o2);
real(val1) = x1;
}
}
- return(op_tc_z(sc, if_true));
+ return(op_tc_z(sc, if_z));
}
}
}
}
- else set_no_bool_opt(code);
+ set_no_bool_opt(code);
}
tf = c_callee(if_test);
if_test = car(if_test);
- while (tf(sc, if_test) == sc->F)
+ if (z_first)
{
- s7_pointer a1;
- a1 = fx_call(sc, la);
- sc->w = a1;
- slot_set_value(laa_slot, fx_call(sc, laa));
- slot_set_value(la_slot, a1);
+ while (tf(sc, if_test) == sc->F)
+ {
+ sc->rec_p1 = fx_call(sc, la);
+ slot_set_value(laa_slot, fx_call(sc, laa));
+ slot_set_value(la_slot, sc->rec_p1);
+ }
}
- return(op_tc_z(sc, if_true));
+ else
+ {
+ while (tf(sc, if_test) != sc->F)
+ {
+ sc->rec_p1 = fx_call(sc, la);
+ slot_set_value(laa_slot, fx_call(sc, laa));
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+ }
+ return(op_tc_z(sc, if_z));
}
static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg)
@@ -84847,123 +85155,103 @@ static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg)
#if S7_DEBUGGING
tc_rec_calls[OP_TC_IF_A_Z_LAA]++;
#endif
- op_tc_if_a_z_laa(sc, arg);
+ op_tc_if_a_z_laa(sc, arg, true);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
-static bool op_tc_if_a_laa_z(s7_scheme *sc, s7_pointer code)
+static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer if_test, if_false, la, laa, la_slot, laa_slot;
+#if S7_DEBUGGING
+ tc_rec_calls[OP_TC_IF_A_LAA_Z]++;
+#endif
+ op_tc_if_a_z_laa(sc, arg, false);
+ sc->rec_p1 = sc->F;
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer code, bool z_first)
+{
+ s7_pointer if_test, f_z, la, laa, l3a, la_slot, laa_slot, l3a_slot;
+ s7_function tf;
if_test = cdr(code);
- if_false = cddr(if_test);
- la = cdadr(if_test);
+ f_z = (z_first) ? cdr(if_test) : cddr(if_test);
+ la = (z_first) ? cdaddr(if_test) : cdadr(if_test);
laa = cdr(la);
+ l3a = cdr(laa);
la_slot = let_slots(sc->envir);
laa_slot = next_slot(la_slot);
-
- if (!no_bool_opt(code))
+ l3a_slot = next_slot(laa_slot);
+ tf = c_callee(if_test);
+ if_test = car(if_test);
+ if (z_first)
{
- sc->pc = 0;
- reset_opts(sc);
- if (bool_optimize(sc, if_test))
+ while (tf(sc, if_test) == sc->F)
{
- opt_info *o, *o1, *o2;
- int32_t start_pc;
- o = sc->opts[0];
- start_pc = sc->pc;
- o1 = sc->opts[sc->pc];
- if ((is_t_integer(slot_value(la_slot))) &&
- (is_t_integer(slot_value(laa_slot))))
- {
- if (int_optimize(sc, la))
- {
- o2 = sc->opts[sc->pc];
- if (int_optimize(sc, laa))
- {
- s7_pointer val1, val2;
- slot_set_value(la_slot, val1 = make_mutable_integer(sc, integer(slot_value(la_slot))));
- slot_set_value(laa_slot, val2 = make_mutable_integer(sc, integer(slot_value(laa_slot))));
- while (true)
- {
- sc->pc = 0;
- if (o->v[0].fb(o))
- {
- s7_int i1;
- sc->pc++;
- i1 = o1->v[0].fi(o1);
- sc->pc++;
- integer(val2) = o2->v[0].fi(o2);
- integer(val1) = i1;
- }
- else break;
- }
- return(op_tc_z(sc, if_false));
- }
- }
- }
- if ((is_float(slot_value(la_slot))) &&
- (is_float(slot_value(laa_slot))))
- {
- sc->pc = start_pc;
- if (float_optimize(sc, la))
- {
- o2 = sc->opts[sc->pc];
- if (float_optimize(sc, laa))
- {
- s7_pointer val1, val2;
- slot_set_value(la_slot, val1 = s7_make_mutable_real(sc, real(slot_value(la_slot))));
- slot_set_value(laa_slot, val2 = s7_make_mutable_real(sc, real(slot_value(laa_slot))));
- while (true)
- {
- sc->pc = 0;
- if (o->v[0].fb(o))
- {
- s7_double x1;
- sc->pc++;
- x1 = o1->v[0].fd(o1);
- sc->pc++;
- real(val2) = o2->v[0].fd(o2);
- real(val1) = x1;
- }
- else break;
- }
- return(op_tc_z(sc, if_false));
- }
- }
- }
+ sc->rec_p1 = fx_call(sc, la);
+ sc->rec_p2 = fx_call(sc, laa);
+ slot_set_value(l3a_slot, fx_call(sc, l3a));
+ slot_set_value(laa_slot, sc->rec_p2);
+ slot_set_value(la_slot, sc->rec_p1);
}
- else set_no_bool_opt(code);
}
- while (true)
+ else
{
- 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));
- slot_set_value(la_slot, a1);
+ while (tf(sc, if_test) != sc->F)
+ {
+ sc->rec_p1 = fx_call(sc, la);
+ sc->rec_p2 = fx_call(sc, laa);
+ slot_set_value(l3a_slot, fx_call(sc, l3a));
+ slot_set_value(laa_slot, sc->rec_p2);
+ slot_set_value(la_slot, sc->rec_p1);
+ }
}
- return(op_tc_z(sc, if_false));
+ return(op_tc_z(sc, f_z));
}
-static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg)
{
#if S7_DEBUGGING
- tc_rec_calls[OP_TC_IF_A_LAA_Z]++;
+ tc_rec_calls[OP_TC_IF_A_Z_L3A]++;
#endif
- op_tc_if_a_laa_z(sc, arg);
+ op_tc_if_a_z_l3a(sc, arg, true);
+ sc->rec_p1 = sc->F;
+ sc->rec_p2 = sc->F;
return(sc->value);
}
-static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code)
+static s7_pointer fx_tc_if_a_l3a_z(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer if_test, if_true, if_false, f_test, f_true, la, la_slot, endp;
- if_test = cdr(code);
- if_true = cdr(if_test);
- if_false = cadr(if_true);
- f_test = cdr(if_false);
- f_true = cdr(f_test);
- la = cdadr(f_true);
+#if S7_DEBUGGING
+ tc_rec_calls[OP_TC_IF_A_L3A_Z]++;
+#endif
+ op_tc_if_a_z_l3a(sc, arg, false);
+ sc->rec_p1 = sc->F;
+ sc->rec_p2 = sc->F;
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, bool cond)
+{
+ s7_pointer if_test, if_true, if_false, f_test, f_z, la, la_slot, endp;
+ if (!cond)
+ {
+ if_test = cdr(code);
+ if_true = cdr(if_test);
+ if_false = cadr(if_true);
+ f_test = cdr(if_false);
+ f_z = (z_first) ? cdr(f_test) : cddr(f_test);
+ la = (z_first) ? cdaddr(f_test) : cdadr(f_test);
+ }
+ else
+ {
+ if_test = cadr(code);
+ if_true = cdr(if_test);
+ if_false = caddr(code);
+ f_test = if_false;
+ f_z = cdr(f_test);
+ la = cdadr(cadddr(code));
+ }
la_slot = let_slots(sc->envir);
if (is_t_integer(slot_value(la_slot)))
@@ -84985,20 +85273,29 @@ static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code)
slot_set_value(la_slot, val = make_mutable_integer(sc, integer(slot_value(la_slot))));
while (true)
{
- sc->pc = 0;
if (o->v[0].fb(o)) {endp = if_true; break;}
- sc->pc++;
- if (o1->v[0].fb(o1)) {endp = f_true; break;}
- sc->pc++;
+ if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;}
integer(val) = o2->v[0].fi(o2);
}
return(op_tc_z(sc, endp));
}}}}
- while (true)
+ if (z_first)
{
- if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
- if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;}
- slot_set_value(la_slot, fx_call(sc, la));
+ while (true)
+ {
+ if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
+ if (fx_call(sc, f_test) != sc->F) {endp = f_z; break;}
+ slot_set_value(la_slot, fx_call(sc, la));
+ }
+ }
+ else
+ {
+ while (true)
+ {
+ if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
+ if (fx_call(sc, f_test) == sc->F) {endp = f_z; break;}
+ slot_set_value(la_slot, fx_call(sc, la));
+ }
}
return(op_tc_z(sc, endp));
}
@@ -85008,69 +85305,25 @@ static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg)
#if S7_DEBUGGING
tc_rec_calls[OP_TC_IF_A_Z_IF_A_Z_LA]++;
#endif
- op_tc_if_a_z_if_a_z_la(sc, arg);
+ op_tc_if_a_z_if_a_z_la(sc, arg, true, false);
return(sc->value);
}
-static bool op_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer code)
+static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg)
{
- s7_pointer if_test, if_true, if_false, f_test, f_true, f_false, la, la_slot, endp;
- if_test = cdr(code);
- if_true = cdr(if_test);
- if_false = cadr(if_true);
- f_test = cdr(if_false);
- f_true = cdr(f_test);
- f_false = cdr(f_true);
- la = cdar(f_true);
- la_slot = let_slots(sc->envir);
-
- if (is_t_integer(slot_value(la_slot)))
- {
- opt_info *o;
- sc->pc = 0;
- o = sc->opts[0];
- if (bool_optimize_nw(sc, if_test))
- {
- opt_info *o1;
- o1 = sc->opts[sc->pc];
- if (bool_optimize_nw(sc, f_test))
- {
- opt_info *o2;
- o2 = sc->opts[sc->pc];
- if (int_optimize(sc, la))
- {
- s7_pointer val;
- slot_set_value(la_slot, val = make_mutable_integer(sc, integer(slot_value(la_slot))));
- while (true)
- {
- sc->pc = 0;
- if (o->v[0].fb(o)) {endp = if_true; break;}
- sc->pc++;
- if (o1->v[0].fb(o1))
- {
- sc->pc++;
- integer(val) = o2->v[0].fi(o2);
- }
- else {endp = f_false; break;}
- }
- return(op_tc_z(sc, endp));
- }}}}
-
- while (true)
- {
- if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
- if (fx_call(sc, f_test) == sc->F) {endp = f_false; break;}
- slot_set_value(la_slot, fx_call(sc, la));
- }
- return(op_tc_z(sc, endp));
+#if S7_DEBUGGING
+ tc_rec_calls[OP_TC_IF_A_Z_IF_A_LA_Z]++;
+#endif
+ op_tc_if_a_z_if_a_z_la(sc, arg, false, false);
+ return(sc->value);
}
-static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg)
+static s7_pointer fx_tc_cond_a_z_a_z_la(s7_scheme *sc, s7_pointer arg)
{
#if S7_DEBUGGING
- tc_rec_calls[OP_TC_IF_A_Z_IF_A_LA_Z]++;
+ tc_rec_calls[OP_TC_COND_A_Z_A_Z_LA]++;
#endif
- op_tc_if_a_z_if_a_la_z(sc, arg);
+ op_tc_if_a_z_if_a_z_la(sc, arg, true, true);
return(sc->value);
}
@@ -85089,13 +85342,11 @@ static bool op_tc_if_a_z_if_a_z_laa(s7_scheme *sc, bool cond, s7_pointer code)
while (true)
{
- s7_pointer a1;
if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;}
- a1 = fx_call(sc, la);
- sc->w = a1;
+ sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
- slot_set_value(la_slot, a1);
+ slot_set_value(la_slot, sc->rec_p1);
}
return(op_tc_z(sc, endp));
}
@@ -85106,6 +85357,7 @@ static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_IF_A_Z_IF_A_Z_LAA]++;
#endif
op_tc_if_a_z_if_a_z_laa(sc, false, arg);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
@@ -85115,6 +85367,7 @@ static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_COND_A_Z_A_Z_LAA]++;
#endif
op_tc_if_a_z_if_a_z_laa(sc, true, arg);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
@@ -85134,13 +85387,11 @@ static bool op_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer code)
while (true)
{
- s7_pointer a1;
if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
if (fx_call(sc, f_test) == sc->F) {endp = f_false; break;}
- a1 = fx_call(sc, la);
- sc->w = a1;
+ sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
- slot_set_value(la_slot, a1);
+ slot_set_value(la_slot, sc->rec_p1);
}
return(op_tc_z(sc, endp));
}
@@ -85151,6 +85402,58 @@ static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_IF_A_Z_IF_A_LAA_Z]++;
#endif
op_tc_if_a_z_if_a_laa_z(sc, arg);
+ sc->rec_p1 = sc->F;
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer if_test, if_true, if_false, f_test, f_true, f_false, la1, la2, la_slot, laa1, laa2, laa_slot, l3a1, l3a2, l3a_slot, endp;
+ if_test = cdr(code);
+ if_true = cdr(if_test);
+ if_false = cadr(if_true);
+ f_test = cdr(if_false);
+ f_true = cdr(f_test);
+ f_false = cdr(f_true);
+ la1 = cdar(f_true);
+ la2 = cdar(f_false);
+ la_slot = let_slots(sc->envir);
+ laa1 = cdr(la1);
+ laa2 = cdr(la2);
+ laa_slot = next_slot(la_slot);
+ l3a1 = cdr(laa1);
+ l3a2 = cdr(laa2);
+ l3a_slot = next_slot(laa_slot);
+
+ while (true)
+ {
+ if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
+ if (fx_call(sc, f_test) != sc->F)
+ {
+ sc->rec_p1 = fx_call(sc, la1);
+ sc->rec_p2 = fx_call(sc, laa1);
+ slot_set_value(l3a_slot, fx_call(sc, l3a1));
+ }
+ else
+ {
+ sc->rec_p1 = fx_call(sc, la2);
+ sc->rec_p2 = fx_call(sc, laa2);
+ slot_set_value(l3a_slot, fx_call(sc, l3a2));
+ }
+ slot_set_value(laa_slot, sc->rec_p2);
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+ return(op_tc_z(sc, endp));
+}
+
+static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer arg)
+{
+#if S7_DEBUGGING
+ tc_rec_calls[OP_TC_IF_A_Z_IF_A_L3A_L3A]++;
+#endif
+ op_tc_if_a_z_if_a_l3a_l3a(sc, arg);
+ sc->rec_p1 = sc->F;
+ sc->rec_p2 = sc->F;
return(sc->value);
}
@@ -85178,7 +85481,6 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code)
if (!no_bool_opt(code))
{
sc->pc = 0;
- reset_opts(sc);
if (bool_optimize(sc, if_test))
{
opt_info *o, *o1, *o2, *o3;
@@ -85204,17 +85506,11 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code)
while (true)
{
s7_int i1;
- sc->pc = 0;
if (o->v[0].fb(o)) break;
- sc->pc++;
i1 = o1->v[0].fi(o1);
- sc->pc++;
integer(val2) = o2->v[0].fi(o2);
integer(val1) = i1;
- sc->pc++;
- /* sc->envir = outer_env; */ /* can this matter? all slots are preset */
integer(val3) = o3->v[0].fi(o3);
- /* sc->envir = inner_env; */
}
unstack(sc);
return(op_tc_z(sc, if_true)); /* sc->inner_env in effect here since it was the last set above */
@@ -85223,17 +85519,15 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code)
}
}
}
- else set_no_bool_opt(code);
+ set_no_bool_opt(code);
}
while (true)
{
- s7_pointer a1;
if (fx_call(sc, if_test) != sc->F) break;
- a1 = fx_call(sc, la);
- sc->w = a1;
+ sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
- slot_set_value(la_slot, a1);
+ slot_set_value(la_slot, sc->rec_p1);
sc->envir = outer_env;
slot_set_value(let_slot, fx_call(sc, let_var));
sc->envir = inner_env;
@@ -85248,6 +85542,7 @@ static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_LET_IF_A_Z_LAA]++;
#endif
op_tc_let_if_a_z_laa(sc, arg);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
@@ -85289,15 +85584,13 @@ static void op_tc_let_when_laa(s7_scheme *sc, bool when, s7_pointer code)
laa_slot = next_slot(la_slot);
while (true)
{
- s7_pointer a1;
p = fx_call(sc, if_test);
if (when) {if (p == sc->F) break;} else {if (p != sc->F) break;}
for (p = if_true; is_pair(cdr(p)); p = cdr(p))
fx_call(sc, p);
- a1 = fx_call(sc, la);
- sc->w = a1;
+ sc->rec_p1 = fx_call(sc, la);
slot_set_value(laa_slot, fx_call(sc, laa));
- slot_set_value(la_slot, a1);
+ slot_set_value(la_slot, sc->rec_p1);
sc->envir = outer_env;
slot_set_value(let_slot, fx_call(sc, let_var));
sc->envir = inner_env;
@@ -85313,6 +85606,7 @@ static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_LET_WHEN_LAA]++;
#endif
op_tc_let_when_laa(sc, true, arg);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
@@ -85322,12 +85616,13 @@ static s7_pointer fx_tc_let_unless_laa(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_LET_WHEN_LAA]++;
#endif
op_tc_let_when_laa(sc, false, arg);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code)
{
- s7_pointer outer_env, inner_env, let_var, let_slot, let_body, slots, result;
+ s7_pointer outer_env, inner_env, let_var, let_slot, cond_body, slots, result;
/* code here == body in check_tc */
let_var = caadr(code);
outer_env = sc->envir;
@@ -85336,7 +85631,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code)
push_stack_no_let_no_code(sc, OP_GC_PROTECT, inner_env);
let_slot = let_slots(sc->envir);
let_var = cdr(let_var);
- let_body = cdaddr(code);
+ cond_body = cdaddr(code);
slots = let_slots(outer_env);
/* in the named let no-var case slots may contain the let name (it's the funclet) */
@@ -85345,7 +85640,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code)
while (true)
{
s7_pointer p;
- for (p = let_body; is_pair(p); p = cdr(p))
+ for (p = cond_body; is_pair(p); p = cdr(p))
{
if (fx_call(sc, car(p)) != sc->F)
{
@@ -85364,25 +85659,26 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code)
while (true)
{
s7_pointer p;
- for (p = let_body; is_pair(p); p = cdr(p))
+ for (p = cond_body; is_pair(p); p = cdr(p))
{
if (fx_call(sc, car(p)) != sc->F)
{
result = cdar(p);
if (has_tc(result))
{
- slot_set_value(slots, fx_call(sc, cdar(result)));
+ slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */
sc->envir = outer_env;
- slot_set_value(let_slot, fx_call(sc, let_var));
+ slot_set_value(let_slot, fx_call(sc, let_var)); /* inner let var */
sc->envir = inner_env;
break;
}
else goto TC_LET_COND_DONE;
}}}}
+ let_set_has_pending_value(outer_env);
while (true)
{
s7_pointer p;
- for (p = let_body; is_pair(p); p = cdr(p))
+ for (p = cond_body; is_pair(p); p = cdr(p))
{
if (fx_call(sc, car(p)) != sc->F)
{
@@ -85394,7 +85690,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code)
{
s7_pointer slot, arg;
for (slot = slots, arg = result; is_pair(arg); slot = next_slot(slot), arg = cdr(arg))
- slot_set_pending_value(slot, fx_call(sc, arg));
+ slot_simply_set_pending_value(slot, fx_call(sc, arg));
for (slot = slots; tis_slot(slot); slot = next_slot(slot))
slot_set_value(slot, slot_pending_value(slot));
}
@@ -85405,6 +85701,7 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code)
}
else goto TC_LET_COND_DONE;
}}}
+ let_clear_has_pending_value(outer_env);
TC_LET_COND_DONE:
unstack(sc);
@@ -85440,21 +85737,18 @@ static bool op_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer code)
laa_slot = next_slot(la_slot);
while (true)
{
- s7_pointer a1;
if (fx_call(sc, c1) != sc->F) {c1 = cdr(c1); break;}
if (fx_call(sc, c2) != sc->F)
{
- a1 = fx_call(sc, la1);
- sc->w = a1;
+ sc->rec_p1 = fx_call(sc, la1);
slot_set_value(laa_slot, fx_call(sc, laa1));
}
else
{
- a1 = fx_call(sc, la2);
- sc->w = a1;
+ sc->rec_p1 = fx_call(sc, la2);
slot_set_value(laa_slot, fx_call(sc, laa2));
}
- slot_set_value(la_slot, a1);
+ slot_set_value(la_slot, sc->rec_p1);
}
return(op_tc_z(sc, c1));
}
@@ -85465,6 +85759,7 @@ static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg)
tc_rec_calls[OP_TC_COND_A_Z_A_LAA_LAA]++;
#endif
op_tc_cond_a_z_a_laa_laa(sc, arg);
+ sc->rec_p1 = sc->F;
return(sc->value);
}
@@ -85759,6 +86054,45 @@ static s7_pointer op_recur_cond_a_a_opa_laaq(s7_scheme *sc)
}
+/* -------- if_a_a_opa_l3aq -------- */
+static void opinit_if_a_a_opa_l3aq(s7_scheme *sc)
+{
+ s7_pointer caller, l3a;
+ rec_set_test(sc, cdr(sc->code));
+ rec_set_res(sc, cddr(sc->code));
+ caller = opt3_pair(sc->code);
+ rec_set_f1(sc, cdr(caller));
+ l3a = cdr(opt3_pair(caller));
+ rec_set_f2(sc, l3a);
+ rec_set_f3(sc, cdr(l3a));
+ rec_set_f4(sc, cddr(l3a));
+ sc->rec_slot1 = let_slots(sc->envir);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+ sc->rec_slot3 = next_slot(sc->rec_slot2);
+ sc->rec_call = c_callee(caller);
+}
+
+static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
+ return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p));
+ slot_set_value(sc->rec_slot2, recur_pop(sc));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ set_car(sc->t2_2, oprec_if_a_a_opa_l3aq(sc));
+ set_car(sc->t2_1, recur_pop(sc));
+ return(sc->rec_call(sc, sc->t2_1));
+}
+
+static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme *sc)
+{
+ opinit_if_a_a_opa_l3aq(sc);
+ return(oprec_if_a_a_opa_l3aq(sc));
+}
+
/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */
typedef enum {OPT_PTR, OPT_INT, OPT_DBL, OPT_INT_0} opt_pid_t;
@@ -85779,7 +86113,6 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
if (is_c_function(s_func))
{
sc->pc = 0;
- reset_opts(sc);
sc->rec_test_o = sc->opts[0];
if (bool_optimize(sc, cdr(sc->code)))
{
@@ -85795,7 +86128,6 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
sc->rec_a1_o = sc->opts[sc->pc];
if (int_optimize(sc, cdadr(caller)))
{
- sc->rec_pc1 = sc->pc;
sc->rec_a2_o = sc->opts[sc->pc];
if (int_optimize(sc, cdr(opt3_pair(caller))))
{
@@ -85824,7 +86156,6 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
sc->rec_result_o = sc->opts[start_pc];
if (float_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)))
{
- sc->rec_pc1 = sc->pc;
sc->rec_a1_o = sc->opts[sc->pc];
if (float_optimize(sc, cdadr(caller)))
{
@@ -85848,15 +86179,9 @@ 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) */
- {
- sc->pc++;
- return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */
- }
- sc->pc = sc->rec_pc1;
+ return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */
i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */
- sc->pc++;
integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); /* slot1 = a2 */
i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */
integer(sc->rec_val1) = i1; /* slot1 = a1 */
@@ -85888,13 +86213,8 @@ static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme *sc)
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))
- {
- sc->pc++;
- return(sc->rec_result_o->v[0].fd(sc->rec_result_o));
- }
- sc->pc = sc->rec_pc1;
+ return(sc->rec_result_o->v[0].fd(sc->rec_result_o));
x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o);
real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o);
x2 = oprec_d_if_a_a_opla_laq(sc);
@@ -85917,15 +86237,9 @@ 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)))
- {
- sc->pc++;
- return(sc->rec_result_o->v[0].fi(sc->rec_result_o));
- }
- sc->pc = sc->rec_pc1;
+ return(sc->rec_result_o->v[0].fi(sc->rec_result_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);
i2 = oprec_i_if_a_opla_laq_a(sc);
integer(sc->rec_val1) = i1;
@@ -85957,15 +86271,9 @@ static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme *sc)
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)))
- {
- sc->pc++;
- return(sc->rec_result_o->v[0].fd(sc->rec_result_o));
- }
- sc->pc = sc->rec_pc1;
+ return(sc->rec_result_o->v[0].fd(sc->rec_result_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);
x2 = oprec_d_if_a_opla_laq_a(sc);
real(sc->rec_val1) = x1;
@@ -86104,6 +86412,17 @@ static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme *sc)
* 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 stack manipulations.
*/
+static s7_pointer rec_x(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot1));}
+static s7_pointer rec_y(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot2));}
+static s7_pointer rec_z(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot3));}
+static s7_pointer rec_sub_z1(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer x;
+ x = slot_value(sc->rec_slot3);
+ if (is_t_integer(x)) return(make_integer(sc, integer(x) - 1));
+ return(minus_c1(sc, x));
+}
+
static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc)
{
s7_pointer caller, la1, la2, la3;
@@ -86117,10 +86436,12 @@ static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc)
rec_set_f1(sc, cdr(la1));
rec_set_f2(sc, cddr(la1));
+ if (sc->rec_f2f == fx_u) sc->rec_f2f = rec_y;
rec_set_f3(sc, cdddr(la1));
rec_set_f4(sc, cdr(la2));
rec_set_f5(sc, cddr(la2));
rec_set_f6(sc, cdddr(la2));
+ if (sc->rec_f6f == fx_t) sc->rec_f6f = rec_x;
sc->rec_f7p = cdr(la3);
sc->rec_f7f = c_callee(sc->rec_f7p);
@@ -86128,15 +86449,20 @@ static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc)
sc->rec_f8p = cddr(la3);
sc->rec_f8f = c_callee(sc->rec_f8p);
+ if (sc->rec_f8f == fx_t) sc->rec_f8f = rec_x;
sc->rec_f8p = car(sc->rec_f8p);
sc->rec_f9p = cdddr(la3);
sc->rec_f9f = c_callee(sc->rec_f9p);
+ if (sc->rec_f9f == fx_u) sc->rec_f9f = rec_y;
sc->rec_f9p = car(sc->rec_f9p);
sc->rec_slot1 = let_slots(sc->envir);
sc->rec_slot2 = next_slot(sc->rec_slot1);
sc->rec_slot3 = next_slot(sc->rec_slot2);
+ if (cadddr(la1) == slot_symbol(sc->rec_slot3)) sc->rec_f3f = rec_z;
+ if (caddr(la2) == slot_symbol(sc->rec_slot3)) sc->rec_f5f = rec_z;
+ if ((sc->rec_f7f == fx_subtract_s1) && (cadadr(la3) == slot_symbol(sc->rec_slot3))) sc->rec_f7f = rec_sub_z1;
}
static s7_pointer oprec_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc)
@@ -86456,7 +86782,6 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc)
(is_t_integer(slot_value(sc->rec_slot2))))
{
sc->pc = 0;
- reset_opts(sc);
sc->rec_test_o = sc->opts[0];
if (bool_optimize(sc, cadr(sc->code)))
{
@@ -86465,7 +86790,6 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc)
{
s7_pointer laa1;
sc->rec_a1_o = sc->opts[sc->pc];
- sc->rec_pc1 = sc->pc;
laa1 = caddr(sc->code);
if (bool_optimize(sc, laa1))
{
@@ -86476,7 +86800,6 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc)
if (int_optimize(sc, cddadr(laa1)))
{
s7_pointer laa2, laa3;
- sc->rec_pc2 = sc->pc;
sc->rec_a4_o = sc->opts[sc->pc];
laa2 = cadr(cadddr(sc->code));
laa3 = caddr(laa2);
@@ -86529,26 +86852,17 @@ 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))
- {
- sc->pc++;
- return(sc->rec_result_o->v[0].fi(sc->rec_result_o));
- }
- sc->pc = sc->rec_pc1;
+ return(sc->rec_result_o->v[0].fi(sc->rec_result_o));
if (sc->rec_a1_o->v[0].fb(sc->rec_a1_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) = i1;
return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc));
}
- sc->pc = sc->rec_pc2;
i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o);
- sc->pc++;
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) = i2;
integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq(sc);
@@ -86612,7 +86926,6 @@ static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc)
}
}
-
static void wrap_recur(s7_scheme *sc, s7_pointer (*recur)(s7_scheme *sc))
{
tick_tc_rec(sc);
@@ -86638,7 +86951,7 @@ static bool op_check_safe_c_s(s7_scheme *sc)
static void op_safe_c_p(s7_scheme *sc)
{
check_stack_size(sc);
- push_stack_no_args(sc, OP_SAFE_C_P_1, sc->code);
+ push_stack_no_args_direct(sc, OP_SAFE_C_P_1, sc->code);
sc->code = T_Pair(cadr(sc->code));
}
@@ -86650,14 +86963,14 @@ static void op_safe_c_p_1(s7_scheme *sc)
static void op_not_p(s7_scheme *sc)
{
- push_stack_no_args(sc, OP_NOT_P_1, sc->code);
+ push_stack_no_args_direct(sc, OP_NOT_P_1, sc->code);
sc->code = T_Pair(cadr(sc->code));
}
static void op_safe_c_ssp(s7_scheme *sc)
{
check_stack_size(sc);
- push_stack_no_args(sc, OP_SAFE_C_SSP_1, sc->code);
+ push_stack_no_args_direct(sc, OP_SAFE_C_SSP_1, sc->code);
sc->code = opt3_pair(sc->code);
}
@@ -86841,7 +87154,7 @@ static void op_safe_c_function_star_aa(s7_scheme *sc)
static void op_safe_c_ps(s7_scheme *sc)
{
- push_stack_no_args(sc, OP_SAFE_C_PS_1, sc->code); /* gotta wait in this case */
+ push_stack_no_args_direct(sc, OP_SAFE_C_PS_1, sc->code); /* gotta wait in this case */
sc->code = cadr(sc->code);
}
@@ -86973,7 +87286,7 @@ static void op_safe_c_ap(s7_scheme *sc)
static void op_safe_c_pp(s7_scheme *sc)
{
check_stack_size(sc);
- push_stack_no_args(sc, OP_SAFE_C_PP_1, sc->code);
+ push_stack_no_args_direct(sc, OP_SAFE_C_PP_1, sc->code);
sc->code = cadr(sc->code);
}
@@ -87003,8 +87316,16 @@ static void op_safe_c_pp_3_mv(s7_scheme *sc)
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));
+ /* 1 mv, 2 normal, sc->args was copied above (and this is a safe c function so its args are in no danger) */
+ s7_pointer p;
+ if (is_null(sc->args))
+ sc->args = list_1(sc, sc->value);
+ else
+ {
+ for (p = sc->args; is_pair(cdr(p)); p = cdr(p));
+ set_cdr(p, cons(sc, sc->value, sc->nil));
+ }
+ /* sc->args = s7_append(sc, sc->args, list_1(sc, sc->value)); */
sc->code = c_function_base(opt1_cfunc(sc->code));
}
@@ -87029,11 +87350,9 @@ static inline bool collect_fp_args(s7_scheme *sc, opcode_t op, s7_pointer args)
static inline bool collect_fp_args(s7_scheme *sc, opcode_t op, s7_pointer args)
{
s7_pointer p;
-
sc->args = args;
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));
@@ -87053,7 +87372,7 @@ static void op_safe_c_fp(s7_scheme *sc) /* code: (func . args) where at least on
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));
+ 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));
@@ -87100,7 +87419,6 @@ static void op_safe_closure_fp(s7_scheme *sc)
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, z;
@@ -87194,7 +87512,7 @@ static void op_c_a(s7_scheme *sc)
static void op_c_p(s7_scheme *sc)
{
- push_stack_no_args(sc, OP_C_P_1, sc->code);
+ push_stack_no_args_direct(sc, OP_C_P_1, sc->code);
sc->code = T_Pair(cadr(sc->code));
}
@@ -87474,7 +87792,7 @@ static bool op_load_close_and_pop_if_eof(s7_scheme *sc)
}
#if S7_DEBUGGING
if (!is_loader_port(sc->input_port))
- fprintf(stderr, "%s not loading?\n", DISPLAY(sc->input_port));
+ fprintf(stderr, "%s not loading?\n", display(sc->input_port));
/* if *#readers* func hits error, clear_loader_port might not be undone? */
#endif
s7_close_input_port(sc, sc->input_port);
@@ -87782,7 +88100,7 @@ static inline void op_map_gather(s7_scheme *sc)
static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
{
#if SHOW_EVAL_OPS
- safe_print(fprintf(stderr, "eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], DISPLAY_80(sc->code), DISPLAY_80(sc->args)));
+ safe_print(fprintf(stderr, "eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], display_80(sc->code), display_80(sc->args)));
#endif
sc->cur_op = first_op;
goto TOP_NO_POP;
@@ -87803,7 +88121,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
TOP_NO_POP:
#if SHOW_EVAL_OPS
- safe_print(fprintf(stderr, "%s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), DISPLAY_80(sc->code)));
+ safe_print(fprintf(stderr, "%s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_80(sc->code)));
#endif
#if WITH_PROFILE
profile_at_start = sc->code;
@@ -87819,7 +88137,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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: if (op_check_safe_c_s(sc)) goto EVAL;
+ case OP_SAFE_C_S: if (op_check_safe_c_s(sc)) goto EVAL;
case HOP_SAFE_C_S: op_safe_c_s(sc); continue;
case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break;
@@ -87946,14 +88264,17 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_C_opSq: if (!c_function_is_ok_cadr(sc, sc->code)) break;
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); continue;
+ case OP_SAFE_C_op_opSqq: 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_opSqq: sc->value = fx_c_op_opsqq(sc, sc->code); continue;
+
+ case OP_SAFE_C_op_opSq_Cq: 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_Cq: sc->value = fx_c_op_opsq_cq(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); continue;
+ case OP_SAFE_C_op_S_opSqq: if ((!c_function_is_ok(sc, sc->code)) || (!c_function_is_ok(sc, cadr(sc->code))) || (!c_function_is_ok(sc, caddadr(sc->code)))) break;
+ case HOP_SAFE_C_op_S_opSqq: sc->value = fx_c_op_s_opsqq(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); continue;
+ case OP_SAFE_C_op_opSq_Sq: 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_Sq: sc->value = fx_c_op_opsq_sq(sc, sc->code); continue;
case OP_SAFE_C_PS: if (!c_function_is_ok(sc, sc->code)) break;
case HOP_SAFE_C_PS: op_safe_c_ps(sc); goto EVAL;
@@ -88032,25 +88353,25 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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); 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); continue;
+ case OP_SAFE_C_op_opSSqq_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_opSSqq_C: sc->value = fx_c_op_opssqq_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); continue;
+ case OP_SAFE_C_op_opSSqq_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_opSSqq_S: sc->value = fx_c_op_opssqq_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); 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); continue;
+ case OP_SAFE_C_op_opSqq_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_opSqq_C: sc->value = fx_c_op_opsqq_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 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, cadaddr(sc->code)))) break;
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 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, caddaddr(sc->code)))) break;
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 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, caddaddr(sc->code)))) break;
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;
@@ -88221,15 +88542,15 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_ID_S: if (!closure_is_eq(sc)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
- case HOP_SAFE_CLOSURE_ID_S: sc->value = fx_safe_closure_id_s(sc, sc->code); continue;
-
case OP_SAFE_CLOSURE_S_TO_S: if (!closure_is_eq(sc)) {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_SAFE_CLOSURE_S_TO_SC: if (!closure_is_eq(sc)) {if (op_unknown_g(sc, sc->last_function) == goto_eval) goto EVAL; break;}
case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_safe_closure_s_to_sc(sc, sc->code); continue;
+ case OP_SAFE_CLOSURE_A_TO_SC: if (!closure_is_eq(sc)) {if (op_unknown_a(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case HOP_SAFE_CLOSURE_A_TO_SC: sc->value = fx_safe_closure_a_to_sc(sc, sc->code); continue;
+
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;
@@ -88248,7 +88569,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break;
case HOP_CLOSURE_P: op_closure_p(sc); goto EVAL;
case OP_CLOSURE_P_1: op_closure_p_1(sc); goto BEGIN;
- case OP_CLOSURE_P_MV: op_closure_p_mv(sc); goto APPLY;
case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break;
case HOP_SAFE_CLOSURE_P: op_safe_closure_p(sc); goto EVAL;
@@ -88272,12 +88592,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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, 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_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break;
+ case HOP_CLOSURE_PP: op_closure_pp(sc); goto EVAL;
+ case OP_CLOSURE_PP_1: op_closure_pp_1(sc); goto EVAL;
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;
@@ -88287,6 +88609,17 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_SAFE_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) break;
+ case HOP_SAFE_CLOSURE_PP: op_safe_closure_pp(sc); goto EVAL;
+ case OP_SAFE_CLOSURE_PP_1: op_safe_closure_pp_1(sc); goto EVAL;
+
+ /* TODO: type check should ignore T_SAFE_CLOSURE */
+ case OP_SAFE_OR_UNSAFE_CLOSURE_3P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) break;
+ case HOP_SAFE_OR_UNSAFE_CLOSURE_3P: op_safe_or_unsafe_closure_3p(sc); goto EVAL;
+ case OP_SAFE_OR_UNSAFE_CLOSURE_3P_1: if (!op_safe_or_unsafe_closure_3p_1(sc)) goto EVAL; goto BEGIN;
+ case OP_SAFE_OR_UNSAFE_CLOSURE_3P_2: if (!op_safe_or_unsafe_closure_3p_2(sc)) goto EVAL; goto BEGIN;
+ case OP_SAFE_OR_UNSAFE_CLOSURE_3P_3: op_safe_or_unsafe_closure_3p_3(sc); goto BEGIN;
+
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;
@@ -88371,6 +88704,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_SAFE_CLOSURE_3S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {if (op_unknown_all_s(sc, sc->last_function) == goto_eval) goto EVAL; break;}
+ case HOP_SAFE_CLOSURE_3S_A: sc->value = fx_safe_closure_3s_a(sc, sc->code); continue;
+
case OP_CLOSURE_ALL_S: switch (op_check_closure_all_s(sc)) {case goto_eval: goto EVAL; case goto_unopt: goto UNOPT; default: break;}
case HOP_CLOSURE_ALL_S: op_closure_all_s(sc); goto EVAL;
@@ -88391,43 +88727,43 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
goto EVAL;
- 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_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_AND_A_OR_A_A_LA: tick_tc_rec(sc); op_tc_and_a_or_a_a_la(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_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, true)) continue; goto EVAL;
+ case OP_TC_IF_A_Z_L3A: tick_tc_rec(sc); if (op_tc_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL;
+ case OP_TC_IF_A_L3A_Z: tick_tc_rec(sc); if (op_tc_if_a_z_l3a(sc, sc->code, false)) 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_z_laa(sc, sc->code, false)) 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, true, false)) continue; goto EVAL;
+ case OP_TC_COND_A_Z_A_Z_LA: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, true)) 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_z_la(sc, sc->code, false, false)) 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_L3A_L3A: tick_tc_rec(sc); if (op_tc_if_a_z_if_a_l3a_l3a(sc, 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_A_opA_L3Aq: wrap_recur(sc, op_recur_if_a_a_opa_l3aq); 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;
@@ -88445,6 +88781,14 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_A1:
+ 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_A1: safe_closure_star_a1(sc, sc->code); goto BEGIN;
+
+ case OP_SAFE_CLOSURE_STAR_KA:
+ 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_KA: safe_closure_star_ka(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;
@@ -88476,6 +88820,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
closure_star_a(sc, sc->code);
goto BEGIN;
+ case OP_CLOSURE_STAR_KA:
+ 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_KA: closure_star_ka(sc, sc->code); goto BEGIN;
+
case OP_CLOSURE_STAR_FX:
switch (op_check_closure_star_fx(sc)) {case goto_eval: goto EVAL; case goto_unopt: goto UNOPT; default: break;}
case HOP_CLOSURE_STAR_FX:
@@ -88565,7 +88913,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_UNOPT:
#if UNOPT_PRINT
- fprintf(stderr, "unopt %s\n", DISPLAY_80(sc->code));
+ fprintf(stderr, "unopt %s\n", display_80(sc->code));
#endif
goto UNOPT;
@@ -88602,7 +88950,6 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
sc->args = sc->nil;
EVAL_ARGS: /* first time, value = op, args = nil, code is args */
- /* fprintf(stderr, "%d %s\n", __LINE__, DISPLAY(sc->code)); */
if (is_pair(sc->code)) /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */
{
if ((sc->safety > NO_SAFETY) &&
@@ -88634,9 +88981,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
else
{
/* here we know sc->code is a pair, cdr(sc->code) is not null, sc->value is the previous arg's value */
- s7_pointer x;
- x = cons(sc, sc->value, sc->args);
- sc->args = x;
+ sc->args = cons(sc, sc->value, sc->args);
goto EVAL_ARGS_PAIR;
}
}
@@ -88662,7 +89007,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_APPLY:
set_current_code(sc, history_cons(sc, sc->code, sc->args));
#if SHOW_EVAL_OPS
- safe_print(fprintf(stderr, " apply %s to %s\n", DISPLAY_80(sc->code), DISPLAY_80(sc->args)));
+ safe_print(fprintf(stderr, " apply %s to %s\n", display_80(sc->code), display_80(sc->args)));
#endif
switch (type(sc->code))
{
@@ -88746,7 +89091,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_DOTIMES:
SAFE_DOTIMES: /* check_do */
- switch (safe_dotimes_ex(sc))
+ switch (op_safe_dotimes(sc))
{
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;
@@ -88757,7 +89102,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_SAFE_DO:
SAFE_DO: /* from check_do */
- switch (safe_do_ex(sc))
+ switch (op_safe_do(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 */
@@ -88770,7 +89115,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_DOTIMES_P:
DOTIMES_P: /* from check_do */
- switch (dotimes_p_ex(sc))
+ switch (op_dotimes_p(sc))
{
case goto_do_end_clauses: goto DO_END_CLAUSES;
case goto_do_unchecked: goto DO_UNCHECKED;
@@ -88779,7 +89124,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_DOX:
DOX: /* from check_do */
- switch (dox_ex(sc))
+ switch (op_dox(sc))
{
case goto_do_end_clauses: goto DO_END_CLAUSES;
case goto_start: continue;
@@ -88826,7 +89171,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
}
#if 0
fprintf(stderr, "----------------------------------------\n");
- fprintf(stderr, "%s (do %s\n %s\n %s)\n\n", op_names[optimize_op(sc->code)], DISPLAY_80(cadr(sc->code)), DISPLAY_80(caddr(sc->code)), DISPLAY_80(cdddr(sc->code)));
+ fprintf(stderr, "%s (do %s\n %s\n %s)\n\n", op_names[optimize_op(sc->code)], display_80(cadr(sc->code)), display_80(caddr(sc->code)), display_80(cdddr(sc->code)));
#endif
case OP_DO_UNCHECKED:
op_do_unchecked(sc);
@@ -89002,7 +89347,9 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_IF1: if (op_if1(sc)) goto EVAL; continue;
case OP_IF_A_CC: sc->value = fx_if_a_cc(sc, sc->code); continue;
case OP_IF_A_A: sc->value = fx_if_a_a(sc, sc->code); continue;
+ case OP_IF_S_AA: sc->value = fx_if_s_aa(sc, sc->code); continue;
case OP_IF_A_AA: sc->value = fx_if_a_aa(sc, sc->code); continue;
+ case OP_IF_AND2_SA: sc->value = fx_if_and2_sa(sc, sc->code); continue;
case OP_IF_NOT_A_A: sc->value = fx_if_not_a_a(sc, sc->code); continue;
case OP_IF_NOT_A_AA: sc->value = fx_if_not_a_aa(sc, sc->code); continue;
@@ -89164,10 +89511,8 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_LET_opaSSq_E_OLD: op_let_opassq_e_old(sc); goto EVAL;
case OP_LET_opaSSq_E_NEW: op_let_opassq_e_new(sc); goto EVAL;
- 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); continue;
- case OP_LET_STAR_FX_A_NEW: op_let_star_fx_a_new(sc); continue;
+ case OP_LET_STAR_FX: op_let_star_fx(sc); goto BEGIN;
+ case OP_LET_STAR_FX_A: op_let_star_fx_a(sc); continue;
case OP_NAMED_LET_STAR: op_named_let_star(sc); goto EVAL;
case OP_LET_STAR2: op_let_star2(sc); goto EVAL;
@@ -89206,6 +89551,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_A_A: sc->value = fx_let_temp_a_a(sc, sc->code); continue;
case OP_LET_TEMP_UNWIND: op_let_temp_unwind(sc); continue;
case OP_LET_TEMP_S7_UNWIND: op_let_temp_s7_unwind(sc); continue;
@@ -89340,13 +89686,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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_P_G_G: push_stack_no_args_direct(sc, OP_CASE_G_G, sc->code); sc->code = cadr(sc->code); goto EVAL;
+ case OP_CASE_P_E_S: push_stack_no_args_direct(sc, OP_CASE_E_S, sc->code); sc->code = cadr(sc->code); goto EVAL;
+ case OP_CASE_P_S_S: push_stack_no_args_direct(sc, OP_CASE_S_S, sc->code); sc->code = cadr(sc->code); goto EVAL;
+ case OP_CASE_P_I_S: push_stack_no_args_direct(sc, OP_CASE_I_S, sc->code); sc->code = cadr(sc->code); goto EVAL;
+ case OP_CASE_P_G_S: push_stack_no_args_direct(sc, OP_CASE_G_S, sc->code); sc->code = cadr(sc->code); goto EVAL;
+ case OP_CASE_P_E_G: push_stack_no_args_direct(sc, OP_CASE_E_G, sc->code); sc->code = cadr(sc->code); goto EVAL;
+ case OP_CASE_P_S_G: push_stack_no_args_direct(sc, OP_CASE_S_G, sc->code); sc->code = cadr(sc->code); goto EVAL;
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 */
@@ -89381,7 +89727,7 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
case OP_ERROR_HOOK_QUIT:
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));
+ fprintf(stderr, "%d: op_error_hook_quit did not jump, returns %s\n", __LINE__, display(sc->value));
#endif
case OP_EVAL_DONE: return(sc->F);
@@ -89590,13 +89936,13 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op)
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, "unknown operator: %" print_pointer " in %s\n", sc->cur_op, display(current_code(sc)));
return(sc->F);
}
clear_all_optimizations(sc, sc->code);
#if UNOPT_PRINT
- fprintf(stderr, "cleared: %s\n", DISPLAY_80(sc->code));
+ fprintf(stderr, "cleared: %s\n", display_80(sc->code));
#endif
UNOPT:
@@ -90677,23 +91023,23 @@ static int32_t result_type_via_method(s7_scheme *sc, int32_t result_type, s7_poi
s7_pointer f;
if (!has_active_methods(sc, p)) return(-1);
- f = find_method(sc, find_let(sc, p), sc->is_integer_symbol);
+ f = find_method_with_let(sc, p, sc->is_integer_symbol);
if ((f != sc->undefined) &&
(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))))
return(big_type_to_result_type(result_type, T_BIG_INTEGER));
- f = find_method(sc, find_let(sc, p), sc->is_rational_symbol);
+ f = find_method_with_let(sc, p, sc->is_rational_symbol);
if ((f != sc->undefined) &&
(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))))
return(big_type_to_result_type(result_type, T_BIG_RATIO));
- f = find_method(sc, find_let(sc, p), sc->is_real_symbol);
+ f = find_method_with_let(sc, p, sc->is_real_symbol);
if ((f != sc->undefined) &&
(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))))
return(big_type_to_result_type(result_type, T_BIG_REAL));
/* might be a number, but not complex (quaternion) */
- f = find_method(sc, find_let(sc, p), sc->is_complex_symbol);
+ f = find_method_with_let(sc, p, sc->is_complex_symbol);
if ((f != sc->undefined) &&
(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil)))))
return(big_type_to_result_type(result_type, T_BIG_COMPLEX));
@@ -91064,7 +91410,7 @@ static s7_pointer big_divide(s7_scheme *sc, s7_pointer args)
{
s7_pointer func;
if ((has_active_methods(sc, car(x))) &&
- ((func = find_method(sc, find_let(sc, car(x)), sc->multiply_symbol)) != sc->undefined))
+ ((func = find_method_with_let(sc, car(x), sc->multiply_symbol)) != sc->undefined))
{
divisor = s7_apply_function(sc, func, cons(sc, divisor, x));
break;
@@ -92310,7 +92656,7 @@ static bool is_integer_via_method(s7_scheme *sc, s7_pointer p)
if (has_active_methods(sc, p))
{
s7_pointer f;
- f = find_method(sc, find_let(sc, p), sc->is_integer_symbol);
+ f = find_method_with_let(sc, p, sc->is_integer_symbol);
if (f != sc->undefined)
return(is_true(sc, s7_apply_function(sc, f, cons(sc, p, sc->nil))));
}
@@ -93422,7 +93768,7 @@ static s7_pointer set_bignum_precision(s7_scheme *sc, int32_t precision)
{
mp_prec_t bits;
if (precision <= 1) /* (set! (*s7* 'bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */
- return(s7_out_of_range_error(sc, "set! (*s7* 'bignum-precision)", 0, wrap_integer1(sc, precision), "has to be greater than 1"));
+ return(s7_out_of_range_error(sc, "set! (*s7* 'bignum-precision)", 0, wrap_integer2(sc, precision), "has to be greater than 1"));
bits = (mp_prec_t)precision;
mpfr_set_default_prec(bits);
@@ -94472,7 +94818,7 @@ static bool is_decodable(s7_scheme *sc, s7_pointer p)
}
for (i = 0; i < NUM_CHARS; i++) if (p == chars[i]) return(true);
- for (i = 0; i <= NUM_SMALL_INTS; i++) if (p == small_ints[i]) return(true);
+ for (i = 0; i < NUM_SMALL_INTS; i++) if (p == small_ints[i]) return(true);
/* also real_one and friends, sc->safe_lists, p|elist? */
/* check the heap */
@@ -94588,6 +94934,166 @@ char *s7_decode_bt(s7_scheme *sc)
/* -------------------------------- initialization -------------------------------- */
+static void fx_function_init(void)
+{
+ int32_t i;
+ for (i = 0; i < NUM_OPS; i++)
+ fx_function[i] = NULL;
+
+ fx_function[HOP_SAFE_C_D] = fx_c_d;
+
+ fx_function[HOP_SAFE_C_S] = fx_c_s;
+ fx_function[HOP_SAFE_C_opDq] = fx_c_opdq;
+ fx_function[HOP_SAFE_C_opSq] = fx_c_opsq;
+ fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq;
+ fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq;
+ fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq;
+
+ fx_function[HOP_SAFE_C_SC] = fx_c_sc;
+ fx_function[HOP_SAFE_C_CS] = fx_c_cs;
+ fx_function[HOP_SAFE_C_CQ] = fx_c_cq;
+ fx_function[HOP_SAFE_C_SS] = fx_c_ss;
+
+ fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s;
+ fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c;
+ fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs;
+ fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq;
+ fx_function[HOP_SAFE_C_S_opDq] = fx_c_s_opdq;
+ fx_function[HOP_SAFE_C_opDq_S] = fx_c_opdq_s;
+ fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq;
+ fx_function[HOP_SAFE_C_C_opDq] = fx_c_c_opdq;
+ fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c;
+ fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s;
+ fx_function[HOP_SAFE_C_C_opCSq] = fx_c_c_opcsq;
+ fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq;
+ fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c;
+ fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c;
+ fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s;
+ fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq;
+ fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq;
+ fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq;
+ fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq;
+ fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq;
+ fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq;
+ fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq;
+ fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq;
+ fx_function[HOP_SAFE_C_op_opSSqq_C] = fx_c_op_opssqq_c;
+ fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq;
+ fx_function[HOP_SAFE_C_op_opSq_Cq] = fx_c_op_opsq_cq;
+ fx_function[HOP_SAFE_C_op_opSqq_C] = fx_c_op_opsqq_c;
+ fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq;
+ fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq;
+ fx_function[HOP_SAFE_C_S_op_S_opSqq] = fx_c_s_op_s_opsqq;
+ fx_function[HOP_SAFE_C_S_op_S_opSSqq] = fx_c_s_op_s_opssqq;
+ fx_function[HOP_SAFE_C_S_op_opSq_Cq] = fx_c_s_op_opsq_cq;
+ fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s;
+ fx_function[HOP_SAFE_C_op_opSSq_Sq_S] = fx_c_op_opssq_sq_s;
+ fx_function[HOP_SAFE_C_S_op_opSSq_opSSqq] = fx_c_s_op_opssq_opssqq;
+
+ 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;
+ fx_function[HOP_SAFE_C_SCC] = fx_c_scc;
+ fx_function[HOP_SAFE_C_CSS] = fx_c_css;
+ fx_function[HOP_SAFE_C_CSC] = fx_c_csc;
+ fx_function[HOP_SAFE_C_CCS] = fx_c_ccs;
+ fx_function[HOP_SAFE_C_ALL_S] = fx_c_all_s;
+
+ fx_function[HOP_SAFE_C_A] = fx_c_a;
+ fx_function[HOP_SAFE_C_AA] = fx_c_aa;
+ fx_function[HOP_SAFE_C_CA] = fx_c_ca;
+ fx_function[HOP_SAFE_C_AC] = fx_c_ac;
+ fx_function[HOP_SAFE_C_AAA] = fx_c_aaa;
+ fx_function[HOP_SAFE_C_CAC] = fx_c_cac;
+ fx_function[HOP_SAFE_C_CSA] = fx_c_csa;
+ 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[HOP_SAFE_C_ALL_CA] = fx_c_all_ca;
+ fx_function[HOP_SAFE_C_FX] = fx_c_fx;
+ fx_function[HOP_SAFE_C_4A] = fx_c_4a;
+ fx_function[HOP_SAFE_C_opAq] = fx_c_opaq;
+ fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq;
+ fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq;
+ fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s;
+ fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq;
+ fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq;
+ fx_function[HOP_SAFE_C_S_opAAAq] = fx_c_s_opaaaq;
+
+ fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a;
+ fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a;
+ 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[HOP_SAFE_CLOSURE_3S_A] = fx_safe_closure_3s_a;
+
+ fx_function[OP_SSA_DIRECT] = fx_c_ssa_direct;
+ fx_function[OP_HASH_INCREMENT] = fx_hash_increment;
+
+ fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s;
+ fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc;
+ fx_function[HOP_SAFE_CLOSURE_A_TO_SC] = fx_safe_closure_a_to_sc;
+
+ fx_function[OP_COND_FX_FX] = fx_cond_fx_fx;
+ fx_function[OP_opIF_A_SSq_A] = fx_opif_a_ssq_a;
+ fx_function[OP_IF_A_CC] = fx_if_a_cc;
+ fx_function[OP_IF_A_A] = fx_if_a_a;
+ fx_function[OP_IF_S_AA] = fx_if_s_aa;
+ fx_function[OP_IF_A_AA] = fx_if_a_aa;
+ fx_function[OP_IF_AND2_SA] = fx_if_and2_sa;
+ fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a;
+ fx_function[OP_IF_NOT_A_AA] = fx_if_not_a_aa;
+ fx_function[OP_OR_2] = fx_or_2;
+ fx_function[OP_OR_S_2] = fx_or_s_2;
+ fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2;
+ fx_function[OP_OR_3] = fx_or_3;
+ fx_function[OP_OR_N] = fx_or_n;
+ fx_function[OP_AND_2] = fx_and_2;
+ fx_function[OP_AND_S_2] = fx_and_s_2;
+ fx_function[OP_AND_3] = fx_and_3;
+ fx_function[OP_AND_N] = fx_and_n;
+ fx_function[OP_LET_TEMP_A_A] = fx_let_temp_a_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;
+ fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la;
+ fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa;
+ fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa;
+ fx_function[OP_TC_AND_A_OR_A_A_LA] = fx_tc_and_a_or_a_a_la;
+ fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la;
+ fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z;
+ fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa;
+ fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z;
+ fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a;
+ fx_function[OP_TC_IF_A_L3A_Z] = fx_tc_if_a_l3a_z;
+ fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la;
+ fx_function[OP_TC_COND_A_Z_A_Z_LA] = fx_tc_cond_a_z_a_z_la;
+ fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z;
+ fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z;
+ fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa;
+ fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a;
+ fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa;
+ fx_function[OP_TC_CASE_LA] = fx_tc_case_la;
+ fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a;
+ fx_function[OP_TC_IF_A_T_AND_A_A_L3A] = fx_tc_if_a_t_and_a_a_l3a;
+ fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa;
+ fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa;
+ fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa;
+ fx_function[OP_TC_LET_COND] = fx_tc_let_cond;
+ fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa;
+
+ fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq;
+ fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a;
+ fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = fx_recur_if_a_a_and_a_laa_laa;
+ fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = fx_recur_cond_a_a_a_a_opla_laq;
+}
+
+#if WITH_FX_TREE
+#include "fx_tree.h"
+#endif
+
+
static s7_pointer make_real_wrapper(void)
{
s7_pointer p;
@@ -94822,6 +95328,9 @@ s7_scheme *s7_init(void)
sc->temp9 = sc->nil;
sc->temp10 = sc->nil;
+ sc->rec_p1 = sc->F;
+ sc->rec_p2 = sc->F;
+
sc->begin_hook = NULL;
sc->autoload_table = sc->nil;
sc->autoload_names = NULL;
@@ -94903,6 +95412,9 @@ s7_scheme *s7_init(void)
o = &os[i];
sc->opts[i] = o;
o->sc = sc;
+#if S7_DEBUGGING
+ o->loc = i;
+#endif
}
}
@@ -95694,7 +96206,6 @@ s7_scheme *s7_init(void)
set_scope_safe(slot_value(global_slot(sc->with_input_from_file_symbol)));
set_scope_safe(slot_value(global_slot(sc->with_output_to_string_symbol)));
set_scope_safe(slot_value(global_slot(sc->with_output_to_file_symbol)));
- set_scope_safe(slot_value(global_slot(sc->set_cdr_symbol)));
set_maybe_safe(slot_value(global_slot(sc->assoc_symbol)));
set_scope_safe(slot_value(global_slot(sc->assoc_symbol)));
set_maybe_safe(slot_value(global_slot(sc->member_symbol)));
@@ -95710,7 +96221,8 @@ s7_scheme *s7_init(void)
set_scope_safe(slot_value(global_slot(sc->throw_symbol)));
set_scope_safe(slot_value(global_slot(sc->error_symbol)));
set_scope_safe(slot_value(global_slot(sc->apply_values_symbol)));
- set_scope_safe(slot_value(global_slot(sc->list_values_symbol)));
+ /* set_scope_safe(slot_value(global_slot(sc->set_cdr_symbol))); */ /* now safe */
+ /* set_scope_safe(slot_value(global_slot(sc->list_values_symbol))); */ /* now safe */
sc->tree_leaves_symbol = defun("tree-leaves", tree_leaves, 1, 0, false);
sc->tree_memq_symbol = defun("tree-memq", tree_memq, 2, 0, false);
@@ -95780,9 +96292,13 @@ s7_scheme *s7_init(void)
sc->local_setter_symbol = make_symbol(sc, "+setter+");
sc->local_iterator_symbol = make_symbol(sc, "+iterator+");
- /* for backwards compatibility */
+#if (!DISABLE_DEPRECATED)
s7_define_constant(sc, "nan.0", real_NaN);
s7_define_constant(sc, "inf.0", real_infinity);
+#else
+ s7_define_variable(sc, "nan.0", real_NaN);
+ s7_define_variable(sc, "inf.0", real_infinity);
+#endif
#if WITH_PURE_S7
s7_provide(sc, "pure-s7");
@@ -96070,6 +96586,7 @@ s7_scheme *s7_init(void)
#if (!WITH_GMP)
s7_set_p_pp_function(slot_value(global_slot(sc->remainder_symbol)), remainder_p_pp);
+ s7_set_p_pp_function(slot_value(global_slot(sc->quotient_symbol)), quotient_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);
@@ -96089,10 +96606,6 @@ s7_scheme *s7_init(void)
s7_set_d_dd_function(slot_value(global_slot(sc->atan_symbol)), atan_d_dd);
s7_set_d_7dd_function(slot_value(global_slot(sc->remainder_symbol)), remainder_d_7dd);
s7_set_d_dd_function(slot_value(global_slot(sc->modulo_symbol)), modulo_d_dd);
- s7_set_p_pp_function(slot_value(global_slot(sc->multiply_symbol)), multiply_p_pp);
- s7_set_p_dd_function(slot_value(global_slot(sc->multiply_symbol)), mul_p_dd);
- s7_set_p_dd_function(slot_value(global_slot(sc->add_symbol)), add_p_dd);
- s7_set_p_dd_function(slot_value(global_slot(sc->subtract_symbol)), sub_p_dd);
s7_set_i_7d_function(slot_value(global_slot(sc->round_symbol)), round_i_7d);
s7_set_i_7d_function(slot_value(global_slot(sc->floor_symbol)), floor_i_7d);
s7_set_i_7p_function(slot_value(global_slot(sc->floor_symbol)), floor_i_7p);
@@ -96104,6 +96617,13 @@ s7_scheme *s7_init(void)
s7_set_i_7ii_function(slot_value(global_slot(sc->remainder_symbol)), remainder_i_7ii);
s7_set_i_ii_function(slot_value(global_slot(sc->modulo_symbol)), modulo_i_ii);
s7_set_p_d_function(slot_value(global_slot(sc->rationalize_symbol)), rationalize_p_d);
+ s7_set_p_pp_function(slot_value(global_slot(sc->add_symbol)), add_p_pp);
+ s7_set_p_pp_function(slot_value(global_slot(sc->subtract_symbol)), subtract_p_pp);
+ s7_set_p_pp_function(slot_value(global_slot(sc->divide_symbol)), divide_p_pp);
+ s7_set_p_pp_function(slot_value(global_slot(sc->multiply_symbol)), multiply_p_pp);
+ s7_set_p_dd_function(slot_value(global_slot(sc->multiply_symbol)), mul_p_dd);
+ s7_set_p_dd_function(slot_value(global_slot(sc->add_symbol)), add_p_dd);
+ s7_set_p_dd_function(slot_value(global_slot(sc->subtract_symbol)), sub_p_dd);
#endif
s7_set_p_d_function(slot_value(global_slot(sc->float_vector_symbol)), float_vector_p_d);
s7_set_p_i_function(slot_value(global_slot(sc->int_vector_symbol)), int_vector_p_i);
@@ -96124,10 +96644,6 @@ s7_scheme *s7_init(void)
s7_set_d_dddd_function(slot_value(global_slot(sc->multiply_symbol)), multiply_d_dddd);
s7_set_p_i_function(slot_value(global_slot(sc->divide_symbol)), divide_p_i);
s7_set_p_ii_function(slot_value(global_slot(sc->divide_symbol)), divide_p_ii);
-#if (!WITH_GMP)
- s7_set_p_pp_function(slot_value(global_slot(sc->add_symbol)), add_p_pp);
- s7_set_p_pp_function(slot_value(global_slot(sc->subtract_symbol)), subtract_p_pp);
-#endif
s7_set_d_dd_function(slot_value(global_slot(sc->max_symbol)), max_d_dd);
s7_set_d_dd_function(slot_value(global_slot(sc->min_symbol)), min_d_dd);
s7_set_d_ddd_function(slot_value(global_slot(sc->max_symbol)), max_d_ddd);
@@ -96248,6 +96764,7 @@ s7_scheme *s7_init(void)
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->list_tail_symbol)), list_tail_p_pp);
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);
@@ -96259,6 +96776,7 @@ s7_scheme *s7_init(void)
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_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_p_function(slot_value(global_slot(sc->read_char_symbol)), read_char_p_p);
s7_set_p_i_function(slot_value(global_slot(sc->make_string_symbol)), make_string_p_i);
s7_set_p_ii_function(slot_value(global_slot(sc->make_int_vector_symbol)), make_int_vector_p_ii);
s7_set_p_ii_function(slot_value(global_slot(sc->make_byte_vector_symbol)), make_byte_vector_p_ii);
@@ -96273,10 +96791,13 @@ s7_scheme *s7_init(void)
#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);
+ s7_set_p_p_function(slot_value(global_slot(sc->magnitude_symbol)), magnitude_p_p);
#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_p_p_function(slot_value(global_slot(sc->real_part_symbol)), real_part_p_p);
+ s7_set_p_p_function(slot_value(global_slot(sc->imag_part_symbol)), imag_part_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);
@@ -96334,6 +96855,7 @@ s7_scheme *s7_init(void)
s7_set_b_pi_function(slot_value(global_slot(sc->geq_symbol)), geq_b_pi);
s7_set_p_pi_function(slot_value(global_slot(sc->add_symbol)), g_add_xi);
+ s7_set_p_pi_function(slot_value(global_slot(sc->subtract_symbol)), g_sub_xi);
s7_set_p_pi_function(slot_value(global_slot(sc->multiply_symbol)), g_mul_xi);
/* s7_set_p_pd_function(slot_value(global_slot(sc->add_symbol)), g_add_xf); */
/* no ip pd dp! */
@@ -96395,7 +96917,7 @@ s7_scheme *s7_init(void)
#endif
/* -------------------------------------------------------------------------------- */
- s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote);
+ sc->quasiquote_symbol = s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote);
#if (!WITH_PURE_S7)
s7_eval_c_string(sc, "(define-macro (call-with-values producer consumer) (list consumer (list producer)))");
@@ -96511,7 +97033,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 != 855) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info));
+ if (NUM_OPS != 880) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info));
/* 64 bit machine: cell size: 48, 80 if gmp, 160 if debugging, block size: 40, opt: 128 */
#endif
@@ -96523,9 +97045,9 @@ s7_scheme *s7_init(void)
s7_eval_c_string(sc, "(begin \n\
(define-constant most-positive-fixnum (*s7* 'most-positive-fixnum)) \n\
(define-constant most-negative-fixnum (*s7* 'most-negative-fixnum)) \n\
- (define global-environment rootlet) \n\
+ (define global-environment rootlet) \n\
(define current-environment curlet) \n\
- (define make-keyword string->keyword))"); /* these are used in CM's scm/s7.scm */
+ (define make-keyword string->keyword))"); /* these are used in CM's scm/s7.scm */
#endif
return(sc);
@@ -96541,37 +97063,120 @@ s7_scheme *s7_init(void)
#define WITH_MAIN 0
#endif
+static void dumb_repl(s7_scheme *sc)
+{
+ while (true)
+ {
+ char buffer[512];
+ fprintf(stdout, "\n> ");
+ if (!fgets(buffer, 512, stdin)) break; /* error or ctrl-D */
+ if (((buffer[0] != '\n') || (strlen(buffer) > 1)))
+ {
+ char response[1024];
+ snprintf(response, 1024, "(write %s)", buffer);
+ s7_eval_c_string(sc, response);
+ }
+ }
+ fprintf(stdout, "\n");
+ if (ferror(stdin))
+ fprintf(stderr, "read error on stdin\n");
+}
+
+void s7_repl(s7_scheme *sc)
+{
+ s7_pointer old_e, e, val;
+ s7_int gc_loc;
+ /* try to get lib_s7.so from the repl's directory, and set *libc*.
+ * otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h
+ */
+ e = s7_inlet(sc, s7_list(sc, 2, s7_make_symbol(sc, "init_func"), s7_make_symbol(sc, "libc_s7_init")));
+ gc_loc = s7_gc_protect(sc, e);
+ old_e = s7_set_curlet(sc, e); /* e is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */
+ val = s7_load_with_environment(sc, "libc_s7.so", e);
+ s7_define_variable(sc, "*libc*", e);
+ s7_eval_c_string(sc, "(set! *libraries* (cons (cons \"libc.scm\" *libc*) *libraries*))");
+ s7_gc_unprotect_at(sc, gc_loc);
+ s7_set_curlet(sc, old_e); /* restore incoming (curlet) */
+ if (!val)
+ dumb_repl(sc);
+ else
+ {
+ s7_load(sc, "repl.scm");
+ s7_eval_c_string(sc, "((*repl* 'run))");
+ }
+}
+
#if (WITH_MAIN && (!USE_SND))
+#if (!MS_WINDOWS)
+static char *realdir(const char *filename) /* this code courtesy Lassi Kortela 4-Nov-19 */
+{
+ char *path;
+ char *p;
+ /* s7_repl wants to load libc_s7.o (for tcsetattr et al), but if it is started in a directory other than the libc_s7.so
+ * directory, it fails (it tries to build the library but that requires s7.h and libc.scm). So here we are trying to
+ * guess the libc_s7 directory from the command line program name. This can't work in general, but it works often
+ * enough to be worth the effort. If S7_LOAD_PATH is set, it is used instead.
+ */
+ if (!strchr(filename, '/'))
+ {
+ if (!file_probe("libc_s7.so"))
+ {
+ fprintf(stderr, "%s needs libc_s7.so (give the explicit pathname)\n", filename); /* env PATH=/home/bil/cl repl */
+ exit(2);
+ }
+ return(NULL); /* we're in the libc_s7.so directory, I hope (local s7 might not match local libc_s7.so) */
+ }
+ if (!(path = realpath(filename, NULL)))
+ {
+ fprintf(stderr, "%s: %s\n", strerror(errno), filename);
+ exit(2);
+ }
+ if (!(p = strrchr(path, '/')))
+ {
+ free(path);
+ fprintf(stderr, "please provide the full pathname for %s\n", filename);
+ exit(2);
+ }
+ if (p > path) *p = '\0'; else p[1] = 0;
+ return(path);
+}
+#endif
+
int main(int argc, char **argv)
{
s7_scheme *sc;
sc = s7_init();
+ fprintf(stderr, "s7: %s\n", S7_DATE);
+
if (argc == 2)
{
fprintf(stderr, "load %s\n", argv[1]);
- s7_load(sc, argv[1]);
+ if (!s7_load(sc, argv[1]))
+ {
+ fprintf(stderr, "can't load %s\n", argv[1]);
+ return(2);
+ }
}
else
{
-#if (!MS_WINDOWS)
- s7_load(sc, "repl.scm"); /* this is libc dependent */
- s7_eval_c_string(sc, "((*repl* 'run))");
+#if MS_WINDOWS
+ dumb_repl(sc);
+#else
+#ifdef S7_LOAD_PATH
+ s7_add_to_load_path(sc, S7_LOAD_PATH);
#else
- while (1) /* a minimal repl -- taken from s7.html */
+ char *dir;
+ dir = realdir(argv[0]);
+ if (dir)
{
- char buffer[512];
- char response[1024];
- fprintf(stdout, "\n> ");
- fgets(buffer, 512, stdin);
- if ((buffer[0] != '\n') || (strlen(buffer) > 1))
- {
- snprintf(response, 1024, "(write %s)", buffer);
- s7_eval_c_string(sc, response);
- }
+ s7_add_to_load_path(sc, dir);
+ free(dir);
}
#endif
+ s7_repl(sc);
+#endif
}
return(0);
}
@@ -96588,64 +97193,61 @@ 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.7 19.8 19.9
- * ------------------------------------------------------------------------------
- * tpeak | | | | 391 | 377 | 199 | 163 163
- * tauto | | | 1752 | 1689 | 1700 | 835 | 630 621
- * tref | | | 2372 | 2125 | 1036 | 983 | 876 791
- * tshoot | | | | | | 1224 | 847
- * index 44.3 | 3291 | 1725 | 1276 | 1255 | 1168 | 1022 | 880 876
- * teq | | | 6612 | 2777 | 1931 | 1539 | 1485 1479
- * s7test 1721 | 1358 | 995 | 1194 | 2926 | 2110 | 1726 | 1685 1674
- * tvect | | | | | | 5729 | 1919 1793
- * tmisc | | | | | | 2636 | 1949 1846
- * lint | | | | 4041 | 2702 | 2120 | 2090 2053
- * tlet | | | | | 4717 | 2959 | 2241 2148
- * tform | | | 6816 | 3714 | 2762 | 2362 | 2238 2207
- * tcopy | | | 13.6 | 3183 | 2974 | 2320 | 2251 2220
- * tread | | | | | 2357 | 2336 | 2258 2264
- * tclo | | 4391 | 4666 | 4651 | 4682 | 3084 | 2626 2397
- * tmat 8641 | 8458 | | 7279 | 7248 | 7252 | 6823 | 2655 2463
- * fbench 4123 | 3869 | 3486 | 3609 | 3602 | 3637 | 3495 | 2681 2653
- * titer | | | | 5971 | 4646 | 3587 | 2828 2727
- * trclo | | | | 10.3 | 10.5 | 8758 | 2886 2820
- * tmap | | | 9.3 | 5279 | 3445 | 3015 | 3049 2897
- * tset | | | | | 10.0 | 6432 | 2980 2928
- * tsort | | | | 8584 | 4111 | 3327 | 3236 3090
- * dup | | | | | 20.8 | 5711 | 3028 3362
- * tmac 8550 | 8396 | 7556 | 5606 | 5503 | 5404 | 3969 | 3624 3514
- * tfft | | 17.1 | 17.3 | 19.2 | 19.3 | 4466 | 4029 3873
- * trec 35.0 | 29.3 | 24.8 | 25.5 | 24.9 | 25.6 | 20.0 | 6435 6432
- * thash | | | | | | 10.3 | 8467 6647
- * 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.8 14.6
- * calls 359.0 |275.0 | 54.0 | 34.7 | 43.7 | 40.4 | 38.4 | 35.6 35.1
- * sg | | | |139.0 | 85.9 | 78.0 | 69.1 68.6
- * lg | | | |211.0 |133.0 |112.7 |106.8 103.8
- * tbig | | | | |246.9 |230.6 |181.2 177.9
- * ------------------------------------------------------------------------------
- *
- * 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
+ * --------------------------------------------------------------------------
+ * 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19.9 |
+ * --------------------------------------------------------------------------
+ * tpeak | | | | 391 | 377 | 199 | 112 |
+ * tauto | | | 1752 | 1689 | 1700 | 835 | 623 |
+ * tref | | | 2372 | 2125 | 1036 | 983 | 715 |
+ * tshoot | | | | | | 1224 | 735 |
+ * index 44.3 | 3291 | 1725 | 1276 | 1255 | 1168 | 1022 | 866 |
+ * teq | | | 6612 | 2777 | 1931 | 1539 | 1447 |
+ * tvect | | | | | | 5729 | 1617 |
+ * s7test 1721 | 1358 | 995 | 1194 | 2926 | 2110 | 1726 | 1680 |
+ * lint | | | | 4041 | 2702 | 2120 | 2038 |
+ * tlet | | | | | 4717 | 2959 | 2123 |
+ * tform | | | 6816 | 3714 | 2762 | 2362 | 2205 |
+ * tcopy | | | 13.6 | 3183 | 2974 | 2320 | 2225 |
+ * tread | | | | | 2357 | 2336 | 2256 |
+ * tmisc | | | | | | 3087 | 2298 |
+ * tmat 8641 | 8458 | | 7279 | 7248 | 7252 | 6823 | 2399 |
+ * dup | | | | | 20.8 | 5711 | 2576 |
+ * trclo | | | | 10.3 | 10.5 | 8758 | 2601 |
+ * fbench 4123 | 3869 | 3486 | 3609 | 3602 | 3637 | 3495 | 2613 |
+ * titer | | | | 5971 | 4646 | 3587 | 2687 |
+ * tmap | | | 9.3 | 5279 | 3445 | 3015 | 2725 |
+ * tb | | | 4727 | 4742 | 4735 | 3481 | 2739 |
+ * tset | | | | | 10.0 | 6432 | 2922 |
+ * tsort | | | | 8584 | 4111 | 3327 | 2935 |
+ * tmac 8550 | 8396 | 7556 | 5606 | 5503 | 5404 | 3969 | 3139 |
+ * tfft | | 17.1 | 17.3 | 19.2 | 19.3 | 4466 | 3727 |
+ * tclo | | 9502 | 10.0 | 9730 | 9729 | 6848 | 4676 |
+ * trec 35.0 | 29.3 | 24.8 | 25.5 | 24.9 | 25.6 | 20.0 | 5949 |
+ * thash | | | | | | 10.3 | 6497 |
+ * tgen | 71.0 | 70.6 | 38.0 | 12.6 | 11.9 | 11.2 | 10.8 |
+ * tall 90.0 | 43.0 | 14.5 | 12.7 | 17.9 | 18.8 | 17.1 | 14.3 |
+ * calls 359.0 |275.0 | 54.0 | 34.7 | 43.7 | 40.4 | 38.4 | 34.6 |
+ * sg | | | |139.0 | 85.9 | 78.0 | 68.2 |
+ * lg | | | |211.0 |133.0 |112.7 |103.1 |
+ * tbig | | | | |246.9 |230.6 |176.8 177.8 see tmp
+ * --------------------------------------------------------------------------
*
- * fx*direct p_pp opts, opt_set_p_i_f* call make_integer, also p_d_f
- * split format as per s7.html, can optimizer catch no string result cases?
- * split add|mul_p_pp -- aren't there splittable pp cases? add_p_pi ip pd dp and mul/-/= [di id?]
- * op_c_s_opssq_direct -> add should notice int-vector et al and use add_p_xx?
- * no ip dp pd yet
- * perhaps hash-table-default [where to store it? -- add room in block data?]
- * need timing for rats/complex -- make sure rats stay that way: continued fractions (t184)
- * replace closure_id_s with all_s? = (define x y) but done stupidly, 71533
- * fx_sqr_1 using t [let* first?] ftree opssq_s? -- wrong order?
- * (t180=overheads)
- * check (named-)let(*) for optimize_lambda, but letrec(*) is safer since outlet is blocked here [these need tests]
- * closure_s_to_opscq_c?
- * if all opts[pc] refs gone at runtime, can all pc++ be removed? [267(+44?) o->sc->pc++][9|56 ++o...]
- * can o_wrap be finessed via b_to_p_0 et al? [28? cases]
- * direct op|fx_safe_c_s|s?
+ * opt* coverage tests t206 opt_i|d|p*
+ * main allocations: frames+slots, arglists: use scope_safe with closure? or needs_copied_args? where is this happening?
+ * lambda arg ok if self-contained
+ * op_named_let_fx (arg list is not needed, pick out lamlet case?), op_safe_c_fp (try gx below? or recog possibility in opt)
+ * make frame first in place of list
+ * for fp-style local lists, use a vector instead? or a cons+opt1... (arglen<6 but needs mv support?)
+ * also gx_call? op_safe_closure_s_a->check+call else jump(back to fp caller) as in no fx_call case, could include unknown* call
+ * gx_functions? or gx_checks+fx_function given hop bit
+ * applies to ap, pa etc, safe_closure_p_a
+ * first var in op_named_let cases
+ * ? tc: if_a_z_let_if_a_z_la
+ * direct? fx_c_aa(sg) opsq_c(lg: lint_let_ref?) sa(lg) aaa(lg/b): need rest of cxr cases
+ * there are lots of offsets in fx* -- cdaddr etc
+ * move bignum checks into vref et al [is_eq_s_vref for example]
+ * vector max-len is s7_int, so even in gmp case the indices need to fit s7_int (so vector_ref_p_pp needs bignum cases)
+ * combiner for opt funcs (pp/pi etc) [p_p+p_pp to p_d+d_dd...][p_any|p|d|i|b = cf_opt_any now]
+ * cp->ca but should be cp->c_opssq (combine_ops sees this case)? sa in big also (via multiply_sa)
+ * t718
*/
diff --git a/s7.h b/s7.h
index 51d44b7..16e5e10 100644
--- a/s7.h
+++ b/s7.h
@@ -1,8 +1,8 @@
#ifndef S7_H
#define S7_H
-#define S7_VERSION "8.8"
-#define S7_DATE "30-Jul-19"
+#define S7_VERSION "8.9"
+#define S7_DATE "2019-11-19"
#include <stdint.h> /* for int64_t */
@@ -90,7 +90,7 @@ void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val));
s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e); /* (eval code e) -- e is the optional environment */
void s7_provide(s7_scheme *sc, const char *feature); /* add feature (as a symbol) to the *features* list */
bool s7_is_provided(s7_scheme *sc, const char *feature); /* (provided? feature) */
-
+void s7_repl(s7_scheme *sc);
s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info);
s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr);
@@ -844,16 +844,16 @@ s7_pointer s7_apply_n_9(s7_scheme *sc, s7_pointer args,
typedef s7_int s7_Int;
typedef s7_double s7_Double;
-#define s7_is_object s7_is_c_object
-#define s7_object_type s7_c_object_type
-#define s7_object_value s7_c_object_value
-#define s7_make_object s7_make_c_object
-#define s7_mark_object s7_mark
-#define s7_UNSPECIFIED(Sc) s7_unspecified(Sc)
-#define s7_NIL(Sc) s7_nil(Sc)
+#define s7_is_object s7_is_c_object
+#define s7_object_type s7_c_object_type
+#define s7_object_value s7_c_object_value
+#define s7_make_object s7_make_c_object
+#define s7_mark_object s7_mark
+#define s7_UNSPECIFIED(Sc) s7_unspecified(Sc)
+#define s7_NIL(Sc) s7_nil(Sc)
#define s7_new_type(Name, Print, GC_Free, Equal, Mark, Ref, Set) s7_new_type_1(s7, Name, Print, GC_Free, Equal, Mark, Ref, Set)
-#define s7_gc_stats(Sc, On) s7_set_gc_stats(Sc, On)
+#define s7_gc_stats(Sc, On) s7_set_gc_stats(Sc, On)
void s7_gc_unprotect(s7_scheme *sc, s7_pointer x);
#endif
@@ -863,6 +863,8 @@ void s7_gc_unprotect(s7_scheme *sc, s7_pointer x);
*
* s7 changes
*
+ * 2-Nov: s7_repl.
+ * 30-Oct: change S7_DATE format, and start updating it to reflect s7.c.
* 30-Jul: define-expansion*.
* 12-Jul: s7_call_with_catch, s7_load now returns NULL if file not found (rather than raise an error).
* 8-July: most-positive-fixnum and most-negative-fixnum moved to *s7*.
diff --git a/s7.html b/s7.html
index 5c2481b..080047d 100644
--- a/s7.html
+++ b/s7.html
@@ -151,7 +151,7 @@ s7.h, that want only to disappear into someone else's source tree. There are no
no run-time init files, and no configuration scripts.
It can be built as a stand-alone
interpreter (see <a href="#repl">below</a>). s7test.scm is a regression test for s7.
-A tarball is available: <a href="ftp://ccrma-ftp.stanford.edu/pub/Lisp/s7.tar.gz">s7 tarball</a>.
+A tarball is available: <a href="https://ccrma.stanford.edu/software/s7/s7.tar.gz">s7 tarball</a>.
</p>
<p>
@@ -310,6 +310,9 @@ Its argument is a string representing the desired number:
<em class="gray">1.12312312312312312312312312300000000009E0</em>
</pre>
+<p>Currently the gmp code is not completely integrated into s7's optimizer, so the gmp version
+of s7 is much slower than the ordinary version. I hope to fix this someday...
+</p>
<blockquote>
<div class="indented">
@@ -1237,7 +1240,7 @@ One long-winded way in s7 uses <a href="#unlet">unlet</a>:
<em class="gray">5</em>
</pre>
-<p>But this is hard to read, and it's not inconceivable that we might want all three
+<p>But this is hard to read, and we might want all three
values of a symbol, the start-up value, the definition-time value, and the
current value. The latter can be accessed with the bare symbol, the definition-time
value with unquote (','), and the start-up value with either unlet
@@ -1263,9 +1266,10 @@ or #_&lt;name&gt;. That is, #_+ is a reader macro for <code>(with-let (unlet) +
<em class="gray">"hiho"</em>
</pre>
-<p>#_&lt;name&gt; could be implemented via *#readers*:
+<blockquote>
+<div class="indented">
+<p>Conceptually, #_&lt;name&gt; could be implemented via *#readers*:
</p>
-
<pre class="indented">
(set! *#readers*
(cons (cons #\_ (lambda (str)
@@ -1273,6 +1277,19 @@ or #_&lt;name&gt;. That is, #_+ is a reader macro for <code>(with-let (unlet) +
(string-&gt;symbol (substring str 1)))))
*#readers*))
</pre>
+<p>but #\_ can't be set by *#readers*; otherwise someone could:
+</p>
+<pre class="indented">
+(set! *#readers* (list (cons #\_ (lambda (str) (string-&gt;symbol (substring str 1))))))
+</pre>
+<p>and now #_ provides no protection:
+</p>
+<pre>
+&gt; (let ((+ -)) (#_+ 1 2))
+<em class="gray">-1</em>
+</pre>
+</div>
+</blockquote>
<p>
So, now we have only the variable capture problem ('a' has been captured in the preceding examples).
@@ -1298,7 +1315,9 @@ national debt. gensym is the standard approach:
<em class="gray">13</em>
</pre>
-<p>But in s7, the simplest approach uses environments. You have complete
+<p>I think syntax-rules and its friends try to conjure up gensyms automatically, but
+the real problem is not name collisions, but unspecified environments.
+In s7 we have first-class environments, so you have complete
control over the environment at any point:
</p>
@@ -1398,6 +1417,61 @@ to be evaluated in its definition environment:
(mac-1 1))))
</pre>
+<blockquote>
+<div class="indented">
+<p>Here are some variations on "unless", inspired by the wikipedia hygienic macro page:
+</p>
+<pre>
+(define-macro (my-unless condition . body)
+ `(with-let (inlet (unlet) :condition ,condition) ; here unlet protects body (format below)
+ (if (not condition) (begin ,@body))))
+
+(let ((not (lambda (x) x))
+ (begin 32)
+ (if +)
+ (format abs))
+ (my-unless #t (format #t "This should not be printed!\n"))
+ (my-unless #f (format #t "This should be printed!\n")))
+
+(set! format abs)
+(let ((not (lambda (x) x)))
+ (my-unless #t (format #t "This should not be printed!\n"))
+ (my-unless #f (format #t "This should be printed!\n")))
+
+(define (user-defined-operator x) (not x))
+
+(define-macro (my-unless-1 condition . body)
+ `(with-let (inlet (unlet) :condition ,condition)
+ (if (user-defined-operator condition) (begin ,@body))))
+
+(let ((user-defined-operator (lambda (x) x)))
+ (my-unless-1 #t (format #t "This should not be printed!\n"))
+ (my-unless-1 #f (format #t "This should be printed!\n")))
+
+(define my-unless-2
+ (let ((op1 (lambda (x) (not x))))
+ (define-macro (_ condition . body)
+ `(with-let (inlet (unlet) (funclet my-unless-2) :condition ,condition)
+ ;; funclet above to get my-unless-2's version of op1
+ (if (op1 condition) (begin ,@body))))))
+
+(let ((op1 (lambda (x) x)))
+ (my-unless-2 #t (format #t "This should not be printed!\n"))
+ (my-unless-2 #f (format #t "This should be printed!\n")))
+
+(define my-unless-3
+ (let ((op1 (lambda (x) x)))
+ (define-macro (_ condition . body)
+ `(with-let (inlet (unlet) :condition ,condition :local-env (curlet))
+ ;; curlet to get run-time local version of op1
+ (if ((with-let local-env op1) condition) (begin ,@body))))))
+
+(let ((op1 (lambda (x) (not x))))
+ (my-unless-3 #t (format #t "This should not be printed!\n"))
+ (my-unless-3 #f (format #t "This should be printed!\n")))
+</pre>
+</div>
+</blockquote>
<!--
(define (tree-quote tree args)
@@ -1416,7 +1490,7 @@ to be evaluated in its definition environment:
`(define-macro ,name-and-args
(list 'with-let
(list 'inlet ,@(map (lambda (arg)
- (values (symbol->keyword arg) arg))
+ (values (symbol-&gt;keyword arg) arg))
args))
,@(tree-quote body args)))))
@@ -1427,6 +1501,47 @@ to be evaluated in its definition environment:
; (lambda (a b) (list 'with-let (list 'inlet :a a :b b) (list-values '+ 'a 'b)))
-->
+<blockquote>
+<div class="indented">
+<p>On the subject of *#readers*, say we have:
+</p>
+<pre>
+(set! *#readers* (list (cons #\o (lambda (str) 42)) ; #o... -&gt; 42
+ (cons #\x (lambda (str) 3)))) ; #x... -&gt; 3
+</pre>
+<p>Now we load a file with:
+</p>
+<pre>
+(define (oct) #o123)
+
+(let-temporarily ((*#readers* ()))
+ (eval (with-input-from-string "(define (hex) #x123)" read)))
+
+(define-constant old-readers *#readers*)
+(set! *#readers* ())
+
+(define (oct1) #o123)
+(define (hex1) #x123)
+
+(set! *#readers* old-readers)
+
+(define (oct2) #o123)
+(define (hex2) #x123)
+</pre>
+<p>Now we evaluate these functions, and get:
+</p>
+<pre>
+(oct): 42 ; oct is not read-time hygienic so #o123 -&gt; 42
+(oct1): 83 ; oct1 is protected by the top-level set, #o123 -&gt; 83
+(oct2): 42 ; same as oct
+(hex): 291 ; hex is protected by let-temporarily + read
+(hex1): 291 ; hex1 is like oct1
+(hex2): 3 ; hex2 is like oct
+</pre>
+
+</div>
+</blockquote>
+
<blockquote>
<div class="indented">
@@ -2510,7 +2625,7 @@ Environments are first class (and applicable) objects in s7.
(<em class=def id="unlet">unlet</em>) a let with any built-in functions that do not have their original value
(<em class=def id="letref">let-ref</em> env sym) get value of sym in env, same as (env sym)
-(<em class=def id="letset">let-set!</em> env sym val) set value of sym in val to val, same as (set! (env sym) val)
+(<em class=def id="letset">let-set!</em> env sym val) set value of sym in env to val, same as (set! (env sym) val)
(<em class=def id="inlet">inlet</em> . bindings) make a new environment with the given bindings
(<em class=def id="sublet">sublet</em> env . bindings) same as inlet, but the new environment is local to env
@@ -2759,7 +2874,7 @@ that those values can be clobbered).
</p>
<p>
-<code>(fill! lt &lt;undefined&gt;)</code> removes all bindings from the let lt.
+<code>(fill! lt #&lt;undefined&gt;)</code> removes all bindings from the let lt.
</p>
<blockquote>
@@ -4078,9 +4193,8 @@ form containing #&lt;eof&gt;, just as with any other constant. If it hits the e
the input while reading a form, it raises an error (e.g. "missing close paren").
If it encounters
#&lt;eof&gt; all by itself at the top level (this never happens),
-it returns that #&lt;eof&gt;. Consider it a feature! If you want a top level
-#&lt;eof&gt; without stopping read, either quote it, or <code>(define *eof* #&lt;eof&gt;)</code> and use *eof* in the
-source: read will return the symbol *eof*. Built-in #&lt;eof&gt; has lots of
+it returns that #&lt;eof&gt;.
+Built-in #&lt;eof&gt; has lots of
uses, and as far as I can see, no drawbacks. For example,
it is very common to call
read (or one of its friends) in a loop which first checks for #&lt;eof&gt;, then falls into
@@ -5595,8 +5709,8 @@ provided? should be feature? or *features* should be *provisions*.
list-ref, list-set!, and list-tail actually only apply to pairs.
let-temporarily should be templet, or maybe set-temporarily.
Finally, the CL-inspired "log*" names such as logand look very old-fashioned. Standard scheme opts
-for the name "bitwise*"; why not "integerwise" or "bytevectorwise"? The "wise" business is just noise.
-Perhaps <code>(define & logand) (define | logior) (define ~ lognot)</code> and so on, but ^ for logxor
+for the name "bitwise*"; why not "integerwise" or "bytevectorwise"? The "wise" business is just noise; are they thinking of "The Hobbit"?
+<code>(define & logand) (define | logior) (define ~ lognot)</code>, but ^ for logxor
(as in C) is not ideal; ^ should be expt.
</p>
@@ -5654,7 +5768,7 @@ Better ideas are always welcome!
<li>pi
<li>*stdin* *stdout* *stderr*
<li>*s7*
-<li>nan.0 +nan.0 -nan.0 inf.0 +inf.0 -inf.0 (what crappy names! nan.0 is an inexact integer that is not a number?)
+<li>+nan.0 -nan.0 +inf.0 -inf.0 (what crappy names! +nan.0 is an inexact integer that is not a number?)
<li>*unbound-variable-hook* *missing-close-paren-hook* *load-hook* *error-hook* *read-error-hook* *rootlet-redefinition-hook*
</ul>
@@ -6148,14 +6262,14 @@ so misleading that I feel guilty about it):
(for-each do-loop (list 1000 1000000 10000000))
</pre>
-<p>In s7, that takes 0.1 seconds on my home machine. In tinyScheme, from
+<p>In s7, that takes 0.09 seconds on my home machine. In tinyScheme, from
whence we sprang, it takes 85 seconds. In the chicken interpreter, 5.3
seconds, and after compilation (using -O2) of the chicken compiler output,
0.75 seconds. So, s7 is comparable to chicken in speed, even though chicken
is compiling to C. I think Guile 2.0.9 takes about 1 second.
The equivalent in CL:
clisp interpreted 9.3 seconds, compiled 0.85 seconds; sbcl 0.21 seconds.
-Similarly, s7 computes (fib 40) in 1.5 seconds, approximately the same as sbcl.
+Similarly, s7 computes (fib 40) in 0.8 seconds, approximately the same as sbcl.
Guile 2.2.3 takes 7 seconds.
</p>
@@ -6221,7 +6335,7 @@ Here are the diffs for the bench script:
<p>
I call the standalone version of s7 "repl", so its path
is /home/bil/motif-snd/repl. To build repl, get s7.tar.gz
-from ftp://ccrma-ftp.stanford.edu/pub/Lisp/s7.tar.gz,
+from https://ccrma.stanford.edu/software/s7/s7.tar.gz,
add the empty file mus-config.h to the tarball's contents,
then (in Linux):
</p>
diff --git a/s7test.scm b/s7test.scm
index 71243e9..7d8e1e5 100644
--- a/s7test.scm
+++ b/s7test.scm
@@ -3679,6 +3679,11 @@ void block_init(s7_scheme *sc)
;;; move these!
(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (quotient i 3)))) (num-test (fc) (quotient 9 3)))
+(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash 3 3)))) (num-test (fc) (ash 3 3)))
+(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash 3 i)))) (num-test (fc) (ash 3 9)))
+(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash 3 (+ i 1))))) (num-test (fc) (ash 3 10)))
+(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash i (+ i 1))))) (num-test (fc) (ash 9 10)))
+(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (ash (+ i 1) (- i 1))))) (num-test (fc) (ash 10 8)))
(let () (define (fc) (do ((count 0) (j 3) (i 0 (+ i 1))) ((= i 10) count) (set! count (quotient i j)))) (num-test (fc) (quotient 9 3)))
(let () (define (fc) (do ((count 0.0) (i 0.0 (+ i 1.0))) ((>= i 10.0) count) (set! count (quotient i 3.0)))) (num-test (fc) (quotient 9.0 3.0)))
(let () (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 10) count) (set! count (remainder i 3)))) (test (fc) (remainder 9 3)))
@@ -3869,6 +3874,209 @@ void block_init(s7_scheme *sc)
(let ((str #u(1 2 3))) (define (fc) (do ((count 0) (i 0 (+ i 1))) ((= i 1) count) (set! count (byte-vector-ref str i)))) (test (fc) 1)) ; byte_vector_ref_i
(let ((str #u(1 2 3))) (define (fc) (do ((i 0 (+ i 1))) ((= i 1) (str 0)) (byte-vector-set! str i 4))) (test (fc) 4)) ; byte_vector_set_i
+(let () (define (f1) (let ((dfn #f)) (do ((count 0) (i 0 (+ i 1))) ((= i 1) dfn) (if (logbit? i count) (set! dfn #t))))) (test (f1) #f)) ; opt_b_ii_ss
+(let () (define (f2) (let ((dfn #f)) (do ((i 0 (+ i 1))) ((= i 1) dfn) (if (logbit? i 0) (set! dfn #t))))) (test (f2) #f)) ; opt_b_ii_sc_bit
+(let () (define (f3) (let ((dfn #f)) (do ((count 0.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (> i count) (set! dfn #t))))) (test (f3) #f)) ; opt_b_dd_ss_gt
+(let () (define (f4) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (< i count) (set! dfn #t))))) (test (f4) #t)) ; opt_b_dd_ss_lt
+(let () (define (f5) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (< i 1.0) (set! dfn #t))))) (test (f5) #t)) ; opt_b_dd_sc_lt
+(let () (define (f6) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (>= i 0.0) (set! dfn #t))))) (test (f6) #t)) ; opt_b_dd_sc_geq
+(let () (define (f7) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((= i 1.0) dfn) (if (<= i 1.0) (set! dfn #t))))) (test (f7) #t)) ; opt_b_dd_sc
+(let () (define (f8) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((>= i 1.0) dfn) (if (= i 1.0) (set! dfn #t))))) (test (f8) #f)) ; opt_b_dd_sc_eq
+(let () (define (f9) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((>= i 1.0) dfn) (if (= i (+ count 1.0)) (set! dfn #t))))) (test (f9) #f)) ; opt_b_dd_sf
+(let () (define (f10) (let ((dfn #f)) (do ((count 1.0) (i 0.0 (+ i 1.0))) ((>= i 1.0) dfn) (if (= (+ i 1.0) (+ count 1.0)) (set! dfn #t))))) (test (f10) #f)) ; opt_b_dd_ff
+(let () (define (f11) (do ((x 1.0) (i 0 (+ i 1))) ((= i 1)) (if (negative? (+ x 1.0)) (* x 2) (- x 3)))) (test (f11) #t)) ; opt_b_d_f
+(let () (define (f12) (let ((dfn #\c)) (do ((i 0 (+ i 1))) ((= i 1) dfn) (if (char=? dfn #\a) (set! dfn #\b))))) (test (f12) #\c)) ; opt_b_7pp_sc
+(let () (define (f13) (let ((dfn #\c)) (do ((i 0 (+ i 1))) ((= i 1) dfn) (if (eq? dfn #\a) (set! dfn #\b))))) (test (f13) #\c)) ; opt_b_pp_sc
+
+(define _gfx_ 3)
+(define _vfx_ (vector (vector 0)))
+(define _vfxi_ (vector 0))
+(let () ; fx_* coverage
+ (define (f1 x) (and (pair? (cddr x)) (symbol? (cadr x))))
+ (test (f1 (list 1 2 3)) #f)
+ (test (f1 (list 1 'a 3)) #t)
+ (test (f1 (list 1 'a)) #f)
+
+ (define (f2 x) (and (not (null? x)) (pair? (car x))))
+ (test (f2 (list 1 2)) #f)
+ (test (f2 (list (list 1) 2)) #t)
+ (test (f2 (list)) #f)
+
+ (define (f3 x y) (or (< x y) (<= x y)))
+ (test (f3 3 2) #f)
+ (test (f3 3 3) #t)
+ (test (f3 1 2) #t)
+
+ (define (f4 x y) (or (>= x y) (> x _gfx_)))
+ (test (f4 4 5) #t)
+ (test (f4 3 3) #t)
+ (test (f4 2 3) #f)
+
+ (define (f5 fv z) (let ((x (vector-ref fv 0))) (when (< x z) (vector-set! fv 0 (+ x 1)) (f5 fv z))))
+ (test (f5 (vector 0) 2) #<unspecified>)
+
+ (define (f6 fv z) (let ((x (length fv))) (when (eqv? x z) (f6 (cons x fv) z))))
+ (test (f6 (list 0) 2) #<unspecified>)
+
+ (define (f7 x y) (let ((z x)) (if (zero? z) (f7 (- x 1) (cons z y)))))
+ (test (f7 2 ()) #<unspecified>)
+
+ (define (f8 x y z) (or (proper-list? z) (hash-table? x) (integer? z)))
+ (test (f8 0 0 (list 1)) #t)
+ (test (f8 0 0 1) #t)
+ (test (f8 0 0 (vector 1)) #f)
+
+ (define (f9 x y) (or (vector? x) (not x) (vector? y)))
+ (test (f9 #f 0) #t)
+ (test (f9 #(0) 0) #t)
+ (test (f9 () ()) #f)
+
+ (define (f10 x) (or (= x _gfx_) (eqv? x _gfx_)))
+ (test (f10 1) #f)
+ (test (f10 _gfx_) #t)
+
+ (define (f11 x y z) (or (not (eq? (car z) 'a)) (null? (cddr z)) (eqv? x y)))
+ (test (f11 1 2 (list 1 2)) #t)
+ (test (f11 1 1 (list 'a 2)) #t)
+
+ (define (f12 x y) (if (not (> y x)) (not (eqv? y x))))
+ (test (f12 1 2) #<unspecified>)
+ (test (f12 1 1) #f)
+
+ (define (f13 x y q r) (if (zero? (- (* q r) (* r q))) 32 12) (if (< (- q r) (- r q)) 32 12))
+ (test (f13 1 2 3 4) 32)
+
+ (define (f14 x y) (let ((z (+ x y))) (cond ((= z 0) pi) ((< z 0) 'oops) (else (f14 (- x 1) (- y 1))))))
+ (test (f14 1 2) 'oops)
+
+ (define (f15 lst) (let loop ((p lst) (sum 0)) (if (null? p) sum (loop (cdr p) (+ sum (car p))))))
+ (test (f15 (list 0 1 2)) 3)
+
+ (define (f16 x y z) (+ (* 3.0 x) (- 3.0 x) (- z 3.0)))
+ (test (f16 3 4 5) 11.0)
+
+ (define (f17 x y z) (let ((v (vector 'a))) (if (eq? z (vector-ref v x)) 0 1)))
+ (test (f17 0 0 'a) 0)
+
+ (define (f18 x y z) (let ((v (vector 0))) (if (>= z (vector-ref v x)) 0 1)))
+ (test (f18 0 0 0) 0)
+
+ (define (f19 x y z) (let ((v (vector 0))) (if (> (vector-ref v x) z) 0 1)))
+ (test (f19 0 0 0) 1)
+
+ (define (f20 x y z) (let ((v (vector 0))) (+ (* z (vector-ref v x)) (- z (vector-ref v y)))))
+ (test (f20 0 0 0) 0)
+
+ (define (f21 x y z) (let ((v (vector 0))) (if (> (+ z (vector-ref v x)) 1) 0 1)))
+ (test (f21 0 0 0) 1)
+
+ (define (len=2? x) (and (pair? x) (pair? (cdr x)) (null? (cddr x))))
+ (define (f22 x) (and (list? x) (len=2? x)))
+ (test (f22 (list 1 2)) #t)
+
+ (define (len>2? x) (and (pair? x) (pair? (cdr x)) (pair? (cddr x))))
+ (define (f23 x) (and (list? x) (len>2? x)))
+ (test (f23 (list 1 2 3)) #t)
+
+ (define (f24 x) (let ((h (hash-table))) (hash-table-set! h x (+ (or (hash-table-ref h x) 0) 1))))
+ (test (f24 'a) 1)
+
+ (define (f25 x) (if (or (not (symbol? x)) (keyword? x)) 1 0))
+ (test (f25 'a) 0)
+ (test (f25 :a) 1)
+ (test (f25 #f) 1)
+
+ (define (f26 x) (if (> (+ _gfx_ (* x 2) 32) 0) 1 0))
+ (test (f26 3) 1)
+
+ (define (f27 x) (let ((y 3)) (if (zero? (remainder x y)) 0 1)))
+ (test (f27 4) 1)
+ (test (f27 6) 0)
+
+ (define (f28 x y) (if (= (remainder (car y) x) 0) 0 (f28 (- x 1) y)))
+ (test (f28 2 '(3)) 0)
+ (test (f28 3 '(3)) 0)
+
+ (define (f29) (let ((v (vector 1 2)) (i 0) (j 1)) (if (zero? (- (vector-ref v i) (vector-ref v j))) 0 1)))
+ (test (f29) 1)
+
+ (define (f30 x) (if (eq? (string-ref (symbol->string (car x)) 0) #\a) 0 1))
+ (test (f30 '(abc)) 0)
+ (test (f30 '(bcd)) 1)
+
+ (define (f31 x) (do ((y 3 (+ y 1))) ((or (zero? x) (>= y x)) 0)))
+ (test (f31 4) 0)
+ (test (f31 0) 0)
+
+ (define (f32 x y z) (if (vector-ref x (+ y z)) 1 0))
+ (test (f32 (vector #f #t) 1 0) 1)
+
+ (define (f33 x y) (if (string? (number->string (+ 1 (car x) (car x)) y)) 1 0))
+ (test (f33 '(0) 10) 1)
+
+ (define (f34 x y q r) (eqv? (vector-ref (vector-ref q r) y) 0))
+ (test (f34 0 0 (vector (vector 1)) 0) #f)
+ (test (f34 0 0 (vector (vector 0)) 0) #t)
+
+ (define (f35 x y q r) (eqv? (vector-ref (vector-ref x y) q) 0))
+ (test (f35 (vector (vector 1)) 0 0 0) #f)
+ (test (f35 (vector (vector 0)) 0 0 0) #t)
+
+ (define (f36 x y) (eqv? (vector-ref (vector-ref _vfx_ y) x) 0))
+ (test (f36 0 0) #t)
+ (test (f36 0 1) 'error)
+
+ (define (f37 x) (eqv? (vector-ref _vfx_ (vector-ref _vfxi_ x)) 0))
+ (test (f37 0) #f)
+
+ (define (f38 x y) (eqv? (+ (* x x) (* y y)) 1))
+ (test (f38 1 2) #f)
+ (test (f38 1 0) #t)
+
+ (define (f39 x y z) (eqv? (vector-ref (vector-ref x y) z) 0))
+ (test (f39 (vector (vector 0)) 0 0) #t)
+ (test (f39 (vector (vector 1)) 0 0) #f)
+
+ (define (f40 items sequence)
+ (cond ((not (pair? sequence)) sequence) ((memq (car sequence) items) (f40 items (cdr sequence))) (else (cons (car sequence) (f40 items (cdr sequence))))))
+ (test (f40 '(a b c) '(a d f e b c)) '(d f e))
+
+ (define (f41 row dist placed) (or (null? placed) (and (not (= (car placed) (+ row dist))) (not (= (car placed) (- row dist))) (f41 row (+ dist 1) (cdr placed)))))
+ (test (f41 0 0 '(0 1 2)) #f)
+ (test (f41 0 1 '(0 1 2)) #t)
+
+ (define (f42 v i j y)
+ (if (and (or (> (vector-ref v i) y)
+ (>= y (vector-ref v j)))
+ (or (> (vector-ref v j) y)
+ (>= y (vector-ref v i))))
+ 0 1))
+ (test (f42 (vector 1 2 3 4) 1 2 3) 0)
+ (test (f42 (vector 1 2 3 4) 1 2 2) 1)
+
+ (define-constant (f43 x)
+ (and (pair? x) (pair? (cdr x))))
+ (define (g)
+ (let ((x (list 1 2)))
+ (if (f43 x) 0 1)))
+ (test (g) 0)
+
+ (define (f44 fv z)
+ (let ((x (vector-ref fv 0)))
+ (when (< x 30)
+ (vector-set! fv 0 z)
+ (f44 fv (+ z 1)))))
+ (test (f44 (vector 0) 0) #<unspecified>)
+
+ (define (f45 x y z q)
+ (zero? (* x (hash-table-ref y (vector-ref z q)))))
+ (test (f45 2.0 (hash-table 'a 3.0) (vector 'a) 0) #f)
+
+ (define (f46 x y z)
+ (zero? (- (string->number (vector-ref x y)) z)))
+ (test (f46 (vector "3.0") 0 1.0) #f)
+)
+
;;; --------------------------------------------------------------------------------
;;; type-of
@@ -10064,6 +10272,8 @@ i" (lambda (p) (eval (read p)))) pi)
(test (append (string->byte-vector "asdasd") '("asd")) 'error)
(test (append (string->byte-vector "asdasd") #("asd")) 'error)
+(test (append (inlet) (hash-table :readable 123)) 'error)
+
(test (let ((h1 (hash-table 'a 1 'b 2)) (h2 (hash-table 'c 3))) (append h1 h2)) (hash-table 'c 3 'a 1 'b 2))
(test (let ((i1 (inlet 'a 1)) (i2 (inlet 'b 2 'c 3))) (append i1 i2)) (inlet 'a 1 'c 3 'b 2))
(test (let ((s1 "abc") (s2 "def")) (append s1 s2)) "abcdef")
@@ -11258,6 +11468,12 @@ i" (lambda (p) (eval (read p)))) pi)
(set! sum (+ sum (iv (- (+ i 1) 1) (+ i 1)))))))
(test (g) 2))
+(let ((iv (make-int-vector (list 2 3) 1)) ; optimizer bug
+ (c 3))
+ (define (f1) (let ((v (vector #f))) (do ((i 0 (+ i 1))) ((= i 1) (vector-ref v 0)) (vector-set! v 0 (int-vector-set! iv 0 0 c)))))
+ (define (f2) (let ((v (vector #f))) (do ((i 0 (+ i 1))) ((= i 1) (vector-ref v 0)) (vector-set! v 0 (int-vector-set! iv 0 0 3)))))
+ (test (f1) 3)
+ (test (f2) 3))
;;; --------------------------------------------------------------------------------
@@ -20428,6 +20644,11 @@ a2" 3) "132")
(test (equal? '`#() ''#()) #f) ; it equals #() -- this is consistent -- see below
(test (equal? '`#() ``#()) #t)
+(test (catch #t (lambda () (with-input-from-string "#0d()" read)) (lambda (type info) (apply format #f info)))
+ "#nD(...) dimensions argument 1, 0, is out of range (must be 1 or more)")
+(test (catch #t (lambda () (with-input-from-string "#1230d()" read)) (lambda (type info) (apply format #f info)))
+ "reading #1230...: 1230 is too large, (*s7* 'max-vector-dimensions): 512")
+
(test (equal? '() '()) #t)
(test (equal? (quote ()) '()) #t)
(test (equal? '() (quote ())) #t)
@@ -21449,7 +21670,8 @@ c"
(test (object->string (inlet 'a (let ((b 1)) (lambda () (+ b c)))) :readable) "(inlet :a (let ((b 1)) (lambda () (+ b c))))")
(test (object->string (inlet 'a (let ((b 1)) (lambda () (+ b pi)))) :readable) "(inlet :a (let ((b 1)) (lambda () (+ b pi))))")
(test (object->string (let* ((a 1) (b a)) (curlet)) :readable)
- "(sublet (sublet (sublet (inlet :ok #t)) :a 1) :b 1)")
+ ;; "(sublet (sublet (sublet (inlet :ok #t)) :a 1) :b 1)"
+ "(sublet (sublet (inlet :ok #t)) :a 1 :b 1)") ; depends on op_let_star1
(test (object->string (let ((a 1)) (define (b c) (+ c a)) (curlet)) :readable)
"(sublet (sublet (inlet :ok #t)) :a 1 :b (let ((a 1)) (lambda (c) (+ c a))))")))
@@ -25233,6 +25455,10 @@ in s7:
(define (dot) (do ((i 0 (+ i 1)) (j 3)) ((or (< i 0) (end i)))))
(dot)
(test y 3))
+(let ()
+ (define (f1) (eval '(do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i))))
+ (define (g) (catch #t f1 (lambda args #f)))
+ (test (g) 2))
(test (let ((lst '(1 2 3))
(v (vector 0 0 0)))
@@ -25681,7 +25907,179 @@ in s7:
(k 0 (+ k 1)))
((= k 8) (set! sum (+ sum lsum)))
(set! lsum (+ lsum k)))))
- (test (h4) 140))
+ (test (h4) 140)
+
+ (define (f1)
+ (let ((sum #i(0)))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) sum)
+ (case (remainder i 3)
+ ((0) (int-vector-set! sum 0 (+ (int-vector-ref sum 0) 1)))
+ ((1) (int-vector-set! sum 0 (+ (int-vector-ref sum 0) 2)))
+ (else (int-vector-set! sum 0 (+ (int-vector-ref sum 0) 3)))))))
+ (test (f1) #i(19))
+
+ (define (f2)
+ (let ((sum 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) sum)
+ (case (remainder i 3)
+ ((0) (set! sum (+ sum 1)))
+ ((1) (set! sum (+ sum 2)))
+ (else (set! sum (+ sum 3))))))) ; 19
+ (test (f2) 19)
+
+ (define (f3)
+ (let ((sum 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) sum)
+ (case (remainder i 3)
+ ((0) (set! sum (+ sum 2)) (set! sum (- sum 1)))
+ ((1) (set! sum (+ sum 2)))
+ (else (set! sum (+ sum 3))))))) ; 19
+ (test (f3) 19)
+
+ (define (f4)
+ (let ((sum 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) sum)
+ (case (remainder i 3)
+ ((0) (set! sum (+ sum 1)))
+ ((1) (set! sum (+ sum 2)))
+ ((3) (set! sum (+ sum 3))))))) ; 10
+ (test (f4) 10)
+
+ (define (f41)
+ (let ((sum 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) sum)
+ (case (remainder i 3)
+ ((0) (set! sum (+ sum 1)))
+ ((1) (set! sum (+ sum 2)))
+ ((2) (set! sum (+ sum 3))))))) ; 19
+ (test (f41) 19)
+
+ (define (f5)
+ (let ((res 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) res)
+ (case i
+ ((0 1 2 3 4 5 6) (set! res 1))
+ ((7 8 9) (set! res 123)))))) ; 123
+ (test (f5) 123)
+
+ (define (f6)
+ (let ((res 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) res)
+ (set! res (case i
+ ((0 1 2 3 4 5 6) 1)
+ ((7 8 9) 2)))))) ; 2
+ (test (f6) 2)
+
+ (define (f7)
+ (let ((res 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) res)
+ (set! res (case i
+ ((0 1 2 3 4 5 6) 1)
+ ((7 8) 2)))))) ; #<unspecified>
+ (test (f7) #<unspecified>)
+
+ (define (f8)
+ (let ((res 0))
+ (do ((i 0 (+ i 1)))
+ ((= i 10) res)
+ (set! res (+ (case i
+ ((0 1 2 3 4 5 6) 1)
+ (else 2))
+ 123))))) ; 125
+ (test (f8) 125)
+
+ (let () ; opt_cond_1
+ (define (cd1)
+ (let ((v (make-vector 6 #f)))
+ (do ((i 0 (+ i 1)))
+ ((= i 6) v)
+ (vector-set! v i (cond ((< i 3) (+ i 10)))))))
+ (test (cd1) #(10 11 12 #<unspecified> #<unspecified> #<unspecified>))
+
+ (define (cd2 x) ; opt_cond_2
+ (let ((y 0)
+ (z 1.0))
+ (do ((i 0 (+ i 1)))
+ ((= i 3) y)
+ (cond ((= x z)
+ (set! y (+ y 1)))
+ (else 3)))))
+ (test (cd2 1.0) 3)
+ (test (cd2 0.0) 0)
+
+ (define (cd3) ; opt_cond
+ (let ((v (make-vector 6 #f)))
+ (do ((i 0 (+ i 1)))
+ ((= i 6) v)
+ (vector-set! v i (cond ((< i 3)
+ (+ i 10))
+ ((>= i 3)
+ (- i 10)))))))
+ (test (cd3) #(10 11 12 -7 -6 -5))
+
+ (define (cd4) ; opt_cond
+ (let ((v (make-vector 6 #f)))
+ (do ((i 0 (+ i 1)))
+ ((= i 6) v)
+ (vector-set! v i (cond ((< i 2)
+ (+ i 10))
+ ((= i 2)
+ 123)
+ ((> i 3)
+ (- i 10)))))))
+ (test (cd4) #(10 11 123 #<unspecified> -6 -5)))
+
+ (define (do1)
+ (let ((v (make-int-vector 10)))
+ (do ((k 0 (+ k 1)))
+ ((= k 1)
+ (int-vector-ref v 0))
+ (do ((i 0 (+ i 1))
+ (j 0 (+ j 2)))
+ ((= i 10)
+ (set! j (* j 2))
+ (int-vector-set! v 0 (+ i j)))
+ (int-vector-set! v 1 1)
+ (int-vector-set! v 0 0)))))
+ (test (do1) 50)
+
+ (define (do2)
+ (let ((v (make-int-vector 10)))
+ (do ((k 0 (+ k 1)))
+ ((= k 1)
+ (int-vector-ref v 0))
+ (do ((i 0 (+ i 1))
+ (j 0 (+ j 2))
+ (z 32))
+ ((= i 10)
+ (set! j (* j 2))
+ (int-vector-set! v 0 (+ i j z)))
+ (int-vector-set! v 1 1)
+ (int-vector-set! v 0 0)))))
+ (test (do2) 82)
+
+ (define (do3)
+ (let ((v (make-int-vector 10)))
+ (do ((k 0 (+ k 1)))
+ ((= k 1)
+ (int-vector-ref v 0))
+ (do ((i 0 (+ i 1))
+ (z 32)
+ (j 0 (+ j 2)))
+ ((= i 10)
+ (set! j (* j 2))
+ (int-vector-set! v 0 (+ i j z)))
+ (int-vector-set! v 1 1)
+ (int-vector-set! v 0 0)))))
+ (test (do3) 82))
(let () (define (fdo5) (do ((si () '())) ((null? si) 'mi))) (test (fdo5) 'mi))
(let () (define (fdo5) (do ((si '() '())) ((null? si) 'mi))) (test (fdo5) 'mi))
@@ -27534,6 +27932,18 @@ in s7:
(define (fx-tc-if-a-laa-z x y) (if (> x 0) (fx-tc-if-a-laa-z (- x 1) (+ y 1)) y))
(test (let ((z 10)) (define (ftc-2 x) (+ x (fx-tc-if-a-laa-z 10 0))) (ftc-2 z)) 20)
+ ;; -------- OP_TC_IF_A_Z_L3A --------
+ (define (tc-if-a-z-l3a-1 x y z) (if (null? x) (begin (vector-set! y 0 (+ z 32)) y) (tc-if-a-z-l3a-1 (cdr x) y (+ z 1))))
+ (test (tc-if-a-z-l3a-1 '(1 2 3) #(1 2 3) 1) #(36 2 3))
+
+ ;; -------- OP_TC_IF_A_L3A_Z --------
+ (define (tc-if-a-l3a-z-1 x y z) (if (pair? x) (tc-if-a-l3a-z-1 (cdr x) y (+ z 1)) (begin (vector-set! y 0 (+ z 32)) y)))
+ (test (tc-if-a-l3a-z-1 '(1 2 3) #(1 2 3) 1) #(36 2 3))
+
+ ;; -------- OP_TC_IF_A_Z_IF_A_L3A_L3A --------
+ (define (l3a x y z) (if (> x y) z (if (< y z) (l3a x y (- z 1)) (l3a x (- y 1) z))))
+ (test (l3a 0 10 10) 0)
+
;; -------- OP_TC_IF_A_Z_LA --------
(define (tc-if-a-z-la-1 x) (if (zero? x) 3 (tc-if-a-z-la-1 (- x 1))))
(test (tc-if-a-z-la-1 10) 3)
@@ -27586,6 +27996,26 @@ in s7:
(define (tc-if-a-z-if-a-z-la-6 x) (if (zero? (modulo x 7)) (- x 7) (if (negative? (modulo x 5)) (* x 2) (tc-if-a-z-if-a-z-la-6 (+ x 1)))))
(test (tc-if-a-z-if-a-z-la-6 22) 21)
+ ;; -------- OP_TC_COND_A_Z_A_Z_LA --------
+ (define (tc-cond-a-z-a-z-la-1 x) (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-1 (+ x 1)))))
+ (test (tc-cond-a-z-a-z-la-1 22) 25)
+ (test (tc-cond-a-z-a-z-la-1 6) 7)
+
+ (define (tc-cond-a-z-a-z-la-2 x) (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-2))))
+ (test (tc-cond-a-z-a-z-la-2 22) 'error)
+
+ (define (tc-cond-a-z-a-z-la-3 x) (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-3 x x))))
+ (test (tc-cond-a-z-a-z-la-3 22) 'error)
+
+ (define (tc-cond-a-z-a-z-la-4 x) (cond ((zero? (modulo x 7)) (set! x (* 2 x)) x) ((zero? (modulo x 5)) x) (else (tc-cond-a-z-a-z-la-4 (+ x 1)))))
+ (test (tc-cond-a-z-a-z-la-4 6) 14)
+
+ (define (tc-cond-a-z-a-z-la-5 x) (cond ((zero? (modulo x 7)) x) ((zero? (modulo x 5)) (let ((z (* 2 x))) z)) (else (tc-cond-a-z-a-z-la-5 (+ x 1)))))
+ (test (tc-cond-a-z-a-z-la-5 22) 50)
+
+ (define (tc-cond-a-z-a-z-la-6 x) (cond ((zero? (modulo x 7)) (- x 7)) ((negative? (modulo x 5)) (* x 2)) (#t (tc-cond-a-z-a-z-la-6 (+ x 1)))))
+ (test (tc-cond-a-z-a-z-la-6 22) 21)
+
;; -------- OP_TC_IF_A_Z_IF_A_LA_Z --------
(define (tc-if-a-z-if-a-la-z-1 x) (if (zero? (modulo x 7)) x (if (positive? (modulo x 5)) (tc-if-a-z-if-a-la-z-1 (+ x 1)) x)))
(test (tc-if-a-z-if-a-la-z-1 22) 25)
@@ -27672,6 +28102,20 @@ in s7:
(define (tc-and-a-or-a-la-5 x) (and (positive? x) (or (= x 10) (tc-and-a-or-a-la-5 x x))))
(test (tc-and-a-or-a-la-5 9) 'error)
+
+ ;; -------- OP_TC_AND_A_OR_A_A_LA --------
+ (define (tc-and-a-or-a-a-la-1 x) (and (positive? x) (or (= x 10) (= x 9) (tc-and-a-or-a-a-la-1 (+ x 1)))))
+ (test (tc-and-a-or-a-a-la-1 1) #t)
+ (test (tc-and-a-or-a-a-la-1 -1) #f)
+
+ (define (tc-and-a-or-a-a-la-3 x) (and (positive? x) (or (= x 10) (= x 9) (tc-and-a-or-a-a-la-3 (- x 1)))))
+ (test (tc-and-a-or-a-a-la-3 8) #f)
+
+ (define (tc-and-a-or-a-a-la-4 x) (and (positive? x) (or (= x 10) (= x 9) (tc-and-a-or-a-a-la-4))))
+ (test (tc-and-a-or-a-a-la-4 8) 'error)
+
+ (define (tc-and-a-or-a-a-la-5 x) (and (positive? x) (or (= x 10) (= x 9) (tc-and-a-or-a-a-la-5 x x))))
+ (test (tc-and-a-or-a-a-la-5 8) 'error)
;; -------- OP_TC_OR_A_AND_A_LA --------
(define (tc-or-a-and-a-la-1 x) (or (null? x) (and (integer? (car x)) (tc-or-a-and-a-la-1 (cdr x)))))
@@ -27899,6 +28343,21 @@ in s7:
(define (recur-if-a-a-opa-laaq-4 x y) (if (= x 0) (call-with-exit (lambda (cc) y)) (+ 1 (recur-if-a-a-opa-laaq-4 (- x 1) (+ y 1)))))
(test (recur-if-a-a-opa-laaq-4 10 0) 20)
+
+ ;; -------- OP_RECUR_IF_A_A_opA_L3Aq --------
+ (define (recur-if-a-a-opa-l3aq-1 x y z) (if (= x 0) y (+ 1 (recur-if-a-a-opa-l3aq-1 (- x 1) (+ y z) (+ z 1)))))
+ (test (recur-if-a-a-opa-l3aq-1 10 0 0) 55) ; z by 1 = 110/2
+
+ (define (recur-if-a-a-opa-l3aq-2 x y z) (if (= x 0) y (+ 1 (recur-if-a-a-opa-l3aq-2))))
+ (test (recur-if-a-a-opa-l3aq-2 10 0 0) 'error)
+
+ (define (recur-if-a-a-opa-l3aq-3 x y z) (if (= x 0) y (+ 1 (recur-if-a-a-opa-l3aq-3 (- x 1) (+ y 1) 2 1))))
+ (test (recur-if-a-a-opa-l3aq-3 10 0 0) 'error)
+
+ (define (wf3 lst i val) (if (= i 0) (cons val (cdr lst)) (cons (car lst) (wf3 (cdr lst) (- i 1) val))))
+ (test (wf3 (list 1 2 3 4) 3 5) '(1 2 3 5))
+ (test (wf3 (list 1 2 3 4) 2 5) '(1 2 5 4))
+ (test (wf3 (list 1 2 3 4) 1 5) '(1 5 3 4))
;; -------- OP_RECUR_IF_A_A_opLA_LAq --------
(define (recur-if-a-a-opla-laq-1 x) (if (< x 2) x (+ (recur-if-a-a-opla-laq-1 (- x 1)) (recur-if-a-a-opla-laq-1 (- x 2)))))
@@ -28250,12 +28709,58 @@ in s7:
(define (tak-3 x y z) (if (not (< y x)) z (tak-3 (tak-3 (- x 1) y z) (tak-3 (- y 1) z x) (tak-3 (- z 1) x y) x)))
(test (tak-3 10 5 1) 'error)
+ (define (dly0 x y) (if (zero? x) y (dly0 (- x 1) (+ x y))))
+ (test (dly0 10 1)56)
+
+ (define (dly1 x y) (if (null? x) y (dly1 (cdr x) (cons (car x) y))))
+ (test (dly1 '(10 9 8 7 6 5 4 3 2 1 0) ()) '(0 1 2 3 4 5 6 7 8 9 10))
+
+ (define (dly2 x y) (and (list? x) (or (and (null? x) y) (dly2 (cdr x) (cons (car x) y)))))
+ (test (dly2 '(10 9 8 7 6 5 4 3 2 1 0) ()) '(0 1 2 3 4 5 6 7 8 9 10))
+
+ (define (dly3 x y) (or (and (null? x) y) (and (pair? x) (dly3 (cdr x) (cons (car x) y)))))
+ (test (dly3 '(10 9 8 7 6 5 4 3 2 1 0) ()) '(0 1 2 3 4 5 6 7 8 9 10))
)
(when (provided? 'debugging)
(report-missed-calls))
;;; end optimizer stuff
+;;; coverage tests for closure_3p
+(let ()
+ (define (byte siz pos) (list pos siz))
+ (define (dpb integer bytespec into) (list integer bytespec into))
+ (define (lpb x integer bytespec into) (let ((v (list-values 0 integer bytespec into))) (set! (v 0) x) v))
+ (define (mpb x y) (values x y))
+ (define (mpb1 x) (values x))
+
+ (define (g)
+ (test (dpb 1 2 3) '(1 2 3))
+ (test (dpb 1 2 (byte 4 5)) '(1 2 (5 4)))
+ (test (dpb 1 (byte 4 5) 3) '(1 (5 4) 3))
+ (test (dpb (byte 4 5) 2 3) '((5 4) 2 3))
+ (test (dpb 1 (byte 4 5) (byte 6 7)) '(1 (5 4) (7 6)))
+ (test (dpb (byte 4 5) (byte 6 7) 3) '((5 4) (7 6) 3))
+ (test (dpb (byte 4 5) 2 (byte 6 7)) '((5 4) 2 (7 6)))
+ (test (dpb (byte 4 5) (byte 6 7) (byte 8 9)) '((5 4) (7 6) (9 8)))
+
+ (test (lpb -1 1 2 3) '(-1 1 2 3))
+ (test (lpb -1 1 2 (byte 4 5)) '(-1 1 2 (5 4)))
+ (test (lpb -1 1 (byte 4 5) 3) '(-1 1 (5 4) 3))
+ (test (lpb -1 (byte 4 5) 2 3) '(-1 (5 4) 2 3))
+ (test (lpb -1 1 (byte 4 5) (byte 6 7)) '(-1 1 (5 4) (7 6)))
+ (test (lpb -1 (byte 4 5) (byte 6 7) 3) '(-1 (5 4) (7 6) 3))
+ (test (lpb -1 (byte 4 5) 2 (byte 6 7)) '(-1 (5 4) 2 (7 6)))
+ (test (lpb -1 (byte 4 5) (byte 6 7) (byte 8 9)) '(-1 (5 4) (7 6) (9 8)))
+
+ (test (dpb (mpb 1 2) 3 4) 'error)
+ (test (dpb 1 2 (mpb 1 2)) 'error)
+ (test (dpb 1 (mpb 1 2) 3) 'error)
+ (test (dpb (mpb1 1) 3 4) '(1 3 4))
+ (test (dpb 1 2 (mpb1 3)) '(1 2 3))
+ (test (dpb 1 (mpb1 2) 3) '(1 2 3)))
+ (g))
+
;;; --------------------------------------------------------------------------------
;;; begin
@@ -30519,6 +31024,11 @@ in s7:
(test (let ((a #<eof>)) (eof-object? a)) #t)
(test (let ((a #<unspecified>)) (eq? a #<unspecified>)) #t)
(test (let* ((x 1) (x (+ x 1))) x) 2) ; ??
+(test (object->string (let* ((a 1) (e (curlet)) (b (+ a 1))) e)) "(inlet 'a 1)")
+(let ()
+ (define (f) (let* ((a 1) (e (curlet)) (b (+ a 1))) e))
+ (define (g) (do ((v (vector #f)) (i 0 (+ i 1))) ((= i 1) (v 0)) (vector-set! v 0 (f))))
+ (test (object->string (g)) "(inlet 'a 1)"))
(test (let _name_ ((x 1) (y (_name_ 2))) (+ x y)) 'error)
(test (let* _name_ ((x 1) (y (_name_ 2))) (+ x y)) 'error)
@@ -32025,6 +32535,17 @@ in s7:
count)
2)
+(let ((continuations ())) ; chicken mailing list
+ (define (push arg)
+ (set! continuations (cons arg continuations)))
+ (define (capture-from-map arg)
+ (call-with-current-continuation
+ (lambda (cc)
+ (push cc)
+ arg)))
+ (define numbers (map capture-from-map '(1 2 3)))
+ (test numbers '(1 2 3)))
+
(let ((c #f)
(vals ()))
(let ((val (+ 1 2 (call/cc (lambda (r) (set! c r) (r 3))))))
@@ -35572,19 +36093,23 @@ who says the continuation has to restart the map from the top?
(set! x y)
(set! y (cdr (v (+ i 1))))))))
-;;; closure_compare coverage:
+;;; closure_sort coverage:
(let ()
(define (f3 a b) (let ((x (+ a 1)) (y (+ b 1))) (< x y)))
(test (sort! '(1 3 2) f3) '(1 2 3)))
-;;; closure_compare_begin
+;;; closure_sort_begin
(let ()
(define (f4 a b) (display a #f) (let ((x (+ a 1)) (y (+ b 1))) (< x y)))
(test (sort! '(1 3 2) f4) '(1 2 3)))
-;;; opt_begin_bool_compare_b
+;;; opt_begin_bool_sort_b2
(let ()
(define (f5 a b) (display a #f) (< a b))
(test (sort! '(1 3 2) f5) '(1 2 3)))
-;;; opt_begin_bool_compare_p
+;;; opt_begin_bool_sort_b
+(let ()
+ (define (f6 a b) (display a #f) (display b #f) (< a b))
+ (test (sort! '(1 3 2) f6) '(1 2 3)))
+;;; opt_begin_bool_sort_p
(let ()
(define (f6 a b) (display a #f) (if (< a b) #t #f))
(test (sort! '(1 3 2) f6) '(1 2 3)))
@@ -37312,6 +37837,10 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
(the-environment)))))
|#
+(let () ; from lisp bboard
+ (define-macro (circularize . forms) `(begin ,@(let loop ((p forms)) (if (pair? (cdr p)) (loop (cdr p)) (set-cdr! p forms)))))
+ (test (circularize (+ 1 2) (- 3 4)) 'error))
+
(let ()
;; how to protect a recursive macro call from being stepped on
;; (define-macro (mac a b) `(if (> ,b 0) (let ((,a (- ,b 1))) (mac ,a (- ,b 1))) ,b))
@@ -37343,7 +37872,6 @@ or better (define-macro (prog vars . body) `(call-with-exit (lambda (return) (ta
;; cltl2 p 134ff is an unreadable discussion of this, but I think it says in this case CL goes right to left
;; weird! in CL (decf x (decf x)) != (setf x (- x (setf x (- x 1))))
;; and (let ((x 10)) (let ((val (decf x))) (decf x val) x))?
- ;; so by adhering to one evaluation order, we lose "referential transparency"? [the phrase is opaque, but that's intentional...]
(test (let ((x 1+i)) (decf x 0+i)) 1.0))
@@ -85520,8 +86048,8 @@ hi6: (string-app...
(test (format #f "~P" 1/0) "s")
(test (nan? (string->number "+nan.0")) #t)
(test (nan? (string->number "+nan.0" 2)) #t)
-(test (equivalent? (string->number "nan.0") (string->number "+nan.0")) #t)
-(test (equivalent? (string->number "+inf.0") (string->number "inf.0")) #t)
+(test (equivalent? nan.0 (string->number "+nan.0")) #t)
+(test (equivalent? (string->number "+inf.0") inf.0) #t)
(test (number->string (real-part (log 0.0))) "-inf.0")
(test (number->string (real-part (log 0.0)) 2) "-inf.0")
@@ -90930,6 +91458,7 @@ etc
(test (let () (define (func) (with-let (mock-hash-table) (undefined-function 0))) (define (hi) (func)) (hi)) 'error)
(test (let () (define (func) (with-let (mock-hash-table) (let ((x 1)) (undefined-function x)))) (define (hi) (func)) (hi)) 'error)
(test (let () (define (func) (with-let (mock-hash-table) (let ((x 1)) (undefined-function (+ x 1))))) (define (hi) (func)) (hi)) 'error)
+ (test (let () (define (func) (clamp #f (vector (inlet :a 1 :b 2 :c 3) #f #f) (mock-hash-table 'b 2))) (define (hi) (func)) (hi)) 'error)
(test (getenv (outlet (mock-string #\h #\o #\h #\o))) 'error)
(test (sort! (list 1 2) (mock-vector 1 2 3)) 'error)
@@ -91981,6 +92510,15 @@ etc
(let ((imp '(0 1))) (define (func) (list (hash-table-ref imp imp) #u(0 1) #r())) (define (hi) (func)) (test (hi) 'error))
(test (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (fill! (curlet) (list-values letrec cond)))) (define (hi) (func)) (hi)) 'error)
(let ((x #f)) (define (func) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (eval-string (object->string (curlet)))))) (define (hi) (func)) (test (hi) (inlet 'i 0)))
+(test (let () (define (func) (hash-table-entries (string-ref (iterator-sequence (symbol? x)) #i2d((101 201) (3 4))))) (func)) 'error)
+(test (let () (define (_fnc3_ x) (* x 2.0)) (define (f) (_fnc3_ (inlet :a (hash-table 'b 1)))) (f)) 'error)
+
+(let ()
+ (define (fibf n) (if (< n 2.0) n (+ (fibf (- n 1.0)) (fibf (- n 2.0)))))
+ (define (clamp minimum x maximum) (min maximum (max x minimum)))
+ (define (func) (clamp (fibf 8.0) 0 (tree-count 0 (vector-dimensions (block)))))
+ (define (hi) (func))
+ (test (hi) 1))
(test (let ((x #f)) (define (func) (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (let-temporarily ((i 0 (+ i 1))) #i(1) 1)))) (define (hi) (func)) (hi)) 'error)
(when with-block
@@ -92104,6 +92642,7 @@ etc
(test (s7-optimize '((cdadr (cddddr (symbol->string (min '((x 1 . 2) . 3) #<undefined> '((x 1) . 2))))))) #<undefined>) ; #<undefined> is s7-optimize's error value
(test (s7-optimize '((set! (cyclic-sequences . 0+0/0i) #f))) #<undefined>)
(test (s7-optimize (list (catch #t (lambda () (with-input-from-string "(if (not) (cadddr (rational?)))" read)) (lambda args args)))) #<undefined>)
+ (test ((s7-optimize '((inlet 'if 3))) 'if) 'error)
)
;;; null sc->args in unbound_variable:
@@ -92272,7 +92811,8 @@ etc
(test (let ()
(define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (tree-count ((lambda (a) (values a (+ a 1))) 2) (vector-dimensions (block))))))
(define (hi) (func)) (hi)) 'error)
- (test (let () (define (func) (append (values "" (block)) (list :go))) (define (hi) (func)) (hi)) 'error)) ; plist clobbered
+ (test (let () (define (func) (append (values "" (block)) (list :go))) (define (hi) (func)) (hi)) 'error) ; plist clobbered
+ (test (let ((b (block 1 2 3))) (define (func) (call-with-exit (lambda (x) (x (unspecified? (c-pointer-weak1 b)))))) (func)) 'error))
(test (let () (define (func x i) (float-vector-set! x i (catch #t (lambda () (float-vector-ref x i)) (lambda args 'error)))) (define (hi) (func #r(1 2 3) 3)) (hi)) 'error)
(test (let () (define (func) (undefined? (list-ref (list #f (make-iterator (list #f))) 1 ()))) (define (hi) (func)) (hi)) 'error) ; safe_c_opaaaq sc->code != code bug
@@ -101049,6 +101589,7 @@ etc
(test (let () (define (hi a) (let ((pair? +)) (pair? a 1))) (hi 2)) 3)
(test ((lambda (let) (let* ((letrec 1)) (+ letrec let))) 123) 124)
+(test (member quasiquote (list 1) (lambda 'ho '(1 2))) 'error)
(test (let ((begin 3)) (+ begin 1)) 4)
(test ((lambda (let*) (let ((letrec 1)) (+ letrec let*))) 123) 124)
@@ -101340,6 +101881,7 @@ etc
(test (let ((max min) (min max)) (define (func) (min 10 (max 12 15))) (define (hi) (func)) (hi)) 12)
(let ((f #_abs)) (test (set! #_abs +) 'error) (set! abs +) (test (eq? f abs) #f) (test (eq? f #_abs) #t) (set! abs #_abs))
+(test (let ((+ -)) (define (f x) (#_+ x 1)) (object->string f :readable)) "(lambda (x) (#_+ x 1))")
(test (catch #t (lambda () ((lambda quote (abs '__a__)))) (lambda (type info) (car info))) "~A: unbound variable")
(test (catch #t (lambda () ((lambda quote (+ '__a__ 1)))) (lambda (type info) (car info))) "~A: unbound variable")
@@ -101377,6 +101919,46 @@ etc
(test (let-temporarily ((else #f)) (mc4 1)) 1))
(test (let () (define (f) (let ((apply cons)) (apply abs -1))) (f)) (cons abs -1))
+(let () ; s7.html examples
+ (define-macro (my-unless condition . body)
+ `(with-let (inlet (unlet) :condition ,condition) ; here unlet protects body (format below)
+ (if (not condition) (begin ,@body))))
+
+ (let ((not (lambda (x) x))
+ (begin 32)
+ (format abs))
+ (test (my-unless #t (format #f "oops")) #<unspecified>)
+ (test (my-unless #f (format #f "ok")) "ok"))
+
+ (let ((format abs))
+ (let ((not (lambda (x) x)))
+ (test (my-unless #t (format #f "oops")) #<unspecified>)
+ (test (my-unless #f (format #f "ok")) "ok")))
+
+ (define my-unless-2
+ (let ((op1 (lambda (x) (not x))))
+ (define-macro (_ condition . body)
+ `(with-let (inlet (unlet) (funclet my-unless-2) :condition ,condition) ; funclet to get my-unless-2's version of op1
+ (if (op1 condition) (begin ,@body))))))
+
+ (let ((op1 (lambda (x) x)))
+ (test (my-unless-2 #t (format #f "oops")) #<unspecified>)
+ (test (my-unless-2 #f (format #f "ok")) "ok"))
+
+ (define my-unless-3
+ (let ((op1 (lambda (x) x)))
+ (define-macro (_ condition . body)
+ `(with-let (inlet (unlet) :condition ,condition :local-env (curlet)) ; curlet to get local version of op1
+ (if ((with-let local-env op1) condition) (begin ,@body))))))
+
+ (let ((op1 (lambda (x) (not x))))
+ (test (my-unless-3 #t (format #f "oops")) #<unspecified>)
+ (test (my-unless-3 #f (format #f "ok")) "ok"))
+ )
+
+(test (map when (vector #f #t #f) (list 1 2 3)) '(#<unspecified> 2 #<unspecified>))
+;; (for-each with-let (list (inlet 'x 1) (inlet 'x 2)) (list '(display x) '(display x))): "12"
+
#|
;;; after much dithering I've decided that built-in C functions have a very aggressive take
diff --git a/snd-xref.c b/snd-xref.c
index 9966a13..ed90763 100644
--- a/snd-xref.c
+++ b/snd-xref.c
@@ -1758,7 +1758,7 @@ static const char *Reverb_urls[] = {
#if HAVE_SCHEME
-static const char *snd_names[11716] = {
+static const char *snd_names[11828] = {
"*clm-array-print-length*", "ws.scm",
"*clm-channels*", "ws.scm",
"*clm-clipped*", "ws.scm",
@@ -2542,6 +2542,13 @@ static const char *snd_names[11716] = {
"GSL_EUNSUP", "libgsl.scm",
"GSL_EZERODIV", "libgsl.scm",
"GSL_FAILURE", "libgsl.scm",
+ "GSL_FILTER_END_PADVALUE", "libgsl.scm",
+ "GSL_FILTER_END_PADZERO", "libgsl.scm",
+ "GSL_FILTER_END_TRUNCATE", "libgsl.scm",
+ "GSL_FILTER_SCALE_IQR", "libgsl.scm",
+ "GSL_FILTER_SCALE_MAD", "libgsl.scm",
+ "GSL_FILTER_SCALE_QN", "libgsl.scm",
+ "GSL_FILTER_SCALE_SN", "libgsl.scm",
"GSL_FLT_EPSILON", "libgsl.scm",
"GSL_FLT_MAX", "libgsl.scm",
"GSL_FLT_MIN", "libgsl.scm",
@@ -2603,6 +2610,9 @@ static const char *snd_names[11716] = {
"GSL_MIN_DBL", "libgsl.scm",
"GSL_MIN_INT", "libgsl.scm",
"GSL_MODE_DEFAULT", "libgsl.scm",
+ "GSL_MOVSTAT_END_PADVALUE", "libgsl.scm",
+ "GSL_MOVSTAT_END_PADZERO", "libgsl.scm",
+ "GSL_MOVSTAT_END_TRUNCATE", "libgsl.scm",
"GSL_NAN", "libgsl.scm",
"GSL_NEGINF", "libgsl.scm",
"GSL_NEGZERO", "libgsl.scm",
@@ -3720,8 +3730,6 @@ static const char *snd_names[11716] = {
"bytevector-copy!", "r7rs.scm",
"bytevector-length", "r7rs.scm",
"bytevector-u8", "r7rs.scm",
- "bytevector-u8-ref", "r7rs.scm",
- "bytevector-u8-set!", "r7rs.scm",
"c-define", "cload.scm",
"c-define-1", "cload.scm",
"c-null?", "libc.scm",
@@ -4716,6 +4724,19 @@ static const char *snd_names[11716] = {
"gsl_fft_real_wavetable_free", "libgsl.scm",
"gsl_fft_real_workspace_alloc", "libgsl.scm",
"gsl_fft_real_workspace_free", "libgsl.scm",
+ "gsl_filter_gaussian", "libgsl.scm",
+ "gsl_filter_gaussian_alloc", "libgsl.scm",
+ "gsl_filter_gaussian_free", "libgsl.scm",
+ "gsl_filter_gaussian_kernel", "libgsl.scm",
+ "gsl_filter_impulse", "libgsl.scm",
+ "gsl_filter_impulse_alloc", "libgsl.scm",
+ "gsl_filter_impulse_free", "libgsl.scm",
+ "gsl_filter_median", "libgsl.scm",
+ "gsl_filter_median_alloc", "libgsl.scm",
+ "gsl_filter_median_free", "libgsl.scm",
+ "gsl_filter_rmedian", "libgsl.scm",
+ "gsl_filter_rmedian_alloc", "libgsl.scm",
+ "gsl_filter_rmedian_free", "libgsl.scm",
"gsl_finite", "libgsl.scm",
"gsl_fit_linear", "libgsl.scm",
"gsl_fit_linear_est", "libgsl.scm",
@@ -4846,6 +4867,9 @@ static const char *snd_names[11716] = {
"gsl_integration_qk51", "libgsl.scm",
"gsl_integration_qk61", "libgsl.scm",
"gsl_integration_qng", "libgsl.scm",
+ "gsl_integration_romberg", "libgsl.scm",
+ "gsl_integration_romberg_alloc", "libgsl.scm",
+ "gsl_integration_romberg_free", "libgsl.scm",
"gsl_integration_workspace_alloc", "libgsl.scm",
"gsl_integration_workspace_free", "libgsl.scm",
"gsl_interp2d_alloc", "libgsl.scm",
@@ -5121,6 +5145,26 @@ static const char *snd_names[11716] = {
"gsl_min_fminimizer_x_minimum", "libgsl.scm",
"gsl_min_fminimizer_x_upper", "libgsl.scm",
"gsl_min_test_interval", "libgsl.scm",
+ "gsl_movstat_Qn", "libgsl.scm",
+ "gsl_movstat_Sn", "libgsl.scm",
+ "gsl_movstat_alloc", "libgsl.scm",
+ "gsl_movstat_alloc2", "libgsl.scm",
+ "gsl_movstat_alloc_with_size", "libgsl.scm",
+ "gsl_movstat_apply", "libgsl.scm",
+ "gsl_movstat_apply_accum", "libgsl.scm",
+ "gsl_movstat_fill", "libgsl.scm",
+ "gsl_movstat_free", "libgsl.scm",
+ "gsl_movstat_mad", "libgsl.scm",
+ "gsl_movstat_mad0", "libgsl.scm",
+ "gsl_movstat_max", "libgsl.scm",
+ "gsl_movstat_mean", "libgsl.scm",
+ "gsl_movstat_median", "libgsl.scm",
+ "gsl_movstat_min", "libgsl.scm",
+ "gsl_movstat_minmax", "libgsl.scm",
+ "gsl_movstat_qqr", "libgsl.scm",
+ "gsl_movstat_sd", "libgsl.scm",
+ "gsl_movstat_sum", "libgsl.scm",
+ "gsl_movstat_variance", "libgsl.scm",
"gsl_multifit_covar", "libgsl.scm",
"gsl_multifit_covar_QRPT", "libgsl.scm",
"gsl_multifit_fsolver_alloc", "libgsl.scm",
@@ -6142,18 +6186,26 @@ static const char *snd_names[11716] = {
"gsl_spmatrix_set_zero", "libgsl.scm",
"gsl_spmatrix_sp2d", "libgsl.scm",
"gsl_spmatrix_transpose_memcpy", "libgsl.scm",
+ "gsl_stats_Qn0_from_sorted_data", "libgsl.scm",
+ "gsl_stats_Qn_from_sorted_data", "libgsl.scm",
+ "gsl_stats_Sn0_from_sorted_data", "libgsl.scm",
+ "gsl_stats_Sn_from_sorted_data", "libgsl.scm",
"gsl_stats_absdev", "libgsl.scm",
"gsl_stats_absdev_m", "libgsl.scm",
"gsl_stats_correlation", "libgsl.scm",
"gsl_stats_covariance", "libgsl.scm",
"gsl_stats_covariance_m", "libgsl.scm",
+ "gsl_stats_gastwirth_from_sorted_data", "libgsl.scm",
"gsl_stats_kurtosis", "libgsl.scm",
"gsl_stats_kurtosis_m_sd", "libgsl.scm",
"gsl_stats_lag1_autocorrelation", "libgsl.scm",
"gsl_stats_lag1_autocorrelation_m", "libgsl.scm",
+ "gsl_stats_mad", "libgsl.scm",
+ "gsl_stats_mad0", "libgsl.scm",
"gsl_stats_max", "libgsl.scm",
"gsl_stats_max_index", "libgsl.scm",
"gsl_stats_mean", "libgsl.scm",
+ "gsl_stats_median", "libgsl.scm",
"gsl_stats_median_from_sorted_data", "libgsl.scm",
"gsl_stats_min", "libgsl.scm",
"gsl_stats_min_index", "libgsl.scm",
@@ -6164,9 +6216,11 @@ static const char *snd_names[11716] = {
"gsl_stats_sd", "libgsl.scm",
"gsl_stats_sd_m", "libgsl.scm",
"gsl_stats_sd_with_fixed_mean", "libgsl.scm",
+ "gsl_stats_select", "libgsl.scm",
"gsl_stats_skew", "libgsl.scm",
"gsl_stats_skew_m_sd", "libgsl.scm",
"gsl_stats_spearman", "libgsl.scm",
+ "gsl_stats_trmean_from_sorted_data", "libgsl.scm",
"gsl_stats_tss", "libgsl.scm",
"gsl_stats_tss_m", "libgsl.scm",
"gsl_stats_ttest", "libgsl.scm",
@@ -6442,6 +6496,7 @@ static const char *snd_names[11716] = {
"lognor", "stuff.scm",
"long-eared-owl", "animals.scm",
"long-spurred-meadow-katydid", "animals.scm",
+ "low-primes.scm", "low-primes.scm",
"lpc-coeffs", "dsp.scm",
"lpc-predict", "dsp.scm",
"lseek", "libc.scm",
@@ -7455,6 +7510,7 @@ static const char *snd_names[11716] = {
"tgamma", "libm.scm",
"the", "stuff.scm",
"third", "stuff.scm",
+ "time", "libc.scm",
"time.make", "libc.scm",
"times->samples", "ws.scm",
"timespec.make", "libc.scm",
@@ -7621,7 +7677,7 @@ static const char *snd_names[11716] = {
static void autoload_info(s7_scheme *sc)
{
- s7_autoload_set_names(sc, snd_names, 5858);
+ s7_autoload_set_names(sc, snd_names, 5914);
}
#endif
diff --git a/snd.h b/snd.h
index 6672675..071266a 100644
--- a/snd.h
+++ b/snd.h
@@ -55,11 +55,11 @@
#include "snd-strings.h"
-#define SND_DATE "14-Oct-19"
+#define SND_DATE "19-Nov-19"
#ifndef SND_VERSION
-#define SND_VERSION "19.8"
+#define SND_VERSION "19.9"
#endif
#define SND_MAJOR_VERSION "19"
-#define SND_MINOR_VERSION "8"
+#define SND_MINOR_VERSION "9"
#endif
diff --git a/snd.html b/snd.html
index 5ba6c25..125d707 100644
--- a/snd.html
+++ b/snd.html
@@ -125,7 +125,8 @@ using either <a href="s7.html">s7</a> (included in the Snd sources),
<a href="http://www.ruby-lang.org">Ruby</a>, or
<a href="http://www.sourceforge.net/projects/fth">Forth</a>.
Snd is free; the code is available via anonymous ftp as
-<a href="ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-18.tar.gz">snd-18.tar.gz</a>.
+<!-- <a href="ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-19.tar.gz">snd-19.tar.gz</a> -->
+<a href="https://ccrma.stanford.edu/software/snd/snd-19.tar.gz">Snd tarball</a>.
Snd has a <a href="http://ccrma.stanford.edu/software/snd/">home page</a>,
and is included in <a href="http://ccrma.stanford.edu/planetccrma/software/">PlanetCCRMA</a>.
</p>
diff --git a/stuff.scm b/stuff.scm
index b55c15d..6dc69e6 100644
--- a/stuff.scm
+++ b/stuff.scm
@@ -1146,7 +1146,7 @@ Unlike full-find-if, safe-find-if can handle any circularity in the sequences.")
;;; ----------------
-(define (clamp minimum x maximum)
+(define (clamp minimum x maximum) ; if min>max maybe an error? (clamp 3 2 1) -> 1
(min maximum (max x minimum)))
(define (1- x) (- x 1))
diff --git a/tools/dup.scm b/tools/dup.scm
index 217dc8c..f3997dd 100644
--- a/tools/dup.scm
+++ b/tools/dup.scm
@@ -4,8 +4,6 @@
;;; "alloc-lines" is any number bigger than the number of lines in "file"
;;; (dups 16 "s7.c" 91000) finds all 16-line matches in s7.c which (we wish) has less than 91000 lines in all
-;(set! (*s7* 'heap-size) (* 2 1024000))
-
(define dups
(let ((unique #f))
@@ -123,7 +121,7 @@
(format *stderr* "~%")))))))))))))
(dups 16 "s7.c" 100000)
-;(dups 8 "s7.c" 100000)
+;(dups 12 "s7.c" 100000)
;(dups 12 "ffitest.c" 2000)
;(dups 8 "ffitest.c" 2000)
;(dups 1 "s7test.scm" 105000)
diff --git a/tools/make-index.scm b/tools/make-index.scm
index 53f645b..025f10a 100644
--- a/tools/make-index.scm
+++ b/tools/make-index.scm
@@ -790,6 +790,7 @@
(make-moog "moog.scm")
(primes.scm "primes.scm")
+ (low-primes.scm "low-primes.scm")
(snd-clm23.scm "clm23.scm")
(snd-edit123.scm "edit123.scm")
(snd-new-effects.scm "new-effects.scm")
diff --git a/tools/tclo.scm b/tools/tclo.scm
index 8de766b..8007c76 100644
--- a/tools/tclo.scm
+++ b/tools/tclo.scm
@@ -1,5 +1,16 @@
(set! (*s7* 'heap-size) (* 8 1024000))
+(define d1-size 200000)
+(define g-size 1000000)
+(define kf-size 30)
+(define k100-size 10000)
+#|
+(define d1-size 0)
+(define g-size 0)
+(define kf-size 30)
+(define k100-size 0)
+|#
+
(define* (f0 a b)
(display b #f))
@@ -18,7 +29,7 @@
(define* (f5 (a 1))
(apply + (list a 2)))
-(define* (f6 a . b)
+(define* (f6 a . b) ; unsafe
(apply values (cons a b)))
(define* (f7 (a 1) (b 2))
@@ -47,7 +58,7 @@
(tfib 35)
(let ((x 1) (y 2))
(do ((i 0 (+ i 1)))
- ((= i 200000))
+ ((= i d1-size))
(f0 1 2)
(f0 x y)
(f0 :a x)
@@ -92,4 +103,113 @@
(d1)
+;;; -------- comparison with non-key case: --------
+
+(define no-key-fib
+ (lambda (n)
+ (if (<= n 2) 1 (+ (no-key-fib (- n 2))
+ (no-key-fib (- n 1))))))
+
+(define key-fib
+ (lambda* (n)
+ (if (<= n 2) 1
+ (+ (key-fib :n (- n 2))
+ (key-fib :n (- n 1))))))
+
+(define (f12 a b)
+ (when (> a b)
+ (+ a b)))
+
+(define* (f13 a b)
+ (when (> a b)
+ (+ a b)))
+
+(define* (f14 (a 1) (b 0))
+ (when (> a b)
+ (+ a b)))
+
+
+(define size g-size)
+
+(define (g1)
+ (do ((i 0 (+ i 1)))
+ ((= i g-size))
+ (f12 i i)))
+
+(define (g2)
+ (do ((i 0 (+ i 1)))
+ ((= i g-size))
+ (f13 i i)))
+
+(define (g3)
+ (do ((i 0 (+ i 1)))
+ ((= i g-size))
+ (f13 :a i :b i)))
+
+(define (g4)
+ (do ((i 0 (+ i 1)))
+ ((= i g-size))
+ (f13 :b i :a i)))
+
+(define (g5)
+ (do ((i 0 (+ i 1)))
+ ((= i g-size))
+ (f14)))
+
+(define (g6)
+ (do ((i 0 (+ i 1)))
+ ((= i g-size))
+ (f14 i i)))
+
+(define (g7)
+ (do ((i 0 (+ i 1)))
+ ((= i g-size))
+ (f14 :a i)))
+
+
+;;; -------- 100 key args --------
+
+(define* (k100 a0 a1 a2 a3 a4 a5 a6 a7 a8 a9
+ a10 a11 a12 a13 a14 a15 a16 a17 a18 a19
+ a20 a21 a22 a23 a24 a25 a26 a27 a28 a29
+ a30 a31 a32 a33 a34 a35 a36 a37 a38 a39
+ a40 a41 a42 a43 a44 a45 a46 a47 a48 a49
+ a50 a51 a52 a53 a54 a55 a56 a57 a58 a59
+ a60 a61 a62 a63 a64 a65 a66 a67 a68 a69
+ a70 a71 a72 a73 a74 a75 a76 a77 a78 a79
+ a80 a81 a82 a83 a84 a85 a86 a87 a88 a89
+ a90 a91 a92 a93 a94 a95 a96 a97 a98 a99)
+ (+ a0 a1))
+
+(define (g100)
+ (do ((i 0 (+ i 1)))
+ ((= i k100-size))
+ (k100 :a0 1 :a1 1 :a2 1 :a3 1 :a4 1 :a5 1 :a6 1 :a7 1 :a8 1 :a9 1
+ :a10 1 :a11 1 :a12 1 :a13 1 :a14 1 :a15 1 :a16 1 :a17 1 :a18 1 :a19 1
+ :a20 1 :a21 1 :a22 1 :a23 1 :a24 1 :a25 1 :a26 1 :a27 1 :a28 1 :a29 1
+ :a30 1 :a31 1 :a32 1 :a33 1 :a34 1 :a35 1 :a36 1 :a37 1 :a38 1 :a39 1
+ :a40 1 :a41 1 :a42 1 :a43 1 :a44 1 :a45 1 :a46 1 :a47 1 :a48 1 :a49 1
+ :a50 1 :a51 1 :a52 1 :a53 1 :a54 1 :a55 1 :a56 1 :a57 1 :a58 1 :a59 1
+ :a60 1 :a61 1 :a62 1 :a63 1 :a64 1 :a65 1 :a66 1 :a67 1 :a68 1 :a69 1
+ :a70 1 :a71 1 :a72 1 :a73 1 :a74 1 :a75 1 :a76 1 :a77 1 :a78 1 :a79 1
+ :a80 1 :a81 1 :a82 1 :a83 1 :a84 1 :a85 1 :a86 1 :a87 1 :a88 1 :a89 1
+ :a90 1 :a91 1 :a92 1 :a93 1 :a94 1 :a95 1 :a96 1 :a97 1 :a98 1 :a99 1)))
+
+
+;;; --------------------------------
+(define (kcall)
+ (no-key-fib kf-size)
+ (key-fib kf-size))
+(kcall)
+
+(g1)
+(g2)
+(g3)
+(g4)
+(g5)
+(g6)
+(g7)
+
+(g100)
+
(exit)
diff --git a/tools/tgen.scm b/tools/tgen.scm
index 488b648..fbb836c 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) ; also, unset heap-size is best
+;(set! (*s7* 'gc-stats) #t)
(define start-run (get-internal-real-time))
(define M (float-vector 0 0 1 10))
diff --git a/tools/thash.scm b/tools/thash.scm
index 1828322..f24c986 100644
--- a/tools/thash.scm
+++ b/tools/thash.scm
@@ -1,4 +1,4 @@
-(set! (*s7* 'heap-size) (* 5 1024000))
+(set! (*s7* 'heap-size) (* 3 1024000))
;(set! (*s7* 'gc-stats) 6)
(define (reader)
diff --git a/tools/tmac.scm b/tools/tmac.scm
index cfb0145..ef86aac 100644
--- a/tools/tmac.scm
+++ b/tools/tmac.scm
@@ -51,7 +51,7 @@
(m5 1 3 4 5)))
(f5-test)
-(define-macro (m61 a b) `(+ ,a ,@b))
+(define-macro (m61 a b) (cons '+ (cons a b)))
(define (f61-test mx)
(do ((i 0 (+ i 1)))
((= i size))
@@ -86,11 +86,10 @@
(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)))))))
+ (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)
diff --git a/tools/tmisc.scm b/tools/tmisc.scm
index 107219e..7fe56d9 100644
--- a/tools/tmisc.scm
+++ b/tools/tmisc.scm
@@ -160,4 +160,39 @@
(mvtest)
-(exit)
+;;; unlet
+;;; incrementally set all globals to 42 -- check that unlet exprs return the same results
+
+(let* ((syms (symbol-table))
+ (num-syms (length syms))
+ (orig-x (*s7* 'print-length)))
+
+ (define (unlet-test i)
+ (with-let (unlet)
+ (catch #t
+ (lambda ()
+ (eval `(define ,(syms i) 42))
+ (when (procedure? (symbol->value (syms i) (rootlet)))
+ (with-let (unlet)
+ (eval `(set! ,(syms i) 42) (rootlet)))))
+ (lambda (type info)
+ ;(format *stderr* "~S unchanged: ~S~%" (syms i) (apply format #f info))
+ #f)))
+
+ (with-let (unlet)
+ (do ((k 0 (+ k 1)))
+ ((= k 1000))
+ (catch #t
+ (lambda ()
+ (let ((x (+ k (*s7* 'print-length))))
+ (unless (eqv? x (+ k orig-x))
+ (format *stderr* "sym: ~S, x: ~S, orig: ~S~%" (syms i) x (+ k orig-x)))))
+ (lambda (type info)
+ (format *stderr* "sym: ~S, error: ~S~%" (syms i) (apply format #f info)))))))
+
+ (do ((i 0 (#_+ i 1))) ; "do" is not a procedure (see above) so it's not in danger here
+ ((#_= i num-syms))
+ (unlet-test i)))
+
+
+(#_exit) ; we just clobbered exit above
diff --git a/tools/tpeak.scm b/tools/tpeak.scm
index 1aac941..a16b89e 100644
--- a/tools/tpeak.scm
+++ b/tools/tpeak.scm
@@ -1,5 +1,6 @@
-(if (not (provided? 'snd-peak-phases.scm)) (load "peak-phases.scm"))
-(load "primes.scm")
+(unless (provided? 'snd-peak-phases.scm)
+ (load "low-primes.scm")
+ (load "peak-phases.scm"))
(define (get-best choice n)
(let ((val (vector-ref (case choice
diff --git a/tools/trclo.scm b/tools/trclo.scm
index 91e5f81..82c1aa7 100644
--- a/tools/trclo.scm
+++ b/tools/trclo.scm
@@ -384,13 +384,13 @@
(define (lcond1 x y)
(let ((z (+ x y)))
- (cond ((= 0 z) pi)
+ (cond ((= z 0) pi)
((< z 0) 'oops)
(else (lcond1 (- x 1) (- y 1))))))
(define (lcond2 x)
(let ((z (+ x 1)))
- (cond ((= 0 z) pi)
+ (cond ((= z 0) pi)
((< z 0) 'oops)
(else (lcond2 (- x 1))))))
@@ -398,13 +398,13 @@
(define (lcond3 x y)
(let ((z (+ x y)))
- (cond ((= 0 z) pi)
+ (cond ((= z 0) pi)
((< z 0) (lcond3 (+ x 1) y))
(else (lcond3 (- x 1) y)))))
(define (lcond4 x y z)
(let ((a (+ x y z)))
- (cond ((= 0 z) pi)
+ (cond ((= z 0) pi)
(else (lcond4 x (- y 1) (- z 1))))))
(define (cond-f)
diff --git a/tools/trec.scm b/tools/trec.scm
index 901ff72..9fba9fd 100644
--- a/tools/trec.scm
+++ b/tools/trec.scm
@@ -5,8 +5,8 @@
`(if (not ,test) (begin ,@body))))
(define (fib n)
- (if (< n 2)
- n
+ (if (<= n 2)
+ 1
(+ (fib (- n 1))
(fib (- n 2)))))
@@ -16,10 +16,10 @@
(define (fibr n)
- (if (>= n 2)
+ (if (> n 2)
(+ (fibr (- n 1))
(fibr (- n 2)))
- n))
+ 1))
(let ((f32 (fibr 32)))
(unless (= f32 2178309) ;3524578)
diff --git a/tools/tshoot.scm b/tools/tshoot.scm
index 84bfdf5..4c711d1 100644
--- a/tools/tshoot.scm
+++ b/tools/tshoot.scm
@@ -52,7 +52,7 @@
;; (fannkuch 7): (228 . 16), 8: (1616 . 22), 9: (8629 . 30), 10: (73196 . 38), 11: (556355 . 51), 12: (3968050 . 65)
(display (fannkuch 7)) (newline)
-;; (fannkuch 12) takes around 5 minutes (297 secs)
+;(fannkuch 12) ;takes around 5 minutes (297 secs)
;;; --------------------------------------------------------------------------------
@@ -176,7 +176,7 @@
(format *stderr* "~D~9Ttrees of depth ~D~30Tcheck: ~D~%" iterations depth check)))))
(format *stderr* "long lived tree of depth ~D~30Tcheck: ~D~%" max-depth (item-check long-lived-tree)))))))
-;;(binary-tree 21) ; 20 secs
+;(binary-tree 21) ; 20 secs
(binary-tree 6)
;;; stretch tree of depth 22 check: 8388607
@@ -215,9 +215,9 @@
(set! num i)))
(format *stderr* "Maximum stopping distance ~D, starting number ~D\n" len num)))))
-;(collatz 300000)
+;; (collatz 300000)
;; Maximum stopping distance 442, starting number 230631
-;; .6 secs
+;; .45 secs
(collatz 20000)
@@ -241,7 +241,7 @@
(set! L (cdr L))))))))
(let ()
- (define (count-primes limit) ; for limit=10000000 12.3 secs 664579
+ (define (count-primes limit) ; for limit=10000000 10.4 secs 664579
(let ((primes 0))
(do ((i 2 (+ i 1)))
((= i limit)
@@ -303,7 +303,7 @@
(sqrt (/ vBv vV))))
- (display (spectral-norm 125)) ; (spectral-norm 5500) takes about 19.4 secs
+ (display (spectral-norm 125)) ; (spectral-norm 5500) takes about 14.3 secs
(newline))
;;; --------------------------------------------------------------------------------
diff --git a/tools/tvect.scm b/tools/tvect.scm
index 1c909eb..a9ae4f5 100644
--- a/tools/tvect.scm
+++ b/tools/tvect.scm
@@ -1,6 +1,6 @@
;;; vector timing tests
-(set! (*s7* 'heap-size) 1024000)
+(set! (*s7* 'heap-size) (* 2 1024000))
(define size 300000)
(define size/10 (/ size 10))
@@ -366,7 +366,7 @@
(let ((v (make-vector size)))
(do ((i 0 (+ i 1)))
((= i size) (vector-ref v 0))
- (list-values (vector-set! v i 2)))))
+ (values (vector-set! v i 2)))))
(unless (= (h7) 2)
(format *stderr* "h7: ~S~%" (h7)))
@@ -452,7 +452,7 @@
((= k 10) (vector-ref v 0 0))
(do ((i 0 (+ i 1)))
((= i size/10))
- (list-values (vector-set! v k i 2))))))
+ (values (vector-set! v k i 2))))))
(unless (= (h17) 2)
(format *stderr* "h17: ~S~%" (h17)))
@@ -515,7 +515,7 @@
(let ((v (make-vector size)))
(do ((i 0 (+ i 1)))
((= i size) (v 0))
- (list-values (set! (v i) 2)))))
+ (values (set! (v i) 2)))))
(unless (= (j6) 2)
(format *stderr* "j6: ~S~%" (j6)))
@@ -587,7 +587,7 @@
((= k 10) (v 0 0))
(do ((i 0 (+ i 1)))
((= i size/10))
- (list-values (set! (v k i) 2))))))
+ (values (set! (v k i) 2))))))
(unless (= (j16) 2)
(format *stderr* "j16: ~S~%" (j16)))
diff --git a/tools/valcall.scm b/tools/valcall.scm
index 58a1964..61de52c 100644
--- a/tools/valcall.scm
+++ b/tools/valcall.scm
@@ -79,25 +79,25 @@
(list "repl" "tshoot.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" "s7test.scm")
(list "repl" "lt.scm")
(list "repl" "tlet.scm")
(list "repl" "tform.scm")
(list "repl" "tcopy.scm")
(list "repl" "tread.scm")
- (list "repl" "tclo.scm")
+ (list "repl" "tmisc.scm")
(list "repl" "tmat.scm")
+ (list "repl" "dup.scm")
+ (list "repl" "trclo.scm")
(list "repl" "fbench.scm")
(list "repl" "titer.scm")
- (list "repl" "trclo.scm")
(list "repl" "tmap.scm")
(list "repl" "tset.scm")
(list "repl" "tsort.scm")
- (list "repl" "dup.scm")
(list "repl" "tmac.scm")
(list "repl" "tfft.scm")
+ (list "repl" "tclo.scm")
(list "repl" "trec.scm")
(list "repl" "thash.scm")
(list "snd -noinit" "tgen.scm") ; repl here + cload sndlib was slower
diff --git a/tools/xgdata.scm b/tools/xgdata.scm
index 38e2e4c..7c0781a 100644
--- a/tools/xgdata.scm
+++ b/tools/xgdata.scm
@@ -3820,7 +3820,7 @@
(CFNC "PangoAttribute* pango_attr_iterator_get PangoAttrIterator* iterator PangoAttrType type")
(CFNC "void pango_attr_iterator_get_font PangoAttrIterator* iterator PangoFontDescription* desc PangoLanguage** [language] GSList** [extra_attrs]")
(CFNC "gboolean pango_parse_markup char* markup_text int length gunichar accel_marker PangoAttrList** attr_list char** text gunichar* accel_char GError** [error]")
-(CFNC "void pango_break gchar* text int length PangoAnalysis* analysis PangoLogAttr* attrs int attrs_len")
+;;; 30-Oct-19 (CFNC "void pango_break gchar* text int length PangoAnalysis* analysis PangoLogAttr* attrs int attrs_len")
(CFNC "void pango_find_paragraph_boundary gchar* text gint length gint* [paragraph_delimiter_index] gint* [next_paragraph_start]")
(CFNC "void pango_get_log_attrs char* text int length int level PangoLanguage* language PangoLogAttr* log_attrs int attrs_len")
;(CFNC-extra "void pango_default_break gchar* text int length PangoAnalysis* analysis PangoLogAttr* attrs int attrs_len")
@@ -3851,9 +3851,9 @@
(CFNC "PangoCoverage* pango_coverage_copy PangoCoverage* coverage")
(CFNC "PangoCoverageLevel pango_coverage_get PangoCoverage* coverage int index")
(CFNC "void pango_coverage_set PangoCoverage* coverage int index PangoCoverageLevel level")
-(CFNC "void pango_coverage_max PangoCoverage* coverage PangoCoverage* other")
-(CFNC "void pango_coverage_to_bytes PangoCoverage* coverage guchar** [bytes] int* [n_bytes]") ; FREE (bytes)
-(CFNC "PangoCoverage* pango_coverage_from_bytes guchar* bytes int n_bytes") ; FREE
+;;; 30-Oct-19 (CFNC "void pango_coverage_max PangoCoverage* coverage PangoCoverage* other")
+;;; 30-Oct-19 (CFNC "void pango_coverage_to_bytes PangoCoverage* coverage guchar** [bytes] int* [n_bytes]") ; FREE (bytes)
+;;; 30-Oct-19 (CFNC "PangoCoverage* pango_coverage_from_bytes guchar* bytes int n_bytes") ; FREE
;(CSTR-extra "PANGO_ENGINE_TYPE_LANG")
;(CSTR-extra "PANGO_ENGINE_TYPE_SHAPE")
;(CSTR-extra "PANGO_RENDER_TYPE_NONE")
@@ -5174,7 +5174,7 @@
;;;(CFNC "void pango_matrix_scale PangoMatrix* matrix double scale_x double scale_y")
;;;(CFNC "void pango_matrix_rotate PangoMatrix* matrix double degrees")
;;;(CFNC "void pango_matrix_concat PangoMatrix* matrix PangoMatrix* new_matrix")
-(CFNC "PangoScript pango_script_for_unichar gunichar ch")
+;;; 30-Oct-19 (CFNC "PangoScript pango_script_for_unichar gunichar ch")
(CFNC "PangoScriptIter* pango_script_iter_new char* text int length")
(CFNC "void pango_script_iter_get_range PangoScriptIter* iter char** [start] char** [end] PangoScript* [script]" 'const)
(CFNC "gboolean pango_script_iter_next PangoScriptIter* iter")
diff --git a/xg.c b/xg.c
index f8d9c88..03d6252 100644
--- a/xg.c
+++ b/xg.c
@@ -204,7 +204,7 @@ static void define_xm_obj(void)
#define Xg_field_pre "F"
#endif
-static Xen xg_GtkTreeListRow__symbol, xg_GtkTreeListModel__symbol, xg_GtkText__symbol, xg_GtkSortListModel__symbol, xg_GtkSliceListModel__symbol, xg_GtkSingleSelection__symbol, xg_GtkPasswordEntry__symbol, xg_GtkMapListModel__symbol, xg_GtkLayoutChild__symbol, xg_GtkGridLayoutChild__symbol, xg_GtkGridLayout__symbol, xg_GtkFlattenListModel__symbol, xg_GtkFilterListModel__symbol, xg_GtkCustomAllocateFunc_symbol, xg_GtkCustomMeasureFunc_symbol, xg_GtkCustomRequestModeFunc_symbol, xg_GtkBoxLayout__symbol, xg_GVariant__symbol, xg_GtkPickFlags_symbol, xg_GtkOverflow_symbol, xg_graphene_point_t__symbol, xg_graphene_matrix_t__symbol, xg_GtkRoot__symbol, xg_GtkWidgetClass__symbol, xg_GtkLayoutManager__symbol, xg_GtkSelectionModel__symbol, xg_GtkStackPage__symbol, xg_GtkPopoverMenu__symbol, xg_GtkNotebookPage__symbol, xg_GskTransform__symbol, xg_GtkEventControllerMotion__symbol, xg_GtkEventControllerKey__symbol, xg_GParamSpec__symbol, xg_GObjectClass__symbol, xg_float_symbol, xg_GListModel__symbol, xg_GtkAssistantPage__symbol, xg_GtkAllocation__symbol, xg_GActionGroup__symbol, xg_GtkWidgetPaintable__symbol, xg_GtkVideo__symbol, xg_GtkPicture__symbol, xg_gint64_symbol, xg_GtkMediaFile__symbol, xg_GtkMediaControls__symbol, xg_GtkMediaStream__symbol, xg_GdkTimeCoord___symbol, xg_GdkAxisUse_symbol, xg_GtkGestureStylus__symbol, xg_GtkPropagationPhase_symbol, xg_GdkPaintableFlags_symbol, xg_GdkGLTexture__symbol, xg_GdkDrag__symbol, xg_GdkDrop__symbol, xg_GdkMemoryFormat_symbol, xg_GdkWMFunction_symbol, xg_GdkWMDecoration_symbol, xg_GdkAnchorHints_symbol, xg_GdkSurfaceHints_symbol, xg_GdkGeometry__symbol, xg_GdkSurfaceEdge_symbol, xg_GdkWMDecoration__symbol, xg_GdkVulkanContext__symbol, xg_GdkSurfaceTypeHint_symbol, xg_GdkSurfaceType_symbol, xg_GdkSurfaceState_symbol, xg_GdkFullscreenMode_symbol, xg_GdkFrameClock__symbol, xg_GdkCairoContext__symbol, xg_GdkSurface__symbol, xg_GMenu__symbol, xg_GtkApplicationInhibitFlags_symbol, xg_GApplicationFlags_symbol, xg_GtkDestDefaults_symbol, xg_GdkPaintable__symbol, xg_GdkAtom__symbol, xg_GtkIconSize_symbol, xg_GdkDragAction_symbol, xg_GdkCursor__symbol, xg_GBytes__symbol, xg_GInputStream__symbol, xg_GdkContentDeserializer__symbol, xg_GdkContentSerializer__symbol, xg_GOutputStream__symbol, xg_GdkContentFormatsBuilder__symbol, xg_GString__symbol, xg_GdkTexture__symbol, xg_GAsyncResult__symbol, xg_GAsyncReadyCallback_symbol, xg_GCancellable__symbol, xg_GdkContentProvider__symbol, xg_GdkContentFormats__symbol, xg_GdkClipboard__symbol, xg_GdkAppLaunchContext__symbol, xg_GtkEventControllerScroll__symbol, xg_GtkEventControllerScrollFlags_symbol, xg_GtkEventController__symbol, xg_GdkTouchpadGesturePhase_symbol, xg_GdkNotifyType_symbol, xg_GdkCrossingMode_symbol, xg_GtkCssProvider__symbol, xg_GtkStyleContextPrintFlags_symbol, xg_GtkCssSection__symbol, xg_GtkStyleProvider__symbol, xg_GtkScrollbar__symbol, xg_GtkCenterBox__symbol, xg_GtkCheckButton__symbol, xg_GtkDrawingAreaDrawFunc_symbol, xg_GtkShortcutLabel__symbol, xg_GtkPadActionType_symbol, xg_GtkPadActionEntry__symbol, xg_GtkPadController__symbol, xg_GdkGravity_symbol, xg_GdkDevicePadFeature_symbol, xg_GdkDevicePad__symbol, xg_GdkSubpixelLayout_symbol, xg_GdkMonitor__symbol, xg_GdkDeviceTool__symbol, xg_GdkAxisFlags_symbol, xg_GdkSeatCapabilities_symbol, xg_GdkSeat__symbol, xg_GtkPopoverConstraint_symbol, xg_GtkShortcutsWindow__symbol, xg_GtkStackSidebar__symbol, xg_GtkStyleContext__symbol, xg_GdkGLContext__symbol, xg_GtkGLArea__symbol, xg_GtkGestureZoom__symbol, xg_GtkGestureSwipe__symbol, xg_GtkGestureSingle__symbol, xg_GtkGestureRotate__symbol, xg_GtkGestureMultiPress__symbol, xg_GtkGesturePan__symbol, xg_GtkGestureDrag__symbol, xg_GdkEventSequence__symbol, xg_GtkEventSequenceState_symbol, xg_GtkGesture__symbol, xg_GtkPopover__symbol, xg_GtkActionBar__symbol, xg_GtkFlowBox__symbol, xg_GtkFlowBoxChild__symbol, xg_GdkEventType_symbol, xg_GtkSearchBar__symbol, xg_GtkListBox__symbol, xg_GtkListBoxRow__symbol, xg_GtkHeaderBar__symbol, xg_GtkRevealerTransitionType_symbol, xg_GtkRevealer__symbol, xg_GtkStackTransitionType_symbol, xg_GtkStack__symbol, xg_GtkStackSwitcher__symbol, xg_GtkBaselinePosition_symbol, xg_GtkInputHints_symbol, xg_GtkInputPurpose_symbol, xg_GtkLevelBarMode_symbol, xg_GtkLevelBar__symbol, xg_GtkMenuButton__symbol, xg_GtkColorChooser__symbol, xg_GtkApplicationWindow__symbol, xg_GtkApplication__symbol, xg_GMenuModel__symbol, xg_guint___symbol, xg_GdkModifierIntent_symbol, xg_GtkFontChooser__symbol, xg_GdkScrollDirection_symbol, xg_GtkOverlay__symbol, xg_GtkWidgetPath__symbol, xg_GtkStateFlags_symbol, xg_GtkToolShell__symbol, xg_GtkWindowGroup__symbol, xg_GIcon__symbol, xg_GtkOrientable__symbol, xg_GtkCellArea__symbol, xg_GtkBorder__symbol, xg_GtkSwitch__symbol, xg_GtkScrollablePolicy_symbol, xg_GtkScrollable__symbol, xg_GtkGrid__symbol, xg_GdkRGBA__symbol, xg_GtkComboBoxText__symbol, xg_GtkAlign_symbol, xg_GtkSizeRequestMode_symbol, xg_cairo_region_overlap_t_symbol, xg_cairo_rectangle_int_t__symbol, xg_double__symbol, xg_cairo_rectangle_t__symbol, xg_cairo_device_t__symbol, xg_cairo_bool_t_symbol, xg_cairo_text_cluster_flags_t__symbol, xg_cairo_text_cluster_t___symbol, xg_cairo_glyph_t___symbol, xg_cairo_text_cluster_flags_t_symbol, xg_cairo_text_cluster_t__symbol, xg_cairo_region_t__symbol, xg_GtkMessageDialog__symbol, xg_GdkDevice__symbol, xg_GtkAccessible__symbol, xg_GdkModifierType__symbol, xg_GtkPackType_symbol, xg_GtkSpinner__symbol, xg_GtkEntryBuffer__symbol, xg_GtkMessageType_symbol, xg_GtkInfoBar__symbol, xg_GtkEntryIconPosition_symbol, xg_GFile__symbol, xg_GtkSensitivityType_symbol, xg_GdkAtom_symbol, xg_GtkScaleButton__symbol, xg_GtkCalendarDetailFunc_symbol, xg_GtkTooltip__symbol, xg_cairo_rectangle_list_t__symbol, xg_void__symbol, xg_cairo_filter_t_symbol, xg_cairo_extend_t_symbol, xg_cairo_format_t_symbol, xg_cairo_path_t__symbol, xg_cairo_destroy_func_t_symbol, xg_cairo_user_data_key_t__symbol, xg_cairo_text_extents_t__symbol, xg_cairo_font_extents_t__symbol, xg_cairo_font_face_t__symbol, xg_cairo_glyph_t__symbol, xg_cairo_scaled_font_t__symbol, xg_cairo_font_weight_t_symbol, xg_cairo_font_slant_t_symbol, xg_cairo_hint_metrics_t_symbol, xg_cairo_hint_style_t_symbol, xg_cairo_subpixel_order_t_symbol, xg_cairo_status_t_symbol, xg_bool_symbol, xg_cairo_matrix_t__symbol, xg_cairo_line_join_t_symbol, xg_cairo_line_cap_t_symbol, xg_cairo_fill_rule_t_symbol, xg_cairo_antialias_t_symbol, xg_cairo_operator_t_symbol, xg_cairo_pattern_t__symbol, xg_cairo_content_t_symbol, xg_GtkPageSet_symbol, xg_GtkPageRange__symbol, xg_GtkPrintPages_symbol, xg_GtkPrintQuality_symbol, xg_GtkPrintDuplex_symbol, xg_GtkPaperSize__symbol, xg_GtkPageOrientation_symbol, xg_GtkPrintSettingsFunc_symbol, xg_GtkPageSetupDoneFunc_symbol, xg_GtkPrintStatus_symbol, xg_GtkPrintOperationAction_symbol, xg_GtkPrintOperationResult_symbol, xg_GtkUnit_symbol, xg_GtkPrintSettings__symbol, xg_GtkPrintOperation__symbol, xg_GtkPageSetup__symbol, xg_GtkPrintContext__symbol, xg_cairo_surface_t__symbol, xg_GtkTreeViewGridLines_symbol, xg_GtkRecentData__symbol, xg_time_t_symbol, xg_GtkRecentInfo__symbol, xg_GtkRecentManager__symbol, xg_GtkLinkButton__symbol, xg_GtkAssistantPageType_symbol, xg_GtkAssistantPageFunc_symbol, xg_GtkAssistant__symbol, xg_GDestroyNotify_symbol, xg_GtkTreeViewSearchPositionFunc_symbol, xg_GtkIconViewDropPosition_symbol, xg_GValue__symbol, xg_GLogFunc_symbol, xg_PangoMatrix__symbol, xg_PangoRenderPart_symbol, xg_PangoRenderer__symbol, xg_GtkMenuToolButton__symbol, xg_GtkFileChooserButton__symbol, xg_PangoScriptIter__symbol, xg_PangoScript_symbol, xg_PangoAttrFilterFunc_symbol, xg_PangoEllipsizeMode_symbol, xg_GtkIconViewForeachFunc_symbol, xg_GtkAboutDialog__symbol, xg_GtkTreeViewRowSeparatorFunc_symbol, xg_GtkCellView__symbol, xg_GtkAccelMap__symbol, xg_GtkOrientation_symbol, xg_GtkToolButton__symbol, xg_GtkIconLookupFlags_symbol, xg_GtkIconInfo__symbol, xg_gchar___symbol, xg_GtkIconTheme__symbol, xg_GtkFileChooser__symbol, xg_GtkCellLayoutDataFunc_symbol, xg_GtkCellLayout__symbol, xg_GtkFileFilterFunc_symbol, xg_GtkFileFilterFlags_symbol, xg_GtkFileFilter__symbol, xg_GSourceFunc_symbol, xg_GtkToggleToolButton__symbol, xg_GtkSeparatorToolItem__symbol, xg_GtkRadioToolButton__symbol, xg_GtkEntryCompletionMatchFunc_symbol, xg_GtkFontButton__symbol, xg_GtkExpander__symbol, xg_GtkComboBox__symbol, xg_GtkTreeModelFilter__symbol, xg_GtkFileChooserAction_symbol, xg_GtkToolItem__symbol, xg_GtkCalendarDisplayOptions_symbol, xg_GdkDisplay__symbol, xg_PangoLayoutRun__symbol, xg_PangoLayoutIter__symbol, xg_PangoLayoutLine__symbol, xg_int__symbol, xg_PangoAlignment_symbol, xg_PangoWrapMode_symbol, xg_PangoItem__symbol, xg_PangoGlyphString__symbol, xg_PangoFontMap__symbol, xg_PangoGlyph_symbol, xg_PangoFontFace__symbol, xg_PangoFontFace___symbol, xg_PangoFontFamily__symbol, xg_PangoFontMask_symbol, xg_PangoFontDescription___symbol, xg_PangoCoverageLevel_symbol, xg_PangoCoverage__symbol, xg_PangoFontMetrics__symbol, xg_PangoFontset__symbol, xg_PangoFont__symbol, xg_PangoFontFamily___symbol, xg_PangoLogAttr__symbol, xg_PangoAnalysis__symbol, xg_PangoAttrList___symbol, xg_PangoAttrIterator__symbol, xg_PangoRectangle__symbol, xg_PangoUnderline_symbol, xg_PangoStretch_symbol, xg_PangoVariant_symbol, xg_PangoWeight_symbol, xg_PangoStyle_symbol, xg_guint16_symbol, xg_PangoAttribute__symbol, xg_PangoAttrType_symbol, xg_PangoColor__symbol, xg_GtkWindowPosition_symbol, xg_GtkWindowType_symbol, xg_GtkWindow__symbol, xg_GtkTextDirection_symbol, xg_PangoContext__symbol, xg_AtkObject__symbol, xg_GtkDirectionType_symbol, xg_GtkViewport__symbol, xg_GtkTreeViewSearchEqualFunc_symbol, xg_GtkTreeViewDropPosition_symbol, xg_GtkTreeViewMappingFunc_symbol, xg_GtkTreeViewColumnDropFunc_symbol, xg_GtkTreeViewColumnSizing_symbol, xg_GtkTreeCellDataFunc_symbol, xg_GtkTreeStore__symbol, xg_GtkTreeIterCompareFunc_symbol, xg_GtkSortType_symbol, xg_GtkTreeSortable__symbol, xg_GtkTreeSelectionForeachFunc_symbol, xg_GtkTreeModel___symbol, xg_GtkTreeSelectionFunc_symbol, xg_GtkSelectionMode_symbol, xg_GtkTreeModelSort__symbol, xg_GtkTreeModelForeachFunc_symbol, xg_GtkTreeModelFlags_symbol, xg_GtkTreeRowReference__symbol, xg_GtkTreeDragDest__symbol, xg_GtkTreeDragSource__symbol, xg_GtkToolbarStyle_symbol, xg_GtkToolbar__symbol, xg_GtkToggleButton__symbol, xg_PangoTabArray__symbol, xg_GtkWrapMode_symbol, xg_GtkTextWindowType_symbol, xg_GtkTextView__symbol, xg_GtkTextTagTableForeach_symbol, xg_GtkTextSearchFlags_symbol, xg_GtkTextCharPredicate_symbol, xg_GtkTextMark__symbol, xg_GtkTextChildAnchor__symbol, xg_GtkTextIter__symbol, xg_GtkTextTagTable__symbol, xg_GtkTextBuffer__symbol, xg_GtkStatusbar__symbol, xg_GtkSpinType_symbol, xg_GtkSpinButtonUpdatePolicy_symbol, xg_GtkSpinButton__symbol, xg_GtkSizeGroupMode_symbol, xg_GtkSizeGroup__symbol, xg_GtkSettings__symbol, xg_GtkSelectionData__symbol, xg_GtkCornerType_symbol, xg_GtkPolicyType_symbol, xg_GtkScrolledWindow__symbol, xg_GtkScale__symbol, xg_GtkRange__symbol, xg_GtkRadioMenuItem__symbol, xg_GtkRadioButton__symbol, xg_GtkProgressBar__symbol, xg_GtkPaned__symbol, xg_GtkPositionType_symbol, xg_GtkNotebook__symbol, xg_GtkMenuShell__symbol, xg_gint__symbol, xg_GtkMenuItem__symbol, xg_GtkMenu__symbol, xg_PangoLanguage__symbol, xg_GtkListStore__symbol, xg_PangoLayout__symbol, xg_GtkJustification_symbol, xg_GtkLabel__symbol, xg_guint16__symbol, xg_GtkIMContextSimple__symbol, xg_GdkEventKey__symbol, xg_PangoAttrList__symbol, xg_GtkIMContext__symbol, xg_GtkImageType_symbol, xg_GtkImage__symbol, xg_GtkShadowType_symbol, xg_GtkFrame__symbol, xg_GtkFixed__symbol, xg_GtkEntry__symbol, xg_GtkEditable__symbol, xg_etc_symbol, xg_GtkDialog__symbol, xg_GList__symbol, xg_GtkCallback_symbol, xg_GtkContainer__symbol, xg_GtkCheckMenuItem__symbol, xg_GtkCellRendererToggle__symbol, xg_GtkCellRendererText__symbol, xg_GtkCellRendererState_symbol, xg_GtkCellEditable__symbol, xg_GtkCalendar__symbol, xg_GtkReliefStyle_symbol, xg_GtkButton__symbol, xg_GtkBox__symbol, xg_GtkBin__symbol, xg_GtkBindingSet__symbol, xg_GtkAspectFrame__symbol, xg_GtkAdjustment__symbol, xg_GtkAccelMapForeach_symbol, xg_GtkAccelLabel__symbol, xg_GtkAccelGroupEntry__symbol, xg_lambda3_symbol, xg_GSList__symbol, xg_GObject__symbol, xg_GtkAccelFlags_symbol, xg_GtkAccelGroup__symbol, xg_GdkInterpType_symbol, xg_double_symbol, xg_gfloat_symbol, xg_guchar_symbol, xg_char___symbol, xg_GdkPixbufDestroyNotify_symbol, xg_GError__symbol, xg_char__symbol, xg_guchar__symbol, xg_GdkPixbuf__symbol, xg_GdkColorspace_symbol, xg_PangoDirection_symbol, xg_GdkKeymapKey__symbol, xg_GdkKeymap__symbol, xg_GdkRectangle__symbol, xg_gdouble_symbol, xg_guint32_symbol, xg_GSignalMatchType_symbol, xg_GConnectFlags_symbol, xg_GtkDestroyNotify_symbol, xg_GSignalEmissionHook_symbol, xg_gulong_symbol, xg_GSignalInvocationHint__symbol, xg_GQuark_symbol, xg_guint__symbol, xg_GSignalQuery__symbol, xg_GType__symbol, xg_GSignalCMarshaller_symbol, xg_gpointer_symbol, xg_GSignalAccumulator_symbol, xg_GSignalFlags_symbol, xg_GType_symbol, xg_GClosureNotify_symbol, xg_GCallback_symbol, xg_GNormalizeMode_symbol, xg_glong_symbol, xg_gssize_symbol, xg_gsize_symbol, xg_gunichar__symbol, xg_void_symbol, xg_int_symbol, xg_GtkDrawingArea__symbol, xg_GLogLevelFlags_symbol, xg_GtkIconView__symbol, xg_GtkEntryCompletion__symbol, xg_GtkFileFilterInfo__symbol, xg_GtkTreeSelection__symbol, xg_GtkCellRenderer__symbol, xg_gint_symbol, xg_GtkTreeViewColumn__symbol, xg_GtkTreeView__symbol, xg_gunichar_symbol, xg_GtkTreeIter__symbol, xg_GtkTreePath__symbol, xg_GtkTreeModel__symbol, xg_gboolean_symbol, xg_GdkModifierType_symbol, xg_guint_symbol, xg_gchar__symbol, xg_GtkTextTag__symbol, xg_GtkWidget__symbol, xg_lambda_data_symbol, xg_GClosure__symbol, xg_GtkAccelKey__symbol, xg_GdkEventMotion__symbol, xg_gdouble__symbol, xg_GdkEventAny__symbol, xg_GdkEvent__symbol, xg_cairo_t__symbol, xg_cairo_font_options_t__symbol, xg_PangoFontDescription__symbol, xg_GtkMenuBar__symbol, xg_GtkEventControllerLegacy__symbol, xg_GtkCellRendererPixbuf__symbol, xg_GtkSeparator__symbol, xg_GtkSeparatorMenuItem__symbol, xg_GdkEventExpose__symbol, xg_GdkEventNoExpose__symbol, xg_GdkEventVisibility__symbol, xg_GdkEventButton__symbol, xg_GdkEventCrossing__symbol, xg_GdkEventFocus__symbol, xg_GdkEventConfigure__symbol, xg_GdkEventProperty__symbol, xg_GdkEventSelection__symbol, xg_GdkEventProximity__symbol, xg_GdkEventSetting__symbol, xg_GdkEventWindowState__symbol, xg_GdkEventDND__symbol, xg_GtkFileChooserDialog__symbol, xg_GtkFileChooserWidget__symbol, xg_GtkColorButton__symbol, xg_GtkAccelMap_symbol, xg_GtkCellRendererCombo__symbol, xg_GtkCellRendererProgress__symbol, xg_GtkCellRendererAccel__symbol, xg_GtkCellRendererSpin__symbol, xg_GtkCellRendererSpinner__symbol, xg_GtkFontChooserDialog__symbol, xg_GtkFontChooserWidget__symbol, xg_GtkColorChooserDialog__symbol, xg_GtkColorWidget__symbol, xg_GtkGestureLongPress__symbol, xg_idler_symbol;
+static Xen xg_GtkTreeListRow__symbol, xg_GtkTreeListModel__symbol, xg_GtkText__symbol, xg_GtkSortListModel__symbol, xg_GtkSliceListModel__symbol, xg_GtkSingleSelection__symbol, xg_GtkPasswordEntry__symbol, xg_GtkMapListModel__symbol, xg_GtkLayoutChild__symbol, xg_GtkGridLayoutChild__symbol, xg_GtkGridLayout__symbol, xg_GtkFlattenListModel__symbol, xg_GtkFilterListModel__symbol, xg_GtkCustomAllocateFunc_symbol, xg_GtkCustomMeasureFunc_symbol, xg_GtkCustomRequestModeFunc_symbol, xg_GtkBoxLayout__symbol, xg_GVariant__symbol, xg_GtkPickFlags_symbol, xg_GtkOverflow_symbol, xg_graphene_point_t__symbol, xg_graphene_matrix_t__symbol, xg_GtkRoot__symbol, xg_GtkWidgetClass__symbol, xg_GtkLayoutManager__symbol, xg_GtkSelectionModel__symbol, xg_GtkStackPage__symbol, xg_GtkPopoverMenu__symbol, xg_GtkNotebookPage__symbol, xg_GskTransform__symbol, xg_GtkEventControllerMotion__symbol, xg_GtkEventControllerKey__symbol, xg_GParamSpec__symbol, xg_GObjectClass__symbol, xg_float_symbol, xg_GListModel__symbol, xg_GtkAssistantPage__symbol, xg_GtkAllocation__symbol, xg_GActionGroup__symbol, xg_GtkWidgetPaintable__symbol, xg_GtkVideo__symbol, xg_GtkPicture__symbol, xg_gint64_symbol, xg_GtkMediaFile__symbol, xg_GtkMediaControls__symbol, xg_GtkMediaStream__symbol, xg_GdkTimeCoord___symbol, xg_GdkAxisUse_symbol, xg_GtkGestureStylus__symbol, xg_GtkPropagationPhase_symbol, xg_GdkPaintableFlags_symbol, xg_GdkGLTexture__symbol, xg_GdkDrag__symbol, xg_GdkDrop__symbol, xg_GdkMemoryFormat_symbol, xg_GdkWMFunction_symbol, xg_GdkWMDecoration_symbol, xg_GdkAnchorHints_symbol, xg_GdkSurfaceHints_symbol, xg_GdkGeometry__symbol, xg_GdkSurfaceEdge_symbol, xg_GdkWMDecoration__symbol, xg_GdkVulkanContext__symbol, xg_GdkSurfaceTypeHint_symbol, xg_GdkSurfaceType_symbol, xg_GdkSurfaceState_symbol, xg_GdkFullscreenMode_symbol, xg_GdkFrameClock__symbol, xg_GdkCairoContext__symbol, xg_GdkSurface__symbol, xg_GMenu__symbol, xg_GtkApplicationInhibitFlags_symbol, xg_GApplicationFlags_symbol, xg_GtkDestDefaults_symbol, xg_GdkPaintable__symbol, xg_GdkAtom__symbol, xg_GtkIconSize_symbol, xg_GdkDragAction_symbol, xg_GdkCursor__symbol, xg_GBytes__symbol, xg_GInputStream__symbol, xg_GdkContentDeserializer__symbol, xg_GdkContentSerializer__symbol, xg_GOutputStream__symbol, xg_GdkContentFormatsBuilder__symbol, xg_GString__symbol, xg_GdkTexture__symbol, xg_GAsyncResult__symbol, xg_GAsyncReadyCallback_symbol, xg_GCancellable__symbol, xg_GdkContentProvider__symbol, xg_GdkContentFormats__symbol, xg_GdkClipboard__symbol, xg_GdkAppLaunchContext__symbol, xg_GtkEventControllerScroll__symbol, xg_GtkEventControllerScrollFlags_symbol, xg_GtkEventController__symbol, xg_GdkTouchpadGesturePhase_symbol, xg_GdkNotifyType_symbol, xg_GdkCrossingMode_symbol, xg_GtkCssProvider__symbol, xg_GtkStyleContextPrintFlags_symbol, xg_GtkCssSection__symbol, xg_GtkStyleProvider__symbol, xg_GtkScrollbar__symbol, xg_GtkCenterBox__symbol, xg_GtkCheckButton__symbol, xg_GtkDrawingAreaDrawFunc_symbol, xg_GtkShortcutLabel__symbol, xg_GtkPadActionType_symbol, xg_GtkPadActionEntry__symbol, xg_GtkPadController__symbol, xg_GdkGravity_symbol, xg_GdkDevicePadFeature_symbol, xg_GdkDevicePad__symbol, xg_GdkSubpixelLayout_symbol, xg_GdkMonitor__symbol, xg_GdkDeviceTool__symbol, xg_GdkAxisFlags_symbol, xg_GdkSeatCapabilities_symbol, xg_GdkSeat__symbol, xg_GtkPopoverConstraint_symbol, xg_GtkShortcutsWindow__symbol, xg_GtkStackSidebar__symbol, xg_GtkStyleContext__symbol, xg_GdkGLContext__symbol, xg_GtkGLArea__symbol, xg_GtkGestureZoom__symbol, xg_GtkGestureSwipe__symbol, xg_GtkGestureSingle__symbol, xg_GtkGestureRotate__symbol, xg_GtkGestureMultiPress__symbol, xg_GtkGesturePan__symbol, xg_GtkGestureDrag__symbol, xg_GdkEventSequence__symbol, xg_GtkEventSequenceState_symbol, xg_GtkGesture__symbol, xg_GtkPopover__symbol, xg_GtkActionBar__symbol, xg_GtkFlowBox__symbol, xg_GtkFlowBoxChild__symbol, xg_GdkEventType_symbol, xg_GtkSearchBar__symbol, xg_GtkListBox__symbol, xg_GtkListBoxRow__symbol, xg_GtkHeaderBar__symbol, xg_GtkRevealerTransitionType_symbol, xg_GtkRevealer__symbol, xg_GtkStackTransitionType_symbol, xg_GtkStack__symbol, xg_GtkStackSwitcher__symbol, xg_GtkBaselinePosition_symbol, xg_GtkInputHints_symbol, xg_GtkInputPurpose_symbol, xg_GtkLevelBarMode_symbol, xg_GtkLevelBar__symbol, xg_GtkMenuButton__symbol, xg_GtkColorChooser__symbol, xg_GtkApplicationWindow__symbol, xg_GtkApplication__symbol, xg_GMenuModel__symbol, xg_guint___symbol, xg_GdkModifierIntent_symbol, xg_GtkFontChooser__symbol, xg_GdkScrollDirection_symbol, xg_GtkOverlay__symbol, xg_GtkWidgetPath__symbol, xg_GtkStateFlags_symbol, xg_GtkToolShell__symbol, xg_GtkWindowGroup__symbol, xg_GIcon__symbol, xg_GtkOrientable__symbol, xg_GtkCellArea__symbol, xg_GtkBorder__symbol, xg_GtkSwitch__symbol, xg_GtkScrollablePolicy_symbol, xg_GtkScrollable__symbol, xg_GtkGrid__symbol, xg_GdkRGBA__symbol, xg_GtkComboBoxText__symbol, xg_GtkAlign_symbol, xg_GtkSizeRequestMode_symbol, xg_cairo_region_overlap_t_symbol, xg_cairo_rectangle_int_t__symbol, xg_double__symbol, xg_cairo_rectangle_t__symbol, xg_cairo_device_t__symbol, xg_cairo_bool_t_symbol, xg_cairo_text_cluster_flags_t__symbol, xg_cairo_text_cluster_t___symbol, xg_cairo_glyph_t___symbol, xg_cairo_text_cluster_flags_t_symbol, xg_cairo_text_cluster_t__symbol, xg_cairo_region_t__symbol, xg_GtkMessageDialog__symbol, xg_GdkDevice__symbol, xg_GtkAccessible__symbol, xg_GdkModifierType__symbol, xg_GtkPackType_symbol, xg_GtkSpinner__symbol, xg_GtkEntryBuffer__symbol, xg_GtkMessageType_symbol, xg_GtkInfoBar__symbol, xg_GtkEntryIconPosition_symbol, xg_GFile__symbol, xg_GtkSensitivityType_symbol, xg_GdkAtom_symbol, xg_GtkScaleButton__symbol, xg_GtkCalendarDetailFunc_symbol, xg_GtkTooltip__symbol, xg_cairo_rectangle_list_t__symbol, xg_void__symbol, xg_cairo_filter_t_symbol, xg_cairo_extend_t_symbol, xg_cairo_format_t_symbol, xg_cairo_path_t__symbol, xg_cairo_destroy_func_t_symbol, xg_cairo_user_data_key_t__symbol, xg_cairo_text_extents_t__symbol, xg_cairo_font_extents_t__symbol, xg_cairo_font_face_t__symbol, xg_cairo_glyph_t__symbol, xg_cairo_scaled_font_t__symbol, xg_cairo_font_weight_t_symbol, xg_cairo_font_slant_t_symbol, xg_cairo_hint_metrics_t_symbol, xg_cairo_hint_style_t_symbol, xg_cairo_subpixel_order_t_symbol, xg_cairo_status_t_symbol, xg_bool_symbol, xg_cairo_matrix_t__symbol, xg_cairo_line_join_t_symbol, xg_cairo_line_cap_t_symbol, xg_cairo_fill_rule_t_symbol, xg_cairo_antialias_t_symbol, xg_cairo_operator_t_symbol, xg_cairo_pattern_t__symbol, xg_cairo_content_t_symbol, xg_GtkPageSet_symbol, xg_GtkPageRange__symbol, xg_GtkPrintPages_symbol, xg_GtkPrintQuality_symbol, xg_GtkPrintDuplex_symbol, xg_GtkPaperSize__symbol, xg_GtkPageOrientation_symbol, xg_GtkPrintSettingsFunc_symbol, xg_GtkPageSetupDoneFunc_symbol, xg_GtkPrintStatus_symbol, xg_GtkPrintOperationAction_symbol, xg_GtkPrintOperationResult_symbol, xg_GtkUnit_symbol, xg_GtkPrintSettings__symbol, xg_GtkPrintOperation__symbol, xg_GtkPageSetup__symbol, xg_GtkPrintContext__symbol, xg_cairo_surface_t__symbol, xg_GtkTreeViewGridLines_symbol, xg_GtkRecentData__symbol, xg_time_t_symbol, xg_GtkRecentInfo__symbol, xg_GtkRecentManager__symbol, xg_GtkLinkButton__symbol, xg_GtkAssistantPageType_symbol, xg_GtkAssistantPageFunc_symbol, xg_GtkAssistant__symbol, xg_GDestroyNotify_symbol, xg_GtkTreeViewSearchPositionFunc_symbol, xg_GtkIconViewDropPosition_symbol, xg_GValue__symbol, xg_GLogFunc_symbol, xg_PangoMatrix__symbol, xg_PangoRenderPart_symbol, xg_PangoRenderer__symbol, xg_GtkMenuToolButton__symbol, xg_GtkFileChooserButton__symbol, xg_PangoScript_symbol, xg_PangoScriptIter__symbol, xg_PangoAttrFilterFunc_symbol, xg_PangoEllipsizeMode_symbol, xg_GtkIconViewForeachFunc_symbol, xg_GtkAboutDialog__symbol, xg_GtkTreeViewRowSeparatorFunc_symbol, xg_GtkCellView__symbol, xg_GtkAccelMap__symbol, xg_GtkOrientation_symbol, xg_GtkToolButton__symbol, xg_GtkIconLookupFlags_symbol, xg_GtkIconInfo__symbol, xg_gchar___symbol, xg_GtkIconTheme__symbol, xg_GtkFileChooser__symbol, xg_GtkCellLayoutDataFunc_symbol, xg_GtkCellLayout__symbol, xg_GtkFileFilterFunc_symbol, xg_GtkFileFilterFlags_symbol, xg_GtkFileFilter__symbol, xg_GSourceFunc_symbol, xg_GtkToggleToolButton__symbol, xg_GtkSeparatorToolItem__symbol, xg_GtkRadioToolButton__symbol, xg_GtkEntryCompletionMatchFunc_symbol, xg_GtkFontButton__symbol, xg_GtkExpander__symbol, xg_GtkComboBox__symbol, xg_GtkTreeModelFilter__symbol, xg_GtkFileChooserAction_symbol, xg_GtkToolItem__symbol, xg_GtkCalendarDisplayOptions_symbol, xg_GdkDisplay__symbol, xg_PangoLayoutRun__symbol, xg_PangoLayoutIter__symbol, xg_PangoLayoutLine__symbol, xg_int__symbol, xg_PangoAlignment_symbol, xg_PangoWrapMode_symbol, xg_PangoItem__symbol, xg_PangoAnalysis__symbol, xg_PangoGlyphString__symbol, xg_PangoFontMap__symbol, xg_PangoGlyph_symbol, xg_PangoFontFace__symbol, xg_PangoFontFace___symbol, xg_PangoFontFamily__symbol, xg_PangoFontMask_symbol, xg_PangoFontDescription___symbol, xg_PangoCoverageLevel_symbol, xg_PangoCoverage__symbol, xg_PangoFontMetrics__symbol, xg_PangoFontset__symbol, xg_PangoFont__symbol, xg_PangoFontFamily___symbol, xg_PangoLogAttr__symbol, xg_PangoAttrList___symbol, xg_PangoAttrIterator__symbol, xg_PangoRectangle__symbol, xg_PangoUnderline_symbol, xg_PangoStretch_symbol, xg_PangoVariant_symbol, xg_PangoWeight_symbol, xg_PangoStyle_symbol, xg_guint16_symbol, xg_PangoAttribute__symbol, xg_PangoAttrType_symbol, xg_PangoColor__symbol, xg_GtkWindowPosition_symbol, xg_GtkWindowType_symbol, xg_GtkWindow__symbol, xg_GtkTextDirection_symbol, xg_PangoContext__symbol, xg_AtkObject__symbol, xg_GtkDirectionType_symbol, xg_GtkViewport__symbol, xg_GtkTreeViewSearchEqualFunc_symbol, xg_GtkTreeViewDropPosition_symbol, xg_GtkTreeViewMappingFunc_symbol, xg_GtkTreeViewColumnDropFunc_symbol, xg_GtkTreeViewColumnSizing_symbol, xg_GtkTreeCellDataFunc_symbol, xg_GtkTreeStore__symbol, xg_GtkTreeIterCompareFunc_symbol, xg_GtkSortType_symbol, xg_GtkTreeSortable__symbol, xg_GtkTreeSelectionForeachFunc_symbol, xg_GtkTreeModel___symbol, xg_GtkTreeSelectionFunc_symbol, xg_GtkSelectionMode_symbol, xg_GtkTreeModelSort__symbol, xg_GtkTreeModelForeachFunc_symbol, xg_GtkTreeModelFlags_symbol, xg_GtkTreeRowReference__symbol, xg_GtkTreeDragDest__symbol, xg_GtkTreeDragSource__symbol, xg_GtkToolbarStyle_symbol, xg_GtkToolbar__symbol, xg_GtkToggleButton__symbol, xg_PangoTabArray__symbol, xg_GtkWrapMode_symbol, xg_GtkTextWindowType_symbol, xg_GtkTextView__symbol, xg_GtkTextTagTableForeach_symbol, xg_GtkTextSearchFlags_symbol, xg_GtkTextCharPredicate_symbol, xg_GtkTextMark__symbol, xg_GtkTextChildAnchor__symbol, xg_GtkTextIter__symbol, xg_GtkTextTagTable__symbol, xg_GtkTextBuffer__symbol, xg_GtkStatusbar__symbol, xg_GtkSpinType_symbol, xg_GtkSpinButtonUpdatePolicy_symbol, xg_GtkSpinButton__symbol, xg_GtkSizeGroupMode_symbol, xg_GtkSizeGroup__symbol, xg_GtkSettings__symbol, xg_GtkSelectionData__symbol, xg_GtkCornerType_symbol, xg_GtkPolicyType_symbol, xg_GtkScrolledWindow__symbol, xg_GtkScale__symbol, xg_GtkRange__symbol, xg_GtkRadioMenuItem__symbol, xg_GtkRadioButton__symbol, xg_GtkProgressBar__symbol, xg_GtkPaned__symbol, xg_GtkPositionType_symbol, xg_GtkNotebook__symbol, xg_GtkMenuShell__symbol, xg_gint__symbol, xg_GtkMenuItem__symbol, xg_GtkMenu__symbol, xg_PangoLanguage__symbol, xg_GtkListStore__symbol, xg_PangoLayout__symbol, xg_GtkJustification_symbol, xg_GtkLabel__symbol, xg_guint16__symbol, xg_GtkIMContextSimple__symbol, xg_GdkEventKey__symbol, xg_PangoAttrList__symbol, xg_GtkIMContext__symbol, xg_GtkImageType_symbol, xg_GtkImage__symbol, xg_GtkShadowType_symbol, xg_GtkFrame__symbol, xg_GtkFixed__symbol, xg_GtkEntry__symbol, xg_GtkEditable__symbol, xg_etc_symbol, xg_GtkDialog__symbol, xg_GList__symbol, xg_GtkCallback_symbol, xg_GtkContainer__symbol, xg_GtkCheckMenuItem__symbol, xg_GtkCellRendererToggle__symbol, xg_GtkCellRendererText__symbol, xg_GtkCellRendererState_symbol, xg_GtkCellEditable__symbol, xg_GtkCalendar__symbol, xg_GtkReliefStyle_symbol, xg_GtkButton__symbol, xg_GtkBox__symbol, xg_GtkBin__symbol, xg_GtkBindingSet__symbol, xg_GtkAspectFrame__symbol, xg_GtkAdjustment__symbol, xg_GtkAccelMapForeach_symbol, xg_GtkAccelLabel__symbol, xg_GtkAccelGroupEntry__symbol, xg_lambda3_symbol, xg_GSList__symbol, xg_GObject__symbol, xg_GtkAccelFlags_symbol, xg_GtkAccelGroup__symbol, xg_GdkInterpType_symbol, xg_double_symbol, xg_gfloat_symbol, xg_guchar_symbol, xg_char___symbol, xg_GdkPixbufDestroyNotify_symbol, xg_GError__symbol, xg_char__symbol, xg_guchar__symbol, xg_GdkPixbuf__symbol, xg_GdkColorspace_symbol, xg_PangoDirection_symbol, xg_GdkKeymapKey__symbol, xg_GdkKeymap__symbol, xg_GdkRectangle__symbol, xg_gdouble_symbol, xg_guint32_symbol, xg_GSignalMatchType_symbol, xg_GConnectFlags_symbol, xg_GtkDestroyNotify_symbol, xg_GSignalEmissionHook_symbol, xg_gulong_symbol, xg_GSignalInvocationHint__symbol, xg_GQuark_symbol, xg_guint__symbol, xg_GSignalQuery__symbol, xg_GType__symbol, xg_GSignalCMarshaller_symbol, xg_gpointer_symbol, xg_GSignalAccumulator_symbol, xg_GSignalFlags_symbol, xg_GType_symbol, xg_GClosureNotify_symbol, xg_GCallback_symbol, xg_GNormalizeMode_symbol, xg_glong_symbol, xg_gssize_symbol, xg_gsize_symbol, xg_gunichar__symbol, xg_void_symbol, xg_int_symbol, xg_GtkDrawingArea__symbol, xg_GLogLevelFlags_symbol, xg_GtkIconView__symbol, xg_GtkEntryCompletion__symbol, xg_GtkFileFilterInfo__symbol, xg_GtkTreeSelection__symbol, xg_GtkCellRenderer__symbol, xg_gint_symbol, xg_GtkTreeViewColumn__symbol, xg_GtkTreeView__symbol, xg_gunichar_symbol, xg_GtkTreeIter__symbol, xg_GtkTreePath__symbol, xg_GtkTreeModel__symbol, xg_gboolean_symbol, xg_GdkModifierType_symbol, xg_guint_symbol, xg_gchar__symbol, xg_GtkTextTag__symbol, xg_GtkWidget__symbol, xg_lambda_data_symbol, xg_GClosure__symbol, xg_GtkAccelKey__symbol, xg_GdkEventMotion__symbol, xg_gdouble__symbol, xg_GdkEventAny__symbol, xg_GdkEvent__symbol, xg_cairo_t__symbol, xg_cairo_font_options_t__symbol, xg_PangoFontDescription__symbol, xg_GtkMenuBar__symbol, xg_GtkEventControllerLegacy__symbol, xg_GtkCellRendererPixbuf__symbol, xg_GtkSeparator__symbol, xg_GtkSeparatorMenuItem__symbol, xg_GdkEventExpose__symbol, xg_GdkEventNoExpose__symbol, xg_GdkEventVisibility__symbol, xg_GdkEventButton__symbol, xg_GdkEventCrossing__symbol, xg_GdkEventFocus__symbol, xg_GdkEventConfigure__symbol, xg_GdkEventProperty__symbol, xg_GdkEventSelection__symbol, xg_GdkEventProximity__symbol, xg_GdkEventSetting__symbol, xg_GdkEventWindowState__symbol, xg_GdkEventDND__symbol, xg_GtkFileChooserDialog__symbol, xg_GtkFileChooserWidget__symbol, xg_GtkColorButton__symbol, xg_GtkAccelMap_symbol, xg_GtkCellRendererCombo__symbol, xg_GtkCellRendererProgress__symbol, xg_GtkCellRendererAccel__symbol, xg_GtkCellRendererSpin__symbol, xg_GtkCellRendererSpinner__symbol, xg_GtkFontChooserDialog__symbol, xg_GtkFontChooserWidget__symbol, xg_GtkColorChooserDialog__symbol, xg_GtkColorWidget__symbol, xg_GtkGestureLongPress__symbol, xg_idler_symbol;
#define wrap_for_Xen(Name, Value) Xen_list_2(xg_ ## Name ## _symbol, Xen_wrap_C_pointer(Value))
#define is_wrapped(Name, Value) (Xen_is_pair(Value) && (Xen_car(Value) == xg_ ## Name ## _symbol))
@@ -576,7 +576,6 @@ Xm_type_Ptr(PangoAttribute_, PangoAttribute*)
Xm_type_Ptr_1(PangoRectangle_, PangoRectangle*)
Xm_type_Ptr(PangoAttrIterator_, PangoAttrIterator*)
Xm_type_Ptr_1(PangoAttrList__, PangoAttrList**)
-Xm_type_Ptr_1(PangoAnalysis_, PangoAnalysis*)
Xm_type_Ptr(PangoLogAttr_, PangoLogAttr*)
Xm_type_Ptr_2(PangoFontFamily__, PangoFontFamily**)
Xm_type_Ptr(PangoFont_, PangoFont*)
@@ -597,6 +596,7 @@ Xm_type_Ptr(PangoFontFace_, PangoFontFace*)
#define Xen_is_PangoGlyph(Arg) Xen_is_ulong(Arg)
Xm_type_Ptr(PangoFontMap_, PangoFontMap*)
Xm_type_Ptr(PangoGlyphString_, PangoGlyphString*)
+Xm_type_Ptr_1(PangoAnalysis_, PangoAnalysis*)
Xm_type_Ptr(PangoItem_, PangoItem*)
#define C_to_Xen_PangoWrapMode(Arg) C_int_to_Xen_integer(Arg)
#define Xen_to_C_PangoWrapMode(Arg) (PangoWrapMode)(Xen_integer_to_C_int(Arg))
@@ -646,8 +646,8 @@ Xm_type_Ptr_1(GtkAboutDialog_, GtkAboutDialog*)
#define Xen_to_C_PangoEllipsizeMode(Arg) (PangoEllipsizeMode)(Xen_integer_to_C_int(Arg))
#define Xen_is_PangoEllipsizeMode(Arg) Xen_is_integer(Arg)
Xm_type_1(PangoAttrFilterFunc, PangoAttrFilterFunc)
-#define C_to_Xen_PangoScript(Arg) C_int_to_Xen_integer(Arg)
Xm_type_Ptr(PangoScriptIter_, PangoScriptIter*)
+#define C_to_Xen_PangoScript(Arg) C_int_to_Xen_integer(Arg)
Xm_type_Ptr_1(GtkFileChooserButton_, GtkFileChooserButton*)
Xm_type_Ptr_1(GtkMenuToolButton_, GtkMenuToolButton*)
Xm_type_Ptr_1(PangoRenderer_, PangoRenderer*)
@@ -10851,20 +10851,6 @@ PangoAttrList** attr_list, char** text, gunichar* accel_char, GError** [error])"
}
}
-static Xen gxg_pango_break(Xen text, Xen length, Xen analysis, Xen attrs, Xen attrs_len)
-{
- #define H_pango_break "void pango_break(gchar* text, int length, PangoAnalysis* analysis, PangoLogAttr* attrs, \
-int attrs_len)"
- Xen_check_type(Xen_is_gchar_(text), text, 1, "pango_break", "gchar*");
- Xen_check_type(Xen_is_int(length), length, 2, "pango_break", "int");
- Xen_check_type(Xen_is_PangoAnalysis_(analysis), analysis, 3, "pango_break", "PangoAnalysis*");
- Xen_check_type(Xen_is_PangoLogAttr_(attrs), attrs, 4, "pango_break", "PangoLogAttr*");
- Xen_check_type(Xen_is_int(attrs_len), attrs_len, 5, "pango_break", "int");
- pango_break(Xen_to_C_gchar_(text), Xen_to_C_int(length), Xen_to_C_PangoAnalysis_(analysis), Xen_to_C_PangoLogAttr_(attrs),
- Xen_to_C_int(attrs_len));
- return(Xen_false);
-}
-
static Xen gxg_pango_find_paragraph_boundary(Xen text, Xen length, Xen ignore_paragraph_delimiter_index, Xen ignore_next_paragraph_start)
{
#define H_pango_find_paragraph_boundary "void pango_find_paragraph_boundary(gchar* text, gint length, \
@@ -11042,34 +11028,6 @@ static Xen gxg_pango_coverage_set(Xen coverage, Xen index, Xen level)
return(Xen_false);
}
-static Xen gxg_pango_coverage_max(Xen coverage, Xen other)
-{
- #define H_pango_coverage_max "void pango_coverage_max(PangoCoverage* coverage, PangoCoverage* other)"
- Xen_check_type(Xen_is_PangoCoverage_(coverage), coverage, 1, "pango_coverage_max", "PangoCoverage*");
- Xen_check_type(Xen_is_PangoCoverage_(other), other, 2, "pango_coverage_max", "PangoCoverage*");
- pango_coverage_max(Xen_to_C_PangoCoverage_(coverage), Xen_to_C_PangoCoverage_(other));
- return(Xen_false);
-}
-
-static Xen gxg_pango_coverage_to_bytes(Xen coverage, Xen ignore_bytes, Xen ignore_n_bytes)
-{
- #define H_pango_coverage_to_bytes "void pango_coverage_to_bytes(PangoCoverage* coverage, guchar** [bytes], \
-int* [n_bytes])"
- guchar* ref_bytes = NULL;
- int ref_n_bytes;
- Xen_check_type(Xen_is_PangoCoverage_(coverage), coverage, 1, "pango_coverage_to_bytes", "PangoCoverage*");
- pango_coverage_to_bytes(Xen_to_C_PangoCoverage_(coverage), &ref_bytes, &ref_n_bytes);
- return(Xen_list_2(C_to_Xen_guchar_(ref_bytes), C_to_Xen_int(ref_n_bytes)));
-}
-
-static Xen gxg_pango_coverage_from_bytes(Xen bytes, Xen n_bytes)
-{
- #define H_pango_coverage_from_bytes "PangoCoverage* pango_coverage_from_bytes(guchar* bytes, int n_bytes)"
- Xen_check_type(Xen_is_guchar_(bytes), bytes, 1, "pango_coverage_from_bytes", "guchar*");
- Xen_check_type(Xen_is_int(n_bytes), n_bytes, 2, "pango_coverage_from_bytes", "int");
- return(C_to_Xen_PangoCoverage_(pango_coverage_from_bytes(Xen_to_C_guchar_(bytes), Xen_to_C_int(n_bytes))));
-}
-
static Xen gxg_pango_font_description_new(void)
{
#define H_pango_font_description_new "PangoFontDescription* pango_font_description_new( void)"
@@ -15187,13 +15145,6 @@ static Xen gxg_pango_layout_get_auto_dir(Xen layout)
return(C_to_Xen_gboolean(pango_layout_get_auto_dir(Xen_to_C_PangoLayout_(layout))));
}
-static Xen gxg_pango_script_for_unichar(Xen ch)
-{
- #define H_pango_script_for_unichar "PangoScript pango_script_for_unichar(gunichar ch)"
- Xen_check_type(Xen_is_gunichar(ch), ch, 1, "pango_script_for_unichar", "gunichar");
- return(C_to_Xen_PangoScript(pango_script_for_unichar(Xen_to_C_gunichar(ch))));
-}
-
static Xen gxg_pango_script_iter_new(Xen text, Xen length)
{
#define H_pango_script_iter_new "PangoScriptIter* pango_script_iter_new(char* text, int length)"
@@ -36010,7 +35961,6 @@ Xen_wrap_1_arg(gxg_pango_attr_iterator_destroy_w, gxg_pango_attr_iterator_destro
Xen_wrap_2_args(gxg_pango_attr_iterator_get_w, gxg_pango_attr_iterator_get)
Xen_wrap_4_optional_args(gxg_pango_attr_iterator_get_font_w, gxg_pango_attr_iterator_get_font)
Xen_wrap_7_optional_args(gxg_pango_parse_markup_w, gxg_pango_parse_markup)
-Xen_wrap_5_args(gxg_pango_break_w, gxg_pango_break)
Xen_wrap_4_optional_args(gxg_pango_find_paragraph_boundary_w, gxg_pango_find_paragraph_boundary)
Xen_wrap_6_args(gxg_pango_get_log_attrs_w, gxg_pango_get_log_attrs)
Xen_wrap_3_optional_args(gxg_pango_context_list_families_w, gxg_pango_context_list_families)
@@ -36030,9 +35980,6 @@ Xen_wrap_1_arg(gxg_pango_coverage_unref_w, gxg_pango_coverage_unref)
Xen_wrap_1_arg(gxg_pango_coverage_copy_w, gxg_pango_coverage_copy)
Xen_wrap_2_args(gxg_pango_coverage_get_w, gxg_pango_coverage_get)
Xen_wrap_3_args(gxg_pango_coverage_set_w, gxg_pango_coverage_set)
-Xen_wrap_2_args(gxg_pango_coverage_max_w, gxg_pango_coverage_max)
-Xen_wrap_3_optional_args(gxg_pango_coverage_to_bytes_w, gxg_pango_coverage_to_bytes)
-Xen_wrap_2_args(gxg_pango_coverage_from_bytes_w, gxg_pango_coverage_from_bytes)
Xen_wrap_no_args(gxg_pango_font_description_new_w, gxg_pango_font_description_new)
Xen_wrap_1_arg(gxg_pango_font_description_copy_w, gxg_pango_font_description_copy)
Xen_wrap_1_arg(gxg_pango_font_description_copy_static_w, gxg_pango_font_description_copy_static)
@@ -36490,7 +36437,6 @@ Xen_wrap_1_arg(gxg_pango_font_family_is_monospace_w, gxg_pango_font_family_is_mo
Xen_wrap_3_optional_args(gxg_pango_font_face_list_sizes_w, gxg_pango_font_face_list_sizes)
Xen_wrap_2_args(gxg_pango_layout_set_auto_dir_w, gxg_pango_layout_set_auto_dir)
Xen_wrap_1_arg(gxg_pango_layout_get_auto_dir_w, gxg_pango_layout_get_auto_dir)
-Xen_wrap_1_arg(gxg_pango_script_for_unichar_w, gxg_pango_script_for_unichar)
Xen_wrap_2_args(gxg_pango_script_iter_new_w, gxg_pango_script_iter_new)
Xen_wrap_4_optional_args(gxg_pango_script_iter_get_range_w, gxg_pango_script_iter_get_range)
Xen_wrap_1_arg(gxg_pango_script_iter_next_w, gxg_pango_script_iter_next)
@@ -39152,13 +39098,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_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;
+ s7_pointer pl_isigutttiiu, pl_si, pl_is, pl_isi, pl_sig, pl_isgt, pl_iu, pl_pi, pl_bt, pl_tb, pl_iur, pl_bti, pl_iug, pl_iui, pl_ius, pl_piu, pl_pit, pl_iuis, pl_iusi, pl_iuui, pl_btiib, pl_iuuui, pl_iuisi, pl_iuuuui, pl_iuisut, pl_t, pl_du, pl_pr, pl_dui, pl_dus, pl_dusi, pl_dusr, pl_tts, pl_tti, pl_sg, pl_gs, pl_bi, pl_ssi, pl_big, pl_ssig, pl_gu, pl_pg, pl_gus, pl_pgi, pl_pgu, pl_gui, pl_guut, pl_pgbi, pl_guuut, pl_gurrsiu, pl_gussitu, pl_i, 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_ti, pl_it, pl_tiu, pl_itsub, pl_itiiub, pl_itstttg, pl_itgiiut, pl_bsu, pl_bsigb, pl_g, pl_s, pl_buuusuug, pl_bu, pl_pb, pl_bur, pl_bug, pl_bus, pl_bui, pl_bub, pl_buui, pl_busu, pl_buub, pl_buig, pl_buus, pl_busib, pl_buuub, pl_buttu, pl_busgu, pl_buuig, pl_buuui, pl_buiuig, pl_buusib, pl_buuuub, pl_buurbr, pl_p, pl_iit, pl_iiit, pl_tg, pl_ts, pl_tsi, pl_tsig, pl_tsiu, pl_tsiiuui, 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_tusiuiui, pl_tuiiiiui, pl_tuuiiiirrrrg, pl_tuuiiiirrrrgi, pl_b, pl_igi, pl_bpt;
#if GTK_CHECK_VERSION(3, 0, 0)
- s7_pointer pl_pgr, pl_gug, pl_tuuugi, pl_tuuuub, pl_puuig, pl_puiiui, pl_buigu;
+ s7_pointer pl_pgr, pl_gug, pl_puuig, pl_puiiui, pl_buigu, pl_tuuugi, pl_tuuuub;
#endif
#if GTK_CHECK_VERSION(3, 4, 0)
- s7_pointer pl_prrru, pl_tsu, pl_suiig;
+ s7_pointer pl_prrru, pl_suiig, pl_tsu;
#endif
#if GTK_CHECK_VERSION(3, 6, 0)
@@ -39166,7 +39112,7 @@ static void define_functions(void)
#endif
#if GTK_CHECK_VERSION(3, 10, 0)
- s7_pointer pl_tuuuui, pl_pusiig, pl_puuiig, pl_pusiigu;
+ s7_pointer pl_pusiig, pl_puuiig, pl_pusiigu, pl_tuuuui;
#endif
#if GTK_CHECK_VERSION(3, 16, 0)
@@ -39182,11 +39128,11 @@ static void define_functions(void)
#endif
#if GTK_CHECK_VERSION(3, 94, 0)
- 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;
+ s7_pointer pl_iuugs, pl_piigui, pl_pst, pl_purru, pl_purrrru, pl_busi, pl_buib, pl_tuiut, pl_tuuur, pl_tugug, pl_tugui, pl_tuuiut, pl_tutisi, pl_tuiiut, pl_tubbbt, pl_tusuiut, pl_tuugggi, pl_tuuuggu;
#endif
#if GTK_CHECK_VERSION(3, 96, 0)
- s7_pointer pl_tuiiiu, pl_tuugiu, pl_bg, pl_purrg, pl_puuugi, pl_buiu, pl_buiib;
+ s7_pointer pl_purrg, pl_puuugi, pl_bg, pl_buiu, pl_buiib, pl_tuiiiu, pl_tuugiu;
#endif
#endif
@@ -39208,18 +39154,18 @@ static void define_functions(void)
s_gtk_enum_t = s7_make_symbol(s7, "gtk_enum_t?");
s_any = s7_t(s7);
+ 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_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_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_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_iur = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_real);
+ pl_bti = s7_make_circular_signature(s7, 2, 3, s_boolean, s_any, s_integer);
pl_iug = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_gtk_enum_t);
pl_iui = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_integer);
pl_ius = s7_make_circular_signature(s7, 2, 3, s_integer, s_pair_false, s_string);
@@ -39228,101 +39174,38 @@ static void define_functions(void)
pl_iuis = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_integer, s_string);
pl_iusi = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_string, s_integer);
pl_iuui = s7_make_circular_signature(s7, 3, 4, s_integer, s_pair_false, s_pair_false, s_integer);
+ pl_btiib = s7_make_circular_signature(s7, 4, 5, s_boolean, s_any, s_integer, s_integer, s_boolean);
pl_iuuui = s7_make_circular_signature(s7, 4, 5, s_integer, s_pair_false, s_pair_false, s_pair_false, s_integer);
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_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_bi = s7_make_circular_signature(s7, 1, 2, s_boolean, s_integer);
+ pl_ssi = s7_make_circular_signature(s7, 2, 3, s_string, s_string, 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);
- pl_tuuiiiirrrrgi = s7_make_circular_signature(s7, 12, 13, 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, s_integer);
- pl_pt = s7_make_circular_signature(s7, 1, 2, s_pair, s_any);
- pl_tu = s7_make_circular_signature(s7, 1, 2, s_any, s_pair_false);
- pl_tut = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_any);
- pl_tus = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_string);
- pl_tug = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_gtk_enum_t);
- pl_tur = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_real);
- pl_tui = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_integer);
- pl_tub = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_boolean);
- pl_tusg = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_gtk_enum_t);
- pl_tugb = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_boolean);
- pl_tugs = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_string);
- pl_tuui = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_integer);
- pl_tuib = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_boolean);
- pl_tusi = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_integer);
- pl_tuug = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_gtk_enum_t);
- pl_tuig = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_gtk_enum_t);
- pl_tuur = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_real);
- pl_turi = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_real, s_integer);
- pl_tusr = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_real);
- pl_tusb = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_boolean);
- pl_tuub = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_boolean);
- pl_tuus = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_string);
- pl_tugu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_pair_false);
- pl_tugr = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_real);
- pl_tugi = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_integer);
- pl_tusu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_pair_false);
- pl_tuut = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_any);
- pl_tugt = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_any);
- pl_tuis = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_string);
- pl_tust = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_any);
- pl_tuiu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_pair_false);
- pl_tuit = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_any);
- pl_tuuiu = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false);
- pl_tuurb = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_boolean);
- pl_tuuri = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_integer);
- pl_tuugi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer);
- pl_turgs = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_real, s_gtk_enum_t, s_string);
- pl_tuisi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_string, s_integer);
- pl_tusri = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_string, s_real, s_integer);
- pl_tuuut = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_any);
- pl_tuubr = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_boolean, s_real);
- pl_tuuub = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_boolean);
- pl_tuuir = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_real);
- pl_tuuui = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_integer);
- pl_tuusi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_string, s_integer);
- pl_tuiiu = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_integer, s_pair_false);
- pl_tuiggu = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_integer, s_gtk_enum_t, s_gtk_enum_t, s_pair_false);
- pl_turrrb = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_real, s_real, s_real, s_boolean);
- pl_tuusit = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_string, s_integer, s_any);
- pl_tuurbr = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_real, s_boolean, s_real);
- pl_tusiis = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_string, s_integer, s_integer, s_string);
- pl_tusuig = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_string, s_pair_false, s_integer, s_gtk_enum_t);
- 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_ssig = s7_make_circular_signature(s7, 3, 4, s_string, s_string, s_integer, s_gtk_enum_t);
+ 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_i = s7_make_circular_signature(s7, 0, 1, s_integer);
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_sui = s7_make_circular_signature(s7, 2, 3, s_string, s_pair_false, s_integer);
@@ -39374,13 +39257,17 @@ 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_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_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_g = s7_make_circular_signature(s7, 0, 1, s_gtk_enum_t);
+ pl_s = s7_make_circular_signature(s7, 0, 1, s_string);
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);
@@ -39390,48 +39277,105 @@ static void define_functions(void)
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_buus = s7_make_circular_signature(s7, 3, 4, s_boolean, s_pair_false, s_pair_false, s_string);
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_buuui = s7_make_circular_signature(s7, 4, 5, s_boolean, s_pair_false, s_pair_false, s_pair_false, s_integer);
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_p = s7_make_circular_signature(s7, 0, 1, s_pair);
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_tg = s7_make_circular_signature(s7, 1, 2, s_any, s_gtk_enum_t);
+ 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_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_pt = s7_make_circular_signature(s7, 1, 2, s_pair, s_any);
+ pl_tu = s7_make_circular_signature(s7, 1, 2, s_any, s_pair_false);
+ pl_tut = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_any);
+ pl_tus = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_string);
+ pl_tug = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_gtk_enum_t);
+ pl_tur = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_real);
+ pl_tui = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_integer);
+ pl_tub = s7_make_circular_signature(s7, 2, 3, s_any, s_pair_false, s_boolean);
+ pl_tusg = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_gtk_enum_t);
+ pl_tugb = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_boolean);
+ pl_tugs = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_string);
+ pl_tuui = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_integer);
+ pl_tuib = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_boolean);
+ pl_tusi = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_integer);
+ pl_tuug = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_gtk_enum_t);
+ pl_tuig = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_gtk_enum_t);
+ pl_tuur = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_real);
+ pl_turi = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_real, s_integer);
+ pl_tusr = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_real);
+ pl_tusb = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_boolean);
+ pl_tuub = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_boolean);
+ pl_tuus = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_string);
+ pl_tugu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_pair_false);
+ pl_tugr = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_real);
+ pl_tugi = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_integer);
+ pl_tusu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_pair_false);
+ pl_tuut = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_pair_false, s_any);
+ pl_tugt = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_gtk_enum_t, s_any);
+ pl_tuis = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_string);
+ pl_tust = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_string, s_any);
+ pl_tuiu = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_pair_false);
+ pl_tuit = s7_make_circular_signature(s7, 3, 4, s_any, s_pair_false, s_integer, s_any);
+ pl_tuuiu = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_pair_false);
+ pl_tuurb = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_boolean);
+ pl_tuuri = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_real, s_integer);
+ pl_tuugi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_integer);
+ pl_turgs = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_real, s_gtk_enum_t, s_string);
+ pl_tuisi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_string, s_integer);
+ pl_tusri = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_string, s_real, s_integer);
+ pl_tuuut = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_any);
+ pl_tuubr = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_boolean, s_real);
+ pl_tuuub = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_boolean);
+ pl_tuuir = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_integer, s_real);
+ pl_tuuui = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_integer);
+ pl_tuusi = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_string, s_integer);
+ pl_tuiiu = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_integer, s_pair_false);
+ pl_tuiggu = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_integer, s_gtk_enum_t, s_gtk_enum_t, s_pair_false);
+ pl_turrrb = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_real, s_real, s_real, s_boolean);
+ pl_tuusit = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_string, s_integer, s_any);
+ pl_tuurbr = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_real, s_boolean, s_real);
+ pl_tusiis = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_string, s_integer, s_integer, s_string);
+ pl_tusuig = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_string, s_pair_false, s_integer, s_gtk_enum_t);
+ 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_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);
+ pl_tuuiiiirrrrgi = s7_make_circular_signature(s7, 12, 13, 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, s_integer);
+ pl_b = s7_make_circular_signature(s7, 0, 1, s_boolean);
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_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);
+ 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);
#endif
#if GTK_CHECK_VERSION(3, 4, 0)
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);
+ pl_tsu = s7_make_circular_signature(s7, 2, 3, s_any, s_string, s_pair_false);
#endif
#if GTK_CHECK_VERSION(3, 6, 0)
@@ -39440,10 +39384,10 @@ static void define_functions(void)
#endif
#if GTK_CHECK_VERSION(3, 10, 0)
- pl_tuuuui = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_integer);
pl_pusiig = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_string, s_integer, s_integer, s_gtk_enum_t);
pl_puuiig = s7_make_circular_signature(s7, 5, 6, s_pair, s_pair_false, s_pair_false, s_integer, s_integer, s_gtk_enum_t);
pl_pusiigu = s7_make_circular_signature(s7, 6, 7, s_pair, s_pair_false, s_string, s_integer, s_integer, s_gtk_enum_t, s_pair_false);
+ pl_tuuuui = s7_make_circular_signature(s7, 5, 6, s_any, s_pair_false, s_pair_false, s_pair_false, s_pair_false, s_integer);
#endif
#if GTK_CHECK_VERSION(3, 16, 0)
@@ -39464,6 +39408,11 @@ static void define_functions(void)
#if GTK_CHECK_VERSION(3, 94, 0)
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_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);
pl_tuiut = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_integer, s_pair_false, s_any);
pl_tuuur = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_pair_false, s_pair_false, s_real);
pl_tugug = s7_make_circular_signature(s7, 4, 5, s_any, s_pair_false, s_gtk_enum_t, s_pair_false, s_gtk_enum_t);
@@ -39475,21 +39424,16 @@ static void define_functions(void)
pl_tusuiut = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_string, s_pair_false, s_integer, s_pair_false, s_any);
pl_tuugggi = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_pair_false, s_gtk_enum_t, s_gtk_enum_t, s_gtk_enum_t, s_integer);
pl_tuuuggu = s7_make_circular_signature(s7, 6, 7, s_any, s_pair_false, s_pair_false, s_pair_false, s_gtk_enum_t, s_gtk_enum_t, s_pair_false);
- 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_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);
+ 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);
#endif
#endif
@@ -40489,7 +40433,6 @@ static void define_functions(void)
Xg_define_procedure(pango_attr_iterator_get, gxg_pango_attr_iterator_get_w, 2, 0, 0, H_pango_attr_iterator_get, pl_pug);
Xg_define_procedure(pango_attr_iterator_get_font, gxg_pango_attr_iterator_get_font_w, 2, 2, 0, H_pango_attr_iterator_get_font, pl_pu);
Xg_define_procedure(pango_parse_markup, gxg_pango_parse_markup_w, 6, 1, 0, H_pango_parse_markup, pl_psiiuusu);
- Xg_define_procedure(pango_break, gxg_pango_break_w, 5, 0, 0, H_pango_break, pl_tsiuui);
Xg_define_procedure(pango_find_paragraph_boundary, gxg_pango_find_paragraph_boundary_w, 2, 2, 0, H_pango_find_paragraph_boundary, pl_psiu);
Xg_define_procedure(pango_get_log_attrs, gxg_pango_get_log_attrs_w, 6, 0, 0, H_pango_get_log_attrs, pl_tsiiuui);
Xg_define_procedure(pango_context_list_families, gxg_pango_context_list_families_w, 1, 2, 0, H_pango_context_list_families, pl_pu);
@@ -40509,9 +40452,6 @@ static void define_functions(void)
Xg_define_procedure(pango_coverage_copy, gxg_pango_coverage_copy_w, 1, 0, 0, H_pango_coverage_copy, pl_pu);
Xg_define_procedure(pango_coverage_get, gxg_pango_coverage_get_w, 2, 0, 0, H_pango_coverage_get, pl_gui);
Xg_define_procedure(pango_coverage_set, gxg_pango_coverage_set_w, 3, 0, 0, H_pango_coverage_set, pl_tuig);
- Xg_define_procedure(pango_coverage_max, gxg_pango_coverage_max_w, 2, 0, 0, H_pango_coverage_max, pl_tu);
- Xg_define_procedure(pango_coverage_to_bytes, gxg_pango_coverage_to_bytes_w, 1, 2, 0, H_pango_coverage_to_bytes, pl_pu);
- Xg_define_procedure(pango_coverage_from_bytes, gxg_pango_coverage_from_bytes_w, 2, 0, 0, H_pango_coverage_from_bytes, pl_psi);
Xg_define_procedure(pango_font_description_new, gxg_pango_font_description_new_w, 0, 0, 0, H_pango_font_description_new, pl_p);
Xg_define_procedure(pango_font_description_copy, gxg_pango_font_description_copy_w, 1, 0, 0, H_pango_font_description_copy, pl_pu);
Xg_define_procedure(pango_font_description_copy_static, gxg_pango_font_description_copy_static_w, 1, 0, 0, H_pango_font_description_copy_static, pl_pu);
@@ -40969,7 +40909,6 @@ static void define_functions(void)
Xg_define_procedure(pango_font_face_list_sizes, gxg_pango_font_face_list_sizes_w, 1, 2, 0, H_pango_font_face_list_sizes, pl_pu);
Xg_define_procedure(pango_layout_set_auto_dir, gxg_pango_layout_set_auto_dir_w, 2, 0, 0, H_pango_layout_set_auto_dir, pl_tub);
Xg_define_procedure(pango_layout_get_auto_dir, gxg_pango_layout_get_auto_dir_w, 1, 0, 0, H_pango_layout_get_auto_dir, pl_bu);
- Xg_define_procedure(pango_script_for_unichar, gxg_pango_script_for_unichar_w, 1, 0, 0, H_pango_script_for_unichar, pl_gi);
Xg_define_procedure(pango_script_iter_new, gxg_pango_script_iter_new_w, 2, 0, 0, H_pango_script_iter_new, pl_psi);
Xg_define_procedure(pango_script_iter_get_range, gxg_pango_script_iter_get_range_w, 1, 3, 0, H_pango_script_iter_get_range, pl_pu);
Xg_define_procedure(pango_script_iter_next, gxg_pango_script_iter_next_w, 1, 0, 0, H_pango_script_iter_next, pl_bu);
@@ -45235,8 +45174,8 @@ static void define_symbols(void)
xg_PangoRenderer__symbol = C_string_to_Xen_symbol("PangoRenderer_");
xg_GtkMenuToolButton__symbol = C_string_to_Xen_symbol("GtkMenuToolButton_");
xg_GtkFileChooserButton__symbol = C_string_to_Xen_symbol("GtkFileChooserButton_");
- xg_PangoScriptIter__symbol = C_string_to_Xen_symbol("PangoScriptIter_");
xg_PangoScript_symbol = C_string_to_Xen_symbol("PangoScript");
+ xg_PangoScriptIter__symbol = C_string_to_Xen_symbol("PangoScriptIter_");
xg_PangoAttrFilterFunc_symbol = C_string_to_Xen_symbol("PangoAttrFilterFunc");
xg_PangoEllipsizeMode_symbol = C_string_to_Xen_symbol("PangoEllipsizeMode");
xg_GtkIconViewForeachFunc_symbol = C_string_to_Xen_symbol("GtkIconViewForeachFunc");
@@ -45276,6 +45215,7 @@ static void define_symbols(void)
xg_PangoAlignment_symbol = C_string_to_Xen_symbol("PangoAlignment");
xg_PangoWrapMode_symbol = C_string_to_Xen_symbol("PangoWrapMode");
xg_PangoItem__symbol = C_string_to_Xen_symbol("PangoItem_");
+ xg_PangoAnalysis__symbol = C_string_to_Xen_symbol("PangoAnalysis_");
xg_PangoGlyphString__symbol = C_string_to_Xen_symbol("PangoGlyphString_");
xg_PangoFontMap__symbol = C_string_to_Xen_symbol("PangoFontMap_");
xg_PangoGlyph_symbol = C_string_to_Xen_symbol("PangoGlyph");
@@ -45291,7 +45231,6 @@ static void define_symbols(void)
xg_PangoFont__symbol = C_string_to_Xen_symbol("PangoFont_");
xg_PangoFontFamily___symbol = C_string_to_Xen_symbol("PangoFontFamily__");
xg_PangoLogAttr__symbol = C_string_to_Xen_symbol("PangoLogAttr_");
- xg_PangoAnalysis__symbol = C_string_to_Xen_symbol("PangoAnalysis_");
xg_PangoAttrList___symbol = C_string_to_Xen_symbol("PangoAttrList__");
xg_PangoAttrIterator__symbol = C_string_to_Xen_symbol("PangoAttrIterator_");
xg_PangoRectangle__symbol = C_string_to_Xen_symbol("PangoRectangle_");
@@ -46835,7 +46774,7 @@ void Init_libxg(void)
Xen_provide_feature("gtk2");
#endif
#endif
- Xen_define("xg-version", C_string_to_Xen_string("27-Aug-19"));
+ Xen_define("xg-version", C_string_to_Xen_string("30-Oct-19"));
xg_already_inited = true;
#if HAVE_SCHEME
#if USE_SND